Branch data Line data Source code
1 : : /* Perform type resolution on the various structures.
2 : : Copyright (C) 2001-2025 Free Software Foundation, Inc.
3 : : Contributed by Andy Vaught
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "options.h"
25 : : #include "bitmap.h"
26 : : #include "gfortran.h"
27 : : #include "arith.h" /* For gfc_compare_expr(). */
28 : : #include "dependency.h"
29 : : #include "data.h"
30 : : #include "target-memory.h" /* for gfc_simplify_transfer */
31 : : #include "constructor.h"
32 : :
33 : : /* Types used in equivalence statements. */
34 : :
35 : : enum seq_type
36 : : {
37 : : SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38 : : };
39 : :
40 : : /* Stack to keep track of the nesting of blocks as we move through the
41 : : code. See resolve_branch() and gfc_resolve_code(). */
42 : :
43 : : typedef struct code_stack
44 : : {
45 : : struct gfc_code *head, *current;
46 : : struct code_stack *prev;
47 : :
48 : : /* This bitmap keeps track of the targets valid for a branch from
49 : : inside this block except for END {IF|SELECT}s of enclosing
50 : : blocks. */
51 : : bitmap reachable_labels;
52 : : }
53 : : code_stack;
54 : :
55 : : static code_stack *cs_base = NULL;
56 : :
57 : :
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 : : /* True when we are on left hand side in an assignment of a coarray. */
89 : : static bool caf_lhs = false;
90 : :
91 : : /* Is the symbol host associated? */
92 : : static bool
93 : 62918 : is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
94 : : {
95 : 70789 : for (ns = ns->parent; ns; ns = ns->parent)
96 : : {
97 : 8122 : if (sym->ns == ns)
98 : : return true;
99 : : }
100 : :
101 : : return false;
102 : : }
103 : :
104 : : /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
105 : : an ABSTRACT derived-type. If where is not NULL, an error message with that
106 : : locus is printed, optionally using name. */
107 : :
108 : : static bool
109 : 1439303 : resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
110 : : {
111 : 1439303 : if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
112 : : {
113 : 5 : if (where)
114 : : {
115 : 5 : if (name)
116 : 4 : gfc_error ("%qs at %L is of the ABSTRACT type %qs",
117 : : name, where, ts->u.derived->name);
118 : : else
119 : 1 : gfc_error ("ABSTRACT type %qs used at %L",
120 : : ts->u.derived->name, where);
121 : : }
122 : :
123 : 5 : return false;
124 : : }
125 : :
126 : : return true;
127 : : }
128 : :
129 : :
130 : : static bool
131 : 4868 : check_proc_interface (gfc_symbol *ifc, locus *where)
132 : : {
133 : : /* Several checks for F08:C1216. */
134 : 4868 : if (ifc->attr.procedure)
135 : : {
136 : 2 : gfc_error ("Interface %qs at %L is declared "
137 : : "in a later PROCEDURE statement", ifc->name, where);
138 : 2 : return false;
139 : : }
140 : 4866 : if (ifc->generic)
141 : : {
142 : : /* For generic interfaces, check if there is
143 : : a specific procedure with the same name. */
144 : : gfc_interface *gen = ifc->generic;
145 : 12 : while (gen && strcmp (gen->sym->name, ifc->name) != 0)
146 : 5 : gen = gen->next;
147 : 7 : if (!gen)
148 : : {
149 : 4 : gfc_error ("Interface %qs at %L may not be generic",
150 : : ifc->name, where);
151 : 4 : return false;
152 : : }
153 : : }
154 : 4862 : if (ifc->attr.proc == PROC_ST_FUNCTION)
155 : : {
156 : 4 : gfc_error ("Interface %qs at %L may not be a statement function",
157 : : ifc->name, where);
158 : 4 : return false;
159 : : }
160 : 4858 : if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
161 : 4858 : || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
162 : 17 : ifc->attr.intrinsic = 1;
163 : 4858 : if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
164 : : {
165 : 3 : gfc_error ("Intrinsic procedure %qs not allowed in "
166 : : "PROCEDURE statement at %L", ifc->name, where);
167 : 3 : return false;
168 : : }
169 : 4855 : if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
170 : : {
171 : 7 : gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
172 : 7 : return false;
173 : : }
174 : : return true;
175 : : }
176 : :
177 : :
178 : : static void resolve_symbol (gfc_symbol *sym);
179 : :
180 : :
181 : : /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
182 : :
183 : : static bool
184 : 1937 : resolve_procedure_interface (gfc_symbol *sym)
185 : : {
186 : 1937 : gfc_symbol *ifc = sym->ts.interface;
187 : :
188 : 1937 : if (!ifc)
189 : : return true;
190 : :
191 : 1781 : if (ifc == sym)
192 : : {
193 : 2 : gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
194 : : sym->name, &sym->declared_at);
195 : 2 : return false;
196 : : }
197 : 1779 : if (!check_proc_interface (ifc, &sym->declared_at))
198 : : return false;
199 : :
200 : 1770 : if (ifc->attr.if_source || ifc->attr.intrinsic)
201 : : {
202 : : /* Resolve interface and copy attributes. */
203 : 1491 : resolve_symbol (ifc);
204 : 1491 : if (ifc->attr.intrinsic)
205 : 14 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
206 : :
207 : 1491 : if (ifc->result)
208 : : {
209 : 632 : sym->ts = ifc->result->ts;
210 : 632 : sym->attr.allocatable = ifc->result->attr.allocatable;
211 : 632 : sym->attr.pointer = ifc->result->attr.pointer;
212 : 632 : sym->attr.dimension = ifc->result->attr.dimension;
213 : 632 : sym->attr.class_ok = ifc->result->attr.class_ok;
214 : 632 : sym->as = gfc_copy_array_spec (ifc->result->as);
215 : 632 : sym->result = sym;
216 : : }
217 : : else
218 : : {
219 : 859 : sym->ts = ifc->ts;
220 : 859 : sym->attr.allocatable = ifc->attr.allocatable;
221 : 859 : sym->attr.pointer = ifc->attr.pointer;
222 : 859 : sym->attr.dimension = ifc->attr.dimension;
223 : 859 : sym->attr.class_ok = ifc->attr.class_ok;
224 : 859 : sym->as = gfc_copy_array_spec (ifc->as);
225 : : }
226 : 1491 : sym->ts.interface = ifc;
227 : 1491 : sym->attr.function = ifc->attr.function;
228 : 1491 : sym->attr.subroutine = ifc->attr.subroutine;
229 : :
230 : 1491 : sym->attr.pure = ifc->attr.pure;
231 : 1491 : sym->attr.elemental = ifc->attr.elemental;
232 : 1491 : sym->attr.contiguous = ifc->attr.contiguous;
233 : 1491 : sym->attr.recursive = ifc->attr.recursive;
234 : 1491 : sym->attr.always_explicit = ifc->attr.always_explicit;
235 : 1491 : sym->attr.ext_attr |= ifc->attr.ext_attr;
236 : 1491 : sym->attr.is_bind_c = ifc->attr.is_bind_c;
237 : : /* Copy char length. */
238 : 1491 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
239 : : {
240 : 45 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
241 : 45 : if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
242 : 53 : && !gfc_resolve_expr (sym->ts.u.cl->length))
243 : : return false;
244 : : }
245 : : }
246 : :
247 : : return true;
248 : : }
249 : :
250 : :
251 : : /* Resolve types of formal argument lists. These have to be done early so that
252 : : the formal argument lists of module procedures can be copied to the
253 : : containing module before the individual procedures are resolved
254 : : individually. We also resolve argument lists of procedures in interface
255 : : blocks because they are self-contained scoping units.
256 : :
257 : : Since a dummy argument cannot be a non-dummy procedure, the only
258 : : resort left for untyped names are the IMPLICIT types. */
259 : :
260 : : void
261 : 485430 : gfc_resolve_formal_arglist (gfc_symbol *proc)
262 : : {
263 : 485430 : gfc_formal_arglist *f;
264 : 485430 : gfc_symbol *sym;
265 : 485430 : bool saved_specification_expr;
266 : 485430 : int i;
267 : :
268 : 485430 : if (proc->result != NULL)
269 : 308094 : sym = proc->result;
270 : : else
271 : : sym = proc;
272 : :
273 : 485430 : if (gfc_elemental (proc)
274 : 326826 : || sym->attr.pointer || sym->attr.allocatable
275 : 800806 : || (sym->as && sym->as->rank != 0))
276 : : {
277 : 172289 : proc->attr.always_explicit = 1;
278 : 172289 : sym->attr.always_explicit = 1;
279 : : }
280 : :
281 : 485430 : gfc_namespace *orig_current_ns = gfc_current_ns;
282 : 485430 : gfc_current_ns = gfc_get_procedure_ns (proc);
283 : :
284 : 1243219 : for (f = proc->formal; f; f = f->next)
285 : : {
286 : 757791 : gfc_array_spec *as;
287 : :
288 : 757791 : sym = f->sym;
289 : :
290 : 757791 : if (sym == NULL)
291 : : {
292 : : /* Alternate return placeholder. */
293 : 171 : if (gfc_elemental (proc))
294 : 1 : gfc_error ("Alternate return specifier in elemental subroutine "
295 : : "%qs at %L is not allowed", proc->name,
296 : : &proc->declared_at);
297 : 171 : if (proc->attr.function)
298 : 1 : gfc_error ("Alternate return specifier in function "
299 : : "%qs at %L is not allowed", proc->name,
300 : : &proc->declared_at);
301 : 171 : continue;
302 : : }
303 : :
304 : 535 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
305 : 758155 : && !resolve_procedure_interface (sym))
306 : : break;
307 : :
308 : 757620 : if (strcmp (proc->name, sym->name) == 0)
309 : : {
310 : 2 : gfc_error ("Self-referential argument "
311 : : "%qs at %L is not allowed", sym->name,
312 : : &proc->declared_at);
313 : 2 : break;
314 : : }
315 : :
316 : 757618 : if (sym->attr.if_source != IFSRC_UNKNOWN)
317 : 822 : gfc_resolve_formal_arglist (sym);
318 : :
319 : 757618 : if (sym->attr.subroutine || sym->attr.external)
320 : : {
321 : 811 : if (sym->attr.flavor == FL_UNKNOWN)
322 : 9 : gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
323 : : }
324 : : else
325 : : {
326 : 756807 : if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
327 : 3620 : && (!sym->attr.function || sym->result == sym))
328 : 3585 : gfc_set_default_type (sym, 1, sym->ns);
329 : : }
330 : :
331 : 12884 : as = sym->ts.type == BT_CLASS && sym->attr.class_ok
332 : 770502 : ? CLASS_DATA (sym)->as : sym->as;
333 : :
334 : 757618 : saved_specification_expr = specification_expr;
335 : 757618 : specification_expr = true;
336 : 757618 : gfc_resolve_array_spec (as, 0);
337 : 757618 : specification_expr = saved_specification_expr;
338 : :
339 : : /* We can't tell if an array with dimension (:) is assumed or deferred
340 : : shape until we know if it has the pointer or allocatable attributes.
341 : : */
342 : 757618 : if (as && as->rank > 0 && as->type == AS_DEFERRED
343 : 11855 : && ((sym->ts.type != BT_CLASS
344 : 10798 : && !(sym->attr.pointer || sym->attr.allocatable))
345 : 5136 : || (sym->ts.type == BT_CLASS
346 : 1057 : && !(CLASS_DATA (sym)->attr.class_pointer
347 : : || CLASS_DATA (sym)->attr.allocatable)))
348 : 7168 : && sym->attr.flavor != FL_PROCEDURE)
349 : : {
350 : 7167 : as->type = AS_ASSUMED_SHAPE;
351 : 16657 : for (i = 0; i < as->rank; i++)
352 : 9490 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
353 : : }
354 : :
355 : 114306 : if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
356 : 101171 : || (as && as->type == AS_ASSUMED_RANK)
357 : 713262 : || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
358 : 703445 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
359 : 10890 : && (CLASS_DATA (sym)->attr.class_pointer
360 : : || CLASS_DATA (sym)->attr.allocatable
361 : 10890 : || CLASS_DATA (sym)->attr.target))
362 : 702104 : || sym->attr.optional)
363 : : {
364 : 68388 : proc->attr.always_explicit = 1;
365 : 68388 : if (proc->result)
366 : 33194 : proc->result->attr.always_explicit = 1;
367 : : }
368 : :
369 : : /* If the flavor is unknown at this point, it has to be a variable.
370 : : A procedure specification would have already set the type. */
371 : :
372 : 757618 : if (sym->attr.flavor == FL_UNKNOWN)
373 : 46641 : gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
374 : :
375 : 757618 : if (gfc_pure (proc))
376 : : {
377 : 319928 : if (sym->attr.flavor == FL_PROCEDURE)
378 : : {
379 : : /* F08:C1279. */
380 : 24 : if (!gfc_pure (sym))
381 : : {
382 : 1 : gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
383 : : "also be PURE", sym->name, &sym->declared_at);
384 : 1 : continue;
385 : : }
386 : : }
387 : 319904 : else if (!sym->attr.pointer)
388 : : {
389 : 319896 : if (proc->attr.function && sym->attr.intent != INTENT_IN)
390 : : {
391 : 109 : if (sym->attr.value)
392 : 108 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
393 : : " of pure function %qs at %L with VALUE "
394 : : "attribute but without INTENT(IN)",
395 : : sym->name, proc->name, &sym->declared_at);
396 : : else
397 : 1 : gfc_error ("Argument %qs of pure function %qs at %L must "
398 : : "be INTENT(IN) or VALUE", sym->name, proc->name,
399 : : &sym->declared_at);
400 : : }
401 : :
402 : 319896 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
403 : : {
404 : 51 : if (sym->attr.value)
405 : 51 : gfc_notify_std (GFC_STD_F2008, "Argument %qs"
406 : : " of pure subroutine %qs at %L with VALUE "
407 : : "attribute but without INTENT", sym->name,
408 : : proc->name, &sym->declared_at);
409 : : else
410 : 0 : gfc_error ("Argument %qs of pure subroutine %qs at %L "
411 : : "must have its INTENT specified or have the "
412 : : "VALUE attribute", sym->name, proc->name,
413 : : &sym->declared_at);
414 : : }
415 : : }
416 : :
417 : : /* F08:C1278a. */
418 : 319927 : if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
419 : : {
420 : 1 : gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
421 : : " may not be polymorphic", sym->name, proc->name,
422 : : &sym->declared_at);
423 : 1 : continue;
424 : : }
425 : : }
426 : :
427 : 757616 : if (proc->attr.implicit_pure)
428 : : {
429 : 23443 : if (sym->attr.flavor == FL_PROCEDURE)
430 : : {
431 : 282 : if (!gfc_pure (sym))
432 : 264 : proc->attr.implicit_pure = 0;
433 : : }
434 : 23161 : else if (!sym->attr.pointer)
435 : : {
436 : 22380 : if (proc->attr.function && sym->attr.intent != INTENT_IN
437 : 2616 : && !sym->value)
438 : 2616 : proc->attr.implicit_pure = 0;
439 : :
440 : 22380 : if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
441 : 3999 : && !sym->value)
442 : 3999 : proc->attr.implicit_pure = 0;
443 : : }
444 : : }
445 : :
446 : 757616 : if (gfc_elemental (proc))
447 : : {
448 : : /* F08:C1289. */
449 : 295134 : if (sym->attr.codimension
450 : 295133 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
451 : 870 : && CLASS_DATA (sym)->attr.codimension))
452 : : {
453 : 3 : gfc_error ("Coarray dummy argument %qs at %L to elemental "
454 : : "procedure", sym->name, &sym->declared_at);
455 : 3 : continue;
456 : : }
457 : :
458 : 295131 : if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
459 : 868 : && CLASS_DATA (sym)->as))
460 : : {
461 : 2 : gfc_error ("Argument %qs of elemental procedure at %L must "
462 : : "be scalar", sym->name, &sym->declared_at);
463 : 2 : continue;
464 : : }
465 : :
466 : 295129 : if (sym->attr.allocatable
467 : 295128 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
468 : 867 : && CLASS_DATA (sym)->attr.allocatable))
469 : : {
470 : 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
471 : : "have the ALLOCATABLE attribute", sym->name,
472 : : &sym->declared_at);
473 : 2 : continue;
474 : : }
475 : :
476 : 295127 : if (sym->attr.pointer
477 : 295126 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
478 : 866 : && CLASS_DATA (sym)->attr.class_pointer))
479 : : {
480 : 2 : gfc_error ("Argument %qs of elemental procedure at %L cannot "
481 : : "have the POINTER attribute", sym->name,
482 : : &sym->declared_at);
483 : 2 : continue;
484 : : }
485 : :
486 : 295125 : if (sym->attr.flavor == FL_PROCEDURE)
487 : : {
488 : 2 : gfc_error ("Dummy procedure %qs not allowed in elemental "
489 : : "procedure %qs at %L", sym->name, proc->name,
490 : : &sym->declared_at);
491 : 2 : continue;
492 : : }
493 : :
494 : : /* Fortran 2008 Corrigendum 1, C1290a. */
495 : 295123 : if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
496 : : {
497 : 2 : gfc_error ("Argument %qs of elemental procedure %qs at %L must "
498 : : "have its INTENT specified or have the VALUE "
499 : : "attribute", sym->name, proc->name,
500 : : &sym->declared_at);
501 : 2 : continue;
502 : : }
503 : : }
504 : :
505 : : /* Each dummy shall be specified to be scalar. */
506 : 757603 : if (proc->attr.proc == PROC_ST_FUNCTION)
507 : : {
508 : 305 : if (sym->as != NULL)
509 : : {
510 : : /* F03:C1263 (R1238) The function-name and each dummy-arg-name
511 : : shall be specified, explicitly or implicitly, to be scalar. */
512 : 1 : gfc_error ("Argument %qs of statement function %qs at %L "
513 : : "must be scalar", sym->name, proc->name,
514 : : &proc->declared_at);
515 : 1 : continue;
516 : : }
517 : :
518 : 304 : if (sym->ts.type == BT_CHARACTER)
519 : : {
520 : 48 : gfc_charlen *cl = sym->ts.u.cl;
521 : 48 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
522 : : {
523 : 0 : gfc_error ("Character-valued argument %qs of statement "
524 : : "function at %L must have constant length",
525 : : sym->name, &sym->declared_at);
526 : 0 : continue;
527 : : }
528 : : }
529 : : }
530 : : }
531 : :
532 : 485430 : gfc_current_ns = orig_current_ns;
533 : 485430 : }
534 : :
535 : :
536 : : /* Work function called when searching for symbols that have argument lists
537 : : associated with them. */
538 : :
539 : : static void
540 : 1702381 : find_arglists (gfc_symbol *sym)
541 : : {
542 : 1702381 : if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
543 : 308151 : || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
544 : : return;
545 : :
546 : 306641 : gfc_resolve_formal_arglist (sym);
547 : : }
548 : :
549 : :
550 : : /* Given a namespace, resolve all formal argument lists within the namespace.
551 : : */
552 : :
553 : : static void
554 : 322576 : resolve_formal_arglists (gfc_namespace *ns)
555 : : {
556 : 0 : if (ns == NULL)
557 : : return;
558 : :
559 : 322576 : gfc_traverse_ns (ns, find_arglists);
560 : : }
561 : :
562 : :
563 : : static void
564 : 35125 : resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
565 : : {
566 : 35125 : bool t;
567 : :
568 : 35125 : if (sym && sym->attr.flavor == FL_PROCEDURE
569 : 35125 : && sym->ns->parent
570 : 1062 : && sym->ns->parent->proc_name
571 : 1062 : && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
572 : 1 : && !strcmp (sym->name, sym->ns->parent->proc_name->name))
573 : 0 : gfc_error ("Contained procedure %qs at %L has the same name as its "
574 : : "encompassing procedure", sym->name, &sym->declared_at);
575 : :
576 : : /* If this namespace is not a function or an entry master function,
577 : : ignore it. */
578 : 35125 : if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
579 : 10240 : || sym->attr.entry_master)
580 : 25073 : return;
581 : :
582 : 10052 : if (!sym->result)
583 : : return;
584 : :
585 : : /* Try to find out of what the return type is. */
586 : 10052 : if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
587 : : {
588 : 53 : t = gfc_set_default_type (sym->result, 0, ns);
589 : :
590 : 53 : if (!t && !sym->result->attr.untyped)
591 : : {
592 : 19 : if (sym->result == sym)
593 : 1 : gfc_error ("Contained function %qs at %L has no IMPLICIT type",
594 : : sym->name, &sym->declared_at);
595 : 18 : else if (!sym->result->attr.proc_pointer)
596 : 0 : gfc_error ("Result %qs of contained function %qs at %L has "
597 : : "no IMPLICIT type", sym->result->name, sym->name,
598 : : &sym->result->declared_at);
599 : 19 : sym->result->attr.untyped = 1;
600 : : }
601 : : }
602 : :
603 : : /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
604 : : type, lists the only ways a character length value of * can be used:
605 : : dummy arguments of procedures, named constants, function results and
606 : : in allocate statements if the allocate_object is an assumed length dummy
607 : : in external functions. Internal function results and results of module
608 : : procedures are not on this list, ergo, not permitted. */
609 : :
610 : 10052 : if (sym->result->ts.type == BT_CHARACTER)
611 : : {
612 : 1136 : gfc_charlen *cl = sym->result->ts.u.cl;
613 : 1136 : if ((!cl || !cl->length) && !sym->result->ts.deferred)
614 : : {
615 : : /* See if this is a module-procedure and adapt error message
616 : : accordingly. */
617 : 4 : bool module_proc;
618 : 4 : gcc_assert (ns->parent && ns->parent->proc_name);
619 : 4 : module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
620 : :
621 : 7 : gfc_error (module_proc
622 : : ? G_("Character-valued module procedure %qs at %L"
623 : : " must not be assumed length")
624 : : : G_("Character-valued internal function %qs at %L"
625 : : " must not be assumed length"),
626 : : sym->name, &sym->declared_at);
627 : : }
628 : : }
629 : : }
630 : :
631 : :
632 : : /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
633 : : introduce duplicates. */
634 : :
635 : : static void
636 : 1420 : merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
637 : : {
638 : 1420 : gfc_formal_arglist *f, *new_arglist;
639 : 1420 : gfc_symbol *new_sym;
640 : :
641 : 2561 : for (; new_args != NULL; new_args = new_args->next)
642 : : {
643 : 1141 : new_sym = new_args->sym;
644 : : /* See if this arg is already in the formal argument list. */
645 : 2165 : for (f = proc->formal; f; f = f->next)
646 : : {
647 : 1470 : if (new_sym == f->sym)
648 : : break;
649 : : }
650 : :
651 : 1141 : if (f)
652 : 446 : continue;
653 : :
654 : : /* Add a new argument. Argument order is not important. */
655 : 695 : new_arglist = gfc_get_formal_arglist ();
656 : 695 : new_arglist->sym = new_sym;
657 : 695 : new_arglist->next = proc->formal;
658 : 695 : proc->formal = new_arglist;
659 : : }
660 : 1420 : }
661 : :
662 : :
663 : : /* Flag the arguments that are not present in all entries. */
664 : :
665 : : static void
666 : 1420 : check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
667 : : {
668 : 1420 : gfc_formal_arglist *f, *head;
669 : 1420 : head = new_args;
670 : :
671 : 2994 : for (f = proc->formal; f; f = f->next)
672 : : {
673 : 1574 : if (f->sym == NULL)
674 : 36 : continue;
675 : :
676 : 2704 : for (new_args = head; new_args; new_args = new_args->next)
677 : : {
678 : 2262 : if (new_args->sym == f->sym)
679 : : break;
680 : : }
681 : :
682 : 1538 : if (new_args)
683 : 1096 : continue;
684 : :
685 : 442 : f->sym->attr.not_always_present = 1;
686 : : }
687 : 1420 : }
688 : :
689 : :
690 : : /* Resolve alternate entry points. If a symbol has multiple entry points we
691 : : create a new master symbol for the main routine, and turn the existing
692 : : symbol into an entry point. */
693 : :
694 : : static void
695 : 357196 : resolve_entries (gfc_namespace *ns)
696 : : {
697 : 357196 : gfc_namespace *old_ns;
698 : 357196 : gfc_code *c;
699 : 357196 : gfc_symbol *proc;
700 : 357196 : gfc_entry_list *el;
701 : : /* Provide sufficient space to hold "master.%d.%s". */
702 : 357196 : char name[GFC_MAX_SYMBOL_LEN + 1 + 18];
703 : 357196 : static int master_count = 0;
704 : :
705 : 357196 : if (ns->proc_name == NULL)
706 : 356528 : return;
707 : :
708 : : /* No need to do anything if this procedure doesn't have alternate entry
709 : : points. */
710 : 357148 : if (!ns->entries)
711 : : return;
712 : :
713 : : /* We may already have resolved alternate entry points. */
714 : 918 : if (ns->proc_name->attr.entry_master)
715 : : return;
716 : :
717 : : /* If this isn't a procedure something has gone horribly wrong. */
718 : 668 : gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
719 : :
720 : : /* Remember the current namespace. */
721 : 668 : old_ns = gfc_current_ns;
722 : :
723 : 668 : gfc_current_ns = ns;
724 : :
725 : : /* Add the main entry point to the list of entry points. */
726 : 668 : el = gfc_get_entry_list ();
727 : 668 : el->sym = ns->proc_name;
728 : 668 : el->id = 0;
729 : 668 : el->next = ns->entries;
730 : 668 : ns->entries = el;
731 : 668 : ns->proc_name->attr.entry = 1;
732 : :
733 : : /* If it is a module function, it needs to be in the right namespace
734 : : so that gfc_get_fake_result_decl can gather up the results. The
735 : : need for this arose in get_proc_name, where these beasts were
736 : : left in their own namespace, to keep prior references linked to
737 : : the entry declaration.*/
738 : 668 : if (ns->proc_name->attr.function
739 : 564 : && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
740 : 188 : el->sym->ns = ns;
741 : :
742 : : /* Do the same for entries where the master is not a module
743 : : procedure. These are retained in the module namespace because
744 : : of the module procedure declaration. */
745 : 1420 : for (el = el->next; el; el = el->next)
746 : 752 : if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
747 : 0 : && el->sym->attr.mod_proc)
748 : 0 : el->sym->ns = ns;
749 : 668 : el = ns->entries;
750 : :
751 : : /* Add an entry statement for it. */
752 : 668 : c = gfc_get_code (EXEC_ENTRY);
753 : 668 : c->ext.entry = el;
754 : 668 : c->next = ns->code;
755 : 668 : ns->code = c;
756 : :
757 : : /* Create a new symbol for the master function. */
758 : : /* Give the internal function a unique name (within this file).
759 : : Also include the function name so the user has some hope of figuring
760 : : out what is going on. */
761 : 668 : snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
762 : 668 : master_count++, ns->proc_name->name);
763 : 668 : gfc_get_ha_symbol (name, &proc);
764 : 668 : gcc_assert (proc != NULL);
765 : :
766 : 668 : gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
767 : 668 : if (ns->proc_name->attr.subroutine)
768 : 104 : gfc_add_subroutine (&proc->attr, proc->name, NULL);
769 : : else
770 : : {
771 : 564 : gfc_symbol *sym;
772 : 564 : gfc_typespec *ts, *fts;
773 : 564 : gfc_array_spec *as, *fas;
774 : 564 : gfc_add_function (&proc->attr, proc->name, NULL);
775 : 564 : proc->result = proc;
776 : 564 : fas = ns->entries->sym->as;
777 : 564 : fas = fas ? fas : ns->entries->sym->result->as;
778 : 564 : fts = &ns->entries->sym->result->ts;
779 : 564 : if (fts->type == BT_UNKNOWN)
780 : 51 : fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
781 : 1058 : for (el = ns->entries->next; el; el = el->next)
782 : : {
783 : 603 : ts = &el->sym->result->ts;
784 : 603 : as = el->sym->as;
785 : 603 : as = as ? as : el->sym->result->as;
786 : 603 : if (ts->type == BT_UNKNOWN)
787 : 61 : ts = gfc_get_default_type (el->sym->result->name, NULL);
788 : :
789 : 603 : if (! gfc_compare_types (ts, fts)
790 : 497 : || (el->sym->result->attr.dimension
791 : 497 : != ns->entries->sym->result->attr.dimension)
792 : 603 : || (el->sym->result->attr.pointer
793 : 497 : != ns->entries->sym->result->attr.pointer))
794 : : break;
795 : 65 : else if (as && fas && ns->entries->sym->result != el->sym->result
796 : 559 : && gfc_compare_array_spec (as, fas) == 0)
797 : 5 : gfc_error ("Function %s at %L has entries with mismatched "
798 : : "array specifications", ns->entries->sym->name,
799 : 5 : &ns->entries->sym->declared_at);
800 : : /* The characteristics need to match and thus both need to have
801 : : the same string length, i.e. both len=*, or both len=4.
802 : : Having both len=<variable> is also possible, but difficult to
803 : : check at compile time. */
804 : 492 : else if (ts->type == BT_CHARACTER
805 : 89 : && (el->sym->result->attr.allocatable
806 : 89 : != ns->entries->sym->result->attr.allocatable))
807 : : {
808 : 3 : gfc_error ("Function %s at %L has entry %s with mismatched "
809 : : "characteristics", ns->entries->sym->name,
810 : : &ns->entries->sym->declared_at, el->sym->name);
811 : 3 : goto cleanup;
812 : : }
813 : 489 : else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
814 : 86 : && (((ts->u.cl->length && !fts->u.cl->length)
815 : 85 : ||(!ts->u.cl->length && fts->u.cl->length))
816 : 66 : || (ts->u.cl->length
817 : 29 : && ts->u.cl->length->expr_type
818 : 29 : != fts->u.cl->length->expr_type)
819 : 66 : || (ts->u.cl->length
820 : 29 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
821 : 28 : && mpz_cmp (ts->u.cl->length->value.integer,
822 : 28 : fts->u.cl->length->value.integer) != 0)))
823 : 21 : gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
824 : : "entries returning variables of different "
825 : : "string lengths", ns->entries->sym->name,
826 : 21 : &ns->entries->sym->declared_at);
827 : 468 : else if (el->sym->result->attr.allocatable
828 : 468 : != ns->entries->sym->result->attr.allocatable)
829 : : break;
830 : : }
831 : :
832 : 561 : if (el == NULL)
833 : : {
834 : 455 : sym = ns->entries->sym->result;
835 : : /* All result types the same. */
836 : 455 : proc->ts = *fts;
837 : 455 : if (sym->attr.dimension)
838 : 63 : gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
839 : 455 : if (sym->attr.pointer)
840 : 78 : gfc_add_pointer (&proc->attr, NULL);
841 : 455 : if (sym->attr.allocatable)
842 : 24 : gfc_add_allocatable (&proc->attr, NULL);
843 : : }
844 : : else
845 : : {
846 : : /* Otherwise the result will be passed through a union by
847 : : reference. */
848 : 106 : proc->attr.mixed_entry_master = 1;
849 : 340 : for (el = ns->entries; el; el = el->next)
850 : : {
851 : 234 : sym = el->sym->result;
852 : 234 : if (sym->attr.dimension)
853 : : {
854 : 1 : if (el == ns->entries)
855 : 0 : gfc_error ("FUNCTION result %s cannot be an array in "
856 : : "FUNCTION %s at %L", sym->name,
857 : 0 : ns->entries->sym->name, &sym->declared_at);
858 : : else
859 : 1 : gfc_error ("ENTRY result %s cannot be an array in "
860 : : "FUNCTION %s at %L", sym->name,
861 : 1 : ns->entries->sym->name, &sym->declared_at);
862 : : }
863 : 233 : else if (sym->attr.pointer)
864 : : {
865 : 1 : if (el == ns->entries)
866 : 1 : gfc_error ("FUNCTION result %s cannot be a POINTER in "
867 : : "FUNCTION %s at %L", sym->name,
868 : 1 : ns->entries->sym->name, &sym->declared_at);
869 : : else
870 : 0 : gfc_error ("ENTRY result %s cannot be a POINTER in "
871 : : "FUNCTION %s at %L", sym->name,
872 : 0 : ns->entries->sym->name, &sym->declared_at);
873 : : }
874 : 232 : else if (sym->attr.allocatable)
875 : : {
876 : 0 : if (el == ns->entries)
877 : 0 : gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in "
878 : : "FUNCTION %s at %L", sym->name,
879 : 0 : ns->entries->sym->name, &sym->declared_at);
880 : : else
881 : 0 : gfc_error ("ENTRY result %s cannot be ALLOCATABLE in "
882 : : "FUNCTION %s at %L", sym->name,
883 : 0 : ns->entries->sym->name, &sym->declared_at);
884 : : }
885 : : else
886 : : {
887 : 232 : ts = &sym->ts;
888 : 232 : if (ts->type == BT_UNKNOWN)
889 : 9 : ts = gfc_get_default_type (sym->name, NULL);
890 : 232 : switch (ts->type)
891 : : {
892 : 84 : case BT_INTEGER:
893 : 84 : if (ts->kind == gfc_default_integer_kind)
894 : : sym = NULL;
895 : : break;
896 : 99 : case BT_REAL:
897 : 99 : if (ts->kind == gfc_default_real_kind
898 : 18 : || ts->kind == gfc_default_double_kind)
899 : : sym = NULL;
900 : : break;
901 : 19 : case BT_COMPLEX:
902 : 19 : if (ts->kind == gfc_default_complex_kind)
903 : : sym = NULL;
904 : : break;
905 : 27 : case BT_LOGICAL:
906 : 27 : if (ts->kind == gfc_default_logical_kind)
907 : : sym = NULL;
908 : : break;
909 : : case BT_UNKNOWN:
910 : : /* We will issue error elsewhere. */
911 : : sym = NULL;
912 : : break;
913 : : default:
914 : : break;
915 : : }
916 : 3 : if (sym)
917 : : {
918 : 3 : if (el == ns->entries)
919 : 1 : gfc_error ("FUNCTION result %s cannot be of type %s "
920 : : "in FUNCTION %s at %L", sym->name,
921 : 1 : gfc_typename (ts), ns->entries->sym->name,
922 : : &sym->declared_at);
923 : : else
924 : 2 : gfc_error ("ENTRY result %s cannot be of type %s "
925 : : "in FUNCTION %s at %L", sym->name,
926 : 2 : gfc_typename (ts), ns->entries->sym->name,
927 : : &sym->declared_at);
928 : : }
929 : : }
930 : : }
931 : : }
932 : : }
933 : :
934 : 106 : cleanup:
935 : 668 : proc->attr.access = ACCESS_PRIVATE;
936 : 668 : proc->attr.entry_master = 1;
937 : :
938 : : /* Merge all the entry point arguments. */
939 : 2088 : for (el = ns->entries; el; el = el->next)
940 : 1420 : merge_argument_lists (proc, el->sym->formal);
941 : :
942 : : /* Check the master formal arguments for any that are not
943 : : present in all entry points. */
944 : 2088 : for (el = ns->entries; el; el = el->next)
945 : 1420 : check_argument_lists (proc, el->sym->formal);
946 : :
947 : : /* Use the master function for the function body. */
948 : 668 : ns->proc_name = proc;
949 : :
950 : : /* Finalize the new symbols. */
951 : 668 : gfc_commit_symbols ();
952 : :
953 : : /* Restore the original namespace. */
954 : 668 : gfc_current_ns = old_ns;
955 : : }
956 : :
957 : :
958 : : /* Forward declaration. */
959 : : static bool is_non_constant_shape_array (gfc_symbol *sym);
960 : :
961 : :
962 : : /* Resolve common variables. */
963 : : static void
964 : 324507 : resolve_common_vars (gfc_common_head *common_block, bool named_common)
965 : : {
966 : 324507 : gfc_symbol *csym = common_block->head;
967 : 324507 : gfc_gsymbol *gsym;
968 : :
969 : 330570 : for (; csym; csym = csym->common_next)
970 : : {
971 : 6063 : gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
972 : 6063 : if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
973 : : {
974 : 3 : if (csym->common_block)
975 : 2 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
976 : : "COMMON block at %L", gsym->name,
977 : : &gsym->where, &csym->common_block->where);
978 : : else
979 : 1 : gfc_error_now ("Global entity %qs at %L cannot appear in a "
980 : : "COMMON block", gsym->name, &gsym->where);
981 : : }
982 : :
983 : : /* gfc_add_in_common may have been called before, but the reported errors
984 : : have been ignored to continue parsing.
985 : : We do the checks again here, unless the symbol is USE associated. */
986 : 6063 : if (!csym->attr.use_assoc && !csym->attr.used_in_submodule)
987 : : {
988 : 5790 : gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
989 : 5790 : gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
990 : : &common_block->where);
991 : : }
992 : :
993 : 6063 : if (csym->value || csym->attr.data)
994 : : {
995 : 131 : if (!csym->ns->is_block_data)
996 : 32 : gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
997 : : "but only in BLOCK DATA initialization is "
998 : : "allowed", csym->name, &csym->declared_at);
999 : 99 : else if (!named_common)
1000 : 8 : gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
1001 : : "in a blank COMMON but initialization is only "
1002 : : "allowed in named common blocks", csym->name,
1003 : : &csym->declared_at);
1004 : : }
1005 : :
1006 : 6063 : if (UNLIMITED_POLY (csym))
1007 : 1 : gfc_error_now ("%qs at %L cannot appear in COMMON "
1008 : : "[F2008:C5100]", csym->name, &csym->declared_at);
1009 : :
1010 : 6063 : if (csym->attr.dimension && is_non_constant_shape_array (csym))
1011 : : {
1012 : 1 : gfc_error_now ("Automatic object %qs at %L cannot appear in "
1013 : : "COMMON at %L", csym->name, &csym->declared_at,
1014 : : &common_block->where);
1015 : : /* Avoid confusing follow-on error. */
1016 : 1 : csym->error = 1;
1017 : : }
1018 : :
1019 : 6063 : if (csym->ts.type != BT_DERIVED)
1020 : 6016 : continue;
1021 : :
1022 : 47 : if (!(csym->ts.u.derived->attr.sequence
1023 : : || csym->ts.u.derived->attr.is_bind_c))
1024 : 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1025 : : "has neither the SEQUENCE nor the BIND(C) "
1026 : : "attribute", csym->name, &csym->declared_at);
1027 : 47 : if (csym->ts.u.derived->attr.alloc_comp)
1028 : 3 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1029 : : "has an ultimate component that is "
1030 : : "allocatable", csym->name, &csym->declared_at);
1031 : 47 : if (gfc_has_default_initializer (csym->ts.u.derived))
1032 : 2 : gfc_error_now ("Derived type variable %qs in COMMON at %L "
1033 : : "may not have default initializer", csym->name,
1034 : : &csym->declared_at);
1035 : :
1036 : 47 : if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1037 : 16 : gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1038 : : }
1039 : 324507 : }
1040 : :
1041 : : /* Resolve common blocks. */
1042 : : static void
1043 : 323041 : resolve_common_blocks (gfc_symtree *common_root)
1044 : : {
1045 : 323041 : gfc_symbol *sym;
1046 : 323041 : gfc_gsymbol * gsym;
1047 : :
1048 : 323041 : if (common_root == NULL)
1049 : 322919 : return;
1050 : :
1051 : 1931 : if (common_root->left)
1052 : 211 : resolve_common_blocks (common_root->left);
1053 : 1931 : if (common_root->right)
1054 : 254 : resolve_common_blocks (common_root->right);
1055 : :
1056 : 1931 : resolve_common_vars (common_root->n.common, true);
1057 : :
1058 : : /* The common name is a global name - in Fortran 2003 also if it has a
1059 : : C binding name, since Fortran 2008 only the C binding name is a global
1060 : : identifier. */
1061 : 1931 : if (!common_root->n.common->binding_label
1062 : 1931 : || gfc_notification_std (GFC_STD_F2008))
1063 : : {
1064 : 3718 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1065 : 1859 : common_root->n.common->name);
1066 : :
1067 : 835 : if (gsym && gfc_notification_std (GFC_STD_F2008)
1068 : 14 : && gsym->type == GSYM_COMMON
1069 : 1872 : && ((common_root->n.common->binding_label
1070 : 6 : && (!gsym->binding_label
1071 : 0 : || strcmp (common_root->n.common->binding_label,
1072 : : gsym->binding_label) != 0))
1073 : 7 : || (!common_root->n.common->binding_label
1074 : 7 : && gsym->binding_label)))
1075 : : {
1076 : 6 : gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1077 : : "identifier and must thus have the same binding name "
1078 : : "as the same-named COMMON block at %L: %s vs %s",
1079 : 6 : common_root->n.common->name, &common_root->n.common->where,
1080 : : &gsym->where,
1081 : : common_root->n.common->binding_label
1082 : : ? common_root->n.common->binding_label : "(blank)",
1083 : 6 : gsym->binding_label ? gsym->binding_label : "(blank)");
1084 : 6 : return;
1085 : : }
1086 : :
1087 : 1853 : if (gsym && gsym->type != GSYM_COMMON
1088 : 1 : && !common_root->n.common->binding_label)
1089 : : {
1090 : 0 : gfc_error ("COMMON block %qs at %L uses the same global identifier "
1091 : : "as entity at %L",
1092 : 0 : common_root->n.common->name, &common_root->n.common->where,
1093 : : &gsym->where);
1094 : 0 : return;
1095 : : }
1096 : 829 : if (gsym && gsym->type != GSYM_COMMON)
1097 : : {
1098 : 1 : gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1099 : : "%L sharing the identifier with global non-COMMON-block "
1100 : 1 : "entity at %L", common_root->n.common->name,
1101 : 1 : &common_root->n.common->where, &gsym->where);
1102 : 1 : return;
1103 : : }
1104 : 1024 : if (!gsym)
1105 : : {
1106 : 1024 : gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1107 : 1024 : gsym->type = GSYM_COMMON;
1108 : 1024 : gsym->where = common_root->n.common->where;
1109 : 1024 : gsym->defined = 1;
1110 : : }
1111 : 1852 : gsym->used = 1;
1112 : : }
1113 : :
1114 : 1924 : if (common_root->n.common->binding_label)
1115 : : {
1116 : 76 : gsym = gfc_find_gsymbol (gfc_gsym_root,
1117 : : common_root->n.common->binding_label);
1118 : 76 : if (gsym && gsym->type != GSYM_COMMON)
1119 : : {
1120 : 1 : gfc_error ("COMMON block at %L with binding label %qs uses the same "
1121 : : "global identifier as entity at %L",
1122 : : &common_root->n.common->where,
1123 : 1 : common_root->n.common->binding_label, &gsym->where);
1124 : 1 : return;
1125 : : }
1126 : 57 : if (!gsym)
1127 : : {
1128 : 57 : gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1129 : 57 : gsym->type = GSYM_COMMON;
1130 : 57 : gsym->where = common_root->n.common->where;
1131 : 57 : gsym->defined = 1;
1132 : : }
1133 : 75 : gsym->used = 1;
1134 : : }
1135 : :
1136 : 1923 : gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1137 : 1923 : if (sym == NULL)
1138 : : return;
1139 : :
1140 : 122 : if (sym->attr.flavor == FL_PARAMETER)
1141 : 2 : gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1142 : 2 : sym->name, &common_root->n.common->where, &sym->declared_at);
1143 : :
1144 : 122 : if (sym->attr.external)
1145 : 1 : gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1146 : 1 : sym->name, &common_root->n.common->where);
1147 : :
1148 : 122 : if (sym->attr.intrinsic)
1149 : 2 : gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1150 : 2 : sym->name, &common_root->n.common->where);
1151 : 120 : else if (sym->attr.result
1152 : 120 : || gfc_is_function_return_value (sym, gfc_current_ns))
1153 : 1 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1154 : : "that is also a function result", sym->name,
1155 : 1 : &common_root->n.common->where);
1156 : 119 : else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1157 : 5 : && sym->attr.proc != PROC_ST_FUNCTION)
1158 : 3 : gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1159 : : "that is also a global procedure", sym->name,
1160 : 3 : &common_root->n.common->where);
1161 : : }
1162 : :
1163 : :
1164 : : /* Resolve contained function types. Because contained functions can call one
1165 : : another, they have to be worked out before any of the contained procedures
1166 : : can be resolved.
1167 : :
1168 : : The good news is that if a function doesn't already have a type, the only
1169 : : way it can get one is through an IMPLICIT type or a RESULT variable, because
1170 : : by definition contained functions are contained namespace they're contained
1171 : : in, not in a sibling or parent namespace. */
1172 : :
1173 : : static void
1174 : 322576 : resolve_contained_functions (gfc_namespace *ns)
1175 : : {
1176 : 322576 : gfc_namespace *child;
1177 : 322576 : gfc_entry_list *el;
1178 : :
1179 : 322576 : resolve_formal_arglists (ns);
1180 : :
1181 : 357196 : for (child = ns->contained; child; child = child->sibling)
1182 : : {
1183 : : /* Resolve alternate entry points first. */
1184 : 34620 : resolve_entries (child);
1185 : :
1186 : : /* Then check function return types. */
1187 : 34620 : resolve_contained_fntype (child->proc_name, child);
1188 : 35125 : for (el = child->entries; el; el = el->next)
1189 : 505 : resolve_contained_fntype (el->sym, child);
1190 : : }
1191 : 322576 : }
1192 : :
1193 : :
1194 : :
1195 : : /* A Parameterized Derived Type constructor must contain values for
1196 : : the PDT KIND parameters or they must have a default initializer.
1197 : : Go through the constructor picking out the KIND expressions,
1198 : : storing them in 'param_list' and then call gfc_get_pdt_instance
1199 : : to obtain the PDT instance. */
1200 : :
1201 : : static gfc_actual_arglist *param_list, *param_tail, *param;
1202 : :
1203 : : static bool
1204 : 24 : get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1205 : : {
1206 : 24 : param = gfc_get_actual_arglist ();
1207 : 24 : if (!param_list)
1208 : 18 : param_list = param_tail = param;
1209 : : else
1210 : : {
1211 : 6 : param_tail->next = param;
1212 : 6 : param_tail = param_tail->next;
1213 : : }
1214 : :
1215 : 24 : param_tail->name = c->name;
1216 : 24 : if (expr)
1217 : 24 : param_tail->expr = gfc_copy_expr (expr);
1218 : 0 : else if (c->initializer)
1219 : 0 : param_tail->expr = gfc_copy_expr (c->initializer);
1220 : : else
1221 : : {
1222 : 0 : param_tail->spec_type = SPEC_ASSUMED;
1223 : 0 : if (c->attr.pdt_kind)
1224 : : {
1225 : 0 : gfc_error ("The KIND parameter %qs in the PDT constructor "
1226 : : "at %C has no value", param->name);
1227 : 0 : return false;
1228 : : }
1229 : : }
1230 : :
1231 : : return true;
1232 : : }
1233 : :
1234 : : static bool
1235 : 18 : get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1236 : : gfc_symbol *derived)
1237 : : {
1238 : 18 : gfc_constructor *cons = NULL;
1239 : 18 : gfc_component *comp;
1240 : 18 : bool t = true;
1241 : :
1242 : 18 : if (expr && expr->expr_type == EXPR_STRUCTURE)
1243 : 18 : cons = gfc_constructor_first (expr->value.constructor);
1244 : 0 : else if (constr)
1245 : 0 : cons = *constr;
1246 : 18 : gcc_assert (cons);
1247 : :
1248 : 18 : comp = derived->components;
1249 : :
1250 : 66 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1251 : : {
1252 : 48 : if (cons->expr
1253 : 48 : && cons->expr->expr_type == EXPR_STRUCTURE
1254 : 0 : && comp->ts.type == BT_DERIVED)
1255 : : {
1256 : 0 : t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1257 : 0 : if (!t)
1258 : : return t;
1259 : : }
1260 : 48 : else if (comp->ts.type == BT_DERIVED)
1261 : : {
1262 : 0 : t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1263 : 0 : if (!t)
1264 : : return t;
1265 : : }
1266 : 48 : else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1267 : 24 : && derived->attr.pdt_template)
1268 : : {
1269 : 24 : t = get_pdt_spec_expr (comp, cons->expr);
1270 : 24 : if (!t)
1271 : : return t;
1272 : : }
1273 : : }
1274 : : return t;
1275 : : }
1276 : :
1277 : :
1278 : : static bool resolve_fl_derived0 (gfc_symbol *sym);
1279 : : static bool resolve_fl_struct (gfc_symbol *sym);
1280 : :
1281 : :
1282 : : /* Resolve all of the elements of a structure constructor and make sure that
1283 : : the types are correct. The 'init' flag indicates that the given
1284 : : constructor is an initializer. */
1285 : :
1286 : : static bool
1287 : 71267 : resolve_structure_cons (gfc_expr *expr, int init)
1288 : : {
1289 : 71267 : gfc_constructor *cons;
1290 : 71267 : gfc_component *comp;
1291 : 71267 : bool t;
1292 : 71267 : symbol_attribute a;
1293 : :
1294 : 71267 : t = true;
1295 : :
1296 : 71267 : if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1297 : : {
1298 : 68531 : if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1299 : 68381 : resolve_fl_derived0 (expr->ts.u.derived);
1300 : : else
1301 : 150 : resolve_fl_struct (expr->ts.u.derived);
1302 : :
1303 : : /* If this is a Parameterized Derived Type template, find the
1304 : : instance corresponding to the PDT kind parameters. */
1305 : 68531 : if (expr->ts.u.derived->attr.pdt_template)
1306 : : {
1307 : 18 : param_list = NULL;
1308 : 18 : t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1309 : 18 : if (!t)
1310 : : return t;
1311 : 18 : gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1312 : :
1313 : 18 : expr->param_list = gfc_copy_actual_arglist (param_list);
1314 : :
1315 : 18 : if (param_list)
1316 : 18 : gfc_free_actual_arglist (param_list);
1317 : :
1318 : 18 : if (!expr->ts.u.derived->attr.pdt_type)
1319 : : return false;
1320 : : }
1321 : : }
1322 : :
1323 : : /* A constructor may have references if it is the result of substituting a
1324 : : parameter variable. In this case we just pull out the component we
1325 : : want. */
1326 : 71267 : if (expr->ref)
1327 : 144 : comp = expr->ref->u.c.sym->components;
1328 : 71123 : else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1329 : : || expr->ts.type == BT_UNION)
1330 : 71121 : && expr->ts.u.derived)
1331 : 71121 : comp = expr->ts.u.derived->components;
1332 : : else
1333 : : return false;
1334 : :
1335 : 71265 : cons = gfc_constructor_first (expr->value.constructor);
1336 : :
1337 : 301757 : for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1338 : : {
1339 : 230494 : int rank;
1340 : :
1341 : 230494 : if (!cons->expr)
1342 : 79499 : continue;
1343 : :
1344 : : /* Unions use an EXPR_NULL contrived expression to tell the translation
1345 : : phase to generate an initializer of the appropriate length.
1346 : : Ignore it here. */
1347 : 150995 : if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1348 : 15 : continue;
1349 : :
1350 : 150980 : if (!gfc_resolve_expr (cons->expr))
1351 : : {
1352 : 0 : t = false;
1353 : 0 : continue;
1354 : : }
1355 : :
1356 : 150980 : rank = comp->as ? comp->as->rank : 0;
1357 : 150980 : if (comp->ts.type == BT_CLASS
1358 : 1981 : && !comp->ts.u.derived->attr.unlimited_polymorphic
1359 : 1980 : && CLASS_DATA (comp)->as)
1360 : 491 : rank = CLASS_DATA (comp)->as->rank;
1361 : :
1362 : 150980 : if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
1363 : 185 : gfc_find_vtab (&cons->expr->ts);
1364 : :
1365 : 150980 : if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1366 : 414 : && (comp->attr.allocatable || cons->expr->rank))
1367 : : {
1368 : 3 : gfc_error ("The rank of the element in the structure "
1369 : : "constructor at %L does not match that of the "
1370 : : "component (%d/%d)", &cons->expr->where,
1371 : : cons->expr->rank, rank);
1372 : 3 : t = false;
1373 : : }
1374 : :
1375 : : /* If we don't have the right type, try to convert it. */
1376 : :
1377 : 257179 : if (!comp->attr.proc_pointer &&
1378 : 106199 : !gfc_compare_types (&cons->expr->ts, &comp->ts))
1379 : : {
1380 : 11189 : if (strcmp (comp->name, "_extends") == 0)
1381 : : {
1382 : : /* Can afford to be brutal with the _extends initializer.
1383 : : The derived type can get lost because it is PRIVATE
1384 : : but it is not usage constrained by the standard. */
1385 : 8174 : cons->expr->ts = comp->ts;
1386 : : }
1387 : 3015 : else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1388 : : {
1389 : 2 : gfc_error ("The element in the structure constructor at %L, "
1390 : : "for pointer component %qs, is %s but should be %s",
1391 : 2 : &cons->expr->where, comp->name,
1392 : 2 : gfc_basic_typename (cons->expr->ts.type),
1393 : : gfc_basic_typename (comp->ts.type));
1394 : 2 : t = false;
1395 : : }
1396 : 3013 : else if (!UNLIMITED_POLY (comp))
1397 : : {
1398 : 2975 : bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1399 : 2975 : if (t)
1400 : 150980 : t = t2;
1401 : : }
1402 : : }
1403 : :
1404 : : /* For strings, the length of the constructor should be the same as
1405 : : the one of the structure, ensure this if the lengths are known at
1406 : : compile time and when we are dealing with PARAMETER or structure
1407 : : constructors. */
1408 : 150980 : if (cons->expr->ts.type == BT_CHARACTER
1409 : 3610 : && comp->ts.type == BT_CHARACTER
1410 : 3591 : && comp->ts.u.cl && comp->ts.u.cl->length
1411 : 2313 : && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1412 : 2284 : && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1413 : 849 : && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1414 : 849 : && cons->expr->ts.u.cl->length->ts.type == BT_INTEGER
1415 : 849 : && comp->ts.u.cl->length->ts.type == BT_INTEGER
1416 : 849 : && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1417 : 849 : comp->ts.u.cl->length->value.integer) != 0)
1418 : : {
1419 : 11 : if (comp->attr.pointer)
1420 : : {
1421 : 3 : HOST_WIDE_INT la, lb;
1422 : 3 : la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1423 : 3 : lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1424 : 3 : gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1425 : : "component %qs in constructor at %L",
1426 : 3 : la, lb, comp->name, &cons->expr->where);
1427 : 3 : t = false;
1428 : : }
1429 : :
1430 : 11 : if (cons->expr->expr_type == EXPR_VARIABLE
1431 : 4 : && cons->expr->rank != 0
1432 : 2 : && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1433 : : {
1434 : : /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1435 : : to make use of the gfc_resolve_character_array_constructor
1436 : : machinery. The expression is later simplified away to
1437 : : an array of string literals. */
1438 : 1 : gfc_expr *para = cons->expr;
1439 : 1 : cons->expr = gfc_get_expr ();
1440 : 1 : cons->expr->ts = para->ts;
1441 : 1 : cons->expr->where = para->where;
1442 : 1 : cons->expr->expr_type = EXPR_ARRAY;
1443 : 1 : cons->expr->rank = para->rank;
1444 : 1 : cons->expr->corank = para->corank;
1445 : 1 : cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1446 : 1 : gfc_constructor_append_expr (&cons->expr->value.constructor,
1447 : 1 : para, &cons->expr->where);
1448 : : }
1449 : :
1450 : 11 : if (cons->expr->expr_type == EXPR_ARRAY)
1451 : : {
1452 : : /* Rely on the cleanup of the namespace to deal correctly with
1453 : : the old charlen. (There was a block here that attempted to
1454 : : remove the charlen but broke the chain in so doing.) */
1455 : 5 : cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1456 : 5 : cons->expr->ts.u.cl->length_from_typespec = true;
1457 : 5 : cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1458 : 5 : gfc_resolve_character_array_constructor (cons->expr);
1459 : : }
1460 : : }
1461 : :
1462 : 150980 : if (cons->expr->expr_type == EXPR_NULL
1463 : 49322 : && !(comp->attr.pointer || comp->attr.allocatable
1464 : 48298 : || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1465 : 1024 : || (comp->ts.type == BT_CLASS
1466 : 1022 : && (CLASS_DATA (comp)->attr.class_pointer
1467 : 1022 : || CLASS_DATA (comp)->attr.allocatable))))
1468 : : {
1469 : 2 : t = false;
1470 : 2 : gfc_error ("The NULL in the structure constructor at %L is "
1471 : : "being applied to component %qs, which is neither "
1472 : : "a POINTER nor ALLOCATABLE", &cons->expr->where,
1473 : : comp->name);
1474 : : }
1475 : :
1476 : 150980 : if (comp->attr.proc_pointer && comp->ts.interface)
1477 : : {
1478 : : /* Check procedure pointer interface. */
1479 : 15887 : gfc_symbol *s2 = NULL;
1480 : 15887 : gfc_component *c2;
1481 : 15887 : const char *name;
1482 : 15887 : char err[200];
1483 : :
1484 : 15887 : c2 = gfc_get_proc_ptr_comp (cons->expr);
1485 : 15887 : if (c2)
1486 : : {
1487 : 12 : s2 = c2->ts.interface;
1488 : 12 : name = c2->name;
1489 : : }
1490 : 15875 : else if (cons->expr->expr_type == EXPR_FUNCTION)
1491 : : {
1492 : 0 : s2 = cons->expr->symtree->n.sym->result;
1493 : 0 : name = cons->expr->symtree->n.sym->result->name;
1494 : : }
1495 : 15875 : else if (cons->expr->expr_type != EXPR_NULL)
1496 : : {
1497 : 15126 : s2 = cons->expr->symtree->n.sym;
1498 : 15126 : name = cons->expr->symtree->n.sym->name;
1499 : : }
1500 : :
1501 : 15138 : if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1502 : : err, sizeof (err), NULL, NULL))
1503 : : {
1504 : 2 : gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1505 : : "component %qs in structure constructor at %L:"
1506 : 2 : " %s", comp->name, &cons->expr->where, err);
1507 : 2 : return false;
1508 : : }
1509 : : }
1510 : :
1511 : : /* Validate shape, except for dynamic or PDT arrays. */
1512 : 150978 : if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1513 : 2029 : && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1514 : 1317 : && !comp->attr.pdt_array)
1515 : : {
1516 : 1257 : mpz_t len;
1517 : 1257 : mpz_init (len);
1518 : 2616 : for (int n = 0; n < rank; n++)
1519 : : {
1520 : 1360 : if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1521 : 1359 : || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1522 : : {
1523 : 1 : gfc_error ("Bad array spec of component %qs referenced in "
1524 : : "structure constructor at %L",
1525 : 1 : comp->name, &cons->expr->where);
1526 : 1 : t = false;
1527 : 1 : break;
1528 : 1359 : };
1529 : 1359 : if (cons->expr->shape == NULL)
1530 : 12 : continue;
1531 : 1347 : mpz_set_ui (len, 1);
1532 : 1347 : mpz_add (len, len, comp->as->upper[n]->value.integer);
1533 : 1347 : mpz_sub (len, len, comp->as->lower[n]->value.integer);
1534 : 1347 : if (mpz_cmp (cons->expr->shape[n], len) != 0)
1535 : : {
1536 : 9 : gfc_error ("The shape of component %qs in the structure "
1537 : : "constructor at %L differs from the shape of the "
1538 : : "declared component for dimension %d (%ld/%ld)",
1539 : : comp->name, &cons->expr->where, n+1,
1540 : : mpz_get_si (cons->expr->shape[n]),
1541 : : mpz_get_si (len));
1542 : 9 : t = false;
1543 : : }
1544 : : }
1545 : 1257 : mpz_clear (len);
1546 : : }
1547 : :
1548 : 150978 : if (!comp->attr.pointer || comp->attr.proc_pointer
1549 : 19821 : || cons->expr->expr_type == EXPR_NULL)
1550 : 141813 : continue;
1551 : :
1552 : 9165 : a = gfc_expr_attr (cons->expr);
1553 : :
1554 : 9165 : if (!a.pointer && !a.target)
1555 : : {
1556 : 1 : t = false;
1557 : 1 : gfc_error ("The element in the structure constructor at %L, "
1558 : : "for pointer component %qs should be a POINTER or "
1559 : 1 : "a TARGET", &cons->expr->where, comp->name);
1560 : : }
1561 : :
1562 : 9165 : if (init)
1563 : : {
1564 : : /* F08:C461. Additional checks for pointer initialization. */
1565 : 9092 : if (a.allocatable)
1566 : : {
1567 : 0 : t = false;
1568 : 0 : gfc_error ("Pointer initialization target at %L "
1569 : 0 : "must not be ALLOCATABLE", &cons->expr->where);
1570 : : }
1571 : 9092 : if (!a.save)
1572 : : {
1573 : 0 : t = false;
1574 : 0 : gfc_error ("Pointer initialization target at %L "
1575 : 0 : "must have the SAVE attribute", &cons->expr->where);
1576 : : }
1577 : : }
1578 : :
1579 : : /* F2003, C1272 (3). */
1580 : 9165 : bool impure = cons->expr->expr_type == EXPR_VARIABLE
1581 : 9165 : && (gfc_impure_variable (cons->expr->symtree->n.sym)
1582 : 9124 : || gfc_is_coindexed (cons->expr));
1583 : 38 : if (impure && gfc_pure (NULL))
1584 : : {
1585 : 1 : t = false;
1586 : 1 : gfc_error ("Invalid expression in the structure constructor for "
1587 : : "pointer component %qs at %L in PURE procedure",
1588 : 1 : comp->name, &cons->expr->where);
1589 : : }
1590 : :
1591 : 9165 : if (impure)
1592 : 38 : gfc_unset_implicit_pure (NULL);
1593 : : }
1594 : :
1595 : : return t;
1596 : : }
1597 : :
1598 : :
1599 : : /****************** Expression name resolution ******************/
1600 : :
1601 : : /* Returns 0 if a symbol was not declared with a type or
1602 : : attribute declaration statement, nonzero otherwise. */
1603 : :
1604 : : static bool
1605 : 702745 : was_declared (gfc_symbol *sym)
1606 : : {
1607 : 702745 : symbol_attribute a;
1608 : :
1609 : 702745 : a = sym->attr;
1610 : :
1611 : 702745 : if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1612 : : return 1;
1613 : :
1614 : 593967 : if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1615 : : || a.optional || a.pointer || a.save || a.target || a.volatile_
1616 : 593967 : || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1617 : 585784 : || a.asynchronous || a.codimension)
1618 : 8183 : return 1;
1619 : :
1620 : : return 0;
1621 : : }
1622 : :
1623 : :
1624 : : /* Determine if a symbol is generic or not. */
1625 : :
1626 : : static int
1627 : 391217 : generic_sym (gfc_symbol *sym)
1628 : : {
1629 : 391217 : gfc_symbol *s;
1630 : :
1631 : 391217 : if (sym->attr.generic ||
1632 : 363471 : (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1633 : 28813 : return 1;
1634 : :
1635 : 362404 : if (was_declared (sym) || sym->ns->parent == NULL)
1636 : : return 0;
1637 : :
1638 : 76563 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1639 : :
1640 : 76563 : if (s != NULL)
1641 : : {
1642 : 1264 : if (s == sym)
1643 : : return 0;
1644 : : else
1645 : 1253 : return generic_sym (s);
1646 : : }
1647 : :
1648 : : return 0;
1649 : : }
1650 : :
1651 : :
1652 : : /* Determine if a symbol is specific or not. */
1653 : :
1654 : : static int
1655 : 361209 : specific_sym (gfc_symbol *sym)
1656 : : {
1657 : 361209 : gfc_symbol *s;
1658 : :
1659 : 361209 : if (sym->attr.if_source == IFSRC_IFBODY
1660 : 350379 : || sym->attr.proc == PROC_MODULE
1661 : : || sym->attr.proc == PROC_INTERNAL
1662 : : || sym->attr.proc == PROC_ST_FUNCTION
1663 : 277126 : || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1664 : 637604 : || sym->attr.external)
1665 : 87096 : return 1;
1666 : :
1667 : 274113 : if (was_declared (sym) || sym->ns->parent == NULL)
1668 : : return 0;
1669 : :
1670 : 74980 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1671 : :
1672 : 74980 : return (s == NULL) ? 0 : specific_sym (s);
1673 : : }
1674 : :
1675 : :
1676 : : /* Figure out if the procedure is specific, generic or unknown. */
1677 : :
1678 : : enum proc_type
1679 : : { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1680 : :
1681 : : static proc_type
1682 : 389818 : procedure_kind (gfc_symbol *sym)
1683 : : {
1684 : 389818 : if (generic_sym (sym))
1685 : : return PTYPE_GENERIC;
1686 : :
1687 : 361148 : if (specific_sym (sym))
1688 : 87096 : return PTYPE_SPECIFIC;
1689 : :
1690 : : return PTYPE_UNKNOWN;
1691 : : }
1692 : :
1693 : : /* Check references to assumed size arrays. The flag need_full_assumed_size
1694 : : is nonzero when matching actual arguments. */
1695 : :
1696 : : static int need_full_assumed_size = 0;
1697 : :
1698 : : static bool
1699 : 1112524 : check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1700 : : {
1701 : 1112524 : if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1702 : : return false;
1703 : :
1704 : : /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1705 : : What should it be? */
1706 : 3765 : if (e->ref
1707 : 3763 : && e->ref->u.ar.as
1708 : 3762 : && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1709 : 3267 : && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1710 : 3267 : && (e->ref->u.ar.type == AR_FULL))
1711 : : {
1712 : 22 : gfc_error ("The upper bound in the last dimension must "
1713 : : "appear in the reference to the assumed size "
1714 : : "array %qs at %L", sym->name, &e->where);
1715 : 22 : return true;
1716 : : }
1717 : : return false;
1718 : : }
1719 : :
1720 : :
1721 : : /* Look for bad assumed size array references in argument expressions
1722 : : of elemental and array valued intrinsic procedures. Since this is
1723 : : called from procedure resolution functions, it only recurses at
1724 : : operators. */
1725 : :
1726 : : static bool
1727 : 207855 : resolve_assumed_size_actual (gfc_expr *e)
1728 : : {
1729 : 207855 : if (e == NULL)
1730 : : return false;
1731 : :
1732 : 207375 : switch (e->expr_type)
1733 : : {
1734 : 101043 : case EXPR_VARIABLE:
1735 : 101043 : if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1736 : : return true;
1737 : : break;
1738 : :
1739 : 44067 : case EXPR_OP:
1740 : 44067 : if (resolve_assumed_size_actual (e->value.op.op1)
1741 : 44067 : || resolve_assumed_size_actual (e->value.op.op2))
1742 : 0 : return true;
1743 : : break;
1744 : :
1745 : : default:
1746 : : break;
1747 : : }
1748 : : return false;
1749 : : }
1750 : :
1751 : :
1752 : : /* Check a generic procedure, passed as an actual argument, to see if
1753 : : there is a matching specific name. If none, it is an error, and if
1754 : : more than one, the reference is ambiguous. */
1755 : : static int
1756 : 8 : count_specific_procs (gfc_expr *e)
1757 : : {
1758 : 8 : int n;
1759 : 8 : gfc_interface *p;
1760 : 8 : gfc_symbol *sym;
1761 : :
1762 : 8 : n = 0;
1763 : 8 : sym = e->symtree->n.sym;
1764 : :
1765 : 22 : for (p = sym->generic; p; p = p->next)
1766 : 14 : if (strcmp (sym->name, p->sym->name) == 0)
1767 : : {
1768 : 8 : e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1769 : : sym->name);
1770 : 8 : n++;
1771 : : }
1772 : :
1773 : 8 : if (n > 1)
1774 : 1 : gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1775 : : &e->where);
1776 : :
1777 : 8 : if (n == 0)
1778 : 1 : gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1779 : : "argument at %L", sym->name, &e->where);
1780 : :
1781 : 8 : return n;
1782 : : }
1783 : :
1784 : :
1785 : : /* See if a call to sym could possibly be a not allowed RECURSION because of
1786 : : a missing RECURSIVE declaration. This means that either sym is the current
1787 : : context itself, or sym is the parent of a contained procedure calling its
1788 : : non-RECURSIVE containing procedure.
1789 : : This also works if sym is an ENTRY. */
1790 : :
1791 : : static bool
1792 : 142643 : is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1793 : : {
1794 : 142643 : gfc_symbol* proc_sym;
1795 : 142643 : gfc_symbol* context_proc;
1796 : 142643 : gfc_namespace* real_context;
1797 : :
1798 : 142643 : if (sym->attr.flavor == FL_PROGRAM
1799 : : || gfc_fl_struct (sym->attr.flavor))
1800 : : return false;
1801 : :
1802 : : /* If we've got an ENTRY, find real procedure. */
1803 : 142642 : if (sym->attr.entry && sym->ns->entries)
1804 : 45 : proc_sym = sym->ns->entries->sym;
1805 : : else
1806 : : proc_sym = sym;
1807 : :
1808 : : /* If sym is RECURSIVE, all is well of course. */
1809 : 142642 : if (proc_sym->attr.recursive || flag_recursive)
1810 : : return false;
1811 : :
1812 : : /* Find the context procedure's "real" symbol if it has entries.
1813 : : We look for a procedure symbol, so recurse on the parents if we don't
1814 : : find one (like in case of a BLOCK construct). */
1815 : 1614 : for (real_context = context; ; real_context = real_context->parent)
1816 : : {
1817 : : /* We should find something, eventually! */
1818 : 122499 : gcc_assert (real_context);
1819 : :
1820 : 122499 : context_proc = (real_context->entries ? real_context->entries->sym
1821 : : : real_context->proc_name);
1822 : :
1823 : : /* In some special cases, there may not be a proc_name, like for this
1824 : : invalid code:
1825 : : real(bad_kind()) function foo () ...
1826 : : when checking the call to bad_kind ().
1827 : : In these cases, we simply return here and assume that the
1828 : : call is ok. */
1829 : 122499 : if (!context_proc)
1830 : : return false;
1831 : :
1832 : 122235 : if (context_proc->attr.flavor != FL_LABEL)
1833 : : break;
1834 : : }
1835 : :
1836 : : /* A call from sym's body to itself is recursion, of course. */
1837 : 120621 : if (context_proc == proc_sym)
1838 : : return true;
1839 : :
1840 : : /* The same is true if context is a contained procedure and sym the
1841 : : containing one. */
1842 : 120609 : if (context_proc->attr.contained)
1843 : : {
1844 : 19741 : gfc_symbol* parent_proc;
1845 : :
1846 : 19741 : gcc_assert (context->parent);
1847 : 19741 : parent_proc = (context->parent->entries ? context->parent->entries->sym
1848 : : : context->parent->proc_name);
1849 : :
1850 : 19741 : if (parent_proc == proc_sym)
1851 : 9 : return true;
1852 : : }
1853 : :
1854 : : return false;
1855 : : }
1856 : :
1857 : :
1858 : : /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1859 : : its typespec and formal argument list. */
1860 : :
1861 : : bool
1862 : 40213 : gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1863 : : {
1864 : 40213 : gfc_intrinsic_sym* isym = NULL;
1865 : 40213 : const char* symstd;
1866 : :
1867 : 40213 : if (sym->resolve_symbol_called >= 2)
1868 : : return true;
1869 : :
1870 : 30678 : sym->resolve_symbol_called = 2;
1871 : :
1872 : : /* Already resolved. */
1873 : 30678 : if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1874 : : return true;
1875 : :
1876 : : /* We already know this one is an intrinsic, so we don't call
1877 : : gfc_is_intrinsic for full checking but rather use gfc_find_function and
1878 : : gfc_find_subroutine directly to check whether it is a function or
1879 : : subroutine. */
1880 : :
1881 : 23154 : if (sym->intmod_sym_id && sym->attr.subroutine)
1882 : : {
1883 : 8314 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1884 : 8314 : isym = gfc_intrinsic_subroutine_by_id (id);
1885 : 8314 : }
1886 : 14840 : else if (sym->intmod_sym_id)
1887 : : {
1888 : 11533 : gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1889 : 11533 : isym = gfc_intrinsic_function_by_id (id);
1890 : : }
1891 : 3307 : else if (!sym->attr.subroutine)
1892 : 3235 : isym = gfc_find_function (sym->name);
1893 : :
1894 : 23082 : if (isym && !sym->attr.subroutine)
1895 : : {
1896 : 14729 : if (sym->ts.type != BT_UNKNOWN && warn_surprising
1897 : 24 : && !sym->attr.implicit_type)
1898 : 10 : gfc_warning (OPT_Wsurprising,
1899 : : "Type specified for intrinsic function %qs at %L is"
1900 : : " ignored", sym->name, &sym->declared_at);
1901 : :
1902 : 18155 : if (!sym->attr.function &&
1903 : 3426 : !gfc_add_function(&sym->attr, sym->name, loc))
1904 : : return false;
1905 : :
1906 : 14729 : sym->ts = isym->ts;
1907 : : }
1908 : 8425 : else if (isym || (isym = gfc_find_subroutine (sym->name)))
1909 : : {
1910 : 8422 : if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1911 : : {
1912 : 1 : gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1913 : : " specifier", sym->name, &sym->declared_at);
1914 : 1 : return false;
1915 : : }
1916 : :
1917 : 8456 : if (!sym->attr.subroutine &&
1918 : 35 : !gfc_add_subroutine(&sym->attr, sym->name, loc))
1919 : : return false;
1920 : : }
1921 : : else
1922 : : {
1923 : 3 : gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1924 : : &sym->declared_at);
1925 : 3 : return false;
1926 : : }
1927 : :
1928 : 23149 : gfc_copy_formal_args_intr (sym, isym, NULL);
1929 : :
1930 : 23149 : sym->attr.pure = isym->pure;
1931 : 23149 : sym->attr.elemental = isym->elemental;
1932 : :
1933 : : /* Check it is actually available in the standard settings. */
1934 : 23149 : if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1935 : : {
1936 : 24 : gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1937 : : "available in the current standard settings but %s. Use "
1938 : : "an appropriate %<-std=*%> option or enable "
1939 : : "%<-fall-intrinsics%> in order to use it.",
1940 : : sym->name, &sym->declared_at, symstd);
1941 : 24 : return false;
1942 : : }
1943 : :
1944 : : return true;
1945 : : }
1946 : :
1947 : :
1948 : : /* Resolve a procedure expression, like passing it to a called procedure or as
1949 : : RHS for a procedure pointer assignment. */
1950 : :
1951 : : static bool
1952 : 1023583 : resolve_procedure_expression (gfc_expr* expr)
1953 : : {
1954 : 1023583 : gfc_symbol* sym;
1955 : :
1956 : 1023583 : if (expr->expr_type != EXPR_VARIABLE)
1957 : : return true;
1958 : 1023578 : gcc_assert (expr->symtree);
1959 : :
1960 : 1023578 : sym = expr->symtree->n.sym;
1961 : :
1962 : 1023578 : if (sym->attr.intrinsic)
1963 : 1346 : gfc_resolve_intrinsic (sym, &expr->where);
1964 : :
1965 : 1023578 : if (sym->attr.flavor != FL_PROCEDURE
1966 : 30431 : || (sym->attr.function && sym->result == sym))
1967 : : return true;
1968 : :
1969 : : /* A non-RECURSIVE procedure that is used as procedure expression within its
1970 : : own body is in danger of being called recursively. */
1971 : 13249 : if (is_illegal_recursion (sym, gfc_current_ns))
1972 : : {
1973 : 10 : if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
1974 : 0 : gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is "
1975 : : " possibly calling itself recursively in procedure %qs. "
1976 : : " Declare it RECURSIVE or use %<-frecursive%>",
1977 : 0 : sym->name, sym->module, gfc_current_ns->proc_name->name);
1978 : : else
1979 : 10 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1980 : : " itself recursively. Declare it RECURSIVE or use"
1981 : : " %<-frecursive%>", sym->name, &expr->where);
1982 : : }
1983 : :
1984 : : return true;
1985 : : }
1986 : :
1987 : :
1988 : : /* Check that name is not a derived type. */
1989 : :
1990 : : static bool
1991 : 2847 : is_dt_name (const char *name)
1992 : : {
1993 : 2847 : gfc_symbol *dt_list, *dt_first;
1994 : :
1995 : 2847 : dt_list = dt_first = gfc_derived_types;
1996 : 5009 : for (; dt_list; dt_list = dt_list->dt_next)
1997 : : {
1998 : 2938 : if (strcmp(dt_list->name, name) == 0)
1999 : : return true;
2000 : 2935 : if (dt_first == dt_list->dt_next)
2001 : : break;
2002 : : }
2003 : : return false;
2004 : : }
2005 : :
2006 : :
2007 : : /* Resolve an actual argument list. Most of the time, this is just
2008 : : resolving the expressions in the list.
2009 : : The exception is that we sometimes have to decide whether arguments
2010 : : that look like procedure arguments are really simple variable
2011 : : references. */
2012 : :
2013 : : static bool
2014 : 403213 : resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
2015 : : bool no_formal_args)
2016 : : {
2017 : 403213 : gfc_symbol *sym;
2018 : 403213 : gfc_symtree *parent_st;
2019 : 403213 : gfc_expr *e;
2020 : 403213 : gfc_component *comp;
2021 : 403213 : int save_need_full_assumed_size;
2022 : 403213 : bool return_value = false;
2023 : 403213 : bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
2024 : :
2025 : 403213 : actual_arg = true;
2026 : 403213 : first_actual_arg = true;
2027 : :
2028 : 1032291 : for (; arg; arg = arg->next)
2029 : : {
2030 : 629175 : e = arg->expr;
2031 : 629175 : if (e == NULL)
2032 : : {
2033 : : /* Check the label is a valid branching target. */
2034 : 2315 : if (arg->label)
2035 : : {
2036 : 236 : if (arg->label->defined == ST_LABEL_UNKNOWN)
2037 : : {
2038 : 0 : gfc_error ("Label %d referenced at %L is never defined",
2039 : : arg->label->value, &arg->label->where);
2040 : 0 : goto cleanup;
2041 : : }
2042 : : }
2043 : 2315 : first_actual_arg = false;
2044 : 2315 : continue;
2045 : : }
2046 : :
2047 : 626860 : if (e->expr_type == EXPR_VARIABLE
2048 : 276264 : && e->symtree->n.sym->attr.generic
2049 : 8 : && no_formal_args
2050 : 626865 : && count_specific_procs (e) != 1)
2051 : 2 : goto cleanup;
2052 : :
2053 : 626858 : if (e->ts.type != BT_PROCEDURE)
2054 : : {
2055 : 557783 : save_need_full_assumed_size = need_full_assumed_size;
2056 : 557783 : if (e->expr_type != EXPR_VARIABLE)
2057 : 350596 : need_full_assumed_size = 0;
2058 : 557783 : if (!gfc_resolve_expr (e))
2059 : 60 : goto cleanup;
2060 : 557723 : need_full_assumed_size = save_need_full_assumed_size;
2061 : 557723 : goto argument_list;
2062 : : }
2063 : :
2064 : : /* See if the expression node should really be a variable reference. */
2065 : :
2066 : 69075 : sym = e->symtree->n.sym;
2067 : :
2068 : 69075 : if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2069 : : {
2070 : 3 : gfc_error ("Derived type %qs is used as an actual "
2071 : : "argument at %L", sym->name, &e->where);
2072 : 3 : goto cleanup;
2073 : : }
2074 : :
2075 : 69072 : if (sym->attr.flavor == FL_PROCEDURE
2076 : : || sym->attr.intrinsic
2077 : 66228 : || sym->attr.external)
2078 : : {
2079 : 2844 : int actual_ok;
2080 : :
2081 : : /* If a procedure is not already determined to be something else
2082 : : check if it is intrinsic. */
2083 : 2844 : if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2084 : 1254 : sym->attr.intrinsic = 1;
2085 : :
2086 : 2844 : if (sym->attr.proc == PROC_ST_FUNCTION)
2087 : : {
2088 : 2 : gfc_error ("Statement function %qs at %L is not allowed as an "
2089 : : "actual argument", sym->name, &e->where);
2090 : : }
2091 : :
2092 : 5688 : actual_ok = gfc_intrinsic_actual_ok (sym->name,
2093 : 2844 : sym->attr.subroutine);
2094 : 2844 : if (sym->attr.intrinsic && actual_ok == 0)
2095 : : {
2096 : 0 : gfc_error ("Intrinsic %qs at %L is not allowed as an "
2097 : : "actual argument", sym->name, &e->where);
2098 : : }
2099 : :
2100 : 2844 : if (sym->attr.contained && !sym->attr.use_assoc
2101 : 300 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
2102 : : {
2103 : 114 : if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
2104 : : " used as actual argument at %L",
2105 : : sym->name, &e->where))
2106 : 3 : goto cleanup;
2107 : : }
2108 : :
2109 : 2841 : if (sym->attr.elemental && !sym->attr.intrinsic)
2110 : : {
2111 : 2 : gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2112 : : "allowed as an actual argument at %L", sym->name,
2113 : : &e->where);
2114 : : }
2115 : :
2116 : : /* Check if a generic interface has a specific procedure
2117 : : with the same name before emitting an error. */
2118 : 2841 : if (sym->attr.generic && count_specific_procs (e) != 1)
2119 : 0 : goto cleanup;
2120 : :
2121 : : /* Just in case a specific was found for the expression. */
2122 : 2841 : sym = e->symtree->n.sym;
2123 : :
2124 : : /* If the symbol is the function that names the current (or
2125 : : parent) scope, then we really have a variable reference. */
2126 : :
2127 : 2841 : if (gfc_is_function_return_value (sym, sym->ns))
2128 : 0 : goto got_variable;
2129 : :
2130 : : /* If all else fails, see if we have a specific intrinsic. */
2131 : 2841 : if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2132 : : {
2133 : 0 : gfc_intrinsic_sym *isym;
2134 : :
2135 : 0 : isym = gfc_find_function (sym->name);
2136 : 0 : if (isym == NULL || !isym->specific)
2137 : : {
2138 : 0 : gfc_error ("Unable to find a specific INTRINSIC procedure "
2139 : : "for the reference %qs at %L", sym->name,
2140 : : &e->where);
2141 : 0 : goto cleanup;
2142 : : }
2143 : 0 : sym->ts = isym->ts;
2144 : 0 : sym->attr.intrinsic = 1;
2145 : 0 : sym->attr.function = 1;
2146 : : }
2147 : :
2148 : 2841 : if (!gfc_resolve_expr (e))
2149 : 0 : goto cleanup;
2150 : 2841 : goto argument_list;
2151 : : }
2152 : :
2153 : : /* See if the name is a module procedure in a parent unit. */
2154 : :
2155 : 66228 : if (was_declared (sym) || sym->ns->parent == NULL)
2156 : 66141 : goto got_variable;
2157 : :
2158 : 87 : if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2159 : : {
2160 : 0 : gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2161 : 0 : goto cleanup;
2162 : : }
2163 : :
2164 : 87 : if (parent_st == NULL)
2165 : 87 : goto got_variable;
2166 : :
2167 : 0 : sym = parent_st->n.sym;
2168 : 0 : e->symtree = parent_st; /* Point to the right thing. */
2169 : :
2170 : 0 : if (sym->attr.flavor == FL_PROCEDURE
2171 : : || sym->attr.intrinsic
2172 : 0 : || sym->attr.external)
2173 : : {
2174 : 0 : if (!gfc_resolve_expr (e))
2175 : 0 : goto cleanup;
2176 : 0 : goto argument_list;
2177 : : }
2178 : :
2179 : 0 : got_variable:
2180 : 66228 : e->expr_type = EXPR_VARIABLE;
2181 : 66228 : e->ts = sym->ts;
2182 : 66228 : if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2183 : 34085 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2184 : 3749 : && CLASS_DATA (sym)->as))
2185 : : {
2186 : 69682 : gfc_array_spec *as
2187 : 34841 : = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
2188 : 34841 : e->rank = as->rank;
2189 : 34841 : e->corank = as->corank;
2190 : 34841 : e->ref = gfc_get_ref ();
2191 : 34841 : e->ref->type = REF_ARRAY;
2192 : 34841 : e->ref->u.ar.type = AR_FULL;
2193 : 34841 : e->ref->u.ar.as = as;
2194 : : }
2195 : :
2196 : : /* These symbols are set untyped by calls to gfc_set_default_type
2197 : : with 'error_flag' = false. Reset the untyped attribute so that
2198 : : the error will be generated in gfc_resolve_expr. */
2199 : 66228 : if (e->expr_type == EXPR_VARIABLE
2200 : 66228 : && sym->ts.type == BT_UNKNOWN
2201 : 34 : && sym->attr.untyped)
2202 : 5 : sym->attr.untyped = 0;
2203 : :
2204 : : /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2205 : : primary.cc (match_actual_arg). If above code determines that it
2206 : : is a variable instead, it needs to be resolved as it was not
2207 : : done at the beginning of this function. */
2208 : 66228 : save_need_full_assumed_size = need_full_assumed_size;
2209 : 66228 : if (e->expr_type != EXPR_VARIABLE)
2210 : 0 : need_full_assumed_size = 0;
2211 : 66228 : if (!gfc_resolve_expr (e))
2212 : 20 : goto cleanup;
2213 : 66208 : need_full_assumed_size = save_need_full_assumed_size;
2214 : :
2215 : 626772 : argument_list:
2216 : : /* Check argument list functions %VAL, %LOC and %REF. There is
2217 : : nothing to do for %REF. */
2218 : 626772 : if (arg->name && arg->name[0] == '%')
2219 : : {
2220 : 132 : if (strcmp ("%VAL", arg->name) == 0)
2221 : : {
2222 : 58 : if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2223 : : {
2224 : 2 : gfc_error ("By-value argument at %L is not of numeric "
2225 : : "type", &e->where);
2226 : 2 : goto cleanup;
2227 : : }
2228 : :
2229 : 56 : if (e->rank)
2230 : : {
2231 : 1 : gfc_error ("By-value argument at %L cannot be an array or "
2232 : : "an array section", &e->where);
2233 : 1 : goto cleanup;
2234 : : }
2235 : :
2236 : : /* Intrinsics are still PROC_UNKNOWN here. However,
2237 : : since same file external procedures are not resolvable
2238 : : in gfortran, it is a good deal easier to leave them to
2239 : : intrinsic.cc. */
2240 : 55 : if (ptype != PROC_UNKNOWN
2241 : 55 : && ptype != PROC_DUMMY
2242 : 9 : && ptype != PROC_EXTERNAL
2243 : 9 : && ptype != PROC_MODULE)
2244 : : {
2245 : 3 : gfc_error ("By-value argument at %L is not allowed "
2246 : : "in this context", &e->where);
2247 : 3 : goto cleanup;
2248 : : }
2249 : : }
2250 : :
2251 : : /* Statement functions have already been excluded above. */
2252 : 74 : else if (strcmp ("%LOC", arg->name) == 0
2253 : 38 : && e->ts.type == BT_PROCEDURE)
2254 : : {
2255 : 0 : if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2256 : : {
2257 : 0 : gfc_error ("Passing internal procedure at %L by location "
2258 : : "not allowed", &e->where);
2259 : 0 : goto cleanup;
2260 : : }
2261 : : }
2262 : : }
2263 : :
2264 : 626766 : comp = gfc_get_proc_ptr_comp(e);
2265 : 626766 : if (e->expr_type == EXPR_VARIABLE
2266 : 274714 : && comp && comp->attr.elemental)
2267 : : {
2268 : 1 : gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2269 : : "allowed as an actual argument at %L", comp->name,
2270 : : &e->where);
2271 : : }
2272 : :
2273 : : /* Fortran 2008, C1237. */
2274 : 274714 : if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2275 : 626913 : && gfc_has_ultimate_pointer (e))
2276 : : {
2277 : 3 : gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2278 : : "component", &e->where);
2279 : 3 : goto cleanup;
2280 : : }
2281 : :
2282 : 626763 : first_actual_arg = false;
2283 : : }
2284 : :
2285 : : return_value = true;
2286 : :
2287 : 403213 : cleanup:
2288 : 403213 : actual_arg = actual_arg_sav;
2289 : 403213 : first_actual_arg = first_actual_arg_sav;
2290 : :
2291 : 403213 : return return_value;
2292 : : }
2293 : :
2294 : :
2295 : : /* Do the checks of the actual argument list that are specific to elemental
2296 : : procedures. If called with c == NULL, we have a function, otherwise if
2297 : : expr == NULL, we have a subroutine. */
2298 : :
2299 : : static bool
2300 : 305659 : resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2301 : : {
2302 : 305659 : gfc_actual_arglist *arg0;
2303 : 305659 : gfc_actual_arglist *arg;
2304 : 305659 : gfc_symbol *esym = NULL;
2305 : 305659 : gfc_intrinsic_sym *isym = NULL;
2306 : 305659 : gfc_expr *e = NULL;
2307 : 305659 : gfc_intrinsic_arg *iformal = NULL;
2308 : 305659 : gfc_formal_arglist *eformal = NULL;
2309 : 305659 : bool formal_optional = false;
2310 : 305659 : bool set_by_optional = false;
2311 : 305659 : int i;
2312 : 305659 : int rank = 0;
2313 : :
2314 : : /* Is this an elemental procedure? */
2315 : 305659 : if (expr && expr->value.function.actual != NULL)
2316 : : {
2317 : 220153 : if (expr->value.function.esym != NULL
2318 : 42747 : && expr->value.function.esym->attr.elemental)
2319 : : {
2320 : : arg0 = expr->value.function.actual;
2321 : : esym = expr->value.function.esym;
2322 : : }
2323 : 204060 : else if (expr->value.function.isym != NULL
2324 : 176456 : && expr->value.function.isym->elemental)
2325 : : {
2326 : : arg0 = expr->value.function.actual;
2327 : : isym = expr->value.function.isym;
2328 : : }
2329 : : else
2330 : : return true;
2331 : : }
2332 : 85506 : else if (c && c->ext.actual != NULL)
2333 : : {
2334 : 67694 : arg0 = c->ext.actual;
2335 : :
2336 : 67694 : if (c->resolved_sym)
2337 : : esym = c->resolved_sym;
2338 : : else
2339 : 298 : esym = c->symtree->n.sym;
2340 : 67694 : gcc_assert (esym);
2341 : :
2342 : 67694 : if (!esym->attr.elemental)
2343 : : return true;
2344 : : }
2345 : : else
2346 : : return true;
2347 : :
2348 : : /* The rank of an elemental is the rank of its array argument(s). */
2349 : 166824 : for (arg = arg0; arg; arg = arg->next)
2350 : : {
2351 : 107932 : if (arg->expr != NULL && arg->expr->rank != 0)
2352 : : {
2353 : 9460 : rank = arg->expr->rank;
2354 : 9460 : if (arg->expr->expr_type == EXPR_VARIABLE
2355 : 4933 : && arg->expr->symtree->n.sym->attr.optional)
2356 : 9460 : set_by_optional = true;
2357 : :
2358 : : /* Function specific; set the result rank and shape. */
2359 : 9460 : if (expr)
2360 : : {
2361 : 7460 : expr->rank = rank;
2362 : 7460 : expr->corank = arg->expr->corank;
2363 : 7460 : if (!expr->shape && arg->expr->shape)
2364 : : {
2365 : 3620 : expr->shape = gfc_get_shape (rank);
2366 : 7996 : for (i = 0; i < rank; i++)
2367 : 4376 : mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2368 : : }
2369 : : }
2370 : : break;
2371 : : }
2372 : : }
2373 : :
2374 : : /* If it is an array, it shall not be supplied as an actual argument
2375 : : to an elemental procedure unless an array of the same rank is supplied
2376 : : as an actual argument corresponding to a nonoptional dummy argument of
2377 : : that elemental procedure(12.4.1.5). */
2378 : 68352 : formal_optional = false;
2379 : 68352 : if (isym)
2380 : 46880 : iformal = isym->formal;
2381 : : else
2382 : 21472 : eformal = esym->formal;
2383 : :
2384 : 181116 : for (arg = arg0; arg; arg = arg->next)
2385 : : {
2386 : 112764 : if (eformal)
2387 : : {
2388 : 38948 : if (eformal->sym && eformal->sym->attr.optional)
2389 : 38948 : formal_optional = true;
2390 : 38948 : eformal = eformal->next;
2391 : : }
2392 : 73816 : else if (isym && iformal)
2393 : : {
2394 : 64642 : if (iformal->optional)
2395 : 12685 : formal_optional = true;
2396 : 64642 : iformal = iformal->next;
2397 : : }
2398 : 9174 : else if (isym)
2399 : 9166 : formal_optional = true;
2400 : :
2401 : 112764 : if (pedantic && arg->expr != NULL
2402 : 67655 : && arg->expr->expr_type == EXPR_VARIABLE
2403 : 32845 : && arg->expr->symtree->n.sym->attr.optional
2404 : 396 : && formal_optional
2405 : 351 : && arg->expr->rank
2406 : 151 : && (set_by_optional || arg->expr->rank != rank)
2407 : 40 : && !(isym && isym->id == GFC_ISYM_CONVERSION))
2408 : : {
2409 : 110 : bool t = false;
2410 : : gfc_actual_arglist *a;
2411 : :
2412 : : /* Scan the argument list for a non-optional argument with the
2413 : : same rank as arg. */
2414 : 110 : for (a = arg0; a; a = a->next)
2415 : 83 : if (a != arg
2416 : 43 : && a->expr->rank == arg->expr->rank
2417 : 37 : && !a->expr->symtree->n.sym->attr.optional)
2418 : : {
2419 : : t = true;
2420 : : break;
2421 : : }
2422 : :
2423 : 40 : if (!t)
2424 : 27 : gfc_warning (OPT_Wpedantic,
2425 : : "%qs at %L is an array and OPTIONAL; If it is not "
2426 : : "present, then it cannot be the actual argument of "
2427 : : "an ELEMENTAL procedure unless there is a non-optional"
2428 : : " argument with the same rank "
2429 : : "(Fortran 2018, 15.5.2.12)",
2430 : : arg->expr->symtree->n.sym->name, &arg->expr->where);
2431 : : }
2432 : : }
2433 : :
2434 : 181105 : for (arg = arg0; arg; arg = arg->next)
2435 : : {
2436 : 112762 : if (arg->expr == NULL || arg->expr->rank == 0)
2437 : 100674 : continue;
2438 : :
2439 : : /* Being elemental, the last upper bound of an assumed size array
2440 : : argument must be present. */
2441 : 12088 : if (resolve_assumed_size_actual (arg->expr))
2442 : : return false;
2443 : :
2444 : : /* Elemental procedure's array actual arguments must conform. */
2445 : 12085 : if (e != NULL)
2446 : : {
2447 : 2628 : if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
2448 : : return false;
2449 : : }
2450 : : else
2451 : 9457 : e = arg->expr;
2452 : : }
2453 : :
2454 : : /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2455 : : is an array, the intent inout/out variable needs to be also an array. */
2456 : 68343 : if (rank > 0 && esym && expr == NULL)
2457 : 6277 : for (eformal = esym->formal, arg = arg0; arg && eformal;
2458 : 4283 : arg = arg->next, eformal = eformal->next)
2459 : 4285 : if (eformal->sym
2460 : 4284 : && (eformal->sym->attr.intent == INTENT_OUT
2461 : 3220 : || eformal->sym->attr.intent == INTENT_INOUT)
2462 : 1458 : && arg->expr && arg->expr->rank == 0)
2463 : : {
2464 : 2 : gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2465 : : "ELEMENTAL subroutine %qs is a scalar, but another "
2466 : : "actual argument is an array", &arg->expr->where,
2467 : : (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2468 : : : "INOUT", eformal->sym->name, esym->name);
2469 : 2 : return false;
2470 : : }
2471 : : return true;
2472 : : }
2473 : :
2474 : :
2475 : : /* This function does the checking of references to global procedures
2476 : : as defined in sections 18.1 and 14.1, respectively, of the Fortran
2477 : : 77 and 95 standards. It checks for a gsymbol for the name, making
2478 : : one if it does not already exist. If it already exists, then the
2479 : : reference being resolved must correspond to the type of gsymbol.
2480 : : Otherwise, the new symbol is equipped with the attributes of the
2481 : : reference. The corresponding code that is called in creating
2482 : : global entities is parse.cc.
2483 : :
2484 : : In addition, for all but -std=legacy, the gsymbols are used to
2485 : : check the interfaces of external procedures from the same file.
2486 : : The namespace of the gsymbol is resolved and then, once this is
2487 : : done the interface is checked. */
2488 : :
2489 : :
2490 : : static bool
2491 : 14842 : not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2492 : : {
2493 : 14842 : if (!gsym_ns->proc_name->attr.recursive)
2494 : : return true;
2495 : :
2496 : 151 : if (sym->ns == gsym_ns)
2497 : : return false;
2498 : :
2499 : 151 : if (sym->ns->parent && sym->ns->parent == gsym_ns)
2500 : 0 : return false;
2501 : :
2502 : : return true;
2503 : : }
2504 : :
2505 : : static bool
2506 : 14842 : not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2507 : : {
2508 : 14842 : if (gsym_ns->entries)
2509 : : {
2510 : : gfc_entry_list *entry = gsym_ns->entries;
2511 : :
2512 : 3234 : for (; entry; entry = entry->next)
2513 : : {
2514 : 2281 : if (strcmp (sym->name, entry->sym->name) == 0)
2515 : : {
2516 : 946 : if (strcmp (gsym_ns->proc_name->name,
2517 : 946 : sym->ns->proc_name->name) == 0)
2518 : : return false;
2519 : :
2520 : 946 : if (sym->ns->parent
2521 : 0 : && strcmp (gsym_ns->proc_name->name,
2522 : 0 : sym->ns->parent->proc_name->name) == 0)
2523 : : return false;
2524 : : }
2525 : : }
2526 : : }
2527 : : return true;
2528 : : }
2529 : :
2530 : :
2531 : : /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2532 : :
2533 : : bool
2534 : 15600 : gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2535 : : {
2536 : 15600 : gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2537 : :
2538 : 58581 : for ( ; arg; arg = arg->next)
2539 : : {
2540 : 27727 : if (!arg->sym)
2541 : 157 : continue;
2542 : :
2543 : 27570 : if (arg->sym->attr.allocatable) /* (2a) */
2544 : : {
2545 : 0 : strncpy (errmsg, _("allocatable argument"), err_len);
2546 : 0 : return true;
2547 : : }
2548 : 27570 : else if (arg->sym->attr.asynchronous)
2549 : : {
2550 : 0 : strncpy (errmsg, _("asynchronous argument"), err_len);
2551 : 0 : return true;
2552 : : }
2553 : 27570 : else if (arg->sym->attr.optional)
2554 : : {
2555 : 75 : strncpy (errmsg, _("optional argument"), err_len);
2556 : 75 : return true;
2557 : : }
2558 : 27495 : else if (arg->sym->attr.pointer)
2559 : : {
2560 : 12 : strncpy (errmsg, _("pointer argument"), err_len);
2561 : 12 : return true;
2562 : : }
2563 : 27483 : else if (arg->sym->attr.target)
2564 : : {
2565 : 48 : strncpy (errmsg, _("target argument"), err_len);
2566 : 48 : return true;
2567 : : }
2568 : 27435 : else if (arg->sym->attr.value)
2569 : : {
2570 : 0 : strncpy (errmsg, _("value argument"), err_len);
2571 : 0 : return true;
2572 : : }
2573 : 27435 : else if (arg->sym->attr.volatile_)
2574 : : {
2575 : 1 : strncpy (errmsg, _("volatile argument"), err_len);
2576 : 1 : return true;
2577 : : }
2578 : 27434 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2579 : : {
2580 : 45 : strncpy (errmsg, _("assumed-shape argument"), err_len);
2581 : 45 : return true;
2582 : : }
2583 : 27389 : else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2584 : : {
2585 : 1 : strncpy (errmsg, _("assumed-rank argument"), err_len);
2586 : 1 : return true;
2587 : : }
2588 : 27388 : else if (arg->sym->attr.codimension) /* (2c) */
2589 : : {
2590 : 1 : strncpy (errmsg, _("coarray argument"), err_len);
2591 : 1 : return true;
2592 : : }
2593 : 27387 : else if (false) /* (2d) TODO: parametrized derived type */
2594 : : {
2595 : : strncpy (errmsg, _("parametrized derived type argument"), err_len);
2596 : : return true;
2597 : : }
2598 : 27387 : else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2599 : : {
2600 : 162 : strncpy (errmsg, _("polymorphic argument"), err_len);
2601 : 162 : return true;
2602 : : }
2603 : 27225 : else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2604 : : {
2605 : 0 : strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2606 : 0 : return true;
2607 : : }
2608 : 27225 : else if (arg->sym->ts.type == BT_ASSUMED)
2609 : : {
2610 : : /* As assumed-type is unlimited polymorphic (cf. above).
2611 : : See also TS 29113, Note 6.1. */
2612 : 1 : strncpy (errmsg, _("assumed-type argument"), err_len);
2613 : 1 : return true;
2614 : : }
2615 : : }
2616 : :
2617 : 15254 : if (sym->attr.function)
2618 : : {
2619 : 3466 : gfc_symbol *res = sym->result ? sym->result : sym;
2620 : :
2621 : 3466 : if (res->attr.dimension) /* (3a) */
2622 : : {
2623 : 93 : strncpy (errmsg, _("array result"), err_len);
2624 : 93 : return true;
2625 : : }
2626 : 3373 : else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2627 : : {
2628 : 38 : strncpy (errmsg, _("pointer or allocatable result"), err_len);
2629 : 38 : return true;
2630 : : }
2631 : 3335 : else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2632 : 347 : && res->ts.u.cl->length
2633 : 166 : && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2634 : : {
2635 : 12 : strncpy (errmsg, _("result with non-constant character length"), err_len);
2636 : 12 : return true;
2637 : : }
2638 : : }
2639 : :
2640 : 15111 : if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2641 : : {
2642 : 7 : strncpy (errmsg, _("elemental procedure"), err_len);
2643 : 7 : return true;
2644 : : }
2645 : 15104 : else if (sym->attr.is_bind_c) /* (5) */
2646 : : {
2647 : 0 : strncpy (errmsg, _("bind(c) procedure"), err_len);
2648 : 0 : return true;
2649 : : }
2650 : :
2651 : : return false;
2652 : : }
2653 : :
2654 : :
2655 : : static void
2656 : 28631 : resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2657 : : {
2658 : 28631 : gfc_gsymbol * gsym;
2659 : 28631 : gfc_namespace *ns;
2660 : 28631 : enum gfc_symbol_type type;
2661 : 28631 : char reason[200];
2662 : :
2663 : 28631 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2664 : :
2665 : 28631 : gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2666 : 28631 : sym->binding_label != NULL);
2667 : :
2668 : 28631 : if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2669 : 10 : gfc_global_used (gsym, where);
2670 : :
2671 : 28631 : if ((sym->attr.if_source == IFSRC_UNKNOWN
2672 : 8701 : || sym->attr.if_source == IFSRC_IFBODY)
2673 : 24711 : && gsym->type != GSYM_UNKNOWN
2674 : 22574 : && !gsym->binding_label
2675 : 20317 : && gsym->ns
2676 : 14842 : && gsym->ns->proc_name
2677 : 14842 : && not_in_recursive (sym, gsym->ns)
2678 : 43473 : && not_entry_self_reference (sym, gsym->ns))
2679 : : {
2680 : 14842 : gfc_symbol *def_sym;
2681 : 14842 : def_sym = gsym->ns->proc_name;
2682 : :
2683 : 14842 : if (gsym->ns->resolved != -1)
2684 : : {
2685 : :
2686 : : /* Resolve the gsymbol namespace if needed. */
2687 : 14821 : if (!gsym->ns->resolved)
2688 : : {
2689 : 2758 : gfc_symbol *old_dt_list;
2690 : :
2691 : : /* Stash away derived types so that the backend_decls
2692 : : do not get mixed up. */
2693 : 2758 : old_dt_list = gfc_derived_types;
2694 : 2758 : gfc_derived_types = NULL;
2695 : :
2696 : 2758 : gfc_resolve (gsym->ns);
2697 : :
2698 : : /* Store the new derived types with the global namespace. */
2699 : 2758 : if (gfc_derived_types)
2700 : 293 : gsym->ns->derived_types = gfc_derived_types;
2701 : :
2702 : : /* Restore the derived types of this namespace. */
2703 : 2758 : gfc_derived_types = old_dt_list;
2704 : : }
2705 : :
2706 : : /* Make sure that translation for the gsymbol occurs before
2707 : : the procedure currently being resolved. */
2708 : 14821 : ns = gfc_global_ns_list;
2709 : 24902 : for (; ns && ns != gsym->ns; ns = ns->sibling)
2710 : : {
2711 : 16484 : if (ns->sibling == gsym->ns)
2712 : : {
2713 : 6403 : ns->sibling = gsym->ns->sibling;
2714 : 6403 : gsym->ns->sibling = gfc_global_ns_list;
2715 : 6403 : gfc_global_ns_list = gsym->ns;
2716 : 6403 : break;
2717 : : }
2718 : : }
2719 : :
2720 : : /* This can happen if a binding name has been specified. */
2721 : 14821 : if (gsym->binding_label && gsym->sym_name != def_sym->name)
2722 : 0 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2723 : :
2724 : 14821 : if (def_sym->attr.entry_master || def_sym->attr.entry)
2725 : : {
2726 : 953 : gfc_entry_list *entry;
2727 : 1659 : for (entry = gsym->ns->entries; entry; entry = entry->next)
2728 : 1659 : if (strcmp (entry->sym->name, sym->name) == 0)
2729 : : {
2730 : 953 : def_sym = entry->sym;
2731 : 953 : break;
2732 : : }
2733 : : }
2734 : : }
2735 : :
2736 : 14842 : if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2737 : : {
2738 : 6 : gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2739 : : sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2740 : 6 : gfc_typename (&def_sym->ts));
2741 : 29 : goto done;
2742 : : }
2743 : :
2744 : 14836 : if (sym->attr.if_source == IFSRC_UNKNOWN
2745 : 14836 : && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2746 : : {
2747 : 8 : gfc_error ("Explicit interface required for %qs at %L: %s",
2748 : : sym->name, &sym->declared_at, reason);
2749 : 8 : goto done;
2750 : : }
2751 : :
2752 : 14828 : bool bad_result_characteristics;
2753 : 14828 : if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2754 : : reason, sizeof(reason), NULL, NULL,
2755 : : &bad_result_characteristics))
2756 : : {
2757 : : /* Turn erros into warnings with -std=gnu and -std=legacy,
2758 : : unless a function returns a wrong type, which can lead
2759 : : to all kinds of ICEs and wrong code. */
2760 : :
2761 : 15 : if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2762 : 2 : && !bad_result_characteristics)
2763 : 2 : gfc_errors_to_warnings (true);
2764 : :
2765 : 15 : gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2766 : : sym->name, &sym->declared_at, reason);
2767 : 15 : sym->error = 1;
2768 : 15 : gfc_errors_to_warnings (false);
2769 : 15 : goto done;
2770 : : }
2771 : : }
2772 : :
2773 : 28631 : done:
2774 : :
2775 : 28631 : if (gsym->type == GSYM_UNKNOWN)
2776 : : {
2777 : 3812 : gsym->type = type;
2778 : 3812 : gsym->where = *where;
2779 : : }
2780 : :
2781 : 28631 : gsym->used = 1;
2782 : 28631 : }
2783 : :
2784 : :
2785 : : /************* Function resolution *************/
2786 : :
2787 : : /* Resolve a function call known to be generic.
2788 : : Section 14.1.2.4.1. */
2789 : :
2790 : : static match
2791 : 26648 : resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2792 : : {
2793 : 26648 : gfc_symbol *s;
2794 : :
2795 : 26648 : if (sym->attr.generic)
2796 : : {
2797 : 25539 : s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2798 : 25539 : if (s != NULL)
2799 : : {
2800 : 19637 : expr->value.function.name = s->name;
2801 : 19637 : expr->value.function.esym = s;
2802 : :
2803 : 19637 : if (s->ts.type != BT_UNKNOWN)
2804 : 19620 : expr->ts = s->ts;
2805 : 17 : else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2806 : 15 : expr->ts = s->result->ts;
2807 : :
2808 : 19637 : if (s->as != NULL)
2809 : : {
2810 : 54 : expr->rank = s->as->rank;
2811 : 54 : expr->corank = s->as->corank;
2812 : : }
2813 : 19583 : else if (s->result != NULL && s->result->as != NULL)
2814 : : {
2815 : 0 : expr->rank = s->result->as->rank;
2816 : 0 : expr->corank = s->result->as->corank;
2817 : : }
2818 : :
2819 : 19637 : gfc_set_sym_referenced (expr->value.function.esym);
2820 : :
2821 : 19637 : return MATCH_YES;
2822 : : }
2823 : :
2824 : : /* TODO: Need to search for elemental references in generic
2825 : : interface. */
2826 : : }
2827 : :
2828 : 7011 : if (sym->attr.intrinsic)
2829 : 1066 : return gfc_intrinsic_func_interface (expr, 0);
2830 : :
2831 : : return MATCH_NO;
2832 : : }
2833 : :
2834 : :
2835 : : static bool
2836 : 26507 : resolve_generic_f (gfc_expr *expr)
2837 : : {
2838 : 26507 : gfc_symbol *sym;
2839 : 26507 : match m;
2840 : 26507 : gfc_interface *intr = NULL;
2841 : :
2842 : 26507 : sym = expr->symtree->n.sym;
2843 : :
2844 : 26648 : for (;;)
2845 : : {
2846 : 26648 : m = resolve_generic_f0 (expr, sym);
2847 : 26648 : if (m == MATCH_YES)
2848 : : return true;
2849 : 5947 : else if (m == MATCH_ERROR)
2850 : : return false;
2851 : :
2852 : 5947 : generic:
2853 : 5950 : if (!intr)
2854 : 5904 : for (intr = sym->generic; intr; intr = intr->next)
2855 : 5821 : if (gfc_fl_struct (intr->sym->attr.flavor))
2856 : : break;
2857 : :
2858 : 5950 : if (sym->ns->parent == NULL)
2859 : : break;
2860 : 273 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2861 : :
2862 : 273 : if (sym == NULL)
2863 : : break;
2864 : 144 : if (!generic_sym (sym))
2865 : 3 : goto generic;
2866 : : }
2867 : :
2868 : : /* Last ditch attempt. See if the reference is to an intrinsic
2869 : : that possesses a matching interface. 14.1.2.4 */
2870 : 5806 : if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2871 : : {
2872 : 4 : if (gfc_init_expr_flag)
2873 : 1 : gfc_error ("Function %qs in initialization expression at %L "
2874 : : "must be an intrinsic function",
2875 : 1 : expr->symtree->n.sym->name, &expr->where);
2876 : : else
2877 : 3 : gfc_error ("There is no specific function for the generic %qs "
2878 : 3 : "at %L", expr->symtree->n.sym->name, &expr->where);
2879 : 4 : return false;
2880 : : }
2881 : :
2882 : 5802 : if (intr)
2883 : : {
2884 : 5767 : if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2885 : : NULL, false))
2886 : : return false;
2887 : 5747 : if (!gfc_use_derived (expr->ts.u.derived))
2888 : : return false;
2889 : 5746 : return resolve_structure_cons (expr, 0);
2890 : : }
2891 : :
2892 : 35 : m = gfc_intrinsic_func_interface (expr, 0);
2893 : 35 : if (m == MATCH_YES)
2894 : : return true;
2895 : :
2896 : 3 : if (m == MATCH_NO)
2897 : 3 : gfc_error ("Generic function %qs at %L is not consistent with a "
2898 : 3 : "specific intrinsic interface", expr->symtree->n.sym->name,
2899 : : &expr->where);
2900 : :
2901 : : return false;
2902 : : }
2903 : :
2904 : :
2905 : : /* Resolve a function call known to be specific. */
2906 : :
2907 : : static match
2908 : 26876 : resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2909 : : {
2910 : 26876 : match m;
2911 : :
2912 : 26876 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2913 : : {
2914 : 7676 : if (sym->attr.dummy)
2915 : : {
2916 : 253 : sym->attr.proc = PROC_DUMMY;
2917 : 253 : goto found;
2918 : : }
2919 : :
2920 : 7423 : sym->attr.proc = PROC_EXTERNAL;
2921 : 7423 : goto found;
2922 : : }
2923 : :
2924 : 19200 : if (sym->attr.proc == PROC_MODULE
2925 : : || sym->attr.proc == PROC_ST_FUNCTION
2926 : : || sym->attr.proc == PROC_INTERNAL)
2927 : 18462 : goto found;
2928 : :
2929 : 738 : if (sym->attr.intrinsic)
2930 : : {
2931 : 731 : m = gfc_intrinsic_func_interface (expr, 1);
2932 : 731 : if (m == MATCH_YES)
2933 : : return MATCH_YES;
2934 : 0 : if (m == MATCH_NO)
2935 : 0 : gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2936 : : "with an intrinsic", sym->name, &expr->where);
2937 : :
2938 : 0 : return MATCH_ERROR;
2939 : : }
2940 : :
2941 : : return MATCH_NO;
2942 : :
2943 : 26138 : found:
2944 : 26138 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2945 : :
2946 : 26138 : if (sym->result)
2947 : 26138 : expr->ts = sym->result->ts;
2948 : : else
2949 : 0 : expr->ts = sym->ts;
2950 : 26138 : expr->value.function.name = sym->name;
2951 : 26138 : expr->value.function.esym = sym;
2952 : : /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2953 : : error(s). */
2954 : 26138 : if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2955 : : return MATCH_ERROR;
2956 : 26137 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2957 : : {
2958 : 310 : expr->rank = CLASS_DATA (sym)->as->rank;
2959 : 310 : expr->corank = CLASS_DATA (sym)->as->corank;
2960 : : }
2961 : 25827 : else if (sym->as != NULL)
2962 : : {
2963 : 2288 : expr->rank = sym->as->rank;
2964 : 2288 : expr->corank = sym->as->corank;
2965 : : }
2966 : :
2967 : : return MATCH_YES;
2968 : : }
2969 : :
2970 : :
2971 : : static bool
2972 : 26869 : resolve_specific_f (gfc_expr *expr)
2973 : : {
2974 : 26869 : gfc_symbol *sym;
2975 : 26869 : match m;
2976 : :
2977 : 26869 : sym = expr->symtree->n.sym;
2978 : :
2979 : 26876 : for (;;)
2980 : : {
2981 : 26876 : m = resolve_specific_f0 (sym, expr);
2982 : 26876 : if (m == MATCH_YES)
2983 : : return true;
2984 : 8 : if (m == MATCH_ERROR)
2985 : : return false;
2986 : :
2987 : 7 : if (sym->ns->parent == NULL)
2988 : : break;
2989 : :
2990 : 7 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2991 : :
2992 : 7 : if (sym == NULL)
2993 : : break;
2994 : : }
2995 : :
2996 : 0 : gfc_error ("Unable to resolve the specific function %qs at %L",
2997 : 0 : expr->symtree->n.sym->name, &expr->where);
2998 : :
2999 : 0 : return true;
3000 : : }
3001 : :
3002 : : /* Recursively append candidate SYM to CANDIDATES. Store the number of
3003 : : candidates in CANDIDATES_LEN. */
3004 : :
3005 : : static void
3006 : 209 : lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
3007 : : char **&candidates,
3008 : : size_t &candidates_len)
3009 : : {
3010 : 370 : gfc_symtree *p;
3011 : :
3012 : 370 : if (sym == NULL)
3013 : : return;
3014 : 370 : if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
3015 : 120 : && sym->n.sym->attr.flavor == FL_PROCEDURE)
3016 : 47 : vec_push (candidates, candidates_len, sym->name);
3017 : :
3018 : 370 : p = sym->left;
3019 : 370 : if (p)
3020 : 153 : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3021 : :
3022 : 370 : p = sym->right;
3023 : 370 : if (p)
3024 : : lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
3025 : : }
3026 : :
3027 : :
3028 : : /* Lookup function FN fuzzily, taking names in SYMROOT into account. */
3029 : :
3030 : : const char*
3031 : 56 : gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
3032 : : {
3033 : 56 : char **candidates = NULL;
3034 : 56 : size_t candidates_len = 0;
3035 : 56 : lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
3036 : 56 : return gfc_closest_fuzzy_match (fn, candidates);
3037 : : }
3038 : :
3039 : :
3040 : : /* Resolve a procedure call not known to be generic nor specific. */
3041 : :
3042 : : static bool
3043 : 258737 : resolve_unknown_f (gfc_expr *expr)
3044 : : {
3045 : 258737 : gfc_symbol *sym;
3046 : 258737 : gfc_typespec *ts;
3047 : :
3048 : 258737 : sym = expr->symtree->n.sym;
3049 : :
3050 : 258737 : if (sym->attr.dummy)
3051 : : {
3052 : 287 : sym->attr.proc = PROC_DUMMY;
3053 : 287 : expr->value.function.name = sym->name;
3054 : 287 : goto set_type;
3055 : : }
3056 : :
3057 : : /* See if we have an intrinsic function reference. */
3058 : :
3059 : 258450 : if (gfc_is_intrinsic (sym, 0, expr->where))
3060 : : {
3061 : 256159 : if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
3062 : : return true;
3063 : : return false;
3064 : : }
3065 : :
3066 : : /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
3067 : : /* Intrinsics were handled above, only non-intrinsics left here. */
3068 : 2291 : if (sym->attr.flavor == FL_PROCEDURE
3069 : 2288 : && sym->attr.implicit_type
3070 : 382 : && sym->ns
3071 : 382 : && sym->ns->has_implicit_none_export)
3072 : : {
3073 : 3 : gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3074 : : "for symbol %qs at %L", sym->name, &sym->declared_at);
3075 : 3 : sym->error = 1;
3076 : 3 : return false;
3077 : : }
3078 : :
3079 : : /* The reference is to an external name. */
3080 : :
3081 : 2288 : sym->attr.proc = PROC_EXTERNAL;
3082 : 2288 : expr->value.function.name = sym->name;
3083 : 2288 : expr->value.function.esym = expr->symtree->n.sym;
3084 : :
3085 : 2288 : if (sym->as != NULL)
3086 : : {
3087 : 1 : expr->rank = sym->as->rank;
3088 : 1 : expr->corank = sym->as->corank;
3089 : : }
3090 : :
3091 : : /* Type of the expression is either the type of the symbol or the
3092 : : default type of the symbol. */
3093 : :
3094 : 2287 : set_type:
3095 : 2575 : gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3096 : :
3097 : 2575 : if (sym->ts.type != BT_UNKNOWN)
3098 : 2524 : expr->ts = sym->ts;
3099 : : else
3100 : : {
3101 : 51 : ts = gfc_get_default_type (sym->name, sym->ns);
3102 : :
3103 : 51 : if (ts->type == BT_UNKNOWN)
3104 : : {
3105 : 41 : const char *guessed
3106 : 41 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3107 : 41 : if (guessed)
3108 : 3 : gfc_error ("Function %qs at %L has no IMPLICIT type"
3109 : : "; did you mean %qs?",
3110 : : sym->name, &expr->where, guessed);
3111 : : else
3112 : 38 : gfc_error ("Function %qs at %L has no IMPLICIT type",
3113 : : sym->name, &expr->where);
3114 : 41 : return false;
3115 : : }
3116 : : else
3117 : 10 : expr->ts = *ts;
3118 : : }
3119 : :
3120 : : return true;
3121 : : }
3122 : :
3123 : :
3124 : : /* Return true, if the symbol is an external procedure. */
3125 : : static bool
3126 : 804342 : is_external_proc (gfc_symbol *sym)
3127 : : {
3128 : 802714 : if (!sym->attr.dummy && !sym->attr.contained
3129 : 699070 : && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3130 : 155398 : && sym->attr.proc != PROC_ST_FUNCTION
3131 : : && !sym->attr.proc_pointer
3132 : 154803 : && !sym->attr.use_assoc
3133 : 861628 : && sym->name)
3134 : : return true;
3135 : :
3136 : : return false;
3137 : : }
3138 : :
3139 : :
3140 : : /* Figure out if a function reference is pure or not. Also set the name
3141 : : of the function for a potential error message. Return nonzero if the
3142 : : function is PURE, zero if not. */
3143 : : static bool
3144 : : pure_stmt_function (gfc_expr *, gfc_symbol *);
3145 : :
3146 : : bool
3147 : 239567 : gfc_pure_function (gfc_expr *e, const char **name)
3148 : : {
3149 : 239567 : bool pure;
3150 : 239567 : gfc_component *comp;
3151 : :
3152 : 239567 : *name = NULL;
3153 : :
3154 : 239567 : if (e->symtree != NULL
3155 : 239251 : && e->symtree->n.sym != NULL
3156 : 239251 : && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3157 : 305 : return pure_stmt_function (e, e->symtree->n.sym);
3158 : :
3159 : 239262 : comp = gfc_get_proc_ptr_comp (e);
3160 : 239262 : if (comp)
3161 : : {
3162 : 290 : pure = gfc_pure (comp->ts.interface);
3163 : 290 : *name = comp->name;
3164 : : }
3165 : 238972 : else if (e->value.function.esym)
3166 : : {
3167 : 51298 : pure = gfc_pure (e->value.function.esym);
3168 : 51298 : *name = e->value.function.esym->name;
3169 : : }
3170 : 187674 : else if (e->value.function.isym)
3171 : : {
3172 : 186710 : pure = e->value.function.isym->pure
3173 : 186710 : || e->value.function.isym->elemental;
3174 : 186710 : *name = e->value.function.isym->name;
3175 : : }
3176 : : else
3177 : : {
3178 : : /* Implicit functions are not pure. */
3179 : 964 : pure = 0;
3180 : 964 : *name = e->value.function.name;
3181 : : }
3182 : :
3183 : : return pure;
3184 : : }
3185 : :
3186 : :
3187 : : /* Check if the expression is a reference to an implicitly pure function. */
3188 : :
3189 : : bool
3190 : 36728 : gfc_implicit_pure_function (gfc_expr *e)
3191 : : {
3192 : 36728 : gfc_component *comp = gfc_get_proc_ptr_comp (e);
3193 : 36728 : if (comp)
3194 : 274 : return gfc_implicit_pure (comp->ts.interface);
3195 : 36454 : else if (e->value.function.esym)
3196 : 31120 : return gfc_implicit_pure (e->value.function.esym);
3197 : : else
3198 : : return 0;
3199 : : }
3200 : :
3201 : :
3202 : : static bool
3203 : 981 : impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3204 : : int *f ATTRIBUTE_UNUSED)
3205 : : {
3206 : 981 : const char *name;
3207 : :
3208 : : /* Don't bother recursing into other statement functions
3209 : : since they will be checked individually for purity. */
3210 : 981 : if (e->expr_type != EXPR_FUNCTION
3211 : 343 : || !e->symtree
3212 : 343 : || e->symtree->n.sym == sym
3213 : 20 : || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3214 : : return false;
3215 : :
3216 : 19 : return gfc_pure_function (e, &name) ? false : true;
3217 : : }
3218 : :
3219 : :
3220 : : static bool
3221 : 305 : pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3222 : : {
3223 : 305 : return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3224 : : }
3225 : :
3226 : :
3227 : : /* Check if an impure function is allowed in the current context. */
3228 : :
3229 : 228177 : static bool check_pure_function (gfc_expr *e)
3230 : : {
3231 : 228177 : const char *name = NULL;
3232 : 228177 : code_stack *stack;
3233 : 228177 : bool saw_block = false;
3234 : :
3235 : : /* A BLOCK construct within a DO CONCURRENT construct leads to
3236 : : gfc_do_concurrent_flag = 0 when the check for an impure function
3237 : : occurs. Check the stack to see if the source code has a nested
3238 : : BLOCK construct. */
3239 : 529347 : for (stack = cs_base; stack; stack = stack->prev)
3240 : : {
3241 : 301171 : if (stack->current->op == EXEC_BLOCK) saw_block = true;
3242 : 301171 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3243 : : {
3244 : 1 : gfc_error ("Reference to impure function at %L inside a "
3245 : : "DO CONCURRENT", &e->where);
3246 : 1 : return false;
3247 : : }
3248 : : }
3249 : :
3250 : 228176 : if (!gfc_pure_function (e, &name) && name)
3251 : : {
3252 : 35436 : if (forall_flag)
3253 : : {
3254 : 4 : gfc_error ("Reference to impure function %qs at %L inside a "
3255 : : "FORALL %s", name, &e->where,
3256 : : forall_flag == 2 ? "mask" : "block");
3257 : 4 : return false;
3258 : : }
3259 : 35432 : else if (gfc_do_concurrent_flag)
3260 : : {
3261 : 1 : gfc_error ("Reference to impure function %qs at %L inside a "
3262 : : "DO CONCURRENT %s", name, &e->where,
3263 : : gfc_do_concurrent_flag == 2 ? "mask" : "block");
3264 : 1 : return false;
3265 : : }
3266 : 35431 : else if (gfc_pure (NULL))
3267 : : {
3268 : 5 : gfc_error ("Reference to impure function %qs at %L "
3269 : : "within a PURE procedure", name, &e->where);
3270 : 5 : return false;
3271 : : }
3272 : 35426 : if (!gfc_implicit_pure_function (e))
3273 : 29461 : gfc_unset_implicit_pure (NULL);
3274 : : }
3275 : : return true;
3276 : : }
3277 : :
3278 : :
3279 : : /* Update current procedure's array_outer_dependency flag, considering
3280 : : a call to procedure SYM. */
3281 : :
3282 : : static void
3283 : 127411 : update_current_proc_array_outer_dependency (gfc_symbol *sym)
3284 : : {
3285 : : /* Check to see if this is a sibling function that has not yet
3286 : : been resolved. */
3287 : 127411 : gfc_namespace *sibling = gfc_current_ns->sibling;
3288 : 240939 : for (; sibling; sibling = sibling->sibling)
3289 : : {
3290 : 120015 : if (sibling->proc_name == sym)
3291 : : {
3292 : 6487 : gfc_resolve (sibling);
3293 : 6487 : break;
3294 : : }
3295 : : }
3296 : :
3297 : : /* If SYM has references to outer arrays, so has the procedure calling
3298 : : SYM. If SYM is a procedure pointer, we can assume the worst. */
3299 : 127411 : if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3300 : 66236 : && gfc_current_ns->proc_name)
3301 : 66192 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3302 : 127411 : }
3303 : :
3304 : :
3305 : : /* Resolve a function call, which means resolving the arguments, then figuring
3306 : : out which entity the name refers to. */
3307 : :
3308 : : static bool
3309 : 324872 : resolve_function (gfc_expr *expr)
3310 : : {
3311 : 324872 : gfc_actual_arglist *arg;
3312 : 324872 : gfc_symbol *sym;
3313 : 324872 : bool t;
3314 : 324872 : int temp;
3315 : 324872 : procedure_type p = PROC_INTRINSIC;
3316 : 324872 : bool no_formal_args;
3317 : :
3318 : 324872 : sym = NULL;
3319 : 324872 : if (expr->symtree)
3320 : 324556 : sym = expr->symtree->n.sym;
3321 : :
3322 : : /* If this is a procedure pointer component, it has already been resolved. */
3323 : 324872 : if (gfc_is_proc_ptr_comp (expr))
3324 : : return true;
3325 : :
3326 : : /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3327 : : another caf_get. */
3328 : 324481 : if (sym && sym->attr.intrinsic
3329 : 8264 : && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3330 : 8264 : || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3331 : : return true;
3332 : :
3333 : 324479 : if (expr->ref)
3334 : : {
3335 : 1 : gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3336 : : &expr->where);
3337 : 1 : return false;
3338 : : }
3339 : :
3340 : 324162 : if (sym && sym->attr.intrinsic
3341 : 332740 : && !gfc_resolve_intrinsic (sym, &expr->where))
3342 : : return false;
3343 : :
3344 : 324478 : if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3345 : : {
3346 : 4 : gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3347 : 4 : return false;
3348 : : }
3349 : :
3350 : : /* If this is a deferred TBP with an abstract interface (which may
3351 : : of course be referenced), expr->value.function.esym will be set. */
3352 : 324158 : if (sym && sym->attr.abstract && !expr->value.function.esym)
3353 : : {
3354 : 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3355 : : sym->name, &expr->where);
3356 : 1 : return false;
3357 : : }
3358 : :
3359 : : /* If this is a deferred TBP with an abstract interface, its result
3360 : : cannot be an assumed length character (F2003: C418). */
3361 : 324157 : if (sym && sym->attr.abstract && sym->attr.function
3362 : 190 : && sym->result->ts.u.cl
3363 : 157 : && sym->result->ts.u.cl->length == NULL
3364 : 2 : && !sym->result->ts.deferred)
3365 : : {
3366 : 1 : gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3367 : : "character length result (F2008: C418)", sym->name,
3368 : : &sym->declared_at);
3369 : 1 : return false;
3370 : : }
3371 : :
3372 : : /* Switch off assumed size checking and do this again for certain kinds
3373 : : of procedure, once the procedure itself is resolved. */
3374 : 324472 : need_full_assumed_size++;
3375 : :
3376 : 324472 : if (expr->symtree && expr->symtree->n.sym)
3377 : 324156 : p = expr->symtree->n.sym->attr.proc;
3378 : :
3379 : 324472 : if (expr->value.function.isym && expr->value.function.isym->inquiry)
3380 : 1073 : inquiry_argument = true;
3381 : 324156 : no_formal_args = sym && is_external_proc (sym)
3382 : 337687 : && gfc_sym_get_dummy_args (sym) == NULL;
3383 : :
3384 : 324472 : if (!resolve_actual_arglist (expr->value.function.actual,
3385 : : p, no_formal_args))
3386 : : {
3387 : 64 : inquiry_argument = false;
3388 : 64 : return false;
3389 : : }
3390 : :
3391 : 324408 : inquiry_argument = false;
3392 : :
3393 : : /* Resume assumed_size checking. */
3394 : 324408 : need_full_assumed_size--;
3395 : :
3396 : : /* If the procedure is external, check for usage. */
3397 : 324408 : if (sym && is_external_proc (sym))
3398 : 13196 : resolve_global_procedure (sym, &expr->where, 0);
3399 : :
3400 : 324408 : if (sym && sym->ts.type == BT_CHARACTER
3401 : 3141 : && sym->ts.u.cl
3402 : 3081 : && sym->ts.u.cl->length == NULL
3403 : 581 : && !sym->attr.dummy
3404 : 576 : && !sym->ts.deferred
3405 : 2 : && expr->value.function.esym == NULL
3406 : 2 : && !sym->attr.contained)
3407 : : {
3408 : : /* Internal procedures are taken care of in resolve_contained_fntype. */
3409 : 1 : gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3410 : : "be used at %L since it is not a dummy argument",
3411 : : sym->name, &expr->where);
3412 : 1 : return false;
3413 : : }
3414 : :
3415 : : /* See if function is already resolved. */
3416 : :
3417 : 324407 : if (expr->value.function.name != NULL
3418 : 312905 : || expr->value.function.isym != NULL)
3419 : : {
3420 : 12294 : if (expr->ts.type == BT_UNKNOWN)
3421 : 3 : expr->ts = sym->ts;
3422 : : t = true;
3423 : : }
3424 : : else
3425 : : {
3426 : : /* Apply the rules of section 14.1.2. */
3427 : :
3428 : 312113 : switch (procedure_kind (sym))
3429 : : {
3430 : 26507 : case PTYPE_GENERIC:
3431 : 26507 : t = resolve_generic_f (expr);
3432 : 26507 : break;
3433 : :
3434 : 26869 : case PTYPE_SPECIFIC:
3435 : 26869 : t = resolve_specific_f (expr);
3436 : 26869 : break;
3437 : :
3438 : 258737 : case PTYPE_UNKNOWN:
3439 : 258737 : t = resolve_unknown_f (expr);
3440 : 258737 : break;
3441 : :
3442 : : default:
3443 : : gfc_internal_error ("resolve_function(): bad function type");
3444 : : }
3445 : : }
3446 : :
3447 : : /* If the expression is still a function (it might have simplified),
3448 : : then we check to see if we are calling an elemental function. */
3449 : :
3450 : 324407 : if (expr->expr_type != EXPR_FUNCTION)
3451 : : return t;
3452 : :
3453 : : /* Walk the argument list looking for invalid BOZ. */
3454 : 684414 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3455 : 456505 : if (arg->expr && arg->expr->ts.type == BT_BOZ)
3456 : : {
3457 : 5 : gfc_error ("A BOZ literal constant at %L cannot appear as an "
3458 : : "actual argument in a function reference",
3459 : : &arg->expr->where);
3460 : 5 : return false;
3461 : : }
3462 : :
3463 : 227909 : temp = need_full_assumed_size;
3464 : 227909 : need_full_assumed_size = 0;
3465 : :
3466 : 227909 : if (!resolve_elemental_actual (expr, NULL))
3467 : : return false;
3468 : :
3469 : 227906 : if (omp_workshare_flag
3470 : 32 : && expr->value.function.esym
3471 : 227911 : && ! gfc_elemental (expr->value.function.esym))
3472 : : {
3473 : 4 : gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3474 : 4 : "in WORKSHARE construct", expr->value.function.esym->name,
3475 : : &expr->where);
3476 : 4 : t = false;
3477 : : }
3478 : :
3479 : : #define GENERIC_ID expr->value.function.isym->id
3480 : 227902 : else if (expr->value.function.actual != NULL
3481 : 220150 : && expr->value.function.isym != NULL
3482 : 176455 : && GENERIC_ID != GFC_ISYM_LBOUND
3483 : : && GENERIC_ID != GFC_ISYM_LCOBOUND
3484 : : && GENERIC_ID != GFC_ISYM_UCOBOUND
3485 : : && GENERIC_ID != GFC_ISYM_LEN
3486 : : && GENERIC_ID != GFC_ISYM_LOC
3487 : : && GENERIC_ID != GFC_ISYM_C_LOC
3488 : : && GENERIC_ID != GFC_ISYM_PRESENT)
3489 : : {
3490 : : /* Array intrinsics must also have the last upper bound of an
3491 : : assumed size array argument. UBOUND and SIZE have to be
3492 : : excluded from the check if the second argument is anything
3493 : : than a constant. */
3494 : :
3495 : 487504 : for (arg = expr->value.function.actual; arg; arg = arg->next)
3496 : : {
3497 : 336031 : if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3498 : 44437 : && arg == expr->value.function.actual
3499 : 16413 : && arg->next != NULL && arg->next->expr)
3500 : : {
3501 : 8160 : if (arg->next->expr->expr_type != EXPR_CONSTANT)
3502 : : break;
3503 : :
3504 : 7936 : if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3505 : : break;
3506 : :
3507 : 7936 : if ((int)mpz_get_si (arg->next->expr->value.integer)
3508 : 7936 : < arg->expr->rank)
3509 : : break;
3510 : : }
3511 : :
3512 : 333632 : if (arg->expr != NULL
3513 : 222243 : && arg->expr->rank > 0
3514 : 441265 : && resolve_assumed_size_actual (arg->expr))
3515 : : return false;
3516 : : }
3517 : : }
3518 : : #undef GENERIC_ID
3519 : :
3520 : 227903 : need_full_assumed_size = temp;
3521 : :
3522 : 227903 : if (!check_pure_function(expr))
3523 : 10 : t = false;
3524 : :
3525 : : /* Functions without the RECURSIVE attribution are not allowed to
3526 : : * call themselves. */
3527 : 227903 : if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3528 : : {
3529 : 50088 : gfc_symbol *esym;
3530 : 50088 : esym = expr->value.function.esym;
3531 : :
3532 : 50088 : if (is_illegal_recursion (esym, gfc_current_ns))
3533 : : {
3534 : 5 : if (esym->attr.entry && esym->ns->entries)
3535 : 3 : gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3536 : : " function %qs is not RECURSIVE",
3537 : 3 : esym->name, &expr->where, esym->ns->entries->sym->name);
3538 : : else
3539 : 2 : gfc_error ("Function %qs at %L cannot be called recursively, as it"
3540 : : " is not RECURSIVE", esym->name, &expr->where);
3541 : :
3542 : : t = false;
3543 : : }
3544 : : }
3545 : :
3546 : : /* Character lengths of use associated functions may contains references to
3547 : : symbols not referenced from the current program unit otherwise. Make sure
3548 : : those symbols are marked as referenced. */
3549 : :
3550 : 227903 : if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3551 : 3279 : && expr->value.function.esym->attr.use_assoc)
3552 : : {
3553 : 1223 : gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3554 : : }
3555 : :
3556 : : /* Make sure that the expression has a typespec that works. */
3557 : 227903 : if (expr->ts.type == BT_UNKNOWN)
3558 : : {
3559 : 812 : if (expr->symtree->n.sym->result
3560 : 804 : && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3561 : 501 : && !expr->symtree->n.sym->result->attr.proc_pointer)
3562 : 501 : expr->ts = expr->symtree->n.sym->result->ts;
3563 : : }
3564 : :
3565 : : /* These derived types with an incomplete namespace, arising from use
3566 : : association, cause gfc_get_derived_vtab to segfault. If the function
3567 : : namespace does not suffice, something is badly wrong. */
3568 : 227903 : if (expr->ts.type == BT_DERIVED
3569 : 8714 : && !expr->ts.u.derived->ns->proc_name)
3570 : : {
3571 : 3 : gfc_symbol *der;
3572 : 3 : gfc_find_symbol (expr->ts.u.derived->name, expr->symtree->n.sym->ns, 1, &der);
3573 : 3 : if (der)
3574 : : {
3575 : 3 : expr->ts.u.derived->refs--;
3576 : 3 : expr->ts.u.derived = der;
3577 : 3 : der->refs++;
3578 : : }
3579 : : else
3580 : 0 : expr->ts.u.derived->ns = expr->symtree->n.sym->ns;
3581 : : }
3582 : :
3583 : 227903 : if (!expr->ref && !expr->value.function.isym)
3584 : : {
3585 : 51327 : if (expr->value.function.esym)
3586 : 50363 : update_current_proc_array_outer_dependency (expr->value.function.esym);
3587 : : else
3588 : 964 : update_current_proc_array_outer_dependency (sym);
3589 : : }
3590 : 176576 : else if (expr->ref)
3591 : : /* typebound procedure: Assume the worst. */
3592 : 0 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3593 : :
3594 : 227903 : if (expr->value.function.esym
3595 : 50363 : && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3596 : 2 : gfc_warning (OPT_Wdeprecated_declarations,
3597 : : "Using function %qs at %L is deprecated",
3598 : : sym->name, &expr->where);
3599 : : return t;
3600 : : }
3601 : :
3602 : :
3603 : : /************* Subroutine resolution *************/
3604 : :
3605 : : static bool
3606 : 73945 : pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3607 : : {
3608 : 73945 : code_stack *stack;
3609 : 73945 : bool saw_block = false;
3610 : :
3611 : 73945 : if (gfc_pure (sym))
3612 : : return true;
3613 : :
3614 : : /* A BLOCK construct within a DO CONCURRENT construct leads to
3615 : : gfc_do_concurrent_flag = 0 when the check for an impure subroutine
3616 : : occurs. Check the stack to see if the source code has a nested
3617 : : BLOCK construct. */
3618 : 153956 : for (stack = cs_base; stack; stack = stack->prev)
3619 : : {
3620 : 84837 : if (stack->current->op == EXEC_BLOCK) saw_block = true;
3621 : 84837 : if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
3622 : : {
3623 : 1 : gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
3624 : : "is not PURE", loc);
3625 : 1 : return false;
3626 : : }
3627 : : }
3628 : :
3629 : 69119 : if (forall_flag)
3630 : : {
3631 : 0 : gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3632 : : name, loc);
3633 : 0 : return false;
3634 : : }
3635 : 69119 : else if (gfc_do_concurrent_flag)
3636 : : {
3637 : 5 : gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3638 : : "PURE", name, loc);
3639 : 5 : return false;
3640 : : }
3641 : 69114 : else if (gfc_pure (NULL))
3642 : : {
3643 : 4 : gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3644 : 4 : return false;
3645 : : }
3646 : :
3647 : 69110 : gfc_unset_implicit_pure (NULL);
3648 : 69110 : return true;
3649 : : }
3650 : :
3651 : :
3652 : : static match
3653 : 2165 : resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3654 : : {
3655 : 2165 : gfc_symbol *s;
3656 : :
3657 : 2165 : if (sym->attr.generic)
3658 : : {
3659 : 2164 : s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3660 : 2164 : if (s != NULL)
3661 : : {
3662 : 2155 : c->resolved_sym = s;
3663 : 2155 : if (!pure_subroutine (s, s->name, &c->loc))
3664 : : return MATCH_ERROR;
3665 : 2155 : return MATCH_YES;
3666 : : }
3667 : :
3668 : : /* TODO: Need to search for elemental references in generic interface. */
3669 : : }
3670 : :
3671 : 10 : if (sym->attr.intrinsic)
3672 : 1 : return gfc_intrinsic_sub_interface (c, 0);
3673 : :
3674 : : return MATCH_NO;
3675 : : }
3676 : :
3677 : :
3678 : : static bool
3679 : 2163 : resolve_generic_s (gfc_code *c)
3680 : : {
3681 : 2163 : gfc_symbol *sym;
3682 : 2163 : match m;
3683 : :
3684 : 2163 : sym = c->symtree->n.sym;
3685 : :
3686 : 2165 : for (;;)
3687 : : {
3688 : 2165 : m = resolve_generic_s0 (c, sym);
3689 : 2165 : if (m == MATCH_YES)
3690 : : return true;
3691 : 9 : else if (m == MATCH_ERROR)
3692 : : return false;
3693 : :
3694 : 9 : generic:
3695 : 9 : if (sym->ns->parent == NULL)
3696 : : break;
3697 : 3 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3698 : :
3699 : 3 : if (sym == NULL)
3700 : : break;
3701 : 2 : if (!generic_sym (sym))
3702 : 0 : goto generic;
3703 : : }
3704 : :
3705 : : /* Last ditch attempt. See if the reference is to an intrinsic
3706 : : that possesses a matching interface. 14.1.2.4 */
3707 : 7 : sym = c->symtree->n.sym;
3708 : :
3709 : 7 : if (!gfc_is_intrinsic (sym, 1, c->loc))
3710 : : {
3711 : 4 : gfc_error ("There is no specific subroutine for the generic %qs at %L",
3712 : : sym->name, &c->loc);
3713 : 4 : return false;
3714 : : }
3715 : :
3716 : 3 : m = gfc_intrinsic_sub_interface (c, 0);
3717 : 3 : if (m == MATCH_YES)
3718 : : return true;
3719 : 1 : if (m == MATCH_NO)
3720 : 1 : gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3721 : : "intrinsic subroutine interface", sym->name, &c->loc);
3722 : :
3723 : : return false;
3724 : : }
3725 : :
3726 : :
3727 : : /* Resolve a subroutine call known to be specific. */
3728 : :
3729 : : static match
3730 : 60227 : resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3731 : : {
3732 : 60227 : match m;
3733 : :
3734 : 60227 : if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3735 : : {
3736 : 5498 : if (sym->attr.dummy)
3737 : : {
3738 : 252 : sym->attr.proc = PROC_DUMMY;
3739 : 252 : goto found;
3740 : : }
3741 : :
3742 : 5246 : sym->attr.proc = PROC_EXTERNAL;
3743 : 5246 : goto found;
3744 : : }
3745 : :
3746 : 54729 : if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3747 : 54729 : goto found;
3748 : :
3749 : 0 : if (sym->attr.intrinsic)
3750 : : {
3751 : 0 : m = gfc_intrinsic_sub_interface (c, 1);
3752 : 0 : if (m == MATCH_YES)
3753 : : return MATCH_YES;
3754 : 0 : if (m == MATCH_NO)
3755 : 0 : gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3756 : : "with an intrinsic", sym->name, &c->loc);
3757 : :
3758 : 0 : return MATCH_ERROR;
3759 : : }
3760 : :
3761 : : return MATCH_NO;
3762 : :
3763 : 60227 : found:
3764 : 60227 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3765 : :
3766 : 60227 : c->resolved_sym = sym;
3767 : 60227 : if (!pure_subroutine (sym, sym->name, &c->loc))
3768 : : return MATCH_ERROR;
3769 : :
3770 : : return MATCH_YES;
3771 : : }
3772 : :
3773 : :
3774 : : static bool
3775 : 60227 : resolve_specific_s (gfc_code *c)
3776 : : {
3777 : 60227 : gfc_symbol *sym;
3778 : 60227 : match m;
3779 : :
3780 : 60227 : sym = c->symtree->n.sym;
3781 : :
3782 : 60227 : for (;;)
3783 : : {
3784 : 60227 : m = resolve_specific_s0 (c, sym);
3785 : 60227 : if (m == MATCH_YES)
3786 : : return true;
3787 : 5 : if (m == MATCH_ERROR)
3788 : : return false;
3789 : :
3790 : 0 : if (sym->ns->parent == NULL)
3791 : : break;
3792 : :
3793 : 0 : gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3794 : :
3795 : 0 : if (sym == NULL)
3796 : : break;
3797 : : }
3798 : :
3799 : 0 : sym = c->symtree->n.sym;
3800 : 0 : gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3801 : : sym->name, &c->loc);
3802 : :
3803 : 0 : return false;
3804 : : }
3805 : :
3806 : :
3807 : : /* Resolve a subroutine call not known to be generic nor specific. */
3808 : :
3809 : : static bool
3810 : 15315 : resolve_unknown_s (gfc_code *c)
3811 : : {
3812 : 15315 : gfc_symbol *sym;
3813 : :
3814 : 15315 : sym = c->symtree->n.sym;
3815 : :
3816 : 15315 : if (sym->attr.dummy)
3817 : : {
3818 : 19 : sym->attr.proc = PROC_DUMMY;
3819 : 19 : goto found;
3820 : : }
3821 : :
3822 : : /* See if we have an intrinsic function reference. */
3823 : :
3824 : 15296 : if (gfc_is_intrinsic (sym, 1, c->loc))
3825 : : {
3826 : 3874 : if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3827 : : return true;
3828 : 294 : return false;
3829 : : }
3830 : :
3831 : : /* The reference is to an external name. */
3832 : :
3833 : 11422 : found:
3834 : 11441 : gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3835 : :
3836 : 11441 : c->resolved_sym = sym;
3837 : :
3838 : 11441 : return pure_subroutine (sym, sym->name, &c->loc);
3839 : : }
3840 : :
3841 : :
3842 : : /* Resolve a subroutine call. Although it was tempting to use the same code
3843 : : for functions, subroutines and functions are stored differently and this
3844 : : makes things awkward. */
3845 : :
3846 : : static bool
3847 : 77789 : resolve_call (gfc_code *c)
3848 : : {
3849 : 77789 : bool t;
3850 : 77789 : procedure_type ptype = PROC_INTRINSIC;
3851 : 77789 : gfc_symbol *csym, *sym;
3852 : 77789 : bool no_formal_args;
3853 : :
3854 : 77789 : csym = c->symtree ? c->symtree->n.sym : NULL;
3855 : :
3856 : 77789 : if (csym && csym->ts.type != BT_UNKNOWN)
3857 : : {
3858 : 4 : gfc_error ("%qs at %L has a type, which is not consistent with "
3859 : : "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3860 : 4 : return false;
3861 : : }
3862 : :
3863 : 77785 : if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3864 : : {
3865 : 16045 : gfc_symtree *st;
3866 : 16045 : gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3867 : 16045 : sym = st ? st->n.sym : NULL;
3868 : 16045 : if (sym && csym != sym
3869 : 3 : && sym->ns == gfc_current_ns
3870 : : && sym->attr.flavor == FL_PROCEDURE
3871 : 3 : && sym->attr.contained)
3872 : : {
3873 : 3 : sym->refs++;
3874 : 3 : if (csym->attr.generic)
3875 : 2 : c->symtree->n.sym = sym;
3876 : : else
3877 : 1 : c->symtree = st;
3878 : 3 : csym = c->symtree->n.sym;
3879 : : }
3880 : : }
3881 : :
3882 : : /* If this ia a deferred TBP, c->expr1 will be set. */
3883 : 77785 : if (!c->expr1 && csym)
3884 : : {
3885 : 76127 : if (csym->attr.abstract)
3886 : : {
3887 : 1 : gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3888 : : csym->name, &c->loc);
3889 : 1 : return false;
3890 : : }
3891 : :
3892 : : /* Subroutines without the RECURSIVE attribution are not allowed to
3893 : : call themselves. */
3894 : 76126 : if (is_illegal_recursion (csym, gfc_current_ns))
3895 : : {
3896 : 4 : if (csym->attr.entry && csym->ns->entries)
3897 : 2 : gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3898 : : "as subroutine %qs is not RECURSIVE",
3899 : 2 : csym->name, &c->loc, csym->ns->entries->sym->name);
3900 : : else
3901 : 2 : gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3902 : : "as it is not RECURSIVE", csym->name, &c->loc);
3903 : :
3904 : 77784 : t = false;
3905 : : }
3906 : : }
3907 : :
3908 : : /* Switch off assumed size checking and do this again for certain kinds
3909 : : of procedure, once the procedure itself is resolved. */
3910 : 77784 : need_full_assumed_size++;
3911 : :
3912 : 77784 : if (csym)
3913 : 77784 : ptype = csym->attr.proc;
3914 : :
3915 : 77784 : no_formal_args = csym && is_external_proc (csym)
3916 : 15440 : && gfc_sym_get_dummy_args (csym) == NULL;
3917 : 77784 : if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
3918 : : return false;
3919 : :
3920 : : /* Resume assumed_size checking. */
3921 : 77751 : need_full_assumed_size--;
3922 : :
3923 : : /* If external, check for usage. */
3924 : 77751 : if (csym && is_external_proc (csym))
3925 : 15435 : resolve_global_procedure (csym, &c->loc, 1);
3926 : :
3927 : 77751 : t = true;
3928 : 77751 : if (c->resolved_sym == NULL)
3929 : : {
3930 : 77705 : c->resolved_isym = NULL;
3931 : 77705 : switch (procedure_kind (csym))
3932 : : {
3933 : 2163 : case PTYPE_GENERIC:
3934 : 2163 : t = resolve_generic_s (c);
3935 : 2163 : break;
3936 : :
3937 : 60227 : case PTYPE_SPECIFIC:
3938 : 60227 : t = resolve_specific_s (c);
3939 : 60227 : break;
3940 : :
3941 : 15315 : case PTYPE_UNKNOWN:
3942 : 15315 : t = resolve_unknown_s (c);
3943 : 15315 : break;
3944 : :
3945 : : default:
3946 : : gfc_internal_error ("resolve_subroutine(): bad function type");
3947 : : }
3948 : : }
3949 : :
3950 : : /* Some checks of elemental subroutine actual arguments. */
3951 : 77750 : if (!resolve_elemental_actual (NULL, c))
3952 : : return false;
3953 : :
3954 : 77742 : if (!c->expr1)
3955 : 76084 : update_current_proc_array_outer_dependency (csym);
3956 : : else
3957 : : /* Typebound procedure: Assume the worst. */
3958 : 1658 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3959 : :
3960 : 77742 : if (c->resolved_sym
3961 : 77444 : && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3962 : 2 : gfc_warning (OPT_Wdeprecated_declarations,
3963 : : "Using subroutine %qs at %L is deprecated",
3964 : : c->resolved_sym->name, &c->loc);
3965 : :
3966 : : return t;
3967 : : }
3968 : :
3969 : :
3970 : : /* Compare the shapes of two arrays that have non-NULL shapes. If both
3971 : : op1->shape and op2->shape are non-NULL return true if their shapes
3972 : : match. If both op1->shape and op2->shape are non-NULL return false
3973 : : if their shapes do not match. If either op1->shape or op2->shape is
3974 : : NULL, return true. */
3975 : :
3976 : : static bool
3977 : 30761 : compare_shapes (gfc_expr *op1, gfc_expr *op2)
3978 : : {
3979 : 30761 : bool t;
3980 : 30761 : int i;
3981 : :
3982 : 30761 : t = true;
3983 : :
3984 : 30761 : if (op1->shape != NULL && op2->shape != NULL)
3985 : : {
3986 : 41603 : for (i = 0; i < op1->rank; i++)
3987 : : {
3988 : 22226 : if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3989 : : {
3990 : 3 : gfc_error ("Shapes for operands at %L and %L are not conformable",
3991 : : &op1->where, &op2->where);
3992 : 3 : t = false;
3993 : 3 : break;
3994 : : }
3995 : : }
3996 : : }
3997 : :
3998 : 30761 : return t;
3999 : : }
4000 : :
4001 : : /* Convert a logical operator to the corresponding bitwise intrinsic call.
4002 : : For example A .AND. B becomes IAND(A, B). */
4003 : : static gfc_expr *
4004 : 668 : logical_to_bitwise (gfc_expr *e)
4005 : : {
4006 : 668 : gfc_expr *tmp, *op1, *op2;
4007 : 668 : gfc_isym_id isym;
4008 : 668 : gfc_actual_arglist *args = NULL;
4009 : :
4010 : 668 : gcc_assert (e->expr_type == EXPR_OP);
4011 : :
4012 : 668 : isym = GFC_ISYM_NONE;
4013 : 668 : op1 = e->value.op.op1;
4014 : 668 : op2 = e->value.op.op2;
4015 : :
4016 : 668 : switch (e->value.op.op)
4017 : : {
4018 : : case INTRINSIC_NOT:
4019 : : isym = GFC_ISYM_NOT;
4020 : : break;
4021 : 126 : case INTRINSIC_AND:
4022 : 126 : isym = GFC_ISYM_IAND;
4023 : 126 : break;
4024 : 127 : case INTRINSIC_OR:
4025 : 127 : isym = GFC_ISYM_IOR;
4026 : 127 : break;
4027 : 270 : case INTRINSIC_NEQV:
4028 : 270 : isym = GFC_ISYM_IEOR;
4029 : 270 : break;
4030 : 126 : case INTRINSIC_EQV:
4031 : : /* "Bitwise eqv" is just the complement of NEQV === IEOR.
4032 : : Change the old expression to NEQV, which will get replaced by IEOR,
4033 : : and wrap it in NOT. */
4034 : 126 : tmp = gfc_copy_expr (e);
4035 : 126 : tmp->value.op.op = INTRINSIC_NEQV;
4036 : 126 : tmp = logical_to_bitwise (tmp);
4037 : 126 : isym = GFC_ISYM_NOT;
4038 : 126 : op1 = tmp;
4039 : 126 : op2 = NULL;
4040 : 126 : break;
4041 : 0 : default:
4042 : 0 : gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
4043 : : }
4044 : :
4045 : : /* Inherit the original operation's operands as arguments. */
4046 : 668 : args = gfc_get_actual_arglist ();
4047 : 668 : args->expr = op1;
4048 : 668 : if (op2)
4049 : : {
4050 : 523 : args->next = gfc_get_actual_arglist ();
4051 : 523 : args->next->expr = op2;
4052 : : }
4053 : :
4054 : : /* Convert the expression to a function call. */
4055 : 668 : e->expr_type = EXPR_FUNCTION;
4056 : 668 : e->value.function.actual = args;
4057 : 668 : e->value.function.isym = gfc_intrinsic_function_by_id (isym);
4058 : 668 : e->value.function.name = e->value.function.isym->name;
4059 : 668 : e->value.function.esym = NULL;
4060 : :
4061 : : /* Make up a pre-resolved function call symtree if we need to. */
4062 : 668 : if (!e->symtree || !e->symtree->n.sym)
4063 : : {
4064 : 668 : gfc_symbol *sym;
4065 : 668 : gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
4066 : 668 : sym = e->symtree->n.sym;
4067 : 668 : sym->result = sym;
4068 : 668 : sym->attr.flavor = FL_PROCEDURE;
4069 : 668 : sym->attr.function = 1;
4070 : 668 : sym->attr.elemental = 1;
4071 : 668 : sym->attr.pure = 1;
4072 : 668 : sym->attr.referenced = 1;
4073 : 668 : gfc_intrinsic_symbol (sym);
4074 : 668 : gfc_commit_symbol (sym);
4075 : : }
4076 : :
4077 : 668 : args->name = e->value.function.isym->formal->name;
4078 : 668 : if (e->value.function.isym->formal->next)
4079 : 523 : args->next->name = e->value.function.isym->formal->next->name;
4080 : :
4081 : 668 : return e;
4082 : : }
4083 : :
4084 : : /* Recursively append candidate UOP to CANDIDATES. Store the number of
4085 : : candidates in CANDIDATES_LEN. */
4086 : : static void
4087 : 43 : lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
4088 : : char **&candidates,
4089 : : size_t &candidates_len)
4090 : : {
4091 : 45 : gfc_symtree *p;
4092 : :
4093 : 45 : if (uop == NULL)
4094 : : return;
4095 : :
4096 : : /* Not sure how to properly filter here. Use all for a start.
4097 : : n.uop.op is NULL for empty interface operators (is that legal?) disregard
4098 : : these as i suppose they don't make terribly sense. */
4099 : :
4100 : 45 : if (uop->n.uop->op != NULL)
4101 : 2 : vec_push (candidates, candidates_len, uop->name);
4102 : :
4103 : 45 : p = uop->left;
4104 : 45 : if (p)
4105 : 0 : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4106 : :
4107 : 45 : p = uop->right;
4108 : 45 : if (p)
4109 : : lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
4110 : : }
4111 : :
4112 : : /* Lookup user-operator OP fuzzily, taking names in UOP into account. */
4113 : :
4114 : : static const char*
4115 : 43 : lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
4116 : : {
4117 : 43 : char **candidates = NULL;
4118 : 43 : size_t candidates_len = 0;
4119 : 43 : lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
4120 : 43 : return gfc_closest_fuzzy_match (op, candidates);
4121 : : }
4122 : :
4123 : :
4124 : : /* Callback finding an impure function as an operand to an .and. or
4125 : : .or. expression. Remember the last function warned about to
4126 : : avoid double warnings when recursing. */
4127 : :
4128 : : static int
4129 : 112467 : impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4130 : : void *data)
4131 : : {
4132 : 112467 : gfc_expr *f = *e;
4133 : 112467 : const char *name;
4134 : 112467 : static gfc_expr *last = NULL;
4135 : 112467 : bool *found = (bool *) data;
4136 : :
4137 : 112467 : if (f->expr_type == EXPR_FUNCTION)
4138 : : {
4139 : 11366 : *found = 1;
4140 : 11366 : if (f != last && !gfc_pure_function (f, &name)
4141 : 12666 : && !gfc_implicit_pure_function (f))
4142 : : {
4143 : 1161 : if (name)
4144 : 1161 : gfc_warning (OPT_Wfunction_elimination,
4145 : : "Impure function %qs at %L might not be evaluated",
4146 : : name, &f->where);
4147 : : else
4148 : 0 : gfc_warning (OPT_Wfunction_elimination,
4149 : : "Impure function at %L might not be evaluated",
4150 : : &f->where);
4151 : : }
4152 : 11366 : last = f;
4153 : : }
4154 : :
4155 : 112467 : return 0;
4156 : : }
4157 : :
4158 : : /* Return true if TYPE is character based, false otherwise. */
4159 : :
4160 : : static int
4161 : 1373 : is_character_based (bt type)
4162 : : {
4163 : 1373 : return type == BT_CHARACTER || type == BT_HOLLERITH;
4164 : : }
4165 : :
4166 : :
4167 : : /* If expression is a hollerith, convert it to character and issue a warning
4168 : : for the conversion. */
4169 : :
4170 : : static void
4171 : 408 : convert_hollerith_to_character (gfc_expr *e)
4172 : : {
4173 : 408 : if (e->ts.type == BT_HOLLERITH)
4174 : : {
4175 : 108 : gfc_typespec t;
4176 : 108 : gfc_clear_ts (&t);
4177 : 108 : t.type = BT_CHARACTER;
4178 : 108 : t.kind = e->ts.kind;
4179 : 108 : gfc_convert_type_warn (e, &t, 2, 1);
4180 : : }
4181 : 408 : }
4182 : :
4183 : : /* Convert to numeric and issue a warning for the conversion. */
4184 : :
4185 : : static void
4186 : 240 : convert_to_numeric (gfc_expr *a, gfc_expr *b)
4187 : : {
4188 : 240 : gfc_typespec t;
4189 : 240 : gfc_clear_ts (&t);
4190 : 240 : t.type = b->ts.type;
4191 : 240 : t.kind = b->ts.kind;
4192 : 240 : gfc_convert_type_warn (a, &t, 2, 1);
4193 : 240 : }
4194 : :
4195 : : /* Resolve an operator expression node. This can involve replacing the
4196 : : operation with a user defined function call. CHECK_INTERFACES is a
4197 : : helper macro. */
4198 : :
4199 : : #define CHECK_INTERFACES \
4200 : : { \
4201 : : match m = gfc_extend_expr (e); \
4202 : : if (m == MATCH_YES) \
4203 : : return true; \
4204 : : if (m == MATCH_ERROR) \
4205 : : return false; \
4206 : : }
4207 : :
4208 : : static bool
4209 : 388672 : resolve_operator (gfc_expr *e)
4210 : : {
4211 : 388672 : gfc_expr *op1, *op2;
4212 : : /* One error uses 3 names; additional space for wording (also via gettext). */
4213 : 388672 : bool t = true;
4214 : :
4215 : : /* Reduce stacked parentheses to single pair */
4216 : 388672 : while (e->expr_type == EXPR_OP
4217 : 388782 : && e->value.op.op == INTRINSIC_PARENTHESES
4218 : 20724 : && e->value.op.op1->expr_type == EXPR_OP
4219 : 405230 : && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
4220 : : {
4221 : 110 : gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
4222 : 110 : gfc_replace_expr (e, tmp);
4223 : : }
4224 : :
4225 : : /* Resolve all subnodes-- give them types. */
4226 : :
4227 : 388672 : switch (e->value.op.op)
4228 : : {
4229 : 341010 : default:
4230 : 341010 : if (!gfc_resolve_expr (e->value.op.op2))
4231 : 388672 : t = false;
4232 : :
4233 : : /* Fall through. */
4234 : :
4235 : 388672 : case INTRINSIC_NOT:
4236 : 388672 : case INTRINSIC_UPLUS:
4237 : 388672 : case INTRINSIC_UMINUS:
4238 : 388672 : case INTRINSIC_PARENTHESES:
4239 : 388672 : if (!gfc_resolve_expr (e->value.op.op1))
4240 : : return false;
4241 : 388505 : if (e->value.op.op1
4242 : 388496 : && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4243 : : {
4244 : 0 : gfc_error ("BOZ literal constant at %L cannot be an operand of "
4245 : 0 : "unary operator %qs", &e->value.op.op1->where,
4246 : : gfc_op2string (e->value.op.op));
4247 : 0 : return false;
4248 : : }
4249 : 388505 : if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
4250 : 3 : && e->value.op.op == INTRINSIC_UMINUS)
4251 : : {
4252 : 2 : gfc_error ("Negation of unsigned expression at %L not permitted ",
4253 : : &e->value.op.op1->where);
4254 : 2 : return false;
4255 : : }
4256 : 388503 : break;
4257 : : }
4258 : :
4259 : : /* Typecheck the new node. */
4260 : :
4261 : 388503 : op1 = e->value.op.op1;
4262 : 388503 : op2 = e->value.op.op2;
4263 : 388503 : if (op1 == NULL && op2 == NULL)
4264 : : return false;
4265 : : /* Error out if op2 did not resolve. We already diagnosed op1. */
4266 : 388494 : if (t == false)
4267 : : return false;
4268 : :
4269 : : /* op1 and op2 cannot both be BOZ. */
4270 : 388432 : if (op1 && op1->ts.type == BT_BOZ
4271 : 0 : && op2 && op2->ts.type == BT_BOZ)
4272 : : {
4273 : 0 : gfc_error ("Operands at %L and %L cannot appear as operands of "
4274 : 0 : "binary operator %qs", &op1->where, &op2->where,
4275 : : gfc_op2string (e->value.op.op));
4276 : 0 : return false;
4277 : : }
4278 : :
4279 : 388432 : if ((op1 && op1->expr_type == EXPR_NULL)
4280 : 388430 : || (op2 && op2->expr_type == EXPR_NULL))
4281 : : {
4282 : 3 : CHECK_INTERFACES
4283 : 3 : gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
4284 : 3 : return false;
4285 : : }
4286 : :
4287 : 388429 : switch (e->value.op.op)
4288 : : {
4289 : 7853 : case INTRINSIC_UPLUS:
4290 : 7853 : case INTRINSIC_UMINUS:
4291 : 7853 : if (op1->ts.type == BT_INTEGER
4292 : : || op1->ts.type == BT_REAL
4293 : : || op1->ts.type == BT_COMPLEX
4294 : : || op1->ts.type == BT_UNSIGNED)
4295 : : {
4296 : 7784 : e->ts = op1->ts;
4297 : 7784 : break;
4298 : : }
4299 : :
4300 : 69 : CHECK_INTERFACES
4301 : 43 : gfc_error ("Operand of unary numeric operator %qs at %L is %s",
4302 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
4303 : 43 : return false;
4304 : :
4305 : 3637 : case INTRINSIC_POWER:
4306 : :
4307 : 3637 : if (flag_unsigned)
4308 : : {
4309 : 26 : if (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED)
4310 : : {
4311 : 2 : CHECK_INTERFACES
4312 : 2 : gfc_error ("Exponentiation not valid at %L for %s and %s",
4313 : : &e->where, gfc_typename (op1), gfc_typename (op2));
4314 : 2 : return false;
4315 : : }
4316 : : }
4317 : 104355 : gcc_fallthrough ();
4318 : :
4319 : 104355 : case INTRINSIC_PLUS:
4320 : 104355 : case INTRINSIC_MINUS:
4321 : 104355 : case INTRINSIC_TIMES:
4322 : 104355 : case INTRINSIC_DIVIDE:
4323 : :
4324 : : /* UNSIGNED cannot appear in a mixed expression without explicit
4325 : : conversion. */
4326 : 104355 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4327 : : {
4328 : 2 : CHECK_INTERFACES
4329 : 2 : gfc_error ("Operands of binary numeric operator %qs at %L are "
4330 : : "%s/%s", gfc_op2string (e->value.op.op), &e->where,
4331 : : gfc_typename (op1), gfc_typename (op2));
4332 : 2 : return false;
4333 : : }
4334 : :
4335 : 104353 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4336 : : {
4337 : : /* Do not perform conversions if operands are not conformable as
4338 : : required for the binary intrinsic operators (F2018:10.1.5).
4339 : : Defer to a possibly overloading user-defined operator. */
4340 : 103909 : if (!gfc_op_rank_conformable (op1, op2))
4341 : : {
4342 : 36 : CHECK_INTERFACES
4343 : 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4344 : 0 : &op1->where, &op2->where);
4345 : 0 : return false;
4346 : : }
4347 : :
4348 : 103873 : gfc_type_convert_binary (e, 1);
4349 : 103873 : break;
4350 : : }
4351 : :
4352 : 444 : if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4353 : : {
4354 : 215 : CHECK_INTERFACES
4355 : 2 : gfc_error ("Unexpected derived-type entities in binary intrinsic "
4356 : : "numeric operator %qs at %L",
4357 : : gfc_op2string (e->value.op.op), &e->where);
4358 : 2 : return false;
4359 : : }
4360 : : else
4361 : : {
4362 : 229 : CHECK_INTERFACES
4363 : 3 : gfc_error ("Operands of binary numeric operator %qs at %L are %s/%s",
4364 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4365 : : gfc_typename (op2));
4366 : 3 : return false;
4367 : : }
4368 : :
4369 : 2300 : case INTRINSIC_CONCAT:
4370 : 2300 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4371 : 2275 : && op1->ts.kind == op2->ts.kind)
4372 : : {
4373 : 2266 : e->ts.type = BT_CHARACTER;
4374 : 2266 : e->ts.kind = op1->ts.kind;
4375 : 2266 : break;
4376 : : }
4377 : :
4378 : 34 : CHECK_INTERFACES
4379 : 10 : gfc_error ("Operands of string concatenation operator at %L are %s/%s",
4380 : : &e->where, gfc_typename (op1), gfc_typename (op2));
4381 : 10 : return false;
4382 : :
4383 : 37774 : case INTRINSIC_AND:
4384 : 37774 : case INTRINSIC_OR:
4385 : 37774 : case INTRINSIC_EQV:
4386 : 37774 : case INTRINSIC_NEQV:
4387 : 37774 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4388 : : {
4389 : 37223 : e->ts.type = BT_LOGICAL;
4390 : 37223 : e->ts.kind = gfc_kind_max (op1, op2);
4391 : 37223 : if (op1->ts.kind < e->ts.kind)
4392 : 138 : gfc_convert_type (op1, &e->ts, 2);
4393 : 37085 : else if (op2->ts.kind < e->ts.kind)
4394 : 117 : gfc_convert_type (op2, &e->ts, 2);
4395 : :
4396 : 37223 : if (flag_frontend_optimize &&
4397 : 31414 : (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4398 : : {
4399 : : /* Warn about short-circuiting
4400 : : with impure function as second operand. */
4401 : 25627 : bool op2_f = false;
4402 : 25627 : gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4403 : : }
4404 : : break;
4405 : : }
4406 : :
4407 : : /* Logical ops on integers become bitwise ops with -fdec. */
4408 : 551 : else if (flag_dec
4409 : 523 : && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4410 : : {
4411 : 523 : e->ts.type = BT_INTEGER;
4412 : 523 : e->ts.kind = gfc_kind_max (op1, op2);
4413 : 523 : if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4414 : 289 : gfc_convert_type (op1, &e->ts, 1);
4415 : 523 : if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4416 : 144 : gfc_convert_type (op2, &e->ts, 1);
4417 : 523 : e = logical_to_bitwise (e);
4418 : 523 : goto simplify_op;
4419 : : }
4420 : :
4421 : 28 : CHECK_INTERFACES
4422 : 16 : gfc_error ("Operands of logical operator %qs at %L are %s/%s",
4423 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4424 : : gfc_typename (op2));
4425 : 16 : return false;
4426 : :
4427 : 19179 : case INTRINSIC_NOT:
4428 : : /* Logical ops on integers become bitwise ops with -fdec. */
4429 : 19179 : if (flag_dec && op1->ts.type == BT_INTEGER)
4430 : : {
4431 : 19 : e->ts.type = BT_INTEGER;
4432 : 19 : e->ts.kind = op1->ts.kind;
4433 : 19 : e = logical_to_bitwise (e);
4434 : 19 : goto simplify_op;
4435 : : }
4436 : :
4437 : 19160 : if (op1->ts.type == BT_LOGICAL)
4438 : : {
4439 : 19154 : e->ts.type = BT_LOGICAL;
4440 : 19154 : e->ts.kind = op1->ts.kind;
4441 : 19154 : break;
4442 : : }
4443 : :
4444 : 6 : CHECK_INTERFACES
4445 : 3 : gfc_error ("Operand of .not. operator at %L is %s", &e->where,
4446 : : gfc_typename (op1));
4447 : 3 : return false;
4448 : :
4449 : 21132 : case INTRINSIC_GT:
4450 : 21132 : case INTRINSIC_GT_OS:
4451 : 21132 : case INTRINSIC_GE:
4452 : 21132 : case INTRINSIC_GE_OS:
4453 : 21132 : case INTRINSIC_LT:
4454 : 21132 : case INTRINSIC_LT_OS:
4455 : 21132 : case INTRINSIC_LE:
4456 : 21132 : case INTRINSIC_LE_OS:
4457 : 21132 : if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4458 : : {
4459 : 18 : CHECK_INTERFACES
4460 : 0 : gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
4461 : 0 : return false;
4462 : : }
4463 : :
4464 : : /* Fall through. */
4465 : :
4466 : 196148 : case INTRINSIC_EQ:
4467 : 196148 : case INTRINSIC_EQ_OS:
4468 : 196148 : case INTRINSIC_NE:
4469 : 196148 : case INTRINSIC_NE_OS:
4470 : :
4471 : 196148 : if (flag_dec
4472 : 1038 : && is_character_based (op1->ts.type)
4473 : 196483 : && is_character_based (op2->ts.type))
4474 : : {
4475 : 204 : convert_hollerith_to_character (op1);
4476 : 204 : convert_hollerith_to_character (op2);
4477 : : }
4478 : :
4479 : 196148 : if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4480 : 36602 : && op1->ts.kind == op2->ts.kind)
4481 : : {
4482 : 36565 : e->ts.type = BT_LOGICAL;
4483 : 36565 : e->ts.kind = gfc_default_logical_kind;
4484 : 36565 : break;
4485 : : }
4486 : :
4487 : : /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4488 : 159583 : if (op1->ts.type == BT_BOZ)
4489 : : {
4490 : 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4491 : : "as an operand of a relational operator"),
4492 : : &op1->where))
4493 : : return false;
4494 : :
4495 : 0 : if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4496 : : return false;
4497 : :
4498 : 0 : if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4499 : : return false;
4500 : : }
4501 : :
4502 : : /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4503 : 159583 : if (op2->ts.type == BT_BOZ)
4504 : : {
4505 : 0 : if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4506 : : " as an operand of a relational operator"),
4507 : : &op2->where))
4508 : : return false;
4509 : :
4510 : 0 : if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4511 : : return false;
4512 : :
4513 : 0 : if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4514 : : return false;
4515 : : }
4516 : 159583 : if (flag_dec
4517 : 159583 : && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4518 : 120 : convert_to_numeric (op1, op2);
4519 : :
4520 : 159583 : if (flag_dec
4521 : 159583 : && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4522 : 120 : convert_to_numeric (op2, op1);
4523 : :
4524 : 159583 : if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4525 : : {
4526 : : /* Do not perform conversions if operands are not conformable as
4527 : : required for the binary intrinsic operators (F2018:10.1.5).
4528 : : Defer to a possibly overloading user-defined operator. */
4529 : 158458 : if (!gfc_op_rank_conformable (op1, op2))
4530 : : {
4531 : 70 : CHECK_INTERFACES
4532 : 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4533 : 0 : &op1->where, &op2->where);
4534 : 0 : return false;
4535 : : }
4536 : :
4537 : 158388 : if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
4538 : : {
4539 : 1 : CHECK_INTERFACES
4540 : 1 : gfc_error ("Inconsistent types for operator at %L and %L: "
4541 : 1 : "%s and %s", &op1->where, &op2->where,
4542 : : gfc_typename (op1), gfc_typename (op2));
4543 : 1 : return false;
4544 : : }
4545 : :
4546 : 158387 : gfc_type_convert_binary (e, 1);
4547 : :
4548 : 158387 : e->ts.type = BT_LOGICAL;
4549 : 158387 : e->ts.kind = gfc_default_logical_kind;
4550 : :
4551 : 158387 : if (warn_compare_reals)
4552 : : {
4553 : 69 : gfc_intrinsic_op op = e->value.op.op;
4554 : :
4555 : : /* Type conversion has made sure that the types of op1 and op2
4556 : : agree, so it is only necessary to check the first one. */
4557 : 69 : if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4558 : 13 : && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4559 : 6 : || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4560 : : {
4561 : 13 : const char *msg;
4562 : :
4563 : 13 : if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4564 : : msg = G_("Equality comparison for %s at %L");
4565 : : else
4566 : 6 : msg = G_("Inequality comparison for %s at %L");
4567 : :
4568 : 13 : gfc_warning (OPT_Wcompare_reals, msg,
4569 : : gfc_typename (op1), &op1->where);
4570 : : }
4571 : : }
4572 : :
4573 : : break;
4574 : : }
4575 : :
4576 : 1125 : if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4577 : : {
4578 : 2 : CHECK_INTERFACES
4579 : 4 : gfc_error ("Logicals at %L must be compared with %s instead of %s",
4580 : : &e->where,
4581 : 2 : (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
4582 : : ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4583 : 2 : }
4584 : : else
4585 : : {
4586 : 1123 : CHECK_INTERFACES
4587 : 113 : gfc_error ("Operands of comparison operator %qs at %L are %s/%s",
4588 : : gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
4589 : : gfc_typename (op2));
4590 : : }
4591 : :
4592 : : return false;
4593 : :
4594 : 232 : case INTRINSIC_USER:
4595 : 232 : if (e->value.op.uop->op == NULL)
4596 : : {
4597 : 43 : const char *name = e->value.op.uop->name;
4598 : 43 : const char *guessed;
4599 : 43 : guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4600 : 43 : CHECK_INTERFACES
4601 : 4 : if (guessed)
4602 : 1 : gfc_error ("Unknown operator %qs at %L; did you mean "
4603 : : "%qs?", name, &e->where, guessed);
4604 : : else
4605 : 3 : gfc_error ("Unknown operator %qs at %L", name, &e->where);
4606 : : }
4607 : 189 : else if (op2 == NULL)
4608 : : {
4609 : 48 : CHECK_INTERFACES
4610 : 0 : gfc_error ("Operand of user operator %qs at %L is %s",
4611 : 0 : e->value.op.uop->name, &e->where, gfc_typename (op1));
4612 : : }
4613 : : else
4614 : : {
4615 : 141 : e->value.op.uop->op->sym->attr.referenced = 1;
4616 : 141 : CHECK_INTERFACES
4617 : 5 : gfc_error ("Operands of user operator %qs at %L are %s/%s",
4618 : 5 : e->value.op.uop->name, &e->where, gfc_typename (op1),
4619 : : gfc_typename (op2));
4620 : : }
4621 : :
4622 : : return false;
4623 : :
4624 : 20568 : case INTRINSIC_PARENTHESES:
4625 : 20568 : e->ts = op1->ts;
4626 : 20568 : if (e->ts.type == BT_CHARACTER)
4627 : 297 : e->ts.u.cl = op1->ts.u.cl;
4628 : : break;
4629 : :
4630 : 0 : default:
4631 : 0 : gfc_internal_error ("resolve_operator(): Bad intrinsic");
4632 : : }
4633 : :
4634 : : /* Deal with arrayness of an operand through an operator. */
4635 : :
4636 : 385820 : switch (e->value.op.op)
4637 : : {
4638 : 338314 : case INTRINSIC_PLUS:
4639 : 338314 : case INTRINSIC_MINUS:
4640 : 338314 : case INTRINSIC_TIMES:
4641 : 338314 : case INTRINSIC_DIVIDE:
4642 : 338314 : case INTRINSIC_POWER:
4643 : 338314 : case INTRINSIC_CONCAT:
4644 : 338314 : case INTRINSIC_AND:
4645 : 338314 : case INTRINSIC_OR:
4646 : 338314 : case INTRINSIC_EQV:
4647 : 338314 : case INTRINSIC_NEQV:
4648 : 338314 : case INTRINSIC_EQ:
4649 : 338314 : case INTRINSIC_EQ_OS:
4650 : 338314 : case INTRINSIC_NE:
4651 : 338314 : case INTRINSIC_NE_OS:
4652 : 338314 : case INTRINSIC_GT:
4653 : 338314 : case INTRINSIC_GT_OS:
4654 : 338314 : case INTRINSIC_GE:
4655 : 338314 : case INTRINSIC_GE_OS:
4656 : 338314 : case INTRINSIC_LT:
4657 : 338314 : case INTRINSIC_LT_OS:
4658 : 338314 : case INTRINSIC_LE:
4659 : 338314 : case INTRINSIC_LE_OS:
4660 : :
4661 : 338314 : if (op1->rank == 0 && op2->rank == 0)
4662 : 291142 : e->rank = 0;
4663 : :
4664 : 338314 : if (op1->rank == 0 && op2->rank != 0)
4665 : : {
4666 : 2209 : e->rank = op2->rank;
4667 : :
4668 : 2209 : if (e->shape == NULL)
4669 : 2179 : e->shape = gfc_copy_shape (op2->shape, op2->rank);
4670 : : }
4671 : :
4672 : 338314 : if (op1->rank != 0 && op2->rank == 0)
4673 : : {
4674 : 14141 : e->rank = op1->rank;
4675 : :
4676 : 14141 : if (e->shape == NULL)
4677 : 14123 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4678 : : }
4679 : :
4680 : 338314 : if (op1->rank != 0 && op2->rank != 0)
4681 : : {
4682 : 30822 : if (op1->rank == op2->rank)
4683 : : {
4684 : 30822 : e->rank = op1->rank;
4685 : 30822 : if (e->shape == NULL)
4686 : : {
4687 : 30761 : t = compare_shapes (op1, op2);
4688 : 30761 : if (!t)
4689 : 3 : e->shape = NULL;
4690 : : else
4691 : 30758 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4692 : : }
4693 : : }
4694 : : else
4695 : : {
4696 : : /* Allow higher level expressions to work. */
4697 : 0 : e->rank = 0;
4698 : :
4699 : : /* Try user-defined operators, and otherwise throw an error. */
4700 : 0 : CHECK_INTERFACES
4701 : 0 : gfc_error ("Inconsistent ranks for operator at %L and %L",
4702 : 0 : &op1->where, &op2->where);
4703 : 0 : return false;
4704 : : }
4705 : : }
4706 : :
4707 : : /* coranks have to be equal or one has to be zero to be combinable. */
4708 : 338314 : if (op1->corank == op2->corank || (op1->corank != 0 && op2->corank == 0))
4709 : : {
4710 : 338211 : e->corank = op1->corank;
4711 : : /* Only do this, when regular array has not set a shape yet. */
4712 : 338211 : if (e->shape == NULL)
4713 : : {
4714 : 310013 : if (op1->corank != 0)
4715 : : {
4716 : 1394 : e->shape = gfc_copy_shape (op1->shape, op1->corank);
4717 : : }
4718 : : }
4719 : : }
4720 : 103 : else if (op1->corank == 0 && op2->corank != 0)
4721 : : {
4722 : 103 : e->corank = op2->corank;
4723 : : /* Only do this, when regular array has not set a shape yet. */
4724 : 103 : if (e->shape == NULL)
4725 : 75 : e->shape = gfc_copy_shape (op2->shape, op2->corank);
4726 : : }
4727 : : else
4728 : : {
4729 : 0 : gfc_error ("Inconsistent coranks for operator at %L and %L",
4730 : : &op1->where, &op2->where);
4731 : 0 : return false;
4732 : : }
4733 : :
4734 : : break;
4735 : :
4736 : 47506 : case INTRINSIC_PARENTHESES:
4737 : 47506 : case INTRINSIC_NOT:
4738 : 47506 : case INTRINSIC_UPLUS:
4739 : 47506 : case INTRINSIC_UMINUS:
4740 : : /* Simply copy arrayness attribute */
4741 : 47506 : e->rank = op1->rank;
4742 : 47506 : e->corank = op1->corank;
4743 : :
4744 : 47506 : if (e->shape == NULL)
4745 : 47500 : e->shape = gfc_copy_shape (op1->shape, op1->rank);
4746 : :
4747 : : break;
4748 : :
4749 : : default:
4750 : : break;
4751 : : }
4752 : :
4753 : 386362 : simplify_op:
4754 : :
4755 : : /* Attempt to simplify the expression. */
4756 : 386362 : if (t)
4757 : : {
4758 : 386359 : t = gfc_simplify_expr (e, 0);
4759 : : /* Some calls do not succeed in simplification and return false
4760 : : even though there is no error; e.g. variable references to
4761 : : PARAMETER arrays. */
4762 : 386359 : if (!gfc_is_constant_expr (e))
4763 : 343900 : t = true;
4764 : : }
4765 : : return t;
4766 : : }
4767 : :
4768 : :
4769 : : /************** Array resolution subroutines **************/
4770 : :
4771 : : enum compare_result
4772 : : { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
4773 : :
4774 : : /* Compare two integer expressions. */
4775 : :
4776 : : static compare_result
4777 : 436616 : compare_bound (gfc_expr *a, gfc_expr *b)
4778 : : {
4779 : 436616 : int i;
4780 : :
4781 : 436616 : if (a == NULL || a->expr_type != EXPR_CONSTANT
4782 : 285532 : || b == NULL || b->expr_type != EXPR_CONSTANT)
4783 : : return CMP_UNKNOWN;
4784 : :
4785 : : /* If either of the types isn't INTEGER, we must have
4786 : : raised an error earlier. */
4787 : :
4788 : 201884 : if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4789 : : return CMP_UNKNOWN;
4790 : :
4791 : 201880 : i = mpz_cmp (a->value.integer, b->value.integer);
4792 : :
4793 : 201880 : if (i < 0)
4794 : : return CMP_LT;
4795 : 94916 : if (i > 0)
4796 : 37283 : return CMP_GT;
4797 : : return CMP_EQ;
4798 : : }
4799 : :
4800 : :
4801 : : /* Compare an integer expression with an integer. */
4802 : :
4803 : : static compare_result
4804 : 70681 : compare_bound_int (gfc_expr *a, int b)
4805 : : {
4806 : 70681 : int i;
4807 : :
4808 : 70681 : if (a == NULL
4809 : 29705 : || a->expr_type != EXPR_CONSTANT
4810 : 27035 : || a->ts.type != BT_INTEGER)
4811 : : return CMP_UNKNOWN;
4812 : :
4813 : 27035 : i = mpz_cmp_si (a->value.integer, b);
4814 : :
4815 : 27035 : if (i < 0)
4816 : : return CMP_LT;
4817 : 23773 : if (i > 0)
4818 : 20691 : return CMP_GT;
4819 : : return CMP_EQ;
4820 : : }
4821 : :
4822 : :
4823 : : /* Compare an integer expression with a mpz_t. */
4824 : :
4825 : : static compare_result
4826 : 66209 : compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4827 : : {
4828 : 66209 : int i;
4829 : :
4830 : 66209 : if (a == NULL
4831 : 54405 : || a->expr_type != EXPR_CONSTANT
4832 : 52270 : || a->ts.type != BT_INTEGER)
4833 : : return CMP_UNKNOWN;
4834 : :
4835 : 52267 : i = mpz_cmp (a->value.integer, b);
4836 : :
4837 : 52267 : if (i < 0)
4838 : : return CMP_LT;
4839 : 23743 : if (i > 0)
4840 : 10177 : return CMP_GT;
4841 : : return CMP_EQ;
4842 : : }
4843 : :
4844 : :
4845 : : /* Compute the last value of a sequence given by a triplet.
4846 : : Return 0 if it wasn't able to compute the last value, or if the
4847 : : sequence if empty, and 1 otherwise. */
4848 : :
4849 : : static int
4850 : 49340 : compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4851 : : gfc_expr *stride, mpz_t last)
4852 : : {
4853 : 49340 : mpz_t rem;
4854 : :
4855 : 49340 : if (start == NULL || start->expr_type != EXPR_CONSTANT
4856 : 34960 : || end == NULL || end->expr_type != EXPR_CONSTANT
4857 : 30593 : || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4858 : : return 0;
4859 : :
4860 : 30430 : if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4861 : 30429 : || (stride != NULL && stride->ts.type != BT_INTEGER))
4862 : : return 0;
4863 : :
4864 : 6080 : if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
4865 : : {
4866 : 24480 : if (compare_bound (start, end) == CMP_GT)
4867 : : return 0;
4868 : 23091 : mpz_set (last, end->value.integer);
4869 : 23091 : return 1;
4870 : : }
4871 : :
4872 : 5949 : if (compare_bound_int (stride, 0) == CMP_GT)
4873 : : {
4874 : : /* Stride is positive */
4875 : 4987 : if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4876 : : return 0;
4877 : : }
4878 : : else
4879 : : {
4880 : : /* Stride is negative */
4881 : 962 : if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4882 : : return 0;
4883 : : }
4884 : :
4885 : 5929 : mpz_init (rem);
4886 : 5929 : mpz_sub (rem, end->value.integer, start->value.integer);
4887 : 5929 : mpz_tdiv_r (rem, rem, stride->value.integer);
4888 : 5929 : mpz_sub (last, end->value.integer, rem);
4889 : 5929 : mpz_clear (rem);
4890 : :
4891 : 5929 : return 1;
4892 : : }
4893 : :
4894 : :
4895 : : /* Compare a single dimension of an array reference to the array
4896 : : specification. */
4897 : :
4898 : : static bool
4899 : 200118 : check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4900 : : {
4901 : 200118 : mpz_t last_value;
4902 : :
4903 : 200118 : if (ar->dimen_type[i] == DIMEN_STAR)
4904 : : {
4905 : 387 : gcc_assert (ar->stride[i] == NULL);
4906 : : /* This implies [*] as [*:] and [*:3] are not possible. */
4907 : 387 : if (ar->start[i] == NULL)
4908 : : {
4909 : 313 : gcc_assert (ar->end[i] == NULL);
4910 : : return true;
4911 : : }
4912 : : }
4913 : :
4914 : : /* Given start, end and stride values, calculate the minimum and
4915 : : maximum referenced indexes. */
4916 : :
4917 : 199805 : switch (ar->dimen_type[i])
4918 : : {
4919 : : case DIMEN_VECTOR:
4920 : : case DIMEN_THIS_IMAGE:
4921 : : break;
4922 : :
4923 : 144303 : case DIMEN_STAR:
4924 : 144303 : case DIMEN_ELEMENT:
4925 : 144303 : if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4926 : : {
4927 : 2 : if (i < as->rank)
4928 : 2 : gfc_warning (0, "Array reference at %L is out of bounds "
4929 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
4930 : 2 : mpz_get_si (ar->start[i]->value.integer),
4931 : 2 : mpz_get_si (as->lower[i]->value.integer), i+1);
4932 : : else
4933 : 0 : gfc_warning (0, "Array reference at %L is out of bounds "
4934 : : "(%ld < %ld) in codimension %d", &ar->c_where[i],
4935 : 0 : mpz_get_si (ar->start[i]->value.integer),
4936 : 0 : mpz_get_si (as->lower[i]->value.integer),
4937 : 0 : i + 1 - as->rank);
4938 : 2 : return true;
4939 : : }
4940 : 144301 : if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4941 : : {
4942 : 39 : if (i < as->rank)
4943 : 39 : gfc_warning (0, "Array reference at %L is out of bounds "
4944 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
4945 : 39 : mpz_get_si (ar->start[i]->value.integer),
4946 : 39 : mpz_get_si (as->upper[i]->value.integer), i+1);
4947 : : else
4948 : 0 : gfc_warning (0, "Array reference at %L is out of bounds "
4949 : : "(%ld > %ld) in codimension %d", &ar->c_where[i],
4950 : 0 : mpz_get_si (ar->start[i]->value.integer),
4951 : 0 : mpz_get_si (as->upper[i]->value.integer),
4952 : 0 : i + 1 - as->rank);
4953 : 39 : return true;
4954 : : }
4955 : :
4956 : : break;
4957 : :
4958 : 49384 : case DIMEN_RANGE:
4959 : 49384 : {
4960 : : #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4961 : : #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4962 : :
4963 : 49384 : compare_result comp_start_end = compare_bound (AR_START, AR_END);
4964 : 49384 : compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0);
4965 : :
4966 : : /* Check for zero stride, which is not allowed. */
4967 : 49384 : if (comp_stride_zero == CMP_EQ)
4968 : : {
4969 : 1 : gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4970 : 1 : return false;
4971 : : }
4972 : :
4973 : : /* if start == end || (stride > 0 && start < end)
4974 : : || (stride < 0 && start > end),
4975 : : then the array section contains at least one element. In this
4976 : : case, there is an out-of-bounds access if
4977 : : (start < lower || start > upper). */
4978 : 49383 : if (comp_start_end == CMP_EQ
4979 : 48698 : || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
4980 : 46615 : && comp_start_end == CMP_LT)
4981 : 21260 : || (comp_stride_zero == CMP_LT
4982 : 21260 : && comp_start_end == CMP_GT))
4983 : : {
4984 : 29065 : if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4985 : : {
4986 : 26 : gfc_warning (0, "Lower array reference at %L is out of bounds "
4987 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
4988 : 26 : mpz_get_si (AR_START->value.integer),
4989 : 26 : mpz_get_si (as->lower[i]->value.integer), i+1);
4990 : 26 : return true;
4991 : : }
4992 : 29039 : if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4993 : : {
4994 : 17 : gfc_warning (0, "Lower array reference at %L is out of bounds "
4995 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
4996 : 17 : mpz_get_si (AR_START->value.integer),
4997 : 17 : mpz_get_si (as->upper[i]->value.integer), i+1);
4998 : 17 : return true;
4999 : : }
5000 : : }
5001 : :
5002 : : /* If we can compute the highest index of the array section,
5003 : : then it also has to be between lower and upper. */
5004 : 49340 : mpz_init (last_value);
5005 : 49340 : if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
5006 : : last_value))
5007 : : {
5008 : 29020 : if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
5009 : : {
5010 : 3 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5011 : : "(%ld < %ld) in dimension %d", &ar->c_where[i],
5012 : : mpz_get_si (last_value),
5013 : 3 : mpz_get_si (as->lower[i]->value.integer), i+1);
5014 : 3 : mpz_clear (last_value);
5015 : 3 : return true;
5016 : : }
5017 : 29017 : if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
5018 : : {
5019 : 6 : gfc_warning (0, "Upper array reference at %L is out of bounds "
5020 : : "(%ld > %ld) in dimension %d", &ar->c_where[i],
5021 : : mpz_get_si (last_value),
5022 : 6 : mpz_get_si (as->upper[i]->value.integer), i+1);
5023 : 6 : mpz_clear (last_value);
5024 : 6 : return true;
5025 : : }
5026 : : }
5027 : 49331 : mpz_clear (last_value);
5028 : :
5029 : : #undef AR_START
5030 : : #undef AR_END
5031 : : }
5032 : 49331 : break;
5033 : :
5034 : 0 : default:
5035 : 0 : gfc_internal_error ("check_dimension(): Bad array reference");
5036 : : }
5037 : :
5038 : : return true;
5039 : : }
5040 : :
5041 : :
5042 : : /* Compare an array reference with an array specification. */
5043 : :
5044 : : static bool
5045 : 393585 : compare_spec_to_ref (gfc_array_ref *ar)
5046 : : {
5047 : 393585 : gfc_array_spec *as;
5048 : 393585 : int i;
5049 : :
5050 : 393585 : as = ar->as;
5051 : 393585 : i = as->rank - 1;
5052 : : /* TODO: Full array sections are only allowed as actual parameters. */
5053 : 393585 : if (as->type == AS_ASSUMED_SIZE
5054 : 5734 : && (/*ar->type == AR_FULL
5055 : 5734 : ||*/ (ar->type == AR_SECTION
5056 : 514 : && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
5057 : : {
5058 : 5 : gfc_error ("Rightmost upper bound of assumed size array section "
5059 : : "not specified at %L", &ar->where);
5060 : 5 : return false;
5061 : : }
5062 : :
5063 : 393580 : if (ar->type == AR_FULL)
5064 : : return true;
5065 : :
5066 : 150423 : if (as->rank != ar->dimen)
5067 : : {
5068 : 26 : gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
5069 : : &ar->where, ar->dimen, as->rank);
5070 : 26 : return false;
5071 : : }
5072 : :
5073 : : /* ar->codimen == 0 is a local array. */
5074 : 150397 : if (as->corank != ar->codimen && ar->codimen != 0)
5075 : : {
5076 : 0 : gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
5077 : : &ar->where, ar->codimen, as->corank);
5078 : 0 : return false;
5079 : : }
5080 : :
5081 : 343091 : for (i = 0; i < as->rank; i++)
5082 : 192695 : if (!check_dimension (i, ar, as))
5083 : : return false;
5084 : :
5085 : : /* Local access has no coarray spec. */
5086 : 150396 : if (ar->codimen != 0)
5087 : 14191 : for (i = as->rank; i < as->rank + as->corank; i++)
5088 : : {
5089 : 7425 : if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
5090 : 5118 : && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
5091 : : {
5092 : 2 : gfc_error ("Coindex of codimension %d must be a scalar at %L",
5093 : 2 : i + 1 - as->rank, &ar->where);
5094 : 2 : return false;
5095 : : }
5096 : 7423 : if (!check_dimension (i, ar, as))
5097 : : return false;
5098 : : }
5099 : :
5100 : : return true;
5101 : : }
5102 : :
5103 : :
5104 : : /* Resolve one part of an array index. */
5105 : :
5106 : : static bool
5107 : 678781 : gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
5108 : : int force_index_integer_kind)
5109 : : {
5110 : 678781 : gfc_typespec ts;
5111 : :
5112 : 678781 : if (index == NULL)
5113 : : return true;
5114 : :
5115 : 201917 : if (!gfc_resolve_expr (index))
5116 : : return false;
5117 : :
5118 : 201906 : if (check_scalar && index->rank != 0)
5119 : : {
5120 : 1 : gfc_error ("Array index at %L must be scalar", &index->where);
5121 : 1 : return false;
5122 : : }
5123 : :
5124 : 201905 : if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
5125 : : {
5126 : 1 : gfc_error ("Array index at %L must be of INTEGER type, found %s",
5127 : : &index->where, gfc_basic_typename (index->ts.type));
5128 : 1 : return false;
5129 : : }
5130 : :
5131 : 201904 : if (index->ts.type == BT_REAL)
5132 : 336 : if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
5133 : : &index->where))
5134 : : return false;
5135 : :
5136 : 201904 : if ((index->ts.kind != gfc_index_integer_kind
5137 : 197522 : && force_index_integer_kind)
5138 : 172502 : || (index->ts.type != BT_INTEGER
5139 : : && index->ts.type != BT_UNKNOWN))
5140 : : {
5141 : 29737 : gfc_clear_ts (&ts);
5142 : 29737 : ts.type = BT_INTEGER;
5143 : 29737 : ts.kind = gfc_index_integer_kind;
5144 : :
5145 : 29737 : gfc_convert_type_warn (index, &ts, 2, 0);
5146 : : }
5147 : :
5148 : : return true;
5149 : : }
5150 : :
5151 : : /* Resolve one part of an array index. */
5152 : :
5153 : : bool
5154 : 452757 : gfc_resolve_index (gfc_expr *index, int check_scalar)
5155 : : {
5156 : 452757 : return gfc_resolve_index_1 (index, check_scalar, 1);
5157 : : }
5158 : :
5159 : : /* Resolve a dim argument to an intrinsic function. */
5160 : :
5161 : : bool
5162 : 17606 : gfc_resolve_dim_arg (gfc_expr *dim)
5163 : : {
5164 : 17606 : if (dim == NULL)
5165 : : return true;
5166 : :
5167 : 17606 : if (!gfc_resolve_expr (dim))
5168 : : return false;
5169 : :
5170 : 17606 : if (dim->rank != 0)
5171 : : {
5172 : 0 : gfc_error ("Argument dim at %L must be scalar", &dim->where);
5173 : 0 : return false;
5174 : :
5175 : : }
5176 : :
5177 : 17606 : if (dim->ts.type != BT_INTEGER)
5178 : : {
5179 : 0 : gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
5180 : 0 : return false;
5181 : : }
5182 : :
5183 : 17606 : if (dim->ts.kind != gfc_index_integer_kind)
5184 : : {
5185 : 12040 : gfc_typespec ts;
5186 : :
5187 : 12040 : gfc_clear_ts (&ts);
5188 : 12040 : ts.type = BT_INTEGER;
5189 : 12040 : ts.kind = gfc_index_integer_kind;
5190 : :
5191 : 12040 : gfc_convert_type_warn (dim, &ts, 2, 0);
5192 : : }
5193 : :
5194 : : return true;
5195 : : }
5196 : :
5197 : : /* Given an expression that contains array references, update those array
5198 : : references to point to the right array specifications. While this is
5199 : : filled in during matching, this information is difficult to save and load
5200 : : in a module, so we take care of it here.
5201 : :
5202 : : The idea here is that the original array reference comes from the
5203 : : base symbol. We traverse the list of reference structures, setting
5204 : : the stored reference to references. Component references can
5205 : : provide an additional array specification. */
5206 : : static void
5207 : : resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
5208 : :
5209 : : static bool
5210 : 901 : find_array_spec (gfc_expr *e)
5211 : : {
5212 : 901 : gfc_array_spec *as;
5213 : 901 : gfc_component *c;
5214 : 901 : gfc_ref *ref;
5215 : 901 : bool class_as = false;
5216 : :
5217 : 901 : if (e->symtree->n.sym->assoc)
5218 : : {
5219 : 215 : if (e->symtree->n.sym->assoc->target)
5220 : 215 : gfc_resolve_expr (e->symtree->n.sym->assoc->target);
5221 : 215 : resolve_assoc_var (e->symtree->n.sym, false);
5222 : : }
5223 : :
5224 : 901 : if (e->symtree->n.sym->ts.type == BT_CLASS)
5225 : : {
5226 : 112 : as = CLASS_DATA (e->symtree->n.sym)->as;
5227 : 112 : class_as = true;
5228 : : }
5229 : : else
5230 : 789 : as = e->symtree->n.sym->as;
5231 : :
5232 : 2040 : for (ref = e->ref; ref; ref = ref->next)
5233 : 1146 : switch (ref->type)
5234 : : {
5235 : 903 : case REF_ARRAY:
5236 : 903 : if (as == NULL)
5237 : : {
5238 : 7 : locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
5239 : 14 : ? ref->u.ar.where : e->where);
5240 : 7 : gfc_error ("Invalid array reference of a non-array entity at %L",
5241 : : &loc);
5242 : 7 : return false;
5243 : : }
5244 : :
5245 : 896 : ref->u.ar.as = as;
5246 : 896 : if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
5247 : : as = NULL;
5248 : : break;
5249 : :
5250 : 219 : case REF_COMPONENT:
5251 : 219 : c = ref->u.c.component;
5252 : 219 : if (c->attr.dimension)
5253 : : {
5254 : 90 : if (as != NULL && !(class_as && as == c->as))
5255 : 0 : gfc_internal_error ("find_array_spec(): unused as(1)");
5256 : 90 : as = c->as;
5257 : : }
5258 : :
5259 : : break;
5260 : :
5261 : : case REF_SUBSTRING:
5262 : : case REF_INQUIRY:
5263 : : break;
5264 : : }
5265 : :
5266 : 894 : if (as != NULL)
5267 : 0 : gfc_internal_error ("find_array_spec(): unused as(2)");
5268 : :
5269 : : return true;
5270 : : }
5271 : :
5272 : :
5273 : : /* Resolve an array reference. */
5274 : :
5275 : : static bool
5276 : 394295 : resolve_array_ref (gfc_array_ref *ar)
5277 : : {
5278 : 394295 : int i, check_scalar;
5279 : 394295 : gfc_expr *e;
5280 : :
5281 : 620306 : for (i = 0; i < ar->dimen + ar->codimen; i++)
5282 : : {
5283 : 226024 : check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5284 : :
5285 : : /* Do not force gfc_index_integer_kind for the start. We can
5286 : : do fine with any integer kind. This avoids temporary arrays
5287 : : created for indexing with a vector. */
5288 : 226024 : if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5289 : : return false;
5290 : 226012 : if (!gfc_resolve_index (ar->end[i], check_scalar))
5291 : : return false;
5292 : 226011 : if (!gfc_resolve_index (ar->stride[i], check_scalar))
5293 : : return false;
5294 : :
5295 : 226011 : e = ar->start[i];
5296 : :
5297 : 226011 : if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5298 : 137211 : switch (e->rank)
5299 : : {
5300 : 136356 : case 0:
5301 : 136356 : ar->dimen_type[i] = DIMEN_ELEMENT;
5302 : 136356 : break;
5303 : :
5304 : 855 : case 1:
5305 : 855 : ar->dimen_type[i] = DIMEN_VECTOR;
5306 : 855 : if (e->expr_type == EXPR_VARIABLE
5307 : 466 : && e->symtree->n.sym->ts.type == BT_DERIVED)
5308 : 13 : ar->start[i] = gfc_get_parentheses (e);
5309 : : break;
5310 : :
5311 : 0 : default:
5312 : 0 : gfc_error ("Array index at %L is an array of rank %d",
5313 : : &ar->c_where[i], e->rank);
5314 : 0 : return false;
5315 : : }
5316 : :
5317 : : /* Fill in the upper bound, which may be lower than the
5318 : : specified one for something like a(2:10:5), which is
5319 : : identical to a(2:7:5). Only relevant for strides not equal
5320 : : to one. Don't try a division by zero. */
5321 : 226011 : if (ar->dimen_type[i] == DIMEN_RANGE
5322 : 68135 : && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
5323 : 7617 : && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5324 : 7465 : && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
5325 : : {
5326 : 7464 : mpz_t size, end;
5327 : :
5328 : 7464 : if (gfc_ref_dimen_size (ar, i, &size, &end))
5329 : : {
5330 : 5959 : if (ar->end[i] == NULL)
5331 : : {
5332 : 7656 : ar->end[i] =
5333 : 3828 : gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5334 : : &ar->where);
5335 : 3828 : mpz_set (ar->end[i]->value.integer, end);
5336 : : }
5337 : 2131 : else if (ar->end[i]->ts.type == BT_INTEGER
5338 : 2131 : && ar->end[i]->expr_type == EXPR_CONSTANT)
5339 : : {
5340 : 2131 : mpz_set (ar->end[i]->value.integer, end);
5341 : : }
5342 : : else
5343 : 0 : gcc_unreachable ();
5344 : :
5345 : 5959 : mpz_clear (size);
5346 : 5959 : mpz_clear (end);
5347 : : }
5348 : : }
5349 : : }
5350 : :
5351 : 394282 : if (ar->type == AR_FULL)
5352 : : {
5353 : 245987 : if (ar->as->rank == 0)
5354 : 2796 : ar->type = AR_ELEMENT;
5355 : :
5356 : : /* Make sure array is the same as array(:,:), this way
5357 : : we don't need to special case all the time. */
5358 : 245987 : ar->dimen = ar->as->rank;
5359 : 586370 : for (i = 0; i < ar->dimen; i++)
5360 : : {
5361 : 340383 : ar->dimen_type[i] = DIMEN_RANGE;
5362 : :
5363 : 340383 : gcc_assert (ar->start[i] == NULL);
5364 : 340383 : gcc_assert (ar->end[i] == NULL);
5365 : 340383 : gcc_assert (ar->stride[i] == NULL);
5366 : : }
5367 : : }
5368 : :
5369 : : /* If the reference type is unknown, figure out what kind it is. */
5370 : :
5371 : 394282 : if (ar->type == AR_UNKNOWN)
5372 : : {
5373 : 138815 : ar->type = AR_ELEMENT;
5374 : 270109 : for (i = 0; i < ar->dimen; i++)
5375 : 167369 : if (ar->dimen_type[i] == DIMEN_RANGE
5376 : 167369 : || ar->dimen_type[i] == DIMEN_VECTOR)
5377 : : {
5378 : 36075 : ar->type = AR_SECTION;
5379 : 36075 : break;
5380 : : }
5381 : : }
5382 : :
5383 : 394282 : if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5384 : : return false;
5385 : :
5386 : 394248 : if (ar->as->corank && ar->codimen == 0)
5387 : : {
5388 : 1319 : int n;
5389 : 1319 : ar->codimen = ar->as->corank;
5390 : 3812 : for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5391 : 2493 : ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5392 : : }
5393 : :
5394 : : return true;
5395 : : }
5396 : :
5397 : :
5398 : : bool
5399 : 8348 : gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5400 : : {
5401 : 8348 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5402 : :
5403 : 8348 : if (ref->u.ss.start != NULL)
5404 : : {
5405 : 8348 : if (!gfc_resolve_expr (ref->u.ss.start))
5406 : : return false;
5407 : :
5408 : 8348 : if (ref->u.ss.start->ts.type != BT_INTEGER)
5409 : : {
5410 : 1 : gfc_error ("Substring start index at %L must be of type INTEGER",
5411 : : &ref->u.ss.start->where);
5412 : 1 : return false;
5413 : : }
5414 : :
5415 : 8347 : if (ref->u.ss.start->rank != 0)
5416 : : {
5417 : 0 : gfc_error ("Substring start index at %L must be scalar",
5418 : : &ref->u.ss.start->where);
5419 : 0 : return false;
5420 : : }
5421 : :
5422 : 8347 : if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5423 : 8347 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5424 : 34 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5425 : : {
5426 : 1 : gfc_error ("Substring start index at %L is less than one",
5427 : : &ref->u.ss.start->where);
5428 : 1 : return false;
5429 : : }
5430 : : }
5431 : :
5432 : 8346 : if (ref->u.ss.end != NULL)
5433 : : {
5434 : 8177 : if (!gfc_resolve_expr (ref->u.ss.end))
5435 : : return false;
5436 : :
5437 : 8177 : if (ref->u.ss.end->ts.type != BT_INTEGER)
5438 : : {
5439 : 1 : gfc_error ("Substring end index at %L must be of type INTEGER",
5440 : : &ref->u.ss.end->where);
5441 : 1 : return false;
5442 : : }
5443 : :
5444 : 8176 : if (ref->u.ss.end->rank != 0)
5445 : : {
5446 : 0 : gfc_error ("Substring end index at %L must be scalar",
5447 : : &ref->u.ss.end->where);
5448 : 0 : return false;
5449 : : }
5450 : :
5451 : 8176 : if (ref->u.ss.length != NULL
5452 : 7830 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5453 : 8186 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5454 : 10 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5455 : : {
5456 : 4 : gfc_error ("Substring end index at %L exceeds the string length",
5457 : : &ref->u.ss.start->where);
5458 : 4 : return false;
5459 : : }
5460 : :
5461 : 8172 : if (compare_bound_mpz_t (ref->u.ss.end,
5462 : 8172 : gfc_integer_kinds[k].huge) == CMP_GT
5463 : 8172 : && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5464 : 7 : || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5465 : : {
5466 : 4 : gfc_error ("Substring end index at %L is too large",
5467 : : &ref->u.ss.end->where);
5468 : 4 : return false;
5469 : : }
5470 : : /* If the substring has the same length as the original
5471 : : variable, the reference itself can be deleted. */
5472 : :
5473 : 8168 : if (ref->u.ss.length != NULL
5474 : 7822 : && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5475 : 9089 : && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5476 : 228 : *equal_length = true;
5477 : : }
5478 : :
5479 : : return true;
5480 : : }
5481 : :
5482 : :
5483 : : /* This function supplies missing substring charlens. */
5484 : :
5485 : : void
5486 : 4509 : gfc_resolve_substring_charlen (gfc_expr *e)
5487 : : {
5488 : 4509 : gfc_ref *char_ref;
5489 : 4509 : gfc_expr *start, *end;
5490 : 4509 : gfc_typespec *ts = NULL;
5491 : 4509 : mpz_t diff;
5492 : :
5493 : 8639 : for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5494 : : {
5495 : 6802 : if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5496 : : break;
5497 : 4130 : if (char_ref->type == REF_COMPONENT)
5498 : 242 : ts = &char_ref->u.c.component->ts;
5499 : : }
5500 : :
5501 : 4509 : if (!char_ref || char_ref->type == REF_INQUIRY)
5502 : 1899 : return;
5503 : :
5504 : 2672 : gcc_assert (char_ref->next == NULL);
5505 : :
5506 : 2672 : if (e->ts.u.cl)
5507 : : {
5508 : 120 : if (e->ts.u.cl->length)
5509 : 108 : gfc_free_expr (e->ts.u.cl->length);
5510 : 12 : else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
5511 : : return;
5512 : : }
5513 : :
5514 : 2660 : if (!e->ts.u.cl)
5515 : 2552 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5516 : :
5517 : 2660 : if (char_ref->u.ss.start)
5518 : 2660 : start = gfc_copy_expr (char_ref->u.ss.start);
5519 : : else
5520 : 0 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
5521 : :
5522 : 2660 : if (char_ref->u.ss.end)
5523 : 2610 : end = gfc_copy_expr (char_ref->u.ss.end);
5524 : 50 : else if (e->expr_type == EXPR_VARIABLE)
5525 : : {
5526 : 50 : if (!ts)
5527 : 32 : ts = &e->symtree->n.sym->ts;
5528 : 50 : end = gfc_copy_expr (ts->u.cl->length);
5529 : : }
5530 : : else
5531 : : end = NULL;
5532 : :
5533 : 2660 : if (!start || !end)
5534 : : {
5535 : 50 : gfc_free_expr (start);
5536 : 50 : gfc_free_expr (end);
5537 : 50 : return;
5538 : : }
5539 : :
5540 : : /* Length = (end - start + 1).
5541 : : Check first whether it has a constant length. */
5542 : 2610 : if (gfc_dep_difference (end, start, &diff))
5543 : : {
5544 : 2496 : gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5545 : : &e->where);
5546 : :
5547 : 2496 : mpz_add_ui (len->value.integer, diff, 1);
5548 : 2496 : mpz_clear (diff);
5549 : 2496 : e->ts.u.cl->length = len;
5550 : : /* The check for length < 0 is handled below */
5551 : : }
5552 : : else
5553 : : {
5554 : 114 : e->ts.u.cl->length = gfc_subtract (end, start);
5555 : 114 : e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5556 : : gfc_get_int_expr (gfc_charlen_int_kind,
5557 : : NULL, 1));
5558 : : }
5559 : :
5560 : : /* F2008, 6.4.1: Both the starting point and the ending point shall
5561 : : be within the range 1, 2, ..., n unless the starting point exceeds
5562 : : the ending point, in which case the substring has length zero. */
5563 : :
5564 : 2610 : if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
5565 : 15 : mpz_set_si (e->ts.u.cl->length->value.integer, 0);
5566 : :
5567 : 2610 : e->ts.u.cl->length->ts.type = BT_INTEGER;
5568 : 2610 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5569 : :
5570 : : /* Make sure that the length is simplified. */
5571 : 2610 : gfc_simplify_expr (e->ts.u.cl->length, 1);
5572 : 2610 : gfc_resolve_expr (e->ts.u.cl->length);
5573 : : }
5574 : :
5575 : :
5576 : : /* Resolve subtype references. */
5577 : :
5578 : : bool
5579 : 503716 : gfc_resolve_ref (gfc_expr *expr)
5580 : : {
5581 : 503716 : int current_part_dimension, n_components, seen_part_dimension, dim;
5582 : 503716 : gfc_ref *ref, **prev, *array_ref;
5583 : 503716 : bool equal_length, old_caf_lhs;
5584 : :
5585 : 979996 : for (ref = expr->ref; ref; ref = ref->next)
5586 : 477181 : if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
5587 : : {
5588 : 901 : if (!find_array_spec (expr))
5589 : : return false;
5590 : : break;
5591 : : }
5592 : :
5593 : 503709 : old_caf_lhs = caf_lhs;
5594 : 503709 : caf_lhs = false;
5595 : 980978 : for (prev = &expr->ref; *prev != NULL;
5596 : 477269 : prev = *prev == NULL ? prev : &(*prev)->next)
5597 : 477324 : switch ((*prev)->type)
5598 : : {
5599 : 394295 : case REF_ARRAY:
5600 : 394295 : if (!resolve_array_ref (&(*prev)->u.ar))
5601 : : {
5602 : 47 : caf_lhs = old_caf_lhs;
5603 : 47 : return false;
5604 : : }
5605 : : break;
5606 : :
5607 : : case REF_COMPONENT:
5608 : : case REF_INQUIRY:
5609 : : break;
5610 : :
5611 : 8071 : case REF_SUBSTRING:
5612 : 8071 : equal_length = false;
5613 : 8071 : if (!gfc_resolve_substring (*prev, &equal_length))
5614 : : {
5615 : 8 : caf_lhs = old_caf_lhs;
5616 : 8 : return false;
5617 : : }
5618 : :
5619 : 8063 : if (expr->expr_type != EXPR_SUBSTRING && equal_length)
5620 : : {
5621 : : /* Remove the reference and move the charlen, if any. */
5622 : 203 : ref = *prev;
5623 : 203 : *prev = ref->next;
5624 : 203 : ref->next = NULL;
5625 : 203 : expr->ts.u.cl = ref->u.ss.length;
5626 : 203 : ref->u.ss.length = NULL;
5627 : 203 : gfc_free_ref_list (ref);
5628 : : }
5629 : : break;
5630 : : }
5631 : 503654 : caf_lhs = old_caf_lhs;
5632 : :
5633 : : /* Check constraints on part references. */
5634 : :
5635 : 503654 : current_part_dimension = 0;
5636 : 503654 : seen_part_dimension = 0;
5637 : 503654 : n_components = 0;
5638 : 503654 : array_ref = NULL;
5639 : :
5640 : 980695 : for (ref = expr->ref; ref; ref = ref->next)
5641 : : {
5642 : 477052 : switch (ref->type)
5643 : : {
5644 : 394241 : case REF_ARRAY:
5645 : 394241 : array_ref = ref;
5646 : 394241 : switch (ref->u.ar.type)
5647 : : {
5648 : 243189 : case AR_FULL:
5649 : : /* Coarray scalar. */
5650 : 243189 : if (ref->u.ar.as->rank == 0)
5651 : : {
5652 : : current_part_dimension = 0;
5653 : : break;
5654 : : }
5655 : : /* Fall through. */
5656 : 281558 : case AR_SECTION:
5657 : 281558 : current_part_dimension = 1;
5658 : 281558 : break;
5659 : :
5660 : 112683 : case AR_ELEMENT:
5661 : 112683 : array_ref = NULL;
5662 : 112683 : current_part_dimension = 0;
5663 : 112683 : break;
5664 : :
5665 : 0 : case AR_UNKNOWN:
5666 : 0 : gfc_internal_error ("resolve_ref(): Bad array reference");
5667 : : }
5668 : :
5669 : : break;
5670 : :
5671 : 74302 : case REF_COMPONENT:
5672 : 74302 : if (current_part_dimension || seen_part_dimension)
5673 : : {
5674 : : /* F03:C614. */
5675 : 5592 : if (ref->u.c.component->attr.pointer
5676 : 5592 : || ref->u.c.component->attr.proc_pointer
5677 : 5588 : || (ref->u.c.component->ts.type == BT_CLASS
5678 : 1 : && CLASS_DATA (ref->u.c.component)->attr.pointer))
5679 : : {
5680 : 4 : gfc_error ("Component to the right of a part reference "
5681 : : "with nonzero rank must not have the POINTER "
5682 : : "attribute at %L", &expr->where);
5683 : 4 : return false;
5684 : : }
5685 : 5588 : else if (ref->u.c.component->attr.allocatable
5686 : 5582 : || (ref->u.c.component->ts.type == BT_CLASS
5687 : 1 : && CLASS_DATA (ref->u.c.component)->attr.allocatable))
5688 : :
5689 : : {
5690 : 7 : gfc_error ("Component to the right of a part reference "
5691 : : "with nonzero rank must not have the ALLOCATABLE "
5692 : : "attribute at %L", &expr->where);
5693 : 7 : return false;
5694 : : }
5695 : : }
5696 : :
5697 : 74291 : n_components++;
5698 : 74291 : break;
5699 : :
5700 : : case REF_SUBSTRING:
5701 : : break;
5702 : :
5703 : 649 : case REF_INQUIRY:
5704 : : /* Implement requirement in note 9.7 of F2018 that the result of the
5705 : : LEN inquiry be a scalar. */
5706 : 649 : if (ref->u.i == INQUIRY_LEN && array_ref
5707 : 40 : && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
5708 : 40 : || expr->ts.type == BT_INTEGER))
5709 : : {
5710 : 14 : array_ref->u.ar.type = AR_ELEMENT;
5711 : 14 : expr->rank = 0;
5712 : : /* INQUIRY_LEN is not evaluated from the rest of the expr
5713 : : but directly from the string length. This means that setting
5714 : : the array indices to one does not matter but might trigger
5715 : : a runtime bounds error. Suppress the check. */
5716 : 14 : expr->no_bounds_check = 1;
5717 : 28 : for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
5718 : : {
5719 : 14 : array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
5720 : 14 : if (array_ref->u.ar.start[dim])
5721 : 0 : gfc_free_expr (array_ref->u.ar.start[dim]);
5722 : 14 : array_ref->u.ar.start[dim]
5723 : 14 : = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5724 : 14 : if (array_ref->u.ar.end[dim])
5725 : 0 : gfc_free_expr (array_ref->u.ar.end[dim]);
5726 : 14 : if (array_ref->u.ar.stride[dim])
5727 : 0 : gfc_free_expr (array_ref->u.ar.stride[dim]);
5728 : : }
5729 : : }
5730 : : break;
5731 : : }
5732 : :
5733 : 477041 : if (((ref->type == REF_COMPONENT && n_components > 1)
5734 : 467590 : || ref->next == NULL)
5735 : : && current_part_dimension
5736 : 425086 : && seen_part_dimension)
5737 : : {
5738 : 0 : gfc_error ("Two or more part references with nonzero rank must "
5739 : : "not be specified at %L", &expr->where);
5740 : 0 : return false;
5741 : : }
5742 : :
5743 : 477041 : if (ref->type == REF_COMPONENT)
5744 : : {
5745 : 74291 : if (current_part_dimension)
5746 : 5400 : seen_part_dimension = 1;
5747 : :
5748 : : /* reset to make sure */
5749 : : current_part_dimension = 0;
5750 : : }
5751 : : }
5752 : :
5753 : : return true;
5754 : : }
5755 : :
5756 : :
5757 : : /* Given an expression, determine its shape. This is easier than it sounds.
5758 : : Leaves the shape array NULL if it is not possible to determine the shape. */
5759 : :
5760 : : static void
5761 : 1687864 : expression_shape (gfc_expr *e)
5762 : : {
5763 : 1687864 : mpz_t array[GFC_MAX_DIMENSIONS];
5764 : 1687864 : int i;
5765 : :
5766 : 1687864 : if (e->rank <= 0 || e->shape != NULL)
5767 : 1523434 : return;
5768 : :
5769 : 652970 : for (i = 0; i < e->rank; i++)
5770 : 440970 : if (!gfc_array_dimen_size (e, i, &array[i]))
5771 : 164430 : goto fail;
5772 : :
5773 : 212000 : e->shape = gfc_get_shape (e->rank);
5774 : :
5775 : 212000 : memcpy (e->shape, array, e->rank * sizeof (mpz_t));
5776 : :
5777 : 212000 : return;
5778 : :
5779 : 164430 : fail:
5780 : 166116 : for (i--; i >= 0; i--)
5781 : 1686 : mpz_clear (array[i]);
5782 : : }
5783 : :
5784 : :
5785 : : /* Given a variable expression node, compute the rank of the expression by
5786 : : examining the base symbol and any reference structures it may have. */
5787 : :
5788 : : void
5789 : 1687864 : gfc_expression_rank (gfc_expr *e)
5790 : : {
5791 : 1687864 : gfc_ref *ref, *last_arr_ref = nullptr;
5792 : 1687864 : int i, rank, corank;
5793 : :
5794 : : /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5795 : : could lead to serious confusion... */
5796 : 1687864 : gcc_assert (e->expr_type != EXPR_COMPCALL);
5797 : :
5798 : 1687864 : if (e->ref == NULL)
5799 : : {
5800 : 1048597 : if (e->expr_type == EXPR_ARRAY)
5801 : 65888 : goto done;
5802 : : /* Constructors can have a rank different from one via RESHAPE(). */
5803 : :
5804 : 982709 : if (e->symtree != NULL)
5805 : : {
5806 : : /* After errors the ts.u.derived of a CLASS might not be set. */
5807 : 1965394 : gfc_array_spec *as = (e->symtree->n.sym->ts.type == BT_CLASS
5808 : 13546 : && e->symtree->n.sym->ts.u.derived
5809 : 13541 : && CLASS_DATA (e->symtree->n.sym))
5810 : 996243 : ? CLASS_DATA (e->symtree->n.sym)->as
5811 : : : e->symtree->n.sym->as;
5812 : 982697 : if (as)
5813 : : {
5814 : 782 : e->rank = as->rank;
5815 : 782 : e->corank = as->corank;
5816 : 782 : goto done;
5817 : : }
5818 : : }
5819 : 981927 : e->rank = 0;
5820 : 981927 : e->corank = 0;
5821 : 981927 : goto done;
5822 : : }
5823 : :
5824 : : rank = 0;
5825 : : corank = 0;
5826 : :
5827 : 995590 : for (ref = e->ref; ref; ref = ref->next)
5828 : : {
5829 : 723342 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5830 : 126550 : && ref->u.c.component->attr.function && !ref->next)
5831 : : {
5832 : 344 : rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5833 : 344 : corank = ref->u.c.component->as ? ref->u.c.component->as->corank : 0;
5834 : : }
5835 : :
5836 : 723342 : if (ref->type != REF_ARRAY)
5837 : 133322 : continue;
5838 : :
5839 : 590020 : last_arr_ref = ref;
5840 : 590020 : if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
5841 : : {
5842 : 324227 : rank = ref->u.ar.as->rank;
5843 : 324227 : break;
5844 : : }
5845 : :
5846 : 265793 : if (ref->u.ar.type == AR_SECTION)
5847 : : {
5848 : : /* Figure out the rank of the section. */
5849 : 42792 : if (rank != 0)
5850 : 0 : gfc_internal_error ("gfc_expression_rank(): Two array specs");
5851 : :
5852 : 107137 : for (i = 0; i < ref->u.ar.dimen; i++)
5853 : 64345 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5854 : 64345 : || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5855 : 56079 : rank++;
5856 : :
5857 : : break;
5858 : : }
5859 : : }
5860 : 639267 : if (last_arr_ref && last_arr_ref->u.ar.as
5861 : 574771 : && last_arr_ref->u.ar.as->rank != -1)
5862 : : {
5863 : 13940 : for (i = last_arr_ref->u.ar.as->rank;
5864 : 580631 : i < last_arr_ref->u.ar.as->rank + last_arr_ref->u.ar.as->corank; ++i)
5865 : : {
5866 : : /* For unknown dimen in non-resolved as assume full corank. */
5867 : 14577 : if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_STAR
5868 : 14146 : || (last_arr_ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
5869 : 206 : && !last_arr_ref->u.ar.as->resolved))
5870 : : {
5871 : : corank = last_arr_ref->u.ar.as->corank;
5872 : : break;
5873 : : }
5874 : 13940 : else if (last_arr_ref->u.ar.dimen_type[i] == DIMEN_RANGE
5875 : 13940 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_VECTOR
5876 : 13857 : || last_arr_ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE)
5877 : 11838 : corank++;
5878 : 2102 : else if (last_arr_ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
5879 : 0 : gfc_internal_error ("Illegal coarray index");
5880 : : }
5881 : : }
5882 : :
5883 : 639267 : e->rank = rank;
5884 : 639267 : e->corank = corank;
5885 : :
5886 : 1687864 : done:
5887 : 1687864 : expression_shape (e);
5888 : 1687864 : }
5889 : :
5890 : :
5891 : : /* Given two expressions, check that their rank is conformable, i.e. either
5892 : : both have the same rank or at least one is a scalar. */
5893 : :
5894 : : bool
5895 : 11831517 : gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
5896 : : {
5897 : 11831517 : if (op1->expr_type == EXPR_VARIABLE)
5898 : 427056 : gfc_expression_rank (op1);
5899 : 11831517 : if (op2->expr_type == EXPR_VARIABLE)
5900 : 154187 : gfc_expression_rank (op2);
5901 : :
5902 : 71408 : return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
5903 : 11902599 : && (op1->corank == 0 || op2->corank == 0
5904 : 146 : || op1->corank == op2->corank);
5905 : : }
5906 : :
5907 : : static gfc_array_spec *
5908 : 26 : get_arrayspec_from_expr (gfc_expr *expr)
5909 : : {
5910 : 26 : gfc_array_spec *src_as, *dst_as = NULL;
5911 : 26 : gfc_ref *ref;
5912 : 26 : gfc_array_ref mod_src_ar;
5913 : 26 : int dst_rank = 0;
5914 : :
5915 : 26 : if (expr->rank == 0)
5916 : : return NULL;
5917 : :
5918 : : /* Follow any component references. */
5919 : 24 : if (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_CONSTANT)
5920 : : {
5921 : 24 : if (expr->symtree)
5922 : 24 : src_as = expr->symtree->n.sym->as;
5923 : : else
5924 : : src_as = NULL;
5925 : :
5926 : 48 : for (ref = expr->ref; ref; ref = ref->next)
5927 : : {
5928 : 24 : switch (ref->type)
5929 : : {
5930 : 0 : case REF_COMPONENT:
5931 : 0 : src_as = ref->u.c.component->as;
5932 : 0 : continue;
5933 : :
5934 : 0 : case REF_SUBSTRING:
5935 : 0 : case REF_INQUIRY:
5936 : 0 : continue;
5937 : :
5938 : 24 : case REF_ARRAY:
5939 : 24 : switch (ref->u.ar.type)
5940 : : {
5941 : : case AR_ELEMENT:
5942 : 24 : src_as = NULL;
5943 : : break;
5944 : 0 : case AR_SECTION: {
5945 : 0 : if (!dst_as)
5946 : 0 : dst_as = gfc_get_array_spec ();
5947 : 0 : memset (&mod_src_ar, 0, sizeof (gfc_array_ref));
5948 : 0 : mod_src_ar = ref->u.ar;
5949 : 0 : for (int dim = 0; dim < src_as->rank; ++dim)
5950 : : {
5951 : 0 : switch (ref->u.ar.dimen_type[dim])
5952 : : {
5953 : 0 : case DIMEN_ELEMENT:
5954 : 0 : gfc_free_expr (mod_src_ar.start[dim]);
5955 : 0 : mod_src_ar.start[dim] = NULL;
5956 : 0 : break;
5957 : 0 : case DIMEN_RANGE:
5958 : 0 : dst_as->lower[dst_rank]
5959 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
5960 : 0 : mod_src_ar.start[dst_rank]
5961 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
5962 : 0 : if (ref->u.ar.end[dim])
5963 : : {
5964 : 0 : dst_as->upper[dst_rank]
5965 : 0 : = gfc_copy_expr (ref->u.ar.end[dim]);
5966 : 0 : mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
5967 : 0 : mod_src_ar.stride[dst_rank]
5968 : 0 : = ref->u.ar.stride[dim];
5969 : : }
5970 : : else
5971 : 0 : dst_as->upper[dst_rank]
5972 : 0 : = gfc_copy_expr (ref->u.ar.as->upper[dim]);
5973 : 0 : ++dst_rank;
5974 : 0 : break;
5975 : 0 : case DIMEN_STAR:
5976 : 0 : dst_as->lower[dst_rank]
5977 : 0 : = gfc_copy_expr (ref->u.ar.as->lower[dim]);
5978 : 0 : mod_src_ar.start[dst_rank]
5979 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
5980 : 0 : if (ref->u.ar.as->upper[dim])
5981 : : {
5982 : 0 : dst_as->upper[dst_rank]
5983 : 0 : = gfc_copy_expr (ref->u.ar.as->upper[dim]);
5984 : 0 : mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
5985 : 0 : mod_src_ar.stride[dst_rank]
5986 : 0 : = ref->u.ar.stride[dim];
5987 : : }
5988 : 0 : ++dst_rank;
5989 : 0 : break;
5990 : 0 : case DIMEN_VECTOR:
5991 : 0 : dst_as->lower[dst_rank]
5992 : 0 : = gfc_get_constant_expr (BT_INTEGER,
5993 : : gfc_index_integer_kind,
5994 : : &expr->where);
5995 : 0 : mpz_set_ui (dst_as->lower[dst_rank]->value.integer,
5996 : : 1);
5997 : 0 : mod_src_ar.start[dst_rank]
5998 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
5999 : 0 : dst_as->upper[dst_rank]
6000 : 0 : = gfc_get_constant_expr (BT_INTEGER,
6001 : : gfc_index_integer_kind,
6002 : : &expr->where);
6003 : 0 : mpz_set (dst_as->upper[dst_rank]->value.integer,
6004 : 0 : ref->u.ar.start[dim]->shape[0]);
6005 : 0 : ++dst_rank;
6006 : 0 : break;
6007 : 0 : case DIMEN_THIS_IMAGE:
6008 : 0 : case DIMEN_UNKNOWN:
6009 : 0 : gcc_unreachable ();
6010 : : }
6011 : 0 : if (ref->u.ar.dimen_type[dim] != DIMEN_ELEMENT)
6012 : 0 : mod_src_ar.dimen_type[dst_rank]
6013 : 0 : = ref->u.ar.dimen_type[dim];
6014 : : }
6015 : 0 : dst_as->rank = dst_rank;
6016 : 0 : dst_as->type = AS_EXPLICIT;
6017 : 0 : ref->u.ar = mod_src_ar;
6018 : 0 : ref->u.ar.dimen = dst_rank;
6019 : 0 : break;
6020 : :
6021 : : case AR_UNKNOWN:
6022 : 24 : src_as = NULL;
6023 : : break;
6024 : :
6025 : 24 : case AR_FULL:
6026 : 24 : dst_as = gfc_copy_array_spec (src_as);
6027 : 24 : break;
6028 : : }
6029 : : break;
6030 : : }
6031 : 0 : }
6032 : : }
6033 : : }
6034 : : else
6035 : 26 : src_as = NULL;
6036 : :
6037 : : return dst_as;
6038 : : }
6039 : :
6040 : : static void
6041 : 554 : remove_coarray_from_derived_type (gfc_symbol *base, gfc_namespace *ns,
6042 : : gfc_array_spec *src_as = NULL)
6043 : : {
6044 : 554 : gfc_symbol *derived;
6045 : 554 : gfc_symbol *src_derived = base->ts.u.derived;
6046 : :
6047 : 554 : if (!src_as)
6048 : 531 : src_as = src_derived->as;
6049 : 554 : gfc_get_symbol (src_derived->name, ns, &derived);
6050 : 554 : derived->attr.flavor = FL_DERIVED;
6051 : 554 : derived->attr.alloc_comp = src_derived->attr.alloc_comp;
6052 : 554 : if (src_as && src_as->rank != 0)
6053 : : {
6054 : 15 : base->attr.dimension = 1;
6055 : 15 : base->as = gfc_copy_array_spec (src_as);
6056 : 15 : base->as->corank = 0;
6057 : : }
6058 : 2918 : for (gfc_component *p = NULL, *c = src_derived->components; c; c = c->next)
6059 : : {
6060 : 2364 : gfc_component *n = gfc_get_component ();
6061 : 2364 : *n = *c;
6062 : 2364 : if (n->as)
6063 : 1096 : n->as = gfc_copy_array_spec (c->as);
6064 : 2364 : n->backend_decl = NULL;
6065 : 2364 : n->initializer = NULL;
6066 : 2364 : n->param_list = NULL;
6067 : 2364 : if (p)
6068 : 1810 : p->next = n;
6069 : : else
6070 : 554 : derived->components = n;
6071 : :
6072 : 2364 : p = n;
6073 : : }
6074 : 554 : gfc_set_sym_referenced (derived);
6075 : 554 : gfc_commit_symbol (derived);
6076 : 554 : base->ts.u.derived = derived;
6077 : 554 : gfc_commit_symbol (base);
6078 : 554 : }
6079 : :
6080 : : static void
6081 : 23 : convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns)
6082 : : {
6083 : 23 : gfc_symbol *src_derived = CLASS_DATA (base)->ts.u.derived;
6084 : 23 : gfc_array_spec *src_as = CLASS_DATA (base)->as;
6085 : 46 : const bool attr_allocatable
6086 : 23 : = src_as && src_as->rank && src_as->type == AS_DEFERRED;
6087 : :
6088 : 23 : base->ts.type = BT_DERIVED;
6089 : 23 : base->ts.u.derived = src_derived;
6090 : :
6091 : 23 : remove_coarray_from_derived_type (base, ns, src_as);
6092 : :
6093 : 23 : base->attr.allocatable = attr_allocatable;
6094 : 23 : base->attr.pointer = 0; // Ensure, that it is no pointer.
6095 : 23 : }
6096 : :
6097 : : static void
6098 : 795 : split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
6099 : : gfc_expr **post_caf_ref_expr)
6100 : : {
6101 : 795 : gfc_ref *caf_ref = NULL;
6102 : 795 : gfc_symtree *st;
6103 : 795 : gfc_symbol *base;
6104 : :
6105 : 795 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
6106 : 795 : if (!expr->symtree->n.sym->attr.codimension)
6107 : : {
6108 : : /* The coarray is in some component. Find it. */
6109 : 52 : caf_ref = expr->ref;
6110 : 114 : while (caf_ref)
6111 : : {
6112 : 85 : if (caf_ref->type == REF_COMPONENT
6113 : 56 : && caf_ref->u.c.component->attr.codimension)
6114 : : break;
6115 : 62 : caf_ref = caf_ref->next;
6116 : : }
6117 : : }
6118 : :
6119 : 795 : gcc_assert (!gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns,
6120 : : &st, false));
6121 : 795 : st->n.sym->attr.flavor = FL_PARAMETER;
6122 : 795 : st->n.sym->attr.dummy = 1;
6123 : 795 : st->n.sym->attr.intent = INTENT_IN;
6124 : 795 : st->n.sym->ts = caf_ref ? caf_ref->u.c.sym->ts : expr->symtree->n.sym->ts;
6125 : :
6126 : 795 : *post_caf_ref_expr = gfc_get_variable_expr (st);
6127 : 795 : (*post_caf_ref_expr)->where = expr->where;
6128 : 795 : base = (*post_caf_ref_expr)->symtree->n.sym;
6129 : :
6130 : 795 : if (!caf_ref)
6131 : : {
6132 : 772 : (*post_caf_ref_expr)->ref = gfc_copy_ref (expr->ref);
6133 : 772 : if (expr->symtree->n.sym->attr.dimension)
6134 : : {
6135 : 126 : base->as = gfc_copy_array_spec (expr->symtree->n.sym->as);
6136 : 126 : base->as->corank = 0;
6137 : 126 : base->attr.dimension = 1;
6138 : 126 : base->attr.allocatable = expr->symtree->n.sym->attr.allocatable;
6139 : 126 : base->attr.pointer = expr->symtree->n.sym->attr.pointer
6140 : 126 : || expr->symtree->n.sym->attr.associate_var;
6141 : : }
6142 : : }
6143 : : else
6144 : : {
6145 : 23 : (*post_caf_ref_expr)->ref = gfc_copy_ref (caf_ref->next);
6146 : 23 : if (caf_ref->u.c.component->attr.dimension)
6147 : : {
6148 : 2 : base->as = gfc_copy_array_spec (caf_ref->u.c.component->as);
6149 : 2 : base->as->corank = 0;
6150 : 2 : base->attr.dimension = 1;
6151 : 2 : base->attr.allocatable = caf_ref->u.c.component->attr.allocatable;
6152 : 2 : base->attr.pointer = caf_ref->u.c.component->attr.pointer;
6153 : : }
6154 : 23 : base->ts = caf_ref->u.c.component->ts;
6155 : : }
6156 : 795 : (*post_caf_ref_expr)->ts = expr->ts;
6157 : 795 : if (base->ts.type == BT_CHARACTER)
6158 : : {
6159 : 49 : base->ts.u.cl = gfc_get_charlen ();
6160 : 49 : *base->ts.u.cl = *(caf_ref ? caf_ref->u.c.component->ts.u.cl
6161 : 49 : : expr->symtree->n.sym->ts.u.cl);
6162 : 49 : base->ts.deferred = 1;
6163 : 49 : base->ts.u.cl->length = nullptr;
6164 : : }
6165 : :
6166 : 795 : if (base->ts.type == BT_DERIVED)
6167 : 531 : remove_coarray_from_derived_type (base, ns);
6168 : 264 : else if (base->ts.type == BT_CLASS)
6169 : 23 : convert_coarray_class_to_derived_type (base, ns);
6170 : :
6171 : 795 : gfc_expression_rank (expr);
6172 : 795 : gfc_expression_rank (*post_caf_ref_expr);
6173 : 795 : }
6174 : :
6175 : : static void
6176 : 2722 : check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *get_data)
6177 : : {
6178 : 2742 : if (e)
6179 : : {
6180 : 662 : switch (e->expr_type)
6181 : : {
6182 : : case EXPR_CONSTANT:
6183 : : case EXPR_NULL:
6184 : : break;
6185 : 22 : case EXPR_OP:
6186 : 22 : check_add_new_component (type, e->value.op.op1, get_data);
6187 : 22 : if (e->value.op.op2)
6188 : : check_add_new_component (type, e->value.op.op2, get_data);
6189 : : break;
6190 : 0 : case EXPR_COMPCALL:
6191 : 0 : for (gfc_actual_arglist *actual = e->value.compcall.actual; actual;
6192 : 0 : actual = actual->next)
6193 : 0 : check_add_new_component (type, actual->expr, get_data);
6194 : : break;
6195 : 24 : case EXPR_FUNCTION:
6196 : 24 : if (!e->symtree->n.sym->attr.pure
6197 : 24 : && !e->symtree->n.sym->attr.elemental)
6198 : : {
6199 : : // Treat non-pure functions.
6200 : 0 : gfc_error ("Sorry, not yet able to call a non-pure/non-elemental"
6201 : : " function %s in a coarray reference; use a temporary"
6202 : : " for the function's result instead",
6203 : : e->symtree->n.sym->name);
6204 : : }
6205 : 48 : for (gfc_actual_arglist *actual = e->value.function.actual; actual;
6206 : 24 : actual = actual->next)
6207 : 24 : check_add_new_component (type, actual->expr, get_data);
6208 : : break;
6209 : 104 : case EXPR_VARIABLE: {
6210 : 104 : gfc_component *comp;
6211 : 104 : gfc_ref *ref;
6212 : 104 : int old_rank = e->rank;
6213 : :
6214 : : /* Can't use gfc_find_component here, because type is not yet
6215 : : complete. */
6216 : 104 : comp = type->components;
6217 : 288 : while (comp)
6218 : : {
6219 : 188 : if (strcmp (comp->name, e->symtree->name) == 0)
6220 : : break;
6221 : 184 : comp = comp->next;
6222 : : }
6223 : 104 : if (!comp)
6224 : : {
6225 : 100 : gcc_assert (gfc_add_component (type, e->symtree->name, &comp));
6226 : : /* Take a copy of e, before modifying it. */
6227 : 100 : gfc_expr *init = gfc_copy_expr (e);
6228 : 100 : if (e->ref)
6229 : : {
6230 : 26 : switch (e->ref->type)
6231 : : {
6232 : 26 : case REF_ARRAY:
6233 : 26 : comp->as = get_arrayspec_from_expr (e);
6234 : 26 : comp->attr.dimension = e->ref->u.ar.dimen != 0;
6235 : 26 : comp->ts = e->ts;
6236 : 26 : break;
6237 : 0 : case REF_COMPONENT:
6238 : 0 : comp->ts = e->ref->u.c.sym->ts;
6239 : 0 : break;
6240 : 0 : default:
6241 : 0 : gcc_unreachable ();
6242 : : break;
6243 : : }
6244 : : }
6245 : : else
6246 : 74 : comp->ts = e->ts;
6247 : 100 : comp->attr.access = ACCESS_PRIVATE;
6248 : 100 : comp->initializer = init;
6249 : : }
6250 : : else
6251 : 4 : gcc_assert (comp->ts.type == e->ts.type
6252 : : && comp->ts.u.derived == e->ts.u.derived);
6253 : :
6254 : 104 : ref = e->ref;
6255 : 104 : e->ref = NULL;
6256 : 104 : gcc_assert (gfc_find_component (get_data->ts.u.derived,
6257 : : e->symtree->name, false, true,
6258 : : &e->ref));
6259 : 104 : e->symtree
6260 : 104 : = gfc_find_symtree (get_data->ns->sym_root, get_data->name);
6261 : 104 : e->ref->next = ref;
6262 : 104 : gfc_free_shape (&e->shape, old_rank);
6263 : 104 : gfc_expression_rank (e);
6264 : 104 : break;
6265 : : }
6266 : 0 : case EXPR_ARRAY:
6267 : 0 : case EXPR_PPC:
6268 : 0 : case EXPR_STRUCTURE:
6269 : 0 : case EXPR_SUBSTRING:
6270 : 0 : gcc_unreachable ();
6271 : : default:;
6272 : : }
6273 : : }
6274 : 2722 : }
6275 : :
6276 : : static gfc_symbol *
6277 : 795 : create_get_parameter_type (gfc_expr *expr, gfc_namespace *ns,
6278 : : gfc_symbol *get_data)
6279 : : {
6280 : 795 : static int type_cnt = 0;
6281 : 795 : char tname[GFC_MAX_SYMBOL_LEN + 1];
6282 : 795 : char *name;
6283 : 795 : gfc_symbol *type;
6284 : :
6285 : 795 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
6286 : :
6287 : 795 : strcpy (tname, expr->symtree->name);
6288 : 795 : name = xasprintf ("@_rget_data_t_%s_%d", tname, ++type_cnt);
6289 : 795 : gfc_get_symbol (name, ns, &type);
6290 : :
6291 : 795 : type->attr.flavor = FL_DERIVED;
6292 : 795 : get_data->ts.u.derived = type;
6293 : :
6294 : 2125 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
6295 : : {
6296 : 1330 : if (ref->type == REF_ARRAY)
6297 : : {
6298 : : gfc_array_ref *ar = &ref->u.ar;
6299 : 1494 : for (int i = 0; i < ar->dimen; ++i)
6300 : : {
6301 : 892 : check_add_new_component (type, ar->start[i], get_data);
6302 : 892 : check_add_new_component (type, ar->end[i], get_data);
6303 : 892 : check_add_new_component (type, ar->stride[i], get_data);
6304 : : }
6305 : : }
6306 : : }
6307 : :
6308 : 795 : gfc_set_sym_referenced (type);
6309 : 795 : gfc_commit_symbol (type);
6310 : 795 : return type;
6311 : : }
6312 : :
6313 : :
6314 : : static gfc_expr *
6315 : 795 : create_get_callback (gfc_expr *expr)
6316 : : {
6317 : 795 : static int cnt = 0;
6318 : 795 : gfc_namespace *ns;
6319 : 795 : gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data,
6320 : : *old_buffer_data;
6321 : 795 : char tname[GFC_MAX_SYMBOL_LEN + 1];
6322 : 795 : char *name;
6323 : 795 : const char *mname;
6324 : 795 : gfc_expr *cb, *post_caf_ref_expr;
6325 : 795 : gfc_code *code;
6326 : 795 : int expr_rank = expr->rank;
6327 : :
6328 : : /* Find the top-level namespace. */
6329 : 951 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
6330 : : ;
6331 : :
6332 : 795 : if (expr->expr_type == EXPR_VARIABLE)
6333 : 795 : strcpy (tname, expr->symtree->name);
6334 : : else
6335 : 0 : strcpy (tname, "dummy");
6336 : 795 : if (expr->symtree->n.sym->module)
6337 : 3 : mname = expr->symtree->n.sym->module;
6338 : : else
6339 : : mname = "main";
6340 : 795 : name = xasprintf ("_caf_rget_%s_%s_%d", mname, tname, ++cnt);
6341 : 795 : gfc_get_symbol (name, ns, &extproc);
6342 : 795 : gfc_set_sym_referenced (extproc);
6343 : 795 : ++extproc->refs;
6344 : 795 : gfc_commit_symbol (extproc);
6345 : :
6346 : : /* Set up namespace. */
6347 : 795 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
6348 : 795 : sub_ns->sibling = ns->contained;
6349 : 795 : ns->contained = sub_ns;
6350 : 795 : sub_ns->resolved = 1;
6351 : : /* Set up procedure symbol. */
6352 : 795 : gfc_find_symbol (name, sub_ns, 1, &proc);
6353 : 795 : sub_ns->proc_name = proc;
6354 : 795 : proc->attr.if_source = IFSRC_DECL;
6355 : 795 : proc->attr.access = ACCESS_PUBLIC;
6356 : 795 : gfc_add_subroutine (&proc->attr, name, NULL);
6357 : 795 : proc->attr.host_assoc = 1;
6358 : 795 : proc->attr.always_explicit = 1;
6359 : 795 : ++proc->refs;
6360 : 795 : gfc_commit_symbol (proc);
6361 : 795 : free (name);
6362 : :
6363 : 795 : split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr);
6364 : :
6365 : 795 : if (ns->proc_name->attr.flavor == FL_MODULE)
6366 : 1 : proc->module = ns->proc_name->name;
6367 : 795 : gfc_set_sym_referenced (proc);
6368 : : /* Set up formal arguments. */
6369 : 795 : gfc_formal_arglist **argptr = &proc->formal;
6370 : : #define ADD_ARG(name, nsym, stype, sintent) \
6371 : : gfc_get_symbol (name, sub_ns, &nsym); \
6372 : : nsym->ts.type = stype; \
6373 : : nsym->attr.flavor = FL_PARAMETER; \
6374 : : nsym->attr.dummy = 1; \
6375 : : nsym->attr.intent = sintent; \
6376 : : gfc_set_sym_referenced (nsym); \
6377 : : *argptr = gfc_get_formal_arglist (); \
6378 : : (*argptr)->sym = nsym; \
6379 : : argptr = &(*argptr)->next
6380 : :
6381 : 795 : ADD_ARG ("buffer", buffer, expr->ts.type, INTENT_INOUT);
6382 : 795 : buffer->ts = expr->ts;
6383 : 795 : if (expr_rank)
6384 : : {
6385 : 424 : buffer->as = gfc_get_array_spec ();
6386 : 424 : buffer->as->rank = expr_rank;
6387 : 424 : if (expr->shape)
6388 : : {
6389 : 227 : buffer->as->type = AS_EXPLICIT;
6390 : 566 : for (int d = 0; d < expr_rank; ++d)
6391 : : {
6392 : 339 : buffer->as->lower[d]
6393 : 339 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
6394 : : &gfc_current_locus);
6395 : 339 : gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1);
6396 : 339 : buffer->as->upper[d]
6397 : 339 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
6398 : : &gfc_current_locus);
6399 : 339 : gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer,
6400 : 339 : gfc_mpz_get_hwi (expr->shape[d]));
6401 : : }
6402 : 227 : buffer->attr.allocatable = 1;
6403 : : }
6404 : : else
6405 : : {
6406 : 197 : buffer->as->type = AS_DEFERRED;
6407 : 197 : buffer->attr.allocatable = 1;
6408 : : }
6409 : 424 : buffer->attr.dimension = 1;
6410 : : }
6411 : : else
6412 : 371 : buffer->attr.pointer = 1;
6413 : 795 : if (buffer->ts.type == BT_CHARACTER)
6414 : : {
6415 : 49 : buffer->ts.u.cl = gfc_get_charlen ();
6416 : 49 : *buffer->ts.u.cl = *expr->ts.u.cl;
6417 : 49 : buffer->ts.deferred = 1;
6418 : 49 : buffer->ts.u.cl->length = nullptr;
6419 : : }
6420 : 795 : gfc_commit_symbol (buffer);
6421 : 795 : ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, INTENT_OUT);
6422 : 795 : free_buffer->ts.kind = gfc_default_logical_kind;
6423 : 795 : gfc_commit_symbol (free_buffer);
6424 : :
6425 : : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
6426 : 795 : base = post_caf_ref_expr->symtree->n.sym;
6427 : 795 : gfc_set_sym_referenced (base);
6428 : 795 : gfc_commit_symbol (base);
6429 : 795 : *argptr = gfc_get_formal_arglist ();
6430 : 795 : (*argptr)->sym = base;
6431 : 795 : argptr = &(*argptr)->next;
6432 : :
6433 : 795 : gfc_commit_symbol (base);
6434 : 795 : ADD_ARG ("get_data", get_data, BT_DERIVED, INTENT_IN);
6435 : 795 : gfc_commit_symbol (get_data);
6436 : : #undef ADD_ARG
6437 : :
6438 : : /* Set up code. */
6439 : 795 : if (expr->rank != 0)
6440 : : {
6441 : : /* Code: old_buffer_ptr = C_LOC (buffer); */
6442 : 424 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
6443 : 424 : gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data);
6444 : 424 : old_buffer_data->ts.type = BT_VOID;
6445 : 424 : old_buffer_data->attr.flavor = FL_VARIABLE;
6446 : 424 : gfc_set_sym_referenced (old_buffer_data);
6447 : 424 : gfc_commit_symbol (old_buffer_data);
6448 : 424 : code->expr1 = gfc_lval_expr_from_sym (old_buffer_data);
6449 : 424 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
6450 : : gfc_current_locus, 1,
6451 : : gfc_lval_expr_from_sym (buffer));
6452 : 424 : code->next = gfc_get_code (EXEC_ASSIGN);
6453 : 424 : code = code->next;
6454 : : }
6455 : : else
6456 : 371 : code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN);
6457 : :
6458 : : /* Code: buffer = expr; */
6459 : 795 : code->expr1 = gfc_lval_expr_from_sym (buffer);
6460 : 795 : code->expr2 = post_caf_ref_expr;
6461 : 795 : gfc_ref *ref = code->expr2->ref, **pref = &code->expr2->ref;
6462 : 795 : if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
6463 : : {
6464 : 789 : if (ref->u.ar.dimen != 0)
6465 : : {
6466 : 143 : ref->u.ar.codimen = 0;
6467 : 143 : pref = &ref->next;
6468 : 143 : ref = ref->next;
6469 : : }
6470 : : else
6471 : : {
6472 : 646 : code->expr2->ref = ref->next;
6473 : 646 : ref->next = NULL;
6474 : 646 : gfc_free_ref_list (ref);
6475 : 646 : ref = code->expr2->ref;
6476 : 646 : pref = &code->expr2->ref;
6477 : : }
6478 : : }
6479 : 795 : if (ref && ref->type == REF_COMPONENT)
6480 : : {
6481 : 548 : gfc_find_component (code->expr2->symtree->n.sym->ts.u.derived,
6482 : 548 : ref->u.c.component->name, false, false, pref);
6483 : 548 : if (*pref != ref)
6484 : : {
6485 : 548 : (*pref)->next = ref->next;
6486 : 548 : ref->next = NULL;
6487 : 548 : gfc_free_ref_list (ref);
6488 : : }
6489 : : }
6490 : 795 : get_data->ts.u.derived
6491 : 795 : = create_get_parameter_type (code->expr2, ns, get_data);
6492 : 795 : if (code->expr2->rank == 0)
6493 : 371 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
6494 : : gfc_current_locus, 1, code->expr2);
6495 : :
6496 : : /* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or
6497 : : * *free_buffer = 0; for rank == 0. */
6498 : 795 : code->next = gfc_get_code (EXEC_ASSIGN);
6499 : 795 : code = code->next;
6500 : 795 : code->expr1 = gfc_lval_expr_from_sym (free_buffer);
6501 : 795 : if (expr->rank != 0)
6502 : : {
6503 : 424 : code->expr2 = gfc_get_operator_expr (
6504 : : &gfc_current_locus, INTRINSIC_NE_OS,
6505 : : gfc_lval_expr_from_sym (old_buffer_data),
6506 : : gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
6507 : : gfc_current_locus, 1,
6508 : : gfc_lval_expr_from_sym (buffer)));
6509 : 424 : code->expr2->ts.type = BT_LOGICAL;
6510 : 424 : code->expr2->ts.kind = gfc_default_logical_kind;
6511 : : }
6512 : : else
6513 : : {
6514 : 371 : code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
6515 : : &gfc_current_locus, false);
6516 : : }
6517 : :
6518 : 795 : cb = gfc_lval_expr_from_sym (extproc);
6519 : 795 : cb->ts.interface = extproc;
6520 : :
6521 : 795 : return cb;
6522 : : }
6523 : :
6524 : : static void
6525 : 959 : add_caf_get_intrinsic (gfc_expr *e)
6526 : : {
6527 : 959 : gfc_expr *wrapper, *tmp_expr, *rget_expr, *rget_hash_expr;
6528 : 959 : gfc_ref *ref;
6529 : 959 : int n;
6530 : :
6531 : 1012 : for (ref = e->ref; ref; ref = ref->next)
6532 : 1012 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6533 : : break;
6534 : 959 : if (ref == NULL)
6535 : : return;
6536 : :
6537 : 1805 : for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6538 : 1010 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
6539 : : return;
6540 : :
6541 : 795 : tmp_expr = XCNEW (gfc_expr);
6542 : 795 : *tmp_expr = *e;
6543 : 795 : rget_expr = create_get_callback (tmp_expr);
6544 : 795 : rget_hash_expr = gfc_get_expr ();
6545 : 795 : rget_hash_expr->expr_type = EXPR_CONSTANT;
6546 : 795 : rget_hash_expr->ts.type = BT_INTEGER;
6547 : 795 : rget_hash_expr->ts.kind = gfc_default_integer_kind;
6548 : 795 : rget_hash_expr->where = tmp_expr->where;
6549 : 795 : mpz_init_set_ui (rget_hash_expr->value.integer,
6550 : 795 : gfc_hash_value (rget_expr->symtree->n.sym));
6551 : 795 : wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
6552 : : "caf_get", tmp_expr->where, 3, tmp_expr,
6553 : : rget_hash_expr, rget_expr);
6554 : 795 : gfc_add_caf_accessor (rget_hash_expr, rget_expr);
6555 : 795 : wrapper->ts = e->ts;
6556 : 795 : wrapper->rank = e->rank;
6557 : 795 : wrapper->corank = e->corank;
6558 : 795 : if (e->rank)
6559 : 424 : wrapper->shape = gfc_copy_shape (e->shape, e->rank);
6560 : 795 : *e = *wrapper;
6561 : 795 : free (wrapper);
6562 : : }
6563 : :
6564 : : /* Resolve a variable expression. */
6565 : :
6566 : : static bool
6567 : 1024405 : resolve_variable (gfc_expr *e)
6568 : : {
6569 : 1024405 : gfc_symbol *sym;
6570 : 1024405 : bool t;
6571 : :
6572 : 1024405 : t = true;
6573 : :
6574 : 1024405 : if (e->symtree == NULL)
6575 : : return false;
6576 : 1023988 : sym = e->symtree->n.sym;
6577 : :
6578 : : /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
6579 : : as ts.type is set to BT_ASSUMED in resolve_symbol. */
6580 : 1023988 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
6581 : : {
6582 : 167 : if (!actual_arg || inquiry_argument)
6583 : : {
6584 : 2 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
6585 : : "be used as actual argument", sym->name, &e->where);
6586 : 2 : return false;
6587 : : }
6588 : : }
6589 : : /* TS 29113, 407b. */
6590 : 1023821 : else if (e->ts.type == BT_ASSUMED)
6591 : : {
6592 : 555 : if (!actual_arg)
6593 : : {
6594 : 20 : gfc_error ("Assumed-type variable %s at %L may only be used "
6595 : : "as actual argument", sym->name, &e->where);
6596 : 20 : return false;
6597 : : }
6598 : 535 : else if (inquiry_argument && !first_actual_arg)
6599 : : {
6600 : : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6601 : : for all inquiry functions in resolve_function; the reason is
6602 : : that the function-name resolution happens too late in that
6603 : : function. */
6604 : 0 : gfc_error ("Assumed-type variable %s at %L as actual argument to "
6605 : : "an inquiry function shall be the first argument",
6606 : : sym->name, &e->where);
6607 : 0 : return false;
6608 : : }
6609 : : }
6610 : : /* TS 29113, C535b. */
6611 : 1023266 : else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6612 : 35388 : && sym->ts.u.derived && CLASS_DATA (sym)
6613 : 35383 : && CLASS_DATA (sym)->as
6614 : 13641 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6615 : 1022356 : || (sym->ts.type != BT_CLASS && sym->as
6616 : 341813 : && sym->as->type == AS_ASSUMED_RANK))
6617 : 7888 : && !sym->attr.select_rank_temporary
6618 : 7888 : && !(sym->assoc && sym->assoc->ar))
6619 : : {
6620 : 7888 : if (!actual_arg
6621 : 1247 : && !(cs_base && cs_base->current
6622 : 1246 : && (cs_base->current->op == EXEC_SELECT_RANK
6623 : 188 : || sym->attr.target)))
6624 : : {
6625 : 144 : gfc_error ("Assumed-rank variable %s at %L may only be used as "
6626 : : "actual argument", sym->name, &e->where);
6627 : 144 : return false;
6628 : : }
6629 : 7744 : else if (inquiry_argument && !first_actual_arg)
6630 : : {
6631 : : /* FIXME: It doesn't work reliably as inquiry_argument is not set
6632 : : for all inquiry functions in resolve_function; the reason is
6633 : : that the function-name resolution happens too late in that
6634 : : function. */
6635 : 0 : gfc_error ("Assumed-rank variable %s at %L as actual argument "
6636 : : "to an inquiry function shall be the first argument",
6637 : : sym->name, &e->where);
6638 : 0 : return false;
6639 : : }
6640 : : }
6641 : :
6642 : 1023822 : if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
6643 : 165 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6644 : 164 : && e->ref->next == NULL))
6645 : : {
6646 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
6647 : : "a subobject reference", sym->name, &e->ref->u.ar.where);
6648 : 1 : return false;
6649 : : }
6650 : : /* TS 29113, 407b. */
6651 : 1023821 : else if (e->ts.type == BT_ASSUMED && e->ref
6652 : 655 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6653 : 648 : && e->ref->next == NULL))
6654 : : {
6655 : 7 : gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
6656 : : "reference", sym->name, &e->ref->u.ar.where);
6657 : 7 : return false;
6658 : : }
6659 : :
6660 : : /* TS 29113, C535b. */
6661 : 1023814 : if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
6662 : 35388 : && sym->ts.u.derived && CLASS_DATA (sym)
6663 : 35383 : && CLASS_DATA (sym)->as
6664 : 13641 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
6665 : 1022904 : || (sym->ts.type != BT_CLASS && sym->as
6666 : 342317 : && sym->as->type == AS_ASSUMED_RANK))
6667 : 8012 : && !(sym->assoc && sym->assoc->ar)
6668 : 8012 : && e->ref
6669 : 8012 : && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
6670 : 8008 : && e->ref->next == NULL))
6671 : : {
6672 : 4 : gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
6673 : : "reference", sym->name, &e->ref->u.ar.where);
6674 : 4 : return false;
6675 : : }
6676 : :
6677 : : /* Guessed type variables are associate_names whose selector had not been
6678 : : parsed at the time that the construct was parsed. Now the namespace is
6679 : : being resolved, the TKR of the selector will be available for fixup of
6680 : : the associate_name. */
6681 : 1023810 : if (IS_INFERRED_TYPE (e) && e->ref)
6682 : : {
6683 : 370 : gfc_fixup_inferred_type_refs (e);
6684 : : /* KIND inquiry ref returns the kind of the target. */
6685 : 370 : if (e->expr_type == EXPR_CONSTANT)
6686 : : return true;
6687 : : }
6688 : 1023440 : else if (sym->attr.select_type_temporary
6689 : 8771 : && sym->ns->assoc_name_inferred)
6690 : 92 : gfc_fixup_inferred_type_refs (e);
6691 : :
6692 : : /* For variables that are used in an associate (target => object) where
6693 : : the object's basetype is array valued while the target is scalar,
6694 : : the ts' type of the component refs is still array valued, which
6695 : : can't be translated that way. */
6696 : 1023798 : if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
6697 : 561 : && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
6698 : 561 : && sym->assoc->target->ts.u.derived
6699 : 561 : && CLASS_DATA (sym->assoc->target)
6700 : 561 : && CLASS_DATA (sym->assoc->target)->as)
6701 : : {
6702 : : gfc_ref *ref = e->ref;
6703 : 657 : while (ref)
6704 : : {
6705 : 499 : switch (ref->type)
6706 : : {
6707 : 216 : case REF_COMPONENT:
6708 : 216 : ref->u.c.sym = sym->ts.u.derived;
6709 : : /* Stop the loop. */
6710 : 216 : ref = NULL;
6711 : 216 : break;
6712 : 283 : default:
6713 : 283 : ref = ref->next;
6714 : 283 : break;
6715 : : }
6716 : : }
6717 : : }
6718 : :
6719 : : /* If this is an associate-name, it may be parsed with an array reference
6720 : : in error even though the target is scalar. Fail directly in this case.
6721 : : TODO Understand why class scalar expressions must be excluded. */
6722 : 1023798 : if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
6723 : : {
6724 : 10732 : if (sym->ts.type == BT_CLASS)
6725 : 242 : gfc_fix_class_refs (e);
6726 : 10732 : if (!sym->attr.dimension && !sym->attr.codimension && e->ref
6727 : 2009 : && e->ref->type == REF_ARRAY)
6728 : : {
6729 : : /* Unambiguously scalar! */
6730 : 3 : if (sym->assoc->target
6731 : 3 : && (sym->assoc->target->expr_type == EXPR_CONSTANT
6732 : 1 : || sym->assoc->target->expr_type == EXPR_STRUCTURE))
6733 : 2 : gfc_error ("Scalar variable %qs has an array reference at %L",
6734 : : sym->name, &e->where);
6735 : 3 : return false;
6736 : : }
6737 : 10729 : else if ((sym->attr.dimension || sym->attr.codimension)
6738 : 6737 : && (!e->ref || e->ref->type != REF_ARRAY))
6739 : : {
6740 : : /* This can happen because the parser did not detect that the
6741 : : associate name is an array and the expression had no array
6742 : : part_ref. */
6743 : 134 : gfc_ref *ref = gfc_get_ref ();
6744 : 134 : ref->type = REF_ARRAY;
6745 : 134 : ref->u.ar.type = AR_FULL;
6746 : 134 : if (sym->as)
6747 : : {
6748 : 133 : ref->u.ar.as = sym->as;
6749 : 133 : ref->u.ar.dimen = sym->as->rank;
6750 : : }
6751 : 134 : ref->next = e->ref;
6752 : 134 : e->ref = ref;
6753 : : }
6754 : : }
6755 : :
6756 : 1023795 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
6757 : 0 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
6758 : :
6759 : : /* On the other hand, the parser may not have known this is an array;
6760 : : in this case, we have to add a FULL reference. */
6761 : 1023795 : if (sym->assoc && (sym->attr.dimension || sym->attr.codimension) && !e->ref)
6762 : : {
6763 : 0 : e->ref = gfc_get_ref ();
6764 : 0 : e->ref->type = REF_ARRAY;
6765 : 0 : e->ref->u.ar.type = AR_FULL;
6766 : 0 : e->ref->u.ar.dimen = 0;
6767 : : }
6768 : :
6769 : : /* Like above, but for class types, where the checking whether an array
6770 : : ref is present is more complicated. Furthermore make sure not to add
6771 : : the full array ref to _vptr or _len refs. */
6772 : 1023795 : if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
6773 : 966 : && CLASS_DATA (sym)
6774 : 966 : && (CLASS_DATA (sym)->attr.dimension
6775 : 966 : || CLASS_DATA (sym)->attr.codimension)
6776 : 555 : && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
6777 : : {
6778 : 531 : gfc_ref *ref, *newref;
6779 : :
6780 : 531 : newref = gfc_get_ref ();
6781 : 531 : newref->type = REF_ARRAY;
6782 : 531 : newref->u.ar.type = AR_FULL;
6783 : 531 : newref->u.ar.dimen = 0;
6784 : :
6785 : : /* Because this is an associate var and the first ref either is a ref to
6786 : : the _data component or not, no traversal of the ref chain is
6787 : : needed. The array ref needs to be inserted after the _data ref,
6788 : : or when that is not present, which may happened for polymorphic
6789 : : types, then at the first position. */
6790 : 531 : ref = e->ref;
6791 : 531 : if (!ref)
6792 : 18 : e->ref = newref;
6793 : 513 : else if (ref->type == REF_COMPONENT
6794 : 230 : && strcmp ("_data", ref->u.c.component->name) == 0)
6795 : : {
6796 : 230 : if (!ref->next || ref->next->type != REF_ARRAY)
6797 : : {
6798 : 12 : newref->next = ref->next;
6799 : 12 : ref->next = newref;
6800 : : }
6801 : : else
6802 : : /* Array ref present already. */
6803 : 218 : gfc_free_ref_list (newref);
6804 : : }
6805 : 283 : else if (ref->type == REF_ARRAY)
6806 : : /* Array ref present already. */
6807 : 283 : gfc_free_ref_list (newref);
6808 : : else
6809 : : {
6810 : 0 : newref->next = ref;
6811 : 0 : e->ref = newref;
6812 : : }
6813 : : }
6814 : 1023264 : else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
6815 : : {
6816 : 485 : gfc_ref *ref;
6817 : 908 : for (ref = e->ref; ref; ref = ref->next)
6818 : 453 : if (ref->type == REF_SUBSTRING)
6819 : : break;
6820 : 485 : if (ref == NULL)
6821 : 455 : e->ts = sym->ts;
6822 : : }
6823 : :
6824 : 1023795 : if (e->ref && !gfc_resolve_ref (e))
6825 : : return false;
6826 : :
6827 : 1023726 : if (sym->attr.flavor == FL_PROCEDURE
6828 : 30437 : && (!sym->attr.function
6829 : 18314 : || (sym->attr.function && sym->result
6830 : : && sym->result->attr.proc_pointer
6831 : 17882 : && !sym->result->attr.function)))
6832 : : {
6833 : 12123 : e->ts.type = BT_PROCEDURE;
6834 : 12123 : goto resolve_procedure;
6835 : : }
6836 : :
6837 : 1011603 : if (sym->ts.type != BT_UNKNOWN)
6838 : 1010970 : gfc_variable_attr (e, &e->ts);
6839 : 633 : else if (sym->attr.flavor == FL_PROCEDURE
6840 : 12 : && sym->attr.function && sym->result
6841 : 12 : && sym->result->ts.type != BT_UNKNOWN
6842 : 10 : && sym->result->attr.proc_pointer)
6843 : 10 : e->ts = sym->result->ts;
6844 : : else
6845 : : {
6846 : : /* Must be a simple variable reference. */
6847 : 623 : if (!gfc_set_default_type (sym, 1, sym->ns))
6848 : : return false;
6849 : 501 : e->ts = sym->ts;
6850 : : }
6851 : :
6852 : 1011481 : if (check_assumed_size_reference (sym, e))
6853 : : return false;
6854 : :
6855 : : /* Deal with forward references to entries during gfc_resolve_code, to
6856 : : satisfy, at least partially, 12.5.2.5. */
6857 : 1011465 : if (gfc_current_ns->entries
6858 : 3060 : && current_entry_id == sym->entry_id
6859 : 1000 : && cs_base
6860 : 914 : && cs_base->current
6861 : 914 : && cs_base->current->op != EXEC_ENTRY)
6862 : : {
6863 : 914 : gfc_entry_list *entry;
6864 : 914 : gfc_formal_arglist *formal;
6865 : 914 : int n;
6866 : 914 : bool seen, saved_specification_expr;
6867 : :
6868 : : /* If the symbol is a dummy... */
6869 : 914 : if (sym->attr.dummy && sym->ns == gfc_current_ns)
6870 : : {
6871 : : entry = gfc_current_ns->entries;
6872 : : seen = false;
6873 : :
6874 : : /* ...test if the symbol is a parameter of previous entries. */
6875 : 1033 : for (; entry && entry->id <= current_entry_id; entry = entry->next)
6876 : 1006 : for (formal = entry->sym->formal; formal; formal = formal->next)
6877 : : {
6878 : 997 : if (formal->sym && sym->name == formal->sym->name)
6879 : : {
6880 : : seen = true;
6881 : : break;
6882 : : }
6883 : : }
6884 : :
6885 : : /* If it has not been seen as a dummy, this is an error. */
6886 : 453 : if (!seen)
6887 : : {
6888 : 3 : if (specification_expr)
6889 : 2 : gfc_error ("Variable %qs, used in a specification expression"
6890 : : ", is referenced at %L before the ENTRY statement "
6891 : : "in which it is a parameter",
6892 : : sym->name, &cs_base->current->loc);
6893 : : else
6894 : 1 : gfc_error ("Variable %qs is used at %L before the ENTRY "
6895 : : "statement in which it is a parameter",
6896 : : sym->name, &cs_base->current->loc);
6897 : : t = false;
6898 : : }
6899 : : }
6900 : :
6901 : : /* Now do the same check on the specification expressions. */
6902 : 914 : saved_specification_expr = specification_expr;
6903 : 914 : specification_expr = true;
6904 : 914 : if (sym->ts.type == BT_CHARACTER
6905 : 914 : && !gfc_resolve_expr (sym->ts.u.cl->length))
6906 : : t = false;
6907 : :
6908 : 914 : if (sym->as)
6909 : : {
6910 : 112 : bool old_caf_lhs = caf_lhs;
6911 : 112 : caf_lhs = false;
6912 : 271 : for (n = 0; n < sym->as->rank; n++)
6913 : : {
6914 : 159 : if (!gfc_resolve_expr (sym->as->lower[n]))
6915 : 0 : t = false;
6916 : 159 : if (!gfc_resolve_expr (sym->as->upper[n]))
6917 : 1 : t = false;
6918 : : }
6919 : 112 : caf_lhs = old_caf_lhs;
6920 : : }
6921 : 914 : specification_expr = saved_specification_expr;
6922 : :
6923 : 914 : if (t)
6924 : : /* Update the symbol's entry level. */
6925 : 909 : sym->entry_id = current_entry_id + 1;
6926 : : }
6927 : :
6928 : : /* If a symbol has been host_associated mark it. This is used latter,
6929 : : to identify if aliasing is possible via host association. */
6930 : 1011465 : if (sym->attr.flavor == FL_VARIABLE
6931 : 976399 : && (!sym->ns->code || sym->ns->code->op != EXEC_BLOCK
6932 : 5139 : || !sym->ns->code->ext.block.assoc)
6933 : 975006 : && gfc_current_ns->parent
6934 : 343655 : && (gfc_current_ns->parent == sym->ns
6935 : 307408 : || (gfc_current_ns->parent->parent
6936 : 10384 : && gfc_current_ns->parent->parent == sym->ns)))
6937 : 42344 : sym->attr.host_assoc = 1;
6938 : :
6939 : 1011465 : if (gfc_current_ns->proc_name
6940 : 1008096 : && sym->attr.dimension
6941 : 337149 : && (sym->ns != gfc_current_ns
6942 : : || sym->attr.use_assoc
6943 : 313981 : || sym->attr.in_common))
6944 : 31786 : gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
6945 : :
6946 : 1023588 : resolve_procedure:
6947 : 1023588 : if (t && !resolve_procedure_expression (e))
6948 : : t = false;
6949 : :
6950 : : /* F2008, C617 and C1229. */
6951 : 1022559 : if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
6952 : 1112427 : && gfc_is_coindexed (e))
6953 : : {
6954 : 296 : gfc_ref *ref, *ref2 = NULL;
6955 : :
6956 : 369 : for (ref = e->ref; ref; ref = ref->next)
6957 : : {
6958 : 369 : if (ref->type == REF_COMPONENT)
6959 : 73 : ref2 = ref;
6960 : 369 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6961 : : break;
6962 : : }
6963 : :
6964 : 592 : for ( ; ref; ref = ref->next)
6965 : 308 : if (ref->type == REF_COMPONENT)
6966 : : break;
6967 : :
6968 : : /* Expression itself is not coindexed object. */
6969 : 296 : if (ref && e->ts.type == BT_CLASS)
6970 : : {
6971 : 3 : gfc_error ("Polymorphic subobject of coindexed object at %L",
6972 : : &e->where);
6973 : 3 : t = false;
6974 : : }
6975 : :
6976 : : /* Expression itself is coindexed object. */
6977 : 284 : if (ref == NULL)
6978 : : {
6979 : 284 : gfc_component *c;
6980 : 284 : c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6981 : 382 : for ( ; c; c = c->next)
6982 : 98 : if (c->attr.allocatable && c->ts.type == BT_CLASS)
6983 : : {
6984 : 0 : gfc_error ("Coindexed object with polymorphic allocatable "
6985 : : "subcomponent at %L", &e->where);
6986 : 0 : t = false;
6987 : 0 : break;
6988 : : }
6989 : : }
6990 : : }
6991 : :
6992 : 1023588 : if (t)
6993 : 1023580 : gfc_expression_rank (e);
6994 : :
6995 : 1023580 : if (t && flag_coarray == GFC_FCOARRAY_LIB && !caf_lhs
6996 : 10000 : && gfc_is_coindexed (e))
6997 : 959 : add_caf_get_intrinsic (e);
6998 : :
6999 : 1023588 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
7000 : 3 : gfc_warning (OPT_Wdeprecated_declarations,
7001 : : "Using variable %qs at %L is deprecated",
7002 : : sym->name, &e->where);
7003 : : /* Simplify cases where access to a parameter array results in a
7004 : : single constant. Suppress errors since those will have been
7005 : : issued before, as warnings. */
7006 : 1023588 : if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
7007 : : {
7008 : 2548 : gfc_push_suppress_errors ();
7009 : 2548 : gfc_simplify_expr (e, 1);
7010 : 2548 : gfc_pop_suppress_errors ();
7011 : : }
7012 : :
7013 : : return t;
7014 : : }
7015 : :
7016 : :
7017 : : /* 'sym' was initially guessed to be derived type but has been corrected
7018 : : in resolve_assoc_var to be a class entity or the derived type correcting.
7019 : : If a class entity it will certainly need the _data reference or the
7020 : : reference derived type symbol correcting in the first component ref if
7021 : : a derived type. */
7022 : :
7023 : : void
7024 : 840 : gfc_fixup_inferred_type_refs (gfc_expr *e)
7025 : : {
7026 : 840 : gfc_ref *ref, *new_ref;
7027 : 840 : gfc_symbol *sym, *derived;
7028 : 840 : gfc_expr *target;
7029 : 840 : sym = e->symtree->n.sym;
7030 : :
7031 : : /* An associate_name whose selector is (i) a component ref of a selector
7032 : : that is a inferred type associate_name; or (ii) an intrinsic type that
7033 : : has been inferred from an inquiry ref. */
7034 : 840 : if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
7035 : : {
7036 : 282 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
7037 : 282 : sym->attr.codimension = sym->assoc->target->corank ? 1 : 0;
7038 : 282 : if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
7039 : : {
7040 : 60 : ref = e->ref;
7041 : : /* A substring misidentified as an array section. */
7042 : 60 : if (sym->ts.type == BT_CHARACTER
7043 : 30 : && ref->u.ar.start[0] && ref->u.ar.end[0]
7044 : 6 : && !ref->u.ar.stride[0])
7045 : : {
7046 : 6 : new_ref = gfc_get_ref ();
7047 : 6 : new_ref->type = REF_SUBSTRING;
7048 : 6 : new_ref->u.ss.start = ref->u.ar.start[0];
7049 : 6 : new_ref->u.ss.end = ref->u.ar.end[0];
7050 : 6 : new_ref->u.ss.length = sym->ts.u.cl;
7051 : 6 : *ref = *new_ref;
7052 : 6 : free (new_ref);
7053 : : }
7054 : : else
7055 : : {
7056 : 54 : if (e->ref->u.ar.type == AR_UNKNOWN)
7057 : 24 : gfc_error ("Invalid array reference at %L", &e->where);
7058 : 54 : e->ref = ref->next;
7059 : 54 : free (ref);
7060 : : }
7061 : : }
7062 : :
7063 : : /* It is possible for an inquiry reference to be mistaken for a
7064 : : component reference. Correct this now. */
7065 : 282 : ref = e->ref;
7066 : 282 : if (ref && ref->type == REF_ARRAY)
7067 : 138 : ref = ref->next;
7068 : 150 : if (ref && ref->type == REF_COMPONENT
7069 : 150 : && is_inquiry_ref (ref->u.c.component->name, &new_ref))
7070 : : {
7071 : 12 : e->symtree->n.sym = sym;
7072 : 12 : *ref = *new_ref;
7073 : 12 : gfc_free_ref_list (new_ref);
7074 : : }
7075 : :
7076 : : /* The kind of the associate name is best evaluated directly from the
7077 : : selector because of the guesses made in primary.cc, when the type
7078 : : is still unknown. */
7079 : 282 : if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
7080 : : {
7081 : 24 : gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
7082 : 12 : sym->assoc->target->ts.kind);
7083 : 12 : gfc_replace_expr (e, ne);
7084 : : }
7085 : :
7086 : : /* Now that the references are all sorted out, set the expression rank
7087 : : and return. */
7088 : 282 : gfc_expression_rank (e);
7089 : 282 : return;
7090 : : }
7091 : :
7092 : 558 : derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
7093 : : : sym->ts.u.derived;
7094 : :
7095 : : /* Ensure that class symbols have an array spec and ensure that there
7096 : : is a _data field reference following class type references. */
7097 : 558 : if (sym->ts.type == BT_CLASS
7098 : 196 : && sym->assoc->target->ts.type == BT_CLASS)
7099 : : {
7100 : 196 : e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
7101 : 196 : e->corank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0;
7102 : 196 : sym->attr.dimension = 0;
7103 : 196 : sym->attr.codimension = 0;
7104 : 196 : CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
7105 : 196 : CLASS_DATA (sym)->attr.codimension = e->corank ? 1 : 0;
7106 : 196 : if (e->ref && (e->ref->type != REF_COMPONENT
7107 : 160 : || e->ref->u.c.component->name[0] != '_'))
7108 : : {
7109 : 82 : ref = gfc_get_ref ();
7110 : 82 : ref->type = REF_COMPONENT;
7111 : 82 : ref->next = e->ref;
7112 : 82 : e->ref = ref;
7113 : 82 : ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
7114 : : true, true, NULL);
7115 : 82 : ref->u.c.sym = sym->ts.u.derived;
7116 : : }
7117 : : }
7118 : :
7119 : : /* Proceed as far as the first component reference and ensure that the
7120 : : correct derived type is being used. */
7121 : 817 : for (ref = e->ref; ref; ref = ref->next)
7122 : 781 : if (ref->type == REF_COMPONENT)
7123 : : {
7124 : 522 : if (ref->u.c.component->name[0] != '_')
7125 : 326 : ref->u.c.sym = derived;
7126 : : else
7127 : 196 : ref->u.c.sym = sym->ts.u.derived;
7128 : : break;
7129 : : }
7130 : :
7131 : : /* Verify that the type inferrence mechanism has not introduced a spurious
7132 : : array reference. This can happen with an associate name, whose selector
7133 : : is an element of another inferred type. */
7134 : 558 : target = e->symtree->n.sym->assoc->target;
7135 : 558 : if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
7136 : 150 : && e != target && !target->rank)
7137 : : {
7138 : : /* First case: array ref after the scalar class or derived
7139 : : associate_name. */
7140 : 150 : if (e->ref && e->ref->type == REF_ARRAY
7141 : 7 : && e->ref->u.ar.type != AR_ELEMENT)
7142 : : {
7143 : 7 : ref = e->ref;
7144 : 7 : if (ref->u.ar.type == AR_UNKNOWN)
7145 : 1 : gfc_error ("Invalid array reference at %L", &e->where);
7146 : 7 : e->ref = ref->next;
7147 : 7 : free (ref);
7148 : :
7149 : : /* If it hasn't a ref to the '_data' field supply one. */
7150 : 7 : if (sym->ts.type == BT_CLASS
7151 : 0 : && !(e->ref->type == REF_COMPONENT
7152 : 0 : && strcmp (e->ref->u.c.component->name, "_data")))
7153 : : {
7154 : 0 : gfc_ref *new_ref;
7155 : 0 : gfc_find_component (e->symtree->n.sym->ts.u.derived,
7156 : : "_data", true, true, &new_ref);
7157 : 0 : new_ref->next = e->ref;
7158 : 0 : e->ref = new_ref;
7159 : : }
7160 : : }
7161 : : /* 2nd case: a ref to the '_data' field followed by an array ref. */
7162 : 143 : else if (e->ref && e->ref->type == REF_COMPONENT
7163 : 143 : && strcmp (e->ref->u.c.component->name, "_data") == 0
7164 : 64 : && e->ref->next && e->ref->next->type == REF_ARRAY
7165 : 0 : && e->ref->next->u.ar.type != AR_ELEMENT)
7166 : : {
7167 : 0 : ref = e->ref->next;
7168 : 0 : if (ref->u.ar.type == AR_UNKNOWN)
7169 : 0 : gfc_error ("Invalid array reference at %L", &e->where);
7170 : 0 : e->ref->next = e->ref->next->next;
7171 : 0 : free (ref);
7172 : : }
7173 : : }
7174 : :
7175 : : /* Now that all the references are OK, get the expression rank. */
7176 : 558 : gfc_expression_rank (e);
7177 : : }
7178 : :
7179 : :
7180 : : /* Checks to see that the correct symbol has been host associated.
7181 : : The only situations where this arises are:
7182 : : (i) That in which a twice contained function is parsed after
7183 : : the host association is made. On detecting this, change
7184 : : the symbol in the expression and convert the array reference
7185 : : into an actual arglist if the old symbol is a variable; or
7186 : : (ii) That in which an external function is typed but not declared
7187 : : explicitly to be external. Here, the old symbol is changed
7188 : : from a variable to an external function. */
7189 : : static bool
7190 : 1349277 : check_host_association (gfc_expr *e)
7191 : : {
7192 : 1349277 : gfc_symbol *sym, *old_sym;
7193 : 1349277 : gfc_symtree *st;
7194 : 1349277 : int n;
7195 : 1349277 : gfc_ref *ref;
7196 : 1349277 : gfc_actual_arglist *arg, *tail = NULL;
7197 : 1349277 : bool retval = e->expr_type == EXPR_FUNCTION;
7198 : :
7199 : : /* If the expression is the result of substitution in
7200 : : interface.cc(gfc_extend_expr) because there is no way in
7201 : : which the host association can be wrong. */
7202 : 1349277 : if (e->symtree == NULL
7203 : 1348544 : || e->symtree->n.sym == NULL
7204 : 1348544 : || e->user_operator)
7205 : : return retval;
7206 : :
7207 : 1346834 : old_sym = e->symtree->n.sym;
7208 : :
7209 : 1346834 : if (gfc_current_ns->parent
7210 : 462921 : && old_sym->ns != gfc_current_ns)
7211 : : {
7212 : : /* Use the 'USE' name so that renamed module symbols are
7213 : : correctly handled. */
7214 : 85536 : gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
7215 : :
7216 : 85536 : if (sym && old_sym != sym
7217 : : && sym->attr.flavor == FL_PROCEDURE
7218 : 384 : && sym->attr.contained)
7219 : : {
7220 : : /* Clear the shape, since it might not be valid. */
7221 : 71 : gfc_free_shape (&e->shape, e->rank);
7222 : :
7223 : : /* Give the expression the right symtree! */
7224 : 71 : gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
7225 : 71 : gcc_assert (st != NULL);
7226 : :
7227 : 71 : if (old_sym->attr.flavor == FL_PROCEDURE
7228 : 47 : || e->expr_type == EXPR_FUNCTION)
7229 : : {
7230 : : /* Original was function so point to the new symbol, since
7231 : : the actual argument list is already attached to the
7232 : : expression. */
7233 : 30 : e->value.function.esym = NULL;
7234 : 30 : e->symtree = st;
7235 : : }
7236 : : else
7237 : : {
7238 : : /* Original was variable so convert array references into
7239 : : an actual arglist. This does not need any checking now
7240 : : since resolve_function will take care of it. */
7241 : 41 : e->value.function.actual = NULL;
7242 : 41 : e->expr_type = EXPR_FUNCTION;
7243 : 41 : e->symtree = st;
7244 : :
7245 : : /* Ambiguity will not arise if the array reference is not
7246 : : the last reference. */
7247 : 43 : for (ref = e->ref; ref; ref = ref->next)
7248 : 38 : if (ref->type == REF_ARRAY && ref->next == NULL)
7249 : : break;
7250 : :
7251 : 41 : if ((ref == NULL || ref->type != REF_ARRAY)
7252 : 5 : && sym->attr.proc == PROC_INTERNAL)
7253 : : {
7254 : 4 : gfc_error ("%qs at %L is host associated at %L into "
7255 : : "a contained procedure with an internal "
7256 : : "procedure of the same name", sym->name,
7257 : : &old_sym->declared_at, &e->where);
7258 : 4 : return false;
7259 : : }
7260 : :
7261 : 1 : if (ref == NULL)
7262 : : return false;
7263 : :
7264 : 36 : gcc_assert (ref->type == REF_ARRAY);
7265 : :
7266 : : /* Grab the start expressions from the array ref and
7267 : : copy them into actual arguments. */
7268 : 84 : for (n = 0; n < ref->u.ar.dimen; n++)
7269 : : {
7270 : 48 : arg = gfc_get_actual_arglist ();
7271 : 48 : arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
7272 : 48 : if (e->value.function.actual == NULL)
7273 : 36 : tail = e->value.function.actual = arg;
7274 : : else
7275 : : {
7276 : 12 : tail->next = arg;
7277 : 12 : tail = arg;
7278 : : }
7279 : : }
7280 : :
7281 : : /* Dump the reference list and set the rank. */
7282 : 36 : gfc_free_ref_list (e->ref);
7283 : 36 : e->ref = NULL;
7284 : 36 : e->rank = sym->as ? sym->as->rank : 0;
7285 : 36 : e->corank = sym->as ? sym->as->corank : 0;
7286 : : }
7287 : :
7288 : 66 : gfc_resolve_expr (e);
7289 : 66 : sym->refs++;
7290 : : }
7291 : : /* This case corresponds to a call, from a block or a contained
7292 : : procedure, to an external function, which has not been declared
7293 : : as being external in the main program but has been typed. */
7294 : 85465 : else if (sym && old_sym != sym
7295 : 313 : && !e->ref
7296 : 213 : && sym->ts.type == BT_UNKNOWN
7297 : 21 : && old_sym->ts.type != BT_UNKNOWN
7298 : 19 : && sym->attr.flavor == FL_PROCEDURE
7299 : 19 : && old_sym->attr.flavor == FL_VARIABLE
7300 : 7 : && sym->ns->parent == old_sym->ns
7301 : 7 : && sym->ns->proc_name
7302 : 7 : && sym->ns->proc_name->attr.proc != PROC_MODULE
7303 : 6 : && (sym->ns->proc_name->attr.flavor == FL_LABEL
7304 : 6 : || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
7305 : : {
7306 : 6 : old_sym->attr.flavor = FL_PROCEDURE;
7307 : 6 : old_sym->attr.external = 1;
7308 : 6 : old_sym->attr.function = 1;
7309 : 6 : old_sym->result = old_sym;
7310 : 6 : gfc_resolve_expr (e);
7311 : : }
7312 : : }
7313 : : /* This might have changed! */
7314 : 1346829 : return e->expr_type == EXPR_FUNCTION;
7315 : : }
7316 : :
7317 : :
7318 : : static void
7319 : 1529 : gfc_resolve_character_operator (gfc_expr *e)
7320 : : {
7321 : 1529 : gfc_expr *op1 = e->value.op.op1;
7322 : 1529 : gfc_expr *op2 = e->value.op.op2;
7323 : 1529 : gfc_expr *e1 = NULL;
7324 : 1529 : gfc_expr *e2 = NULL;
7325 : :
7326 : 1529 : gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
7327 : :
7328 : 1529 : if (op1->ts.u.cl && op1->ts.u.cl->length)
7329 : 768 : e1 = gfc_copy_expr (op1->ts.u.cl->length);
7330 : 761 : else if (op1->expr_type == EXPR_CONSTANT)
7331 : 336 : e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7332 : : op1->value.character.length);
7333 : :
7334 : 1529 : if (op2->ts.u.cl && op2->ts.u.cl->length)
7335 : 755 : e2 = gfc_copy_expr (op2->ts.u.cl->length);
7336 : 774 : else if (op2->expr_type == EXPR_CONSTANT)
7337 : 536 : e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
7338 : : op2->value.character.length);
7339 : :
7340 : 1529 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7341 : :
7342 : 1529 : if (!e1 || !e2)
7343 : : {
7344 : 562 : gfc_free_expr (e1);
7345 : 562 : gfc_free_expr (e2);
7346 : :
7347 : 562 : return;
7348 : : }
7349 : :
7350 : 967 : e->ts.u.cl->length = gfc_add (e1, e2);
7351 : 967 : e->ts.u.cl->length->ts.type = BT_INTEGER;
7352 : 967 : e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
7353 : 967 : gfc_simplify_expr (e->ts.u.cl->length, 0);
7354 : 967 : gfc_resolve_expr (e->ts.u.cl->length);
7355 : :
7356 : 967 : return;
7357 : : }
7358 : :
7359 : :
7360 : : /* Ensure that an character expression has a charlen and, if possible, a
7361 : : length expression. */
7362 : :
7363 : : static void
7364 : 175592 : fixup_charlen (gfc_expr *e)
7365 : : {
7366 : : /* The cases fall through so that changes in expression type and the need
7367 : : for multiple fixes are picked up. In all circumstances, a charlen should
7368 : : be available for the middle end to hang a backend_decl on. */
7369 : 175592 : switch (e->expr_type)
7370 : : {
7371 : 1529 : case EXPR_OP:
7372 : 1529 : gfc_resolve_character_operator (e);
7373 : : /* FALLTHRU */
7374 : :
7375 : 1584 : case EXPR_ARRAY:
7376 : 1584 : if (e->expr_type == EXPR_ARRAY)
7377 : 55 : gfc_resolve_character_array_constructor (e);
7378 : : /* FALLTHRU */
7379 : :
7380 : 2065 : case EXPR_SUBSTRING:
7381 : 2065 : if (!e->ts.u.cl && e->ref)
7382 : 477 : gfc_resolve_substring_charlen (e);
7383 : : /* FALLTHRU */
7384 : :
7385 : 175592 : default:
7386 : 175592 : if (!e->ts.u.cl)
7387 : 173531 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7388 : :
7389 : 175592 : break;
7390 : : }
7391 : 175592 : }
7392 : :
7393 : :
7394 : : /* Update an actual argument to include the passed-object for type-bound
7395 : : procedures at the right position. */
7396 : :
7397 : : static gfc_actual_arglist*
7398 : 2779 : update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
7399 : : const char *name)
7400 : : {
7401 : 2803 : gcc_assert (argpos > 0);
7402 : :
7403 : 2803 : if (argpos == 1)
7404 : : {
7405 : 2666 : gfc_actual_arglist* result;
7406 : :
7407 : 2666 : result = gfc_get_actual_arglist ();
7408 : 2666 : result->expr = po;
7409 : 2666 : result->next = lst;
7410 : 2666 : if (name)
7411 : 502 : result->name = name;
7412 : :
7413 : 2666 : return result;
7414 : : }
7415 : :
7416 : 137 : if (lst)
7417 : 113 : lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
7418 : : else
7419 : 24 : lst = update_arglist_pass (NULL, po, argpos - 1, name);
7420 : : return lst;
7421 : : }
7422 : :
7423 : :
7424 : : /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
7425 : :
7426 : : static gfc_expr*
7427 : 6847 : extract_compcall_passed_object (gfc_expr* e)
7428 : : {
7429 : 6847 : gfc_expr* po;
7430 : :
7431 : 6847 : if (e->expr_type == EXPR_UNKNOWN)
7432 : : {
7433 : 0 : gfc_error ("Error in typebound call at %L",
7434 : : &e->where);
7435 : 0 : return NULL;
7436 : : }
7437 : :
7438 : 6847 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7439 : :
7440 : 6847 : if (e->value.compcall.base_object)
7441 : 1494 : po = gfc_copy_expr (e->value.compcall.base_object);
7442 : : else
7443 : : {
7444 : 5353 : po = gfc_get_expr ();
7445 : 5353 : po->expr_type = EXPR_VARIABLE;
7446 : 5353 : po->symtree = e->symtree;
7447 : 5353 : po->ref = gfc_copy_ref (e->ref);
7448 : 5353 : po->where = e->where;
7449 : : }
7450 : :
7451 : 6847 : if (!gfc_resolve_expr (po))
7452 : : return NULL;
7453 : :
7454 : : return po;
7455 : : }
7456 : :
7457 : :
7458 : : /* Update the arglist of an EXPR_COMPCALL expression to include the
7459 : : passed-object. */
7460 : :
7461 : : static bool
7462 : 3182 : update_compcall_arglist (gfc_expr* e)
7463 : : {
7464 : 3182 : gfc_expr* po;
7465 : 3182 : gfc_typebound_proc* tbp;
7466 : :
7467 : 3182 : tbp = e->value.compcall.tbp;
7468 : :
7469 : 3182 : if (tbp->error)
7470 : : return false;
7471 : :
7472 : 3181 : po = extract_compcall_passed_object (e);
7473 : 3181 : if (!po)
7474 : : return false;
7475 : :
7476 : 3181 : if (tbp->nopass || e->value.compcall.ignore_pass)
7477 : : {
7478 : 1071 : gfc_free_expr (po);
7479 : 1071 : return true;
7480 : : }
7481 : :
7482 : 2110 : if (tbp->pass_arg_num <= 0)
7483 : : return false;
7484 : :
7485 : 2109 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7486 : : tbp->pass_arg_num,
7487 : : tbp->pass_arg);
7488 : :
7489 : 2109 : return true;
7490 : : }
7491 : :
7492 : :
7493 : : /* Extract the passed object from a PPC call (a copy of it). */
7494 : :
7495 : : static gfc_expr*
7496 : 85 : extract_ppc_passed_object (gfc_expr *e)
7497 : : {
7498 : 85 : gfc_expr *po;
7499 : 85 : gfc_ref **ref;
7500 : :
7501 : 85 : po = gfc_get_expr ();
7502 : 85 : po->expr_type = EXPR_VARIABLE;
7503 : 85 : po->symtree = e->symtree;
7504 : 85 : po->ref = gfc_copy_ref (e->ref);
7505 : 85 : po->where = e->where;
7506 : :
7507 : : /* Remove PPC reference. */
7508 : 85 : ref = &po->ref;
7509 : 91 : while ((*ref)->next)
7510 : 6 : ref = &(*ref)->next;
7511 : 85 : gfc_free_ref_list (*ref);
7512 : 85 : *ref = NULL;
7513 : :
7514 : 85 : if (!gfc_resolve_expr (po))
7515 : 0 : return NULL;
7516 : :
7517 : : return po;
7518 : : }
7519 : :
7520 : :
7521 : : /* Update the actual arglist of a procedure pointer component to include the
7522 : : passed-object. */
7523 : :
7524 : : static bool
7525 : 399 : update_ppc_arglist (gfc_expr* e)
7526 : : {
7527 : 399 : gfc_expr* po;
7528 : 399 : gfc_component *ppc;
7529 : 399 : gfc_typebound_proc* tb;
7530 : :
7531 : 399 : ppc = gfc_get_proc_ptr_comp (e);
7532 : 399 : if (!ppc)
7533 : : return false;
7534 : :
7535 : 399 : tb = ppc->tb;
7536 : :
7537 : 399 : if (tb->error)
7538 : : return false;
7539 : 397 : else if (tb->nopass)
7540 : : return true;
7541 : :
7542 : 85 : po = extract_ppc_passed_object (e);
7543 : 85 : if (!po)
7544 : : return false;
7545 : :
7546 : : /* F08:R739. */
7547 : 85 : if (po->rank != 0)
7548 : : {
7549 : 0 : gfc_error ("Passed-object at %L must be scalar", &e->where);
7550 : 0 : return false;
7551 : : }
7552 : :
7553 : : /* F08:C611. */
7554 : 85 : if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
7555 : : {
7556 : 1 : gfc_error ("Base object for procedure-pointer component call at %L is of"
7557 : : " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
7558 : 1 : return false;
7559 : : }
7560 : :
7561 : 84 : gcc_assert (tb->pass_arg_num > 0);
7562 : 84 : e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
7563 : : tb->pass_arg_num,
7564 : : tb->pass_arg);
7565 : :
7566 : 84 : return true;
7567 : : }
7568 : :
7569 : :
7570 : : /* Check that the object a TBP is called on is valid, i.e. it must not be
7571 : : of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
7572 : :
7573 : : static bool
7574 : 3193 : check_typebound_baseobject (gfc_expr* e)
7575 : : {
7576 : 3193 : gfc_expr* base;
7577 : 3193 : bool return_value = false;
7578 : :
7579 : 3193 : base = extract_compcall_passed_object (e);
7580 : 3193 : if (!base)
7581 : : return false;
7582 : :
7583 : 3190 : if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
7584 : : {
7585 : 1 : gfc_error ("Error in typebound call at %L", &e->where);
7586 : 1 : goto cleanup;
7587 : : }
7588 : :
7589 : 3189 : if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
7590 : 1 : return false;
7591 : :
7592 : : /* F08:C611. */
7593 : 3188 : if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
7594 : : {
7595 : 3 : gfc_error ("Base object for type-bound procedure call at %L is of"
7596 : : " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
7597 : 3 : goto cleanup;
7598 : : }
7599 : :
7600 : : /* F08:C1230. If the procedure called is NOPASS,
7601 : : the base object must be scalar. */
7602 : 3185 : if (e->value.compcall.tbp->nopass && base->rank != 0)
7603 : : {
7604 : 1 : gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
7605 : : " be scalar", &e->where);
7606 : 1 : goto cleanup;
7607 : : }
7608 : :
7609 : : return_value = true;
7610 : :
7611 : 3189 : cleanup:
7612 : 3189 : gfc_free_expr (base);
7613 : 3189 : return return_value;
7614 : : }
7615 : :
7616 : :
7617 : : /* Resolve a call to a type-bound procedure, either function or subroutine,
7618 : : statically from the data in an EXPR_COMPCALL expression. The adapted
7619 : : arglist and the target-procedure symtree are returned. */
7620 : :
7621 : : static bool
7622 : 3182 : resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
7623 : : gfc_actual_arglist** actual)
7624 : : {
7625 : 3182 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7626 : 3182 : gcc_assert (!e->value.compcall.tbp->is_generic);
7627 : :
7628 : : /* Update the actual arglist for PASS. */
7629 : 3182 : if (!update_compcall_arglist (e))
7630 : : return false;
7631 : :
7632 : 3180 : *actual = e->value.compcall.actual;
7633 : 3180 : *target = e->value.compcall.tbp->u.specific;
7634 : :
7635 : 3180 : gfc_free_ref_list (e->ref);
7636 : 3180 : e->ref = NULL;
7637 : 3180 : e->value.compcall.actual = NULL;
7638 : :
7639 : : /* If we find a deferred typebound procedure, check for derived types
7640 : : that an overriding typebound procedure has not been missed. */
7641 : 3180 : if (e->value.compcall.name
7642 : 3180 : && !e->value.compcall.tbp->non_overridable
7643 : 3164 : && e->value.compcall.base_object
7644 : 747 : && e->value.compcall.base_object->ts.type == BT_DERIVED)
7645 : : {
7646 : 460 : gfc_symtree *st;
7647 : 460 : gfc_symbol *derived;
7648 : :
7649 : : /* Use the derived type of the base_object. */
7650 : 460 : derived = e->value.compcall.base_object->ts.u.derived;
7651 : 460 : st = NULL;
7652 : :
7653 : : /* If necessary, go through the inheritance chain. */
7654 : 1381 : while (!st && derived)
7655 : : {
7656 : : /* Look for the typebound procedure 'name'. */
7657 : 461 : if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
7658 : 460 : st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
7659 : : e->value.compcall.name);
7660 : 461 : if (!st)
7661 : 1 : derived = gfc_get_derived_super_type (derived);
7662 : : }
7663 : :
7664 : : /* Now find the specific name in the derived type namespace. */
7665 : 460 : if (st && st->n.tb && st->n.tb->u.specific)
7666 : 460 : gfc_find_sym_tree (st->n.tb->u.specific->name,
7667 : : derived->ns, 1, &st);
7668 : 460 : if (st)
7669 : 460 : *target = st;
7670 : : }
7671 : :
7672 : 3180 : if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
7673 : 3180 : && !e->value.compcall.tbp->deferred)
7674 : 1 : gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
7675 : : " itself recursively. Declare it RECURSIVE or use"
7676 : : " %<-frecursive%>", (*target)->n.sym->name, &e->where);
7677 : :
7678 : : return true;
7679 : : }
7680 : :
7681 : :
7682 : : /* Get the ultimate declared type from an expression. In addition,
7683 : : return the last class/derived type reference and the copy of the
7684 : : reference list. If check_types is set true, derived types are
7685 : : identified as well as class references. */
7686 : : static gfc_symbol*
7687 : 3116 : get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
7688 : : gfc_expr *e, bool check_types)
7689 : : {
7690 : 3116 : gfc_symbol *declared;
7691 : 3116 : gfc_ref *ref;
7692 : :
7693 : 3116 : declared = NULL;
7694 : 3116 : if (class_ref)
7695 : 2745 : *class_ref = NULL;
7696 : 3116 : if (new_ref)
7697 : 2458 : *new_ref = gfc_copy_ref (e->ref);
7698 : :
7699 : 3883 : for (ref = e->ref; ref; ref = ref->next)
7700 : : {
7701 : 767 : if (ref->type != REF_COMPONENT)
7702 : 281 : continue;
7703 : :
7704 : 486 : if ((ref->u.c.component->ts.type == BT_CLASS
7705 : 240 : || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
7706 : 411 : && ref->u.c.component->attr.flavor != FL_PROCEDURE)
7707 : : {
7708 : 337 : declared = ref->u.c.component->ts.u.derived;
7709 : 337 : if (class_ref)
7710 : 319 : *class_ref = ref;
7711 : : }
7712 : : }
7713 : :
7714 : 3116 : if (declared == NULL)
7715 : 2805 : declared = e->symtree->n.sym->ts.u.derived;
7716 : :
7717 : 3116 : return declared;
7718 : : }
7719 : :
7720 : :
7721 : : /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
7722 : : which of the specific bindings (if any) matches the arglist and transform
7723 : : the expression into a call of that binding. */
7724 : :
7725 : : static bool
7726 : 3184 : resolve_typebound_generic_call (gfc_expr* e, const char **name)
7727 : : {
7728 : 3184 : gfc_typebound_proc* genproc;
7729 : 3184 : const char* genname;
7730 : 3184 : gfc_symtree *st;
7731 : 3184 : gfc_symbol *derived;
7732 : :
7733 : 3184 : gcc_assert (e->expr_type == EXPR_COMPCALL);
7734 : 3184 : genname = e->value.compcall.name;
7735 : 3184 : genproc = e->value.compcall.tbp;
7736 : :
7737 : 3184 : if (!genproc->is_generic)
7738 : : return true;
7739 : :
7740 : : /* Try the bindings on this type and in the inheritance hierarchy. */
7741 : 383 : for (; genproc; genproc = genproc->overridden)
7742 : : {
7743 : 381 : gfc_tbp_generic* g;
7744 : :
7745 : 381 : gcc_assert (genproc->is_generic);
7746 : 569 : for (g = genproc->u.generic; g; g = g->next)
7747 : : {
7748 : 559 : gfc_symbol* target;
7749 : 559 : gfc_actual_arglist* args;
7750 : 559 : bool matches;
7751 : :
7752 : 559 : gcc_assert (g->specific);
7753 : :
7754 : 559 : if (g->specific->error)
7755 : 0 : continue;
7756 : :
7757 : 559 : target = g->specific->u.specific->n.sym;
7758 : :
7759 : : /* Get the right arglist by handling PASS/NOPASS. */
7760 : 559 : args = gfc_copy_actual_arglist (e->value.compcall.actual);
7761 : 559 : if (!g->specific->nopass)
7762 : : {
7763 : 473 : gfc_expr* po;
7764 : 473 : po = extract_compcall_passed_object (e);
7765 : 473 : if (!po)
7766 : : {
7767 : 0 : gfc_free_actual_arglist (args);
7768 : 0 : return false;
7769 : : }
7770 : :
7771 : 473 : gcc_assert (g->specific->pass_arg_num > 0);
7772 : 473 : gcc_assert (!g->specific->error);
7773 : 473 : args = update_arglist_pass (args, po, g->specific->pass_arg_num,
7774 : : g->specific->pass_arg);
7775 : : }
7776 : 559 : resolve_actual_arglist (args, target->attr.proc,
7777 : 559 : is_external_proc (target)
7778 : 559 : && gfc_sym_get_dummy_args (target) == NULL);
7779 : :
7780 : : /* Check if this arglist matches the formal. */
7781 : 559 : matches = gfc_arglist_matches_symbol (&args, target);
7782 : :
7783 : : /* Clean up and break out of the loop if we've found it. */
7784 : 559 : gfc_free_actual_arglist (args);
7785 : 559 : if (matches)
7786 : : {
7787 : 371 : e->value.compcall.tbp = g->specific;
7788 : 371 : genname = g->specific_st->name;
7789 : : /* Pass along the name for CLASS methods, where the vtab
7790 : : procedure pointer component has to be referenced. */
7791 : 371 : if (name)
7792 : 159 : *name = genname;
7793 : 371 : goto success;
7794 : : }
7795 : : }
7796 : : }
7797 : :
7798 : : /* Nothing matching found! */
7799 : 2 : gfc_error ("Found no matching specific binding for the call to the GENERIC"
7800 : : " %qs at %L", genname, &e->where);
7801 : 2 : return false;
7802 : :
7803 : 371 : success:
7804 : : /* Make sure that we have the right specific instance for the name. */
7805 : 371 : derived = get_declared_from_expr (NULL, NULL, e, true);
7806 : :
7807 : 371 : st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
7808 : 371 : if (st)
7809 : 371 : e->value.compcall.tbp = st->n.tb;
7810 : :
7811 : : return true;
7812 : : }
7813 : :
7814 : :
7815 : : /* Resolve a call to a type-bound subroutine. */
7816 : :
7817 : : static bool
7818 : 1673 : resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
7819 : : {
7820 : 1673 : gfc_actual_arglist* newactual;
7821 : 1673 : gfc_symtree* target;
7822 : :
7823 : : /* Check that's really a SUBROUTINE. */
7824 : 1673 : if (!c->expr1->value.compcall.tbp->subroutine)
7825 : : {
7826 : 17 : if (!c->expr1->value.compcall.tbp->is_generic
7827 : 15 : && c->expr1->value.compcall.tbp->u.specific
7828 : 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym
7829 : 15 : && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
7830 : 12 : c->expr1->value.compcall.tbp->subroutine = 1;
7831 : : else
7832 : : {
7833 : 5 : gfc_error ("%qs at %L should be a SUBROUTINE",
7834 : : c->expr1->value.compcall.name, &c->loc);
7835 : 5 : return false;
7836 : : }
7837 : : }
7838 : :
7839 : 1668 : if (!check_typebound_baseobject (c->expr1))
7840 : : return false;
7841 : :
7842 : : /* Pass along the name for CLASS methods, where the vtab
7843 : : procedure pointer component has to be referenced. */
7844 : 1661 : if (name)
7845 : 471 : *name = c->expr1->value.compcall.name;
7846 : :
7847 : 1661 : if (!resolve_typebound_generic_call (c->expr1, name))
7848 : : return false;
7849 : :
7850 : : /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
7851 : 1660 : if (overridable)
7852 : 368 : *overridable = !c->expr1->value.compcall.tbp->non_overridable;
7853 : :
7854 : : /* Transform into an ordinary EXEC_CALL for now. */
7855 : :
7856 : 1660 : if (!resolve_typebound_static (c->expr1, &target, &newactual))
7857 : : return false;
7858 : :
7859 : 1658 : c->ext.actual = newactual;
7860 : 1658 : c->symtree = target;
7861 : 1658 : c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
7862 : :
7863 : 1658 : gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
7864 : :
7865 : 1658 : gfc_free_expr (c->expr1);
7866 : 1658 : c->expr1 = gfc_get_expr ();
7867 : 1658 : c->expr1->expr_type = EXPR_FUNCTION;
7868 : 1658 : c->expr1->symtree = target;
7869 : 1658 : c->expr1->where = c->loc;
7870 : :
7871 : 1658 : return resolve_call (c);
7872 : : }
7873 : :
7874 : :
7875 : : /* Resolve a component-call expression. */
7876 : : static bool
7877 : 1532 : resolve_compcall (gfc_expr* e, const char **name)
7878 : : {
7879 : 1532 : gfc_actual_arglist* newactual;
7880 : 1532 : gfc_symtree* target;
7881 : :
7882 : : /* Check that's really a FUNCTION. */
7883 : 1532 : if (!e->value.compcall.tbp->function)
7884 : : {
7885 : 7 : gfc_error ("%qs at %L should be a FUNCTION",
7886 : : e->value.compcall.name, &e->where);
7887 : 7 : return false;
7888 : : }
7889 : :
7890 : :
7891 : : /* These must not be assign-calls! */
7892 : 1525 : gcc_assert (!e->value.compcall.assign);
7893 : :
7894 : 1525 : if (!check_typebound_baseobject (e))
7895 : : return false;
7896 : :
7897 : : /* Pass along the name for CLASS methods, where the vtab
7898 : : procedure pointer component has to be referenced. */
7899 : 1523 : if (name)
7900 : 845 : *name = e->value.compcall.name;
7901 : :
7902 : 1523 : if (!resolve_typebound_generic_call (e, name))
7903 : : return false;
7904 : 1522 : gcc_assert (!e->value.compcall.tbp->is_generic);
7905 : :
7906 : : /* Take the rank from the function's symbol. */
7907 : 1522 : if (e->value.compcall.tbp->u.specific->n.sym->as)
7908 : : {
7909 : 143 : e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
7910 : 143 : e->corank = e->value.compcall.tbp->u.specific->n.sym->as->corank;
7911 : : }
7912 : :
7913 : : /* For now, we simply transform it into an EXPR_FUNCTION call with the same
7914 : : arglist to the TBP's binding target. */
7915 : :
7916 : 1522 : if (!resolve_typebound_static (e, &target, &newactual))
7917 : : return false;
7918 : :
7919 : 1522 : e->value.function.actual = newactual;
7920 : 1522 : e->value.function.name = NULL;
7921 : 1522 : e->value.function.esym = target->n.sym;
7922 : 1522 : e->value.function.isym = NULL;
7923 : 1522 : e->symtree = target;
7924 : 1522 : e->ts = target->n.sym->ts;
7925 : 1522 : e->expr_type = EXPR_FUNCTION;
7926 : :
7927 : : /* Resolution is not necessary if this is a class subroutine; this
7928 : : function only has to identify the specific proc. Resolution of
7929 : : the call will be done next in resolve_typebound_call. */
7930 : 1522 : return gfc_resolve_expr (e);
7931 : : }
7932 : :
7933 : :
7934 : : static bool resolve_fl_derived (gfc_symbol *sym);
7935 : :
7936 : :
7937 : : /* Resolve a typebound function, or 'method'. First separate all
7938 : : the non-CLASS references by calling resolve_compcall directly. */
7939 : :
7940 : : static bool
7941 : 1532 : resolve_typebound_function (gfc_expr* e)
7942 : : {
7943 : 1532 : gfc_symbol *declared;
7944 : 1532 : gfc_component *c;
7945 : 1532 : gfc_ref *new_ref;
7946 : 1532 : gfc_ref *class_ref;
7947 : 1532 : gfc_symtree *st;
7948 : 1532 : const char *name;
7949 : 1532 : gfc_typespec ts;
7950 : 1532 : gfc_expr *expr;
7951 : 1532 : bool overridable;
7952 : :
7953 : 1532 : st = e->symtree;
7954 : :
7955 : : /* Deal with typebound operators for CLASS objects. */
7956 : 1532 : expr = e->value.compcall.base_object;
7957 : 1532 : overridable = !e->value.compcall.tbp->non_overridable;
7958 : 1532 : if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
7959 : : {
7960 : : /* Since the typebound operators are generic, we have to ensure
7961 : : that any delays in resolution are corrected and that the vtab
7962 : : is present. */
7963 : 184 : ts = expr->ts;
7964 : 184 : declared = ts.u.derived;
7965 : 184 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
7966 : 184 : if (c->ts.u.derived == NULL)
7967 : 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
7968 : :
7969 : 184 : if (!resolve_compcall (e, &name))
7970 : : return false;
7971 : :
7972 : : /* Use the generic name if it is there. */
7973 : 184 : name = name ? name : e->value.function.esym->name;
7974 : 184 : e->symtree = expr->symtree;
7975 : 184 : e->ref = gfc_copy_ref (expr->ref);
7976 : 184 : get_declared_from_expr (&class_ref, NULL, e, false);
7977 : :
7978 : : /* Trim away the extraneous references that emerge from nested
7979 : : use of interface.cc (extend_expr). */
7980 : 184 : if (class_ref && class_ref->next)
7981 : : {
7982 : 0 : gfc_free_ref_list (class_ref->next);
7983 : 0 : class_ref->next = NULL;
7984 : : }
7985 : 184 : else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
7986 : : {
7987 : 0 : gfc_free_ref_list (e->ref);
7988 : 0 : e->ref = NULL;
7989 : : }
7990 : :
7991 : 184 : gfc_add_vptr_component (e);
7992 : 184 : gfc_add_component_ref (e, name);
7993 : 184 : e->value.function.esym = NULL;
7994 : 184 : if (expr->expr_type != EXPR_VARIABLE)
7995 : 80 : e->base_expr = expr;
7996 : 184 : return true;
7997 : : }
7998 : :
7999 : 1348 : if (st == NULL)
8000 : 147 : return resolve_compcall (e, NULL);
8001 : :
8002 : 1201 : if (!gfc_resolve_ref (e))
8003 : : return false;
8004 : :
8005 : : /* Get the CLASS declared type. */
8006 : 1201 : declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
8007 : :
8008 : 1201 : if (!resolve_fl_derived (declared))
8009 : : return false;
8010 : :
8011 : : /* Weed out cases of the ultimate component being a derived type. */
8012 : 1201 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
8013 : 1117 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
8014 : : {
8015 : 538 : gfc_free_ref_list (new_ref);
8016 : 538 : return resolve_compcall (e, NULL);
8017 : : }
8018 : :
8019 : 663 : c = gfc_find_component (declared, "_data", true, true, NULL);
8020 : :
8021 : : /* Treat the call as if it is a typebound procedure, in order to roll
8022 : : out the correct name for the specific function. */
8023 : 663 : if (!resolve_compcall (e, &name))
8024 : : {
8025 : 3 : gfc_free_ref_list (new_ref);
8026 : 3 : return false;
8027 : : }
8028 : 660 : ts = e->ts;
8029 : :
8030 : 660 : if (overridable)
8031 : : {
8032 : : /* Convert the expression to a procedure pointer component call. */
8033 : 658 : e->value.function.esym = NULL;
8034 : 658 : e->symtree = st;
8035 : :
8036 : 658 : if (new_ref)
8037 : 124 : e->ref = new_ref;
8038 : :
8039 : : /* '_vptr' points to the vtab, which contains the procedure pointers. */
8040 : 658 : gfc_add_vptr_component (e);
8041 : 658 : gfc_add_component_ref (e, name);
8042 : :
8043 : : /* Recover the typespec for the expression. This is really only
8044 : : necessary for generic procedures, where the additional call
8045 : : to gfc_add_component_ref seems to throw the collection of the
8046 : : correct typespec. */
8047 : 658 : e->ts = ts;
8048 : : }
8049 : 2 : else if (new_ref)
8050 : 0 : gfc_free_ref_list (new_ref);
8051 : :
8052 : : return true;
8053 : : }
8054 : :
8055 : : /* Resolve a typebound subroutine, or 'method'. First separate all
8056 : : the non-CLASS references by calling resolve_typebound_call
8057 : : directly. */
8058 : :
8059 : : static bool
8060 : 1673 : resolve_typebound_subroutine (gfc_code *code)
8061 : : {
8062 : 1673 : gfc_symbol *declared;
8063 : 1673 : gfc_component *c;
8064 : 1673 : gfc_ref *new_ref;
8065 : 1673 : gfc_ref *class_ref;
8066 : 1673 : gfc_symtree *st;
8067 : 1673 : const char *name;
8068 : 1673 : gfc_typespec ts;
8069 : 1673 : gfc_expr *expr;
8070 : 1673 : bool overridable;
8071 : :
8072 : 1673 : st = code->expr1->symtree;
8073 : :
8074 : : /* Deal with typebound operators for CLASS objects. */
8075 : 1673 : expr = code->expr1->value.compcall.base_object;
8076 : 1673 : overridable = !code->expr1->value.compcall.tbp->non_overridable;
8077 : 1673 : if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
8078 : : {
8079 : : /* If the base_object is not a variable, the corresponding actual
8080 : : argument expression must be stored in e->base_expression so
8081 : : that the corresponding tree temporary can be used as the base
8082 : : object in gfc_conv_procedure_call. */
8083 : 103 : if (expr->expr_type != EXPR_VARIABLE)
8084 : : {
8085 : : gfc_actual_arglist *args;
8086 : :
8087 : : args= code->expr1->value.function.actual;
8088 : : for (; args; args = args->next)
8089 : : if (expr == args->expr)
8090 : : expr = args->expr;
8091 : : }
8092 : :
8093 : : /* Since the typebound operators are generic, we have to ensure
8094 : : that any delays in resolution are corrected and that the vtab
8095 : : is present. */
8096 : 103 : declared = expr->ts.u.derived;
8097 : 103 : c = gfc_find_component (declared, "_vptr", true, true, NULL);
8098 : 103 : if (c->ts.u.derived == NULL)
8099 : 0 : c->ts.u.derived = gfc_find_derived_vtab (declared);
8100 : :
8101 : 103 : if (!resolve_typebound_call (code, &name, NULL))
8102 : : return false;
8103 : :
8104 : : /* Use the generic name if it is there. */
8105 : 103 : name = name ? name : code->expr1->value.function.esym->name;
8106 : 103 : code->expr1->symtree = expr->symtree;
8107 : 103 : code->expr1->ref = gfc_copy_ref (expr->ref);
8108 : :
8109 : : /* Trim away the extraneous references that emerge from nested
8110 : : use of interface.cc (extend_expr). */
8111 : 103 : get_declared_from_expr (&class_ref, NULL, code->expr1, false);
8112 : 103 : if (class_ref && class_ref->next)
8113 : : {
8114 : 0 : gfc_free_ref_list (class_ref->next);
8115 : 0 : class_ref->next = NULL;
8116 : : }
8117 : 103 : else if (code->expr1->ref && !class_ref)
8118 : : {
8119 : 12 : gfc_free_ref_list (code->expr1->ref);
8120 : 12 : code->expr1->ref = NULL;
8121 : : }
8122 : :
8123 : : /* Now use the procedure in the vtable. */
8124 : 103 : gfc_add_vptr_component (code->expr1);
8125 : 103 : gfc_add_component_ref (code->expr1, name);
8126 : 103 : code->expr1->value.function.esym = NULL;
8127 : 103 : if (expr->expr_type != EXPR_VARIABLE)
8128 : 0 : code->expr1->base_expr = expr;
8129 : 103 : return true;
8130 : : }
8131 : :
8132 : 1570 : if (st == NULL)
8133 : 313 : return resolve_typebound_call (code, NULL, NULL);
8134 : :
8135 : 1257 : if (!gfc_resolve_ref (code->expr1))
8136 : : return false;
8137 : :
8138 : : /* Get the CLASS declared type. */
8139 : 1257 : get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
8140 : :
8141 : : /* Weed out cases of the ultimate component being a derived type. */
8142 : 1257 : if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
8143 : 1194 : || (!class_ref && st->n.sym->ts.type != BT_CLASS))
8144 : : {
8145 : 884 : gfc_free_ref_list (new_ref);
8146 : 884 : return resolve_typebound_call (code, NULL, NULL);
8147 : : }
8148 : :
8149 : 373 : if (!resolve_typebound_call (code, &name, &overridable))
8150 : : {
8151 : 5 : gfc_free_ref_list (new_ref);
8152 : 5 : return false;
8153 : : }
8154 : 368 : ts = code->expr1->ts;
8155 : :
8156 : 368 : if (overridable)
8157 : : {
8158 : : /* Convert the expression to a procedure pointer component call. */
8159 : 366 : code->expr1->value.function.esym = NULL;
8160 : 366 : code->expr1->symtree = st;
8161 : :
8162 : 366 : if (new_ref)
8163 : 90 : code->expr1->ref = new_ref;
8164 : :
8165 : : /* '_vptr' points to the vtab, which contains the procedure pointers. */
8166 : 366 : gfc_add_vptr_component (code->expr1);
8167 : 366 : gfc_add_component_ref (code->expr1, name);
8168 : :
8169 : : /* Recover the typespec for the expression. This is really only
8170 : : necessary for generic procedures, where the additional call
8171 : : to gfc_add_component_ref seems to throw the collection of the
8172 : : correct typespec. */
8173 : 366 : code->expr1->ts = ts;
8174 : : }
8175 : 2 : else if (new_ref)
8176 : 0 : gfc_free_ref_list (new_ref);
8177 : :
8178 : : return true;
8179 : : }
8180 : :
8181 : :
8182 : : /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
8183 : :
8184 : : static bool
8185 : 123 : resolve_ppc_call (gfc_code* c)
8186 : : {
8187 : 123 : gfc_component *comp;
8188 : :
8189 : 123 : comp = gfc_get_proc_ptr_comp (c->expr1);
8190 : 123 : gcc_assert (comp != NULL);
8191 : :
8192 : 123 : c->resolved_sym = c->expr1->symtree->n.sym;
8193 : 123 : c->expr1->expr_type = EXPR_VARIABLE;
8194 : :
8195 : 123 : if (!comp->attr.subroutine)
8196 : 1 : gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
8197 : :
8198 : 123 : if (!gfc_resolve_ref (c->expr1))
8199 : : return false;
8200 : :
8201 : 123 : if (!update_ppc_arglist (c->expr1))
8202 : : return false;
8203 : :
8204 : 122 : c->ext.actual = c->expr1->value.compcall.actual;
8205 : :
8206 : 122 : if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
8207 : 122 : !(comp->ts.interface
8208 : 93 : && comp->ts.interface->formal)))
8209 : : return false;
8210 : :
8211 : 122 : if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
8212 : : return false;
8213 : :
8214 : 121 : gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
8215 : :
8216 : 121 : return true;
8217 : : }
8218 : :
8219 : :
8220 : : /* Resolve a Function Call to a Procedure Pointer Component (Function). */
8221 : :
8222 : : static bool
8223 : 276 : resolve_expr_ppc (gfc_expr* e)
8224 : : {
8225 : 276 : gfc_component *comp;
8226 : :
8227 : 276 : comp = gfc_get_proc_ptr_comp (e);
8228 : 276 : gcc_assert (comp != NULL);
8229 : :
8230 : : /* Convert to EXPR_FUNCTION. */
8231 : 276 : e->expr_type = EXPR_FUNCTION;
8232 : 276 : e->value.function.isym = NULL;
8233 : 276 : e->value.function.actual = e->value.compcall.actual;
8234 : 276 : e->ts = comp->ts;
8235 : 276 : if (comp->as != NULL)
8236 : : {
8237 : 28 : e->rank = comp->as->rank;
8238 : 28 : e->corank = comp->as->corank;
8239 : : }
8240 : :
8241 : 276 : if (!comp->attr.function)
8242 : 3 : gfc_add_function (&comp->attr, comp->name, &e->where);
8243 : :
8244 : 276 : if (!gfc_resolve_ref (e))
8245 : : return false;
8246 : :
8247 : 276 : if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
8248 : 276 : !(comp->ts.interface
8249 : 275 : && comp->ts.interface->formal)))
8250 : : return false;
8251 : :
8252 : 276 : if (!update_ppc_arglist (e))
8253 : : return false;
8254 : :
8255 : 274 : if (!check_pure_function(e))
8256 : : return false;
8257 : :
8258 : 273 : gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
8259 : :
8260 : 273 : return true;
8261 : : }
8262 : :
8263 : :
8264 : : static bool
8265 : 11317 : gfc_is_expandable_expr (gfc_expr *e)
8266 : : {
8267 : 11317 : gfc_constructor *con;
8268 : :
8269 : 11317 : if (e->expr_type == EXPR_ARRAY)
8270 : : {
8271 : : /* Traverse the constructor looking for variables that are flavor
8272 : : parameter. Parameters must be expanded since they are fully used at
8273 : : compile time. */
8274 : 11317 : con = gfc_constructor_first (e->value.constructor);
8275 : 30267 : for (; con; con = gfc_constructor_next (con))
8276 : : {
8277 : 12991 : if (con->expr->expr_type == EXPR_VARIABLE
8278 : 4700 : && con->expr->symtree
8279 : 4700 : && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
8280 : 4645 : || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
8281 : : return true;
8282 : 8291 : if (con->expr->expr_type == EXPR_ARRAY
8283 : 8291 : && gfc_is_expandable_expr (con->expr))
8284 : : return true;
8285 : : }
8286 : : }
8287 : :
8288 : : return false;
8289 : : }
8290 : :
8291 : :
8292 : : /* Sometimes variables in specification expressions of the result
8293 : : of module procedures in submodules wind up not being the 'real'
8294 : : dummy. Find this, if possible, in the namespace of the first
8295 : : formal argument. */
8296 : :
8297 : : static void
8298 : 3249 : fixup_unique_dummy (gfc_expr *e)
8299 : : {
8300 : 3249 : gfc_symtree *st = NULL;
8301 : 3249 : gfc_symbol *s = NULL;
8302 : :
8303 : 3249 : if (e->symtree->n.sym->ns->proc_name
8304 : 3249 : && e->symtree->n.sym->ns->proc_name->formal)
8305 : 3249 : s = e->symtree->n.sym->ns->proc_name->formal->sym;
8306 : :
8307 : 3249 : if (s != NULL)
8308 : 3249 : st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
8309 : :
8310 : 3249 : if (st != NULL
8311 : 14 : && st->n.sym != NULL
8312 : 14 : && st->n.sym->attr.dummy)
8313 : 14 : e->symtree = st;
8314 : 3249 : }
8315 : :
8316 : : /* Resolve an expression. That is, make sure that types of operands agree
8317 : : with their operators, intrinsic operators are converted to function calls
8318 : : for overloaded types and unresolved function references are resolved. */
8319 : :
8320 : : bool
8321 : 6295400 : gfc_resolve_expr (gfc_expr *e)
8322 : : {
8323 : 6295400 : bool t;
8324 : 6295400 : bool inquiry_save, actual_arg_save, first_actual_arg_save;
8325 : :
8326 : 6295400 : if (e == NULL || e->do_not_resolve_again)
8327 : : return true;
8328 : :
8329 : : /* inquiry_argument only applies to variables. */
8330 : 4549017 : inquiry_save = inquiry_argument;
8331 : 4549017 : actual_arg_save = actual_arg;
8332 : 4549017 : first_actual_arg_save = first_actual_arg;
8333 : :
8334 : 4549017 : if (e->expr_type != EXPR_VARIABLE)
8335 : : {
8336 : 3524576 : inquiry_argument = false;
8337 : 3524576 : actual_arg = false;
8338 : 3524576 : first_actual_arg = false;
8339 : : }
8340 : 1024441 : else if (e->symtree != NULL
8341 : 1024024 : && *e->symtree->name == '@'
8342 : 5911 : && e->symtree->n.sym->attr.dummy)
8343 : : {
8344 : : /* Deal with submodule specification expressions that are not
8345 : : found to be referenced in module.cc(read_cleanup). */
8346 : 3249 : fixup_unique_dummy (e);
8347 : : }
8348 : :
8349 : 4549017 : switch (e->expr_type)
8350 : : {
8351 : 388672 : case EXPR_OP:
8352 : 388672 : t = resolve_operator (e);
8353 : 388672 : break;
8354 : :
8355 : 1349277 : case EXPR_FUNCTION:
8356 : 1349277 : case EXPR_VARIABLE:
8357 : :
8358 : 1349277 : if (check_host_association (e))
8359 : 324872 : t = resolve_function (e);
8360 : : else
8361 : 1024405 : t = resolve_variable (e);
8362 : :
8363 : 1349277 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
8364 : 6790 : && e->ref->type != REF_SUBSTRING)
8365 : 2081 : gfc_resolve_substring_charlen (e);
8366 : :
8367 : : break;
8368 : :
8369 : 1532 : case EXPR_COMPCALL:
8370 : 1532 : t = resolve_typebound_function (e);
8371 : 1532 : break;
8372 : :
8373 : 532 : case EXPR_SUBSTRING:
8374 : 532 : t = gfc_resolve_ref (e);
8375 : 532 : break;
8376 : :
8377 : : case EXPR_CONSTANT:
8378 : : case EXPR_NULL:
8379 : : t = true;
8380 : : break;
8381 : :
8382 : 276 : case EXPR_PPC:
8383 : 276 : t = resolve_expr_ppc (e);
8384 : 276 : break;
8385 : :
8386 : 66059 : case EXPR_ARRAY:
8387 : 66059 : t = false;
8388 : 66059 : if (!gfc_resolve_ref (e))
8389 : : break;
8390 : :
8391 : 66059 : t = gfc_resolve_array_constructor (e);
8392 : : /* Also try to expand a constructor. */
8393 : 66059 : if (t)
8394 : : {
8395 : 65965 : gfc_expression_rank (e);
8396 : 65965 : if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
8397 : 61077 : gfc_expand_constructor (e, false);
8398 : : }
8399 : :
8400 : : /* This provides the opportunity for the length of constructors with
8401 : : character valued function elements to propagate the string length
8402 : : to the expression. */
8403 : 65965 : if (t && e->ts.type == BT_CHARACTER)
8404 : : {
8405 : : /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
8406 : : here rather then add a duplicate test for it above. */
8407 : 9860 : gfc_expand_constructor (e, false);
8408 : 9860 : t = gfc_resolve_character_array_constructor (e);
8409 : : }
8410 : :
8411 : : break;
8412 : :
8413 : 15149 : case EXPR_STRUCTURE:
8414 : 15149 : t = gfc_resolve_ref (e);
8415 : 15149 : if (!t)
8416 : : break;
8417 : :
8418 : 15149 : t = resolve_structure_cons (e, 0);
8419 : 15149 : if (!t)
8420 : : break;
8421 : :
8422 : 15137 : t = gfc_simplify_expr (e, 0);
8423 : 15137 : break;
8424 : :
8425 : 0 : default:
8426 : 0 : gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
8427 : : }
8428 : :
8429 : 4549017 : if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
8430 : 175592 : fixup_charlen (e);
8431 : :
8432 : 4549017 : inquiry_argument = inquiry_save;
8433 : 4549017 : actual_arg = actual_arg_save;
8434 : 4549017 : first_actual_arg = first_actual_arg_save;
8435 : :
8436 : : /* For some reason, resolving these expressions a second time mangles
8437 : : the typespec of the expression itself. */
8438 : 4549017 : if (t && e->expr_type == EXPR_VARIABLE
8439 : 1020801 : && e->symtree->n.sym->attr.select_rank_temporary
8440 : 3422 : && UNLIMITED_POLY (e->symtree->n.sym))
8441 : 83 : e->do_not_resolve_again = 1;
8442 : :
8443 : : return t;
8444 : : }
8445 : :
8446 : :
8447 : : /* Resolve an expression from an iterator. They must be scalar and have
8448 : : INTEGER or (optionally) REAL type. */
8449 : :
8450 : : static bool
8451 : 144381 : gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
8452 : : const char *name_msgid)
8453 : : {
8454 : 144381 : if (!gfc_resolve_expr (expr))
8455 : : return false;
8456 : :
8457 : 144376 : if (expr->rank != 0)
8458 : : {
8459 : 0 : gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
8460 : 0 : return false;
8461 : : }
8462 : :
8463 : 144376 : if (expr->ts.type != BT_INTEGER)
8464 : : {
8465 : 274 : if (expr->ts.type == BT_REAL)
8466 : : {
8467 : 274 : if (real_ok)
8468 : 271 : return gfc_notify_std (GFC_STD_F95_DEL,
8469 : : "%s at %L must be integer",
8470 : 271 : _(name_msgid), &expr->where);
8471 : : else
8472 : : {
8473 : 3 : gfc_error ("%s at %L must be INTEGER", _(name_msgid),
8474 : : &expr->where);
8475 : 3 : return false;
8476 : : }
8477 : : }
8478 : : else
8479 : : {
8480 : 0 : gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
8481 : 0 : return false;
8482 : : }
8483 : : }
8484 : : return true;
8485 : : }
8486 : :
8487 : :
8488 : : /* Resolve the expressions in an iterator structure. If REAL_OK is
8489 : : false allow only INTEGER type iterators, otherwise allow REAL types.
8490 : : Set own_scope to true for ac-implied-do and data-implied-do as those
8491 : : have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
8492 : :
8493 : : bool
8494 : 36104 : gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
8495 : : {
8496 : 36104 : if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
8497 : : return false;
8498 : :
8499 : 36100 : if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
8500 : 36100 : _("iterator variable")))
8501 : : return false;
8502 : :
8503 : 36094 : if (!gfc_resolve_iterator_expr (iter->start, real_ok,
8504 : : "Start expression in DO loop"))
8505 : : return false;
8506 : :
8507 : 36093 : if (!gfc_resolve_iterator_expr (iter->end, real_ok,
8508 : : "End expression in DO loop"))
8509 : : return false;
8510 : :
8511 : 36090 : if (!gfc_resolve_iterator_expr (iter->step, real_ok,
8512 : : "Step expression in DO loop"))
8513 : : return false;
8514 : :
8515 : : /* Convert start, end, and step to the same type as var. */
8516 : 36089 : if (iter->start->ts.kind != iter->var->ts.kind
8517 : 36089 : || iter->start->ts.type != iter->var->ts.type)
8518 : 315 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8519 : :
8520 : 36089 : if (iter->end->ts.kind != iter->var->ts.kind
8521 : 36089 : || iter->end->ts.type != iter->var->ts.type)
8522 : 283 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8523 : :
8524 : 36089 : if (iter->step->ts.kind != iter->var->ts.kind
8525 : 36089 : || iter->step->ts.type != iter->var->ts.type)
8526 : 280 : gfc_convert_type (iter->step, &iter->var->ts, 1);
8527 : :
8528 : 36089 : if (iter->step->expr_type == EXPR_CONSTANT)
8529 : : {
8530 : 34939 : if ((iter->step->ts.type == BT_INTEGER
8531 : 34856 : && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
8532 : 69793 : || (iter->step->ts.type == BT_REAL
8533 : 83 : && mpfr_sgn (iter->step->value.real) == 0))
8534 : : {
8535 : 3 : gfc_error ("Step expression in DO loop at %L cannot be zero",
8536 : 3 : &iter->step->where);
8537 : 3 : return false;
8538 : : }
8539 : : }
8540 : :
8541 : 36086 : if (iter->start->expr_type == EXPR_CONSTANT
8542 : 33020 : && iter->end->expr_type == EXPR_CONSTANT
8543 : 25694 : && iter->step->expr_type == EXPR_CONSTANT)
8544 : : {
8545 : 25427 : int sgn, cmp;
8546 : 25427 : if (iter->start->ts.type == BT_INTEGER)
8547 : : {
8548 : 25373 : sgn = mpz_cmp_ui (iter->step->value.integer, 0);
8549 : 25373 : cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
8550 : : }
8551 : : else
8552 : : {
8553 : 54 : sgn = mpfr_sgn (iter->step->value.real);
8554 : 54 : cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
8555 : : }
8556 : 25427 : if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
8557 : 146 : gfc_warning (OPT_Wzerotrip,
8558 : : "DO loop at %L will be executed zero times",
8559 : 146 : &iter->step->where);
8560 : : }
8561 : :
8562 : 36086 : if (iter->end->expr_type == EXPR_CONSTANT
8563 : 26057 : && iter->end->ts.type == BT_INTEGER
8564 : 26003 : && iter->step->expr_type == EXPR_CONSTANT
8565 : 25695 : && iter->step->ts.type == BT_INTEGER
8566 : 25695 : && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
8567 : 25331 : || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
8568 : : {
8569 : 24563 : bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
8570 : 24563 : int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
8571 : :
8572 : 24563 : if (is_step_positive
8573 : 24199 : && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
8574 : 7 : gfc_warning (OPT_Wundefined_do_loop,
8575 : : "DO loop at %L is undefined as it overflows",
8576 : 7 : &iter->step->where);
8577 : : else if (!is_step_positive
8578 : 364 : && mpz_cmp (iter->end->value.integer,
8579 : 364 : gfc_integer_kinds[k].min_int) == 0)
8580 : 7 : gfc_warning (OPT_Wundefined_do_loop,
8581 : : "DO loop at %L is undefined as it underflows",
8582 : 7 : &iter->step->where);
8583 : : }
8584 : :
8585 : : return true;
8586 : : }
8587 : :
8588 : :
8589 : : /* Traversal function for find_forall_index. f == 2 signals that
8590 : : that variable itself is not to be checked - only the references. */
8591 : :
8592 : : static bool
8593 : 41691 : forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
8594 : : {
8595 : 41691 : if (expr->expr_type != EXPR_VARIABLE)
8596 : : return false;
8597 : :
8598 : : /* A scalar assignment */
8599 : 17765 : if (!expr->ref || *f == 1)
8600 : : {
8601 : 12026 : if (expr->symtree->n.sym == sym)
8602 : : return true;
8603 : : else
8604 : : return false;
8605 : : }
8606 : :
8607 : 5739 : if (*f == 2)
8608 : 1745 : *f = 1;
8609 : : return false;
8610 : : }
8611 : :
8612 : :
8613 : : /* Check whether the FORALL index appears in the expression or not.
8614 : : Returns true if SYM is found in EXPR. */
8615 : :
8616 : : bool
8617 : 26279 : find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
8618 : : {
8619 : 26279 : if (gfc_traverse_expr (expr, sym, forall_index, f))
8620 : : return true;
8621 : : else
8622 : : return false;
8623 : : }
8624 : :
8625 : :
8626 : : /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
8627 : : to be a scalar INTEGER variable. The subscripts and stride are scalar
8628 : : INTEGERs, and if stride is a constant it must be nonzero.
8629 : : Furthermore "A subscript or stride in a forall-triplet-spec shall
8630 : : not contain a reference to any index-name in the
8631 : : forall-triplet-spec-list in which it appears." (7.5.4.1) */
8632 : :
8633 : : static void
8634 : 2074 : resolve_forall_iterators (gfc_forall_iterator *it)
8635 : : {
8636 : 2074 : gfc_forall_iterator *iter, *iter2;
8637 : :
8638 : 6077 : for (iter = it; iter; iter = iter->next)
8639 : : {
8640 : 4003 : if (gfc_resolve_expr (iter->var)
8641 : 4003 : && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
8642 : 0 : gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
8643 : : &iter->var->where);
8644 : :
8645 : 4003 : if (gfc_resolve_expr (iter->start)
8646 : 4003 : && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
8647 : 0 : gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
8648 : : &iter->start->where);
8649 : 4003 : if (iter->var->ts.kind != iter->start->ts.kind)
8650 : 1 : gfc_convert_type (iter->start, &iter->var->ts, 1);
8651 : :
8652 : 4003 : if (gfc_resolve_expr (iter->end)
8653 : 4003 : && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
8654 : 0 : gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
8655 : : &iter->end->where);
8656 : 4003 : if (iter->var->ts.kind != iter->end->ts.kind)
8657 : 2 : gfc_convert_type (iter->end, &iter->var->ts, 1);
8658 : :
8659 : 4003 : if (gfc_resolve_expr (iter->stride))
8660 : : {
8661 : 4003 : if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
8662 : 0 : gfc_error ("FORALL stride expression at %L must be a scalar %s",
8663 : : &iter->stride->where, "INTEGER");
8664 : :
8665 : 4003 : if (iter->stride->expr_type == EXPR_CONSTANT
8666 : 4000 : && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
8667 : 1 : gfc_error ("FORALL stride expression at %L cannot be zero",
8668 : : &iter->stride->where);
8669 : : }
8670 : 4003 : if (iter->var->ts.kind != iter->stride->ts.kind)
8671 : 1 : gfc_convert_type (iter->stride, &iter->var->ts, 1);
8672 : : }
8673 : :
8674 : 6077 : for (iter = it; iter; iter = iter->next)
8675 : 10866 : for (iter2 = iter; iter2; iter2 = iter2->next)
8676 : : {
8677 : 6863 : if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
8678 : 6861 : || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
8679 : 13722 : || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
8680 : 6 : gfc_error ("FORALL index %qs may not appear in triplet "
8681 : 6 : "specification at %L", iter->var->symtree->name,
8682 : 6 : &iter2->start->where);
8683 : : }
8684 : 2074 : }
8685 : :
8686 : :
8687 : : /* Given a pointer to a symbol that is a derived type, see if it's
8688 : : inaccessible, i.e. if it's defined in another module and the components are
8689 : : PRIVATE. The search is recursive if necessary. Returns zero if no
8690 : : inaccessible components are found, nonzero otherwise. */
8691 : :
8692 : : static bool
8693 : 1311 : derived_inaccessible (gfc_symbol *sym)
8694 : : {
8695 : 1311 : gfc_component *c;
8696 : :
8697 : 1311 : if (sym->attr.use_assoc && sym->attr.private_comp)
8698 : : return 1;
8699 : :
8700 : 3895 : for (c = sym->components; c; c = c->next)
8701 : : {
8702 : : /* Prevent an infinite loop through this function. */
8703 : 2597 : if (c->ts.type == BT_DERIVED
8704 : 282 : && (c->attr.pointer || c->attr.allocatable)
8705 : 72 : && sym == c->ts.u.derived)
8706 : 72 : continue;
8707 : :
8708 : 2525 : if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
8709 : : return 1;
8710 : : }
8711 : :
8712 : : return 0;
8713 : : }
8714 : :
8715 : :
8716 : : /* Resolve the argument of a deallocate expression. The expression must be
8717 : : a pointer or a full array. */
8718 : :
8719 : : static bool
8720 : 7599 : resolve_deallocate_expr (gfc_expr *e)
8721 : : {
8722 : 7599 : symbol_attribute attr;
8723 : 7599 : int allocatable, pointer;
8724 : 7599 : gfc_ref *ref;
8725 : 7599 : gfc_symbol *sym;
8726 : 7599 : gfc_component *c;
8727 : 7599 : bool unlimited;
8728 : :
8729 : 7599 : if (!gfc_resolve_expr (e))
8730 : : return false;
8731 : :
8732 : 7599 : if (e->expr_type != EXPR_VARIABLE)
8733 : 0 : goto bad;
8734 : :
8735 : 7599 : sym = e->symtree->n.sym;
8736 : 7599 : unlimited = UNLIMITED_POLY(sym);
8737 : :
8738 : 7599 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
8739 : : {
8740 : 1486 : allocatable = CLASS_DATA (sym)->attr.allocatable;
8741 : 1486 : pointer = CLASS_DATA (sym)->attr.class_pointer;
8742 : : }
8743 : : else
8744 : : {
8745 : 6113 : allocatable = sym->attr.allocatable;
8746 : 6113 : pointer = sym->attr.pointer;
8747 : : }
8748 : 14941 : for (ref = e->ref; ref; ref = ref->next)
8749 : : {
8750 : 7342 : switch (ref->type)
8751 : : {
8752 : 5630 : case REF_ARRAY:
8753 : 5630 : if (ref->u.ar.type != AR_FULL
8754 : 5818 : && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
8755 : 188 : && ref->u.ar.codimen && gfc_ref_this_image (ref)))
8756 : : allocatable = 0;
8757 : : break;
8758 : :
8759 : 1712 : case REF_COMPONENT:
8760 : 1712 : c = ref->u.c.component;
8761 : 1712 : if (c->ts.type == BT_CLASS)
8762 : : {
8763 : 272 : allocatable = CLASS_DATA (c)->attr.allocatable;
8764 : 272 : pointer = CLASS_DATA (c)->attr.class_pointer;
8765 : : }
8766 : : else
8767 : : {
8768 : 1440 : allocatable = c->attr.allocatable;
8769 : 1440 : pointer = c->attr.pointer;
8770 : : }
8771 : : break;
8772 : :
8773 : : case REF_SUBSTRING:
8774 : : case REF_INQUIRY:
8775 : 361 : allocatable = 0;
8776 : : break;
8777 : : }
8778 : : }
8779 : :
8780 : 7599 : attr = gfc_expr_attr (e);
8781 : :
8782 : 7599 : if (allocatable == 0 && attr.pointer == 0 && !unlimited)
8783 : : {
8784 : 3 : bad:
8785 : 3 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
8786 : : &e->where);
8787 : 3 : return false;
8788 : : }
8789 : :
8790 : : /* F2008, C644. */
8791 : 7596 : if (gfc_is_coindexed (e))
8792 : : {
8793 : 1 : gfc_error ("Coindexed allocatable object at %L", &e->where);
8794 : 1 : return false;
8795 : : }
8796 : :
8797 : 7595 : if (pointer
8798 : 9835 : && !gfc_check_vardef_context (e, true, true, false,
8799 : 2240 : _("DEALLOCATE object")))
8800 : : return false;
8801 : 7593 : if (!gfc_check_vardef_context (e, false, true, false,
8802 : 7593 : _("DEALLOCATE object")))
8803 : : return false;
8804 : :
8805 : : return true;
8806 : : }
8807 : :
8808 : :
8809 : : /* Returns true if the expression e contains a reference to the symbol sym. */
8810 : : static bool
8811 : 46537 : sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
8812 : : {
8813 : 46537 : if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
8814 : 2087 : return true;
8815 : :
8816 : : return false;
8817 : : }
8818 : :
8819 : : bool
8820 : 40184 : gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
8821 : : {
8822 : 40184 : return gfc_traverse_expr (e, sym, sym_in_expr, 0);
8823 : : }
8824 : :
8825 : :
8826 : : /* Given the expression node e for an allocatable/pointer of derived type to be
8827 : : allocated, get the expression node to be initialized afterwards (needed for
8828 : : derived types with default initializers, and derived types with allocatable
8829 : : components that need nullification.) */
8830 : :
8831 : : gfc_expr *
8832 : 5272 : gfc_expr_to_initialize (gfc_expr *e)
8833 : : {
8834 : 5272 : gfc_expr *result;
8835 : 5272 : gfc_ref *ref;
8836 : 5272 : int i;
8837 : :
8838 : 5272 : result = gfc_copy_expr (e);
8839 : :
8840 : : /* Change the last array reference from AR_ELEMENT to AR_FULL. */
8841 : 10443 : for (ref = result->ref; ref; ref = ref->next)
8842 : 8179 : if (ref->type == REF_ARRAY && ref->next == NULL)
8843 : : {
8844 : 3008 : if (ref->u.ar.dimen == 0
8845 : 64 : && ref->u.ar.as && ref->u.ar.as->corank)
8846 : : return result;
8847 : :
8848 : 2944 : ref->u.ar.type = AR_FULL;
8849 : :
8850 : 6668 : for (i = 0; i < ref->u.ar.dimen; i++)
8851 : 3724 : ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
8852 : :
8853 : : break;
8854 : : }
8855 : :
8856 : 5208 : gfc_free_shape (&result->shape, result->rank);
8857 : :
8858 : : /* Recalculate rank, shape, etc. */
8859 : 5208 : gfc_resolve_expr (result);
8860 : 5208 : return result;
8861 : : }
8862 : :
8863 : :
8864 : : /* If the last ref of an expression is an array ref, return a copy of the
8865 : : expression with that one removed. Otherwise, a copy of the original
8866 : : expression. This is used for allocate-expressions and pointer assignment
8867 : : LHS, where there may be an array specification that needs to be stripped
8868 : : off when using gfc_check_vardef_context. */
8869 : :
8870 : : static gfc_expr*
8871 : 26108 : remove_last_array_ref (gfc_expr* e)
8872 : : {
8873 : 26108 : gfc_expr* e2;
8874 : 26108 : gfc_ref** r;
8875 : :
8876 : 26108 : e2 = gfc_copy_expr (e);
8877 : 32790 : for (r = &e2->ref; *r; r = &(*r)->next)
8878 : 21906 : if ((*r)->type == REF_ARRAY && !(*r)->next)
8879 : : {
8880 : 15224 : gfc_free_ref_list (*r);
8881 : 15224 : *r = NULL;
8882 : 15224 : break;
8883 : : }
8884 : :
8885 : 26108 : return e2;
8886 : : }
8887 : :
8888 : :
8889 : : /* Used in resolve_allocate_expr to check that a allocation-object and
8890 : : a source-expr are conformable. This does not catch all possible
8891 : : cases; in particular a runtime checking is needed. */
8892 : :
8893 : : static bool
8894 : 1789 : conformable_arrays (gfc_expr *e1, gfc_expr *e2)
8895 : : {
8896 : 1789 : gfc_ref *tail;
8897 : 2470 : for (tail = e2->ref; tail && tail->next; tail = tail->next);
8898 : :
8899 : : /* First compare rank. */
8900 : 1789 : if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
8901 : 2 : || (!tail && e1->rank != e2->rank))
8902 : : {
8903 : 4 : gfc_error ("Source-expr at %L must be scalar or have the "
8904 : : "same rank as the allocate-object at %L",
8905 : : &e1->where, &e2->where);
8906 : 4 : return false;
8907 : : }
8908 : :
8909 : 1785 : if (e1->shape)
8910 : : {
8911 : 1290 : int i;
8912 : 1290 : mpz_t s;
8913 : :
8914 : 1290 : mpz_init (s);
8915 : :
8916 : 2985 : for (i = 0; i < e1->rank; i++)
8917 : : {
8918 : 1296 : if (tail->u.ar.start[i] == NULL)
8919 : : break;
8920 : :
8921 : 405 : if (tail->u.ar.end[i])
8922 : : {
8923 : 54 : mpz_set (s, tail->u.ar.end[i]->value.integer);
8924 : 54 : mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
8925 : 54 : mpz_add_ui (s, s, 1);
8926 : : }
8927 : : else
8928 : : {
8929 : 351 : mpz_set (s, tail->u.ar.start[i]->value.integer);
8930 : : }
8931 : :
8932 : 405 : if (mpz_cmp (e1->shape[i], s) != 0)
8933 : : {
8934 : 0 : gfc_error ("Source-expr at %L and allocate-object at %L must "
8935 : : "have the same shape", &e1->where, &e2->where);
8936 : 0 : mpz_clear (s);
8937 : 0 : return false;
8938 : : }
8939 : : }
8940 : :
8941 : 1290 : mpz_clear (s);
8942 : : }
8943 : :
8944 : : return true;
8945 : : }
8946 : :
8947 : :
8948 : : /* Resolve the expression in an ALLOCATE statement, doing the additional
8949 : : checks to see whether the expression is OK or not. The expression must
8950 : : have a trailing array reference that gives the size of the array. */
8951 : :
8952 : : static bool
8953 : 16374 : resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
8954 : : {
8955 : 16374 : int i, pointer, allocatable, dimension, is_abstract;
8956 : 16374 : int codimension;
8957 : 16374 : bool coindexed;
8958 : 16374 : bool unlimited;
8959 : 16374 : symbol_attribute attr;
8960 : 16374 : gfc_ref *ref, *ref2;
8961 : 16374 : gfc_expr *e2;
8962 : 16374 : gfc_array_ref *ar;
8963 : 16374 : gfc_symbol *sym = NULL;
8964 : 16374 : gfc_alloc *a;
8965 : 16374 : gfc_component *c;
8966 : 16374 : bool t;
8967 : :
8968 : : /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
8969 : : checking of coarrays. */
8970 : 20385 : for (ref = e->ref; ref; ref = ref->next)
8971 : 16381 : if (ref->next == NULL)
8972 : : break;
8973 : :
8974 : 16374 : if (ref && ref->type == REF_ARRAY)
8975 : 11303 : ref->u.ar.in_allocate = true;
8976 : :
8977 : 16374 : if (!gfc_resolve_expr (e))
8978 : 1 : goto failure;
8979 : :
8980 : : /* Make sure the expression is allocatable or a pointer. If it is
8981 : : pointer, the next-to-last reference must be a pointer. */
8982 : :
8983 : 16373 : ref2 = NULL;
8984 : 16373 : if (e->symtree)
8985 : 16373 : sym = e->symtree->n.sym;
8986 : :
8987 : : /* Check whether ultimate component is abstract and CLASS. */
8988 : 32746 : is_abstract = 0;
8989 : :
8990 : : /* Is the allocate-object unlimited polymorphic? */
8991 : 16373 : unlimited = UNLIMITED_POLY(e);
8992 : :
8993 : 16373 : if (e->expr_type != EXPR_VARIABLE)
8994 : : {
8995 : 0 : allocatable = 0;
8996 : 0 : attr = gfc_expr_attr (e);
8997 : 0 : pointer = attr.pointer;
8998 : 0 : dimension = attr.dimension;
8999 : 0 : codimension = attr.codimension;
9000 : : }
9001 : : else
9002 : : {
9003 : 16373 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
9004 : : {
9005 : 3238 : allocatable = CLASS_DATA (sym)->attr.allocatable;
9006 : 3238 : pointer = CLASS_DATA (sym)->attr.class_pointer;
9007 : 3238 : dimension = CLASS_DATA (sym)->attr.dimension;
9008 : 3238 : codimension = CLASS_DATA (sym)->attr.codimension;
9009 : 3238 : is_abstract = CLASS_DATA (sym)->attr.abstract;
9010 : : }
9011 : : else
9012 : : {
9013 : 13135 : allocatable = sym->attr.allocatable;
9014 : 13135 : pointer = sym->attr.pointer;
9015 : 13135 : dimension = sym->attr.dimension;
9016 : 13135 : codimension = sym->attr.codimension;
9017 : : }
9018 : :
9019 : 16373 : coindexed = false;
9020 : :
9021 : 32748 : for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
9022 : : {
9023 : 16377 : switch (ref->type)
9024 : : {
9025 : 12567 : case REF_ARRAY:
9026 : 12567 : if (ref->u.ar.codimen > 0)
9027 : : {
9028 : 633 : int n;
9029 : 914 : for (n = ref->u.ar.dimen;
9030 : 914 : n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
9031 : 670 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
9032 : : {
9033 : : coindexed = true;
9034 : : break;
9035 : : }
9036 : : }
9037 : :
9038 : 12567 : if (ref->next != NULL)
9039 : 1266 : pointer = 0;
9040 : : break;
9041 : :
9042 : 3810 : case REF_COMPONENT:
9043 : : /* F2008, C644. */
9044 : 3810 : if (coindexed)
9045 : : {
9046 : 2 : gfc_error ("Coindexed allocatable object at %L",
9047 : : &e->where);
9048 : 2 : goto failure;
9049 : : }
9050 : :
9051 : 3808 : c = ref->u.c.component;
9052 : 3808 : if (c->ts.type == BT_CLASS)
9053 : : {
9054 : 942 : allocatable = CLASS_DATA (c)->attr.allocatable;
9055 : 942 : pointer = CLASS_DATA (c)->attr.class_pointer;
9056 : 942 : dimension = CLASS_DATA (c)->attr.dimension;
9057 : 942 : codimension = CLASS_DATA (c)->attr.codimension;
9058 : 942 : is_abstract = CLASS_DATA (c)->attr.abstract;
9059 : : }
9060 : : else
9061 : : {
9062 : 2866 : allocatable = c->attr.allocatable;
9063 : 2866 : pointer = c->attr.pointer;
9064 : 2866 : dimension = c->attr.dimension;
9065 : 2866 : codimension = c->attr.codimension;
9066 : 2866 : is_abstract = c->attr.abstract;
9067 : : }
9068 : : break;
9069 : :
9070 : 0 : case REF_SUBSTRING:
9071 : 0 : case REF_INQUIRY:
9072 : 0 : allocatable = 0;
9073 : 0 : pointer = 0;
9074 : 0 : break;
9075 : : }
9076 : : }
9077 : : }
9078 : :
9079 : : /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
9080 : : pointer or an allocatable variable. */
9081 : 16371 : if (allocatable == 0 && pointer == 0)
9082 : : {
9083 : 4 : gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
9084 : : &e->where);
9085 : 4 : goto failure;
9086 : : }
9087 : :
9088 : : /* Some checks for the SOURCE tag. */
9089 : 16367 : if (code->expr3)
9090 : : {
9091 : : /* Check F03:C631. */
9092 : 3629 : if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
9093 : : {
9094 : 10 : gfc_error ("Type of entity at %L is type incompatible with "
9095 : 10 : "source-expr at %L", &e->where, &code->expr3->where);
9096 : 10 : goto failure;
9097 : : }
9098 : :
9099 : : /* Check F03:C632 and restriction following Note 6.18. */
9100 : 3619 : if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
9101 : 4 : goto failure;
9102 : :
9103 : : /* Check F03:C633. */
9104 : 3615 : if (code->expr3->ts.kind != e->ts.kind && !unlimited)
9105 : : {
9106 : 1 : gfc_error ("The allocate-object at %L and the source-expr at %L "
9107 : : "shall have the same kind type parameter",
9108 : : &e->where, &code->expr3->where);
9109 : 1 : goto failure;
9110 : : }
9111 : :
9112 : : /* Check F2008, C642. */
9113 : 3614 : if (code->expr3->ts.type == BT_DERIVED
9114 : 3614 : && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
9115 : 1159 : || (code->expr3->ts.u.derived->from_intmod
9116 : : == INTMOD_ISO_FORTRAN_ENV
9117 : 1159 : && code->expr3->ts.u.derived->intmod_sym_id
9118 : : == ISOFORTRAN_LOCK_TYPE)))
9119 : : {
9120 : 0 : gfc_error ("The source-expr at %L shall neither be of type "
9121 : : "LOCK_TYPE nor have a LOCK_TYPE component if "
9122 : : "allocate-object at %L is a coarray",
9123 : 0 : &code->expr3->where, &e->where);
9124 : 0 : goto failure;
9125 : : }
9126 : :
9127 : : /* Check F2008:C639: "Corresponding kind type parameters of
9128 : : allocate-object and source-expr shall have the same values." */
9129 : 3614 : if (e->ts.type == BT_CHARACTER
9130 : 752 : && !e->ts.deferred
9131 : 138 : && e->ts.u.cl->length
9132 : 138 : && code->expr3->ts.type == BT_CHARACTER
9133 : 3752 : && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
9134 : : "SOURCE= or MOLD= specifier"))
9135 : 17 : goto failure;
9136 : :
9137 : : /* Check TS18508, C702/C703. */
9138 : 3597 : if (code->expr3->ts.type == BT_DERIVED
9139 : 4756 : && ((codimension && gfc_expr_attr (code->expr3).event_comp)
9140 : 1159 : || (code->expr3->ts.u.derived->from_intmod
9141 : : == INTMOD_ISO_FORTRAN_ENV
9142 : 1159 : && code->expr3->ts.u.derived->intmod_sym_id
9143 : : == ISOFORTRAN_EVENT_TYPE)))
9144 : : {
9145 : 0 : gfc_error ("The source-expr at %L shall neither be of type "
9146 : : "EVENT_TYPE nor have a EVENT_TYPE component if "
9147 : : "allocate-object at %L is a coarray",
9148 : 0 : &code->expr3->where, &e->where);
9149 : 0 : goto failure;
9150 : : }
9151 : : }
9152 : :
9153 : : /* Check F08:C629. */
9154 : 16335 : if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
9155 : 153 : && !code->expr3)
9156 : : {
9157 : 2 : gcc_assert (e->ts.type == BT_CLASS);
9158 : 2 : gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
9159 : : "type-spec or source-expr", sym->name, &e->where);
9160 : 2 : goto failure;
9161 : : }
9162 : :
9163 : : /* Check F08:C632. */
9164 : 16333 : if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
9165 : 58 : && !UNLIMITED_POLY (e))
9166 : : {
9167 : 34 : int cmp;
9168 : :
9169 : 34 : if (!e->ts.u.cl->length)
9170 : 13 : goto failure;
9171 : :
9172 : 42 : cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
9173 : 21 : code->ext.alloc.ts.u.cl->length);
9174 : 21 : if (cmp == 1 || cmp == -1 || cmp == -3)
9175 : : {
9176 : 2 : gfc_error ("Allocating %s at %L with type-spec requires the same "
9177 : : "character-length parameter as in the declaration",
9178 : : sym->name, &e->where);
9179 : 2 : goto failure;
9180 : : }
9181 : : }
9182 : :
9183 : : /* In the variable definition context checks, gfc_expr_attr is used
9184 : : on the expression. This is fooled by the array specification
9185 : : present in e, thus we have to eliminate that one temporarily. */
9186 : 16318 : e2 = remove_last_array_ref (e);
9187 : 16318 : t = true;
9188 : 16318 : if (t && pointer)
9189 : 3651 : t = gfc_check_vardef_context (e2, true, true, false,
9190 : 3651 : _("ALLOCATE object"));
9191 : 3651 : if (t)
9192 : 16310 : t = gfc_check_vardef_context (e2, false, true, false,
9193 : 16310 : _("ALLOCATE object"));
9194 : 16318 : gfc_free_expr (e2);
9195 : 16318 : if (!t)
9196 : 11 : goto failure;
9197 : :
9198 : 16307 : code->ext.alloc.expr3_not_explicit = 0;
9199 : 16307 : if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
9200 : 1539 : && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
9201 : : {
9202 : : /* For class arrays, the initialization with SOURCE is done
9203 : : using _copy and trans_call. It is convenient to exploit that
9204 : : when the allocated type is different from the declared type but
9205 : : no SOURCE exists by setting expr3. */
9206 : 275 : code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
9207 : 275 : code->ext.alloc.expr3_not_explicit = 1;
9208 : : }
9209 : 16032 : else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
9210 : 2276 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9211 : 2276 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9212 : : {
9213 : : /* We have to zero initialize the integer variable. */
9214 : 1 : code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
9215 : 1 : code->ext.alloc.expr3_not_explicit = 1;
9216 : : }
9217 : :
9218 : 16307 : if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
9219 : : {
9220 : : /* Make sure the vtab symbol is present when
9221 : : the module variables are generated. */
9222 : 2837 : gfc_typespec ts = e->ts;
9223 : 2837 : if (code->expr3)
9224 : 1281 : ts = code->expr3->ts;
9225 : 1556 : else if (code->ext.alloc.ts.type == BT_DERIVED)
9226 : 677 : ts = code->ext.alloc.ts;
9227 : :
9228 : : /* Finding the vtab also publishes the type's symbol. Therefore this
9229 : : statement is necessary. */
9230 : 2837 : gfc_find_derived_vtab (ts.u.derived);
9231 : 2837 : }
9232 : 13470 : else if (unlimited && !UNLIMITED_POLY (code->expr3))
9233 : : {
9234 : : /* Again, make sure the vtab symbol is present when
9235 : : the module variables are generated. */
9236 : 433 : gfc_typespec *ts = NULL;
9237 : 433 : if (code->expr3)
9238 : 341 : ts = &code->expr3->ts;
9239 : : else
9240 : 92 : ts = &code->ext.alloc.ts;
9241 : :
9242 : 433 : gcc_assert (ts);
9243 : :
9244 : : /* Finding the vtab also publishes the type's symbol. Therefore this
9245 : : statement is necessary. */
9246 : 433 : gfc_find_vtab (ts);
9247 : : }
9248 : :
9249 : 16307 : if (dimension == 0 && codimension == 0)
9250 : 5030 : goto success;
9251 : :
9252 : : /* Make sure the last reference node is an array specification. */
9253 : :
9254 : 11277 : if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
9255 : 10132 : || (dimension && ref2->u.ar.dimen == 0))
9256 : : {
9257 : : /* F08:C633. */
9258 : 1145 : if (code->expr3)
9259 : : {
9260 : 1144 : if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
9261 : : "in ALLOCATE statement at %L", &e->where))
9262 : 0 : goto failure;
9263 : 1144 : if (code->expr3->rank != 0)
9264 : 1143 : *array_alloc_wo_spec = true;
9265 : : else
9266 : : {
9267 : 1 : gfc_error ("Array specification or array-valued SOURCE= "
9268 : : "expression required in ALLOCATE statement at %L",
9269 : : &e->where);
9270 : 1 : goto failure;
9271 : : }
9272 : : }
9273 : : else
9274 : : {
9275 : 1 : gfc_error ("Array specification required in ALLOCATE statement "
9276 : : "at %L", &e->where);
9277 : 1 : goto failure;
9278 : : }
9279 : : }
9280 : :
9281 : : /* Make sure that the array section reference makes sense in the
9282 : : context of an ALLOCATE specification. */
9283 : :
9284 : 11275 : ar = &ref2->u.ar;
9285 : :
9286 : 11275 : if (codimension)
9287 : 926 : for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
9288 : : {
9289 : 550 : switch (ar->dimen_type[i])
9290 : : {
9291 : 2 : case DIMEN_THIS_IMAGE:
9292 : 2 : gfc_error ("Coarray specification required in ALLOCATE statement "
9293 : : "at %L", &e->where);
9294 : 2 : goto failure;
9295 : :
9296 : 83 : case DIMEN_RANGE:
9297 : : /* F2018:R937:
9298 : : * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
9299 : : */
9300 : 83 : if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
9301 : : {
9302 : 8 : gfc_error ("Bad coarray specification in ALLOCATE statement "
9303 : : "at %L", &e->where);
9304 : 8 : goto failure;
9305 : : }
9306 : 75 : else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
9307 : : {
9308 : 2 : gfc_error ("Upper cobound is less than lower cobound at %L",
9309 : 2 : &ar->start[i]->where);
9310 : 2 : goto failure;
9311 : : }
9312 : : break;
9313 : :
9314 : 89 : case DIMEN_ELEMENT:
9315 : 89 : if (ar->start[i]->expr_type == EXPR_CONSTANT)
9316 : : {
9317 : 81 : gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
9318 : 81 : if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
9319 : : {
9320 : 1 : gfc_error ("Upper cobound is less than lower cobound "
9321 : : "of 1 at %L", &ar->start[i]->where);
9322 : 1 : goto failure;
9323 : : }
9324 : : }
9325 : : break;
9326 : :
9327 : : case DIMEN_STAR:
9328 : : break;
9329 : :
9330 : 0 : default:
9331 : 0 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9332 : : &e->where);
9333 : 0 : goto failure;
9334 : :
9335 : : }
9336 : : }
9337 : 27852 : for (i = 0; i < ar->dimen; i++)
9338 : : {
9339 : 16592 : if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
9340 : 13960 : goto check_symbols;
9341 : :
9342 : 2632 : switch (ar->dimen_type[i])
9343 : : {
9344 : : case DIMEN_ELEMENT:
9345 : : break;
9346 : :
9347 : 2367 : case DIMEN_RANGE:
9348 : 2367 : if (ar->start[i] != NULL
9349 : 2367 : && ar->end[i] != NULL
9350 : 2366 : && ar->stride[i] == NULL)
9351 : : break;
9352 : :
9353 : : /* Fall through. */
9354 : :
9355 : 1 : case DIMEN_UNKNOWN:
9356 : 1 : case DIMEN_VECTOR:
9357 : 1 : case DIMEN_STAR:
9358 : 1 : case DIMEN_THIS_IMAGE:
9359 : 1 : gfc_error ("Bad array specification in ALLOCATE statement at %L",
9360 : : &e->where);
9361 : 1 : goto failure;
9362 : : }
9363 : :
9364 : 2366 : check_symbols:
9365 : 43422 : for (a = code->ext.alloc.list; a; a = a->next)
9366 : : {
9367 : 26832 : sym = a->expr->symtree->n.sym;
9368 : :
9369 : : /* TODO - check derived type components. */
9370 : 26832 : if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
9371 : 8657 : continue;
9372 : :
9373 : 18175 : if ((ar->start[i] != NULL
9374 : 17599 : && gfc_find_sym_in_expr (sym, ar->start[i]))
9375 : 35773 : || (ar->end[i] != NULL
9376 : 2615 : && gfc_find_sym_in_expr (sym, ar->end[i])))
9377 : : {
9378 : 1 : gfc_error ("%qs must not appear in the array specification at "
9379 : : "%L in the same ALLOCATE statement where it is "
9380 : : "itself allocated", sym->name, &ar->where);
9381 : 1 : goto failure;
9382 : : }
9383 : : }
9384 : : }
9385 : :
9386 : 11420 : for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
9387 : : {
9388 : 695 : if (ar->dimen_type[i] == DIMEN_ELEMENT
9389 : 535 : || ar->dimen_type[i] == DIMEN_RANGE)
9390 : : {
9391 : 160 : if (i == (ar->dimen + ar->codimen - 1))
9392 : : {
9393 : 0 : gfc_error ("Expected %<*%> in coindex specification in ALLOCATE "
9394 : : "statement at %L", &e->where);
9395 : 0 : goto failure;
9396 : : }
9397 : 160 : continue;
9398 : : }
9399 : :
9400 : 375 : if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
9401 : 375 : && ar->stride[i] == NULL)
9402 : : break;
9403 : :
9404 : 0 : gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
9405 : : &e->where);
9406 : 0 : goto failure;
9407 : : }
9408 : :
9409 : 11260 : success:
9410 : : return true;
9411 : :
9412 : : failure:
9413 : : return false;
9414 : : }
9415 : :
9416 : :
9417 : : static void
9418 : 19048 : resolve_allocate_deallocate (gfc_code *code, const char *fcn)
9419 : : {
9420 : 19048 : gfc_expr *stat, *errmsg, *pe, *qe;
9421 : 19048 : gfc_alloc *a, *p, *q;
9422 : :
9423 : 19048 : stat = code->expr1;
9424 : 19048 : errmsg = code->expr2;
9425 : :
9426 : : /* Check the stat variable. */
9427 : 19048 : if (stat)
9428 : : {
9429 : 618 : if (!gfc_check_vardef_context (stat, false, false, false,
9430 : 618 : _("STAT variable")))
9431 : 8 : goto done_stat;
9432 : :
9433 : 610 : if (stat->ts.type != BT_INTEGER
9434 : 601 : || stat->rank > 0)
9435 : 11 : gfc_error ("Stat-variable at %L must be a scalar INTEGER "
9436 : : "variable", &stat->where);
9437 : :
9438 : 610 : if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
9439 : 0 : goto done_stat;
9440 : :
9441 : : /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
9442 : : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9443 : : */
9444 : 1265 : for (p = code->ext.alloc.list; p; p = p->next)
9445 : 662 : if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
9446 : : {
9447 : 9 : gfc_ref *ref1, *ref2;
9448 : 9 : bool found = true;
9449 : :
9450 : 16 : for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
9451 : 7 : ref1 = ref1->next, ref2 = ref2->next)
9452 : : {
9453 : 9 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9454 : 5 : continue;
9455 : 4 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9456 : : {
9457 : : found = false;
9458 : : break;
9459 : : }
9460 : : }
9461 : :
9462 : 9 : if (found)
9463 : : {
9464 : 7 : gfc_error ("Stat-variable at %L shall not be %sd within "
9465 : : "the same %s statement", &stat->where, fcn, fcn);
9466 : 7 : break;
9467 : : }
9468 : : }
9469 : : }
9470 : :
9471 : 18430 : done_stat:
9472 : :
9473 : : /* Check the errmsg variable. */
9474 : 19048 : if (errmsg)
9475 : : {
9476 : 146 : if (!stat)
9477 : 2 : gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
9478 : : &errmsg->where);
9479 : :
9480 : 146 : if (!gfc_check_vardef_context (errmsg, false, false, false,
9481 : 146 : _("ERRMSG variable")))
9482 : 6 : goto done_errmsg;
9483 : :
9484 : : /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
9485 : : F18:R930 errmsg-variable is scalar-default-char-variable
9486 : : F18:R906 default-char-variable is variable
9487 : : F18:C906 default-char-variable shall be default character. */
9488 : 140 : if (errmsg->ts.type != BT_CHARACTER
9489 : 138 : || errmsg->rank > 0
9490 : 137 : || errmsg->ts.kind != gfc_default_character_kind)
9491 : 4 : gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
9492 : : "variable", &errmsg->where);
9493 : :
9494 : 140 : if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
9495 : 0 : goto done_errmsg;
9496 : :
9497 : : /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
9498 : : * within the ALLOCATE or DEALLOCATE statement in which it appears ...
9499 : : */
9500 : 278 : for (p = code->ext.alloc.list; p; p = p->next)
9501 : 143 : if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
9502 : : {
9503 : 9 : gfc_ref *ref1, *ref2;
9504 : 9 : bool found = true;
9505 : :
9506 : 16 : for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
9507 : 7 : ref1 = ref1->next, ref2 = ref2->next)
9508 : : {
9509 : 11 : if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
9510 : 4 : continue;
9511 : 7 : if (ref1->u.c.component->name != ref2->u.c.component->name)
9512 : : {
9513 : : found = false;
9514 : : break;
9515 : : }
9516 : : }
9517 : :
9518 : 9 : if (found)
9519 : : {
9520 : 5 : gfc_error ("Errmsg-variable at %L shall not be %sd within "
9521 : : "the same %s statement", &errmsg->where, fcn, fcn);
9522 : 5 : break;
9523 : : }
9524 : : }
9525 : : }
9526 : :
9527 : 18902 : done_errmsg:
9528 : :
9529 : : /* Check that an allocate-object appears only once in the statement. */
9530 : :
9531 : 43021 : for (p = code->ext.alloc.list; p; p = p->next)
9532 : : {
9533 : 23973 : pe = p->expr;
9534 : 32445 : for (q = p->next; q; q = q->next)
9535 : : {
9536 : 8472 : qe = q->expr;
9537 : 8472 : if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
9538 : : {
9539 : : /* This is a potential collision. */
9540 : 1903 : gfc_ref *pr = pe->ref;
9541 : 1903 : gfc_ref *qr = qe->ref;
9542 : :
9543 : : /* Follow the references until
9544 : : a) They start to differ, in which case there is no error;
9545 : : you can deallocate a%b and a%c in a single statement
9546 : : b) Both of them stop, which is an error
9547 : : c) One of them stops, which is also an error. */
9548 : 3643 : while (1)
9549 : : {
9550 : 2773 : if (pr == NULL && qr == NULL)
9551 : : {
9552 : 7 : gfc_error ("Allocate-object at %L also appears at %L",
9553 : : &pe->where, &qe->where);
9554 : 7 : break;
9555 : : }
9556 : 2766 : else if (pr != NULL && qr == NULL)
9557 : : {
9558 : 2 : gfc_error ("Allocate-object at %L is subobject of"
9559 : : " object at %L", &pe->where, &qe->where);
9560 : 2 : break;
9561 : : }
9562 : 2764 : else if (pr == NULL && qr != NULL)
9563 : : {
9564 : 2 : gfc_error ("Allocate-object at %L is subobject of"
9565 : : " object at %L", &qe->where, &pe->where);
9566 : 2 : break;
9567 : : }
9568 : : /* Here, pr != NULL && qr != NULL */
9569 : 2762 : gcc_assert(pr->type == qr->type);
9570 : 2762 : if (pr->type == REF_ARRAY)
9571 : : {
9572 : : /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
9573 : : which are legal. */
9574 : 897 : gcc_assert (qr->type == REF_ARRAY);
9575 : :
9576 : 897 : if (pr->next && qr->next)
9577 : : {
9578 : : int i;
9579 : : gfc_array_ref *par = &(pr->u.ar);
9580 : : gfc_array_ref *qar = &(qr->u.ar);
9581 : :
9582 : 1528 : for (i=0; i<par->dimen; i++)
9583 : : {
9584 : 738 : if ((par->start[i] != NULL
9585 : 0 : || qar->start[i] != NULL)
9586 : 738 : && gfc_dep_compare_expr (par->start[i],
9587 : : qar->start[i]) != 0)
9588 : 96 : goto break_label;
9589 : : }
9590 : : }
9591 : : }
9592 : : else
9593 : : {
9594 : 1865 : if (pr->u.c.component->name != qr->u.c.component->name)
9595 : : break;
9596 : : }
9597 : :
9598 : 870 : pr = pr->next;
9599 : 870 : qr = qr->next;
9600 : 870 : }
9601 : 8472 : break_label:
9602 : : ;
9603 : : }
9604 : : }
9605 : : }
9606 : :
9607 : 19048 : if (strcmp (fcn, "ALLOCATE") == 0)
9608 : : {
9609 : 13432 : bool arr_alloc_wo_spec = false;
9610 : :
9611 : : /* Resolving the expr3 in the loop over all objects to allocate would
9612 : : execute loop invariant code for each loop item. Therefore do it just
9613 : : once here. */
9614 : 13432 : if (code->expr3 && code->expr3->mold
9615 : 316 : && code->expr3->ts.type == BT_DERIVED)
9616 : : {
9617 : : /* Default initialization via MOLD (non-polymorphic). */
9618 : 20 : gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
9619 : 20 : if (rhs != NULL)
9620 : : {
9621 : 7 : gfc_resolve_expr (rhs);
9622 : 7 : gfc_free_expr (code->expr3);
9623 : 7 : code->expr3 = rhs;
9624 : : }
9625 : : }
9626 : 29806 : for (a = code->ext.alloc.list; a; a = a->next)
9627 : 16374 : resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
9628 : :
9629 : 13432 : if (arr_alloc_wo_spec && code->expr3)
9630 : : {
9631 : : /* Mark the allocate to have to take the array specification
9632 : : from the expr3. */
9633 : 1137 : code->ext.alloc.arr_spec_from_expr3 = 1;
9634 : : }
9635 : : }
9636 : : else
9637 : : {
9638 : 13215 : for (a = code->ext.alloc.list; a; a = a->next)
9639 : 7599 : resolve_deallocate_expr (a->expr);
9640 : : }
9641 : 19048 : }
9642 : :
9643 : :
9644 : : /************ SELECT CASE resolution subroutines ************/
9645 : :
9646 : : /* Callback function for our mergesort variant. Determines interval
9647 : : overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
9648 : : op1 > op2. Assumes we're not dealing with the default case.
9649 : : We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
9650 : : There are nine situations to check. */
9651 : :
9652 : : static int
9653 : 1592 : compare_cases (const gfc_case *op1, const gfc_case *op2)
9654 : : {
9655 : 1592 : int retval;
9656 : :
9657 : 1592 : if (op1->low == NULL) /* op1 = (:L) */
9658 : : {
9659 : : /* op2 = (:N), so overlap. */
9660 : 52 : retval = 0;
9661 : : /* op2 = (M:) or (M:N), L < M */
9662 : 52 : if (op2->low != NULL
9663 : 52 : && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9664 : : retval = -1;
9665 : : }
9666 : 1540 : else if (op1->high == NULL) /* op1 = (K:) */
9667 : : {
9668 : : /* op2 = (M:), so overlap. */
9669 : 10 : retval = 0;
9670 : : /* op2 = (:N) or (M:N), K > N */
9671 : 10 : if (op2->high != NULL
9672 : 10 : && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9673 : : retval = 1;
9674 : : }
9675 : : else /* op1 = (K:L) */
9676 : : {
9677 : 1530 : if (op2->low == NULL) /* op2 = (:N), K > N */
9678 : 18 : retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9679 : 18 : ? 1 : 0;
9680 : 1512 : else if (op2->high == NULL) /* op2 = (M:), L < M */
9681 : 10 : retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9682 : 10 : ? -1 : 0;
9683 : : else /* op2 = (M:N) */
9684 : : {
9685 : 1502 : retval = 0;
9686 : : /* L < M */
9687 : 1502 : if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
9688 : : retval = -1;
9689 : : /* K > N */
9690 : 437 : else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
9691 : 463 : retval = 1;
9692 : : }
9693 : : }
9694 : :
9695 : 1592 : return retval;
9696 : : }
9697 : :
9698 : :
9699 : : /* Merge-sort a double linked case list, detecting overlap in the
9700 : : process. LIST is the head of the double linked case list before it
9701 : : is sorted. Returns the head of the sorted list if we don't see any
9702 : : overlap, or NULL otherwise. */
9703 : :
9704 : : static gfc_case *
9705 : 667 : check_case_overlap (gfc_case *list)
9706 : : {
9707 : 667 : gfc_case *p, *q, *e, *tail;
9708 : 667 : int insize, nmerges, psize, qsize, cmp, overlap_seen;
9709 : :
9710 : : /* If the passed list was empty, return immediately. */
9711 : 667 : if (!list)
9712 : : return NULL;
9713 : :
9714 : : overlap_seen = 0;
9715 : : insize = 1;
9716 : :
9717 : : /* Loop unconditionally. The only exit from this loop is a return
9718 : : statement, when we've finished sorting the case list. */
9719 : 1379 : for (;;)
9720 : : {
9721 : 1023 : p = list;
9722 : 1023 : list = NULL;
9723 : 1023 : tail = NULL;
9724 : :
9725 : : /* Count the number of merges we do in this pass. */
9726 : 1023 : nmerges = 0;
9727 : :
9728 : : /* Loop while there exists a merge to be done. */
9729 : 2571 : while (p)
9730 : : {
9731 : 1548 : int i;
9732 : :
9733 : : /* Count this merge. */
9734 : 1548 : nmerges++;
9735 : :
9736 : : /* Cut the list in two pieces by stepping INSIZE places
9737 : : forward in the list, starting from P. */
9738 : 1548 : psize = 0;
9739 : 1548 : q = p;
9740 : 3240 : for (i = 0; i < insize; i++)
9741 : : {
9742 : 2261 : psize++;
9743 : 2261 : q = q->right;
9744 : 2261 : if (!q)
9745 : : break;
9746 : : }
9747 : : qsize = insize;
9748 : :
9749 : : /* Now we have two lists. Merge them! */
9750 : 5058 : while (psize > 0 || (qsize > 0 && q != NULL))
9751 : : {
9752 : : /* See from which the next case to merge comes from. */
9753 : 786 : if (psize == 0)
9754 : : {
9755 : : /* P is empty so the next case must come from Q. */
9756 : 786 : e = q;
9757 : 786 : q = q->right;
9758 : 786 : qsize--;
9759 : : }
9760 : 2724 : else if (qsize == 0 || q == NULL)
9761 : : {
9762 : : /* Q is empty. */
9763 : 1132 : e = p;
9764 : 1132 : p = p->right;
9765 : 1132 : psize--;
9766 : : }
9767 : : else
9768 : : {
9769 : 1592 : cmp = compare_cases (p, q);
9770 : 1592 : if (cmp < 0)
9771 : : {
9772 : : /* The whole case range for P is less than the
9773 : : one for Q. */
9774 : 1125 : e = p;
9775 : 1125 : p = p->right;
9776 : 1125 : psize--;
9777 : : }
9778 : 467 : else if (cmp > 0)
9779 : : {
9780 : : /* The whole case range for Q is greater than
9781 : : the case range for P. */
9782 : 463 : e = q;
9783 : 463 : q = q->right;
9784 : 463 : qsize--;
9785 : : }
9786 : : else
9787 : : {
9788 : : /* The cases overlap, or they are the same
9789 : : element in the list. Either way, we must
9790 : : issue an error and get the next case from P. */
9791 : : /* FIXME: Sort P and Q by line number. */
9792 : 4 : gfc_error ("CASE label at %L overlaps with CASE "
9793 : : "label at %L", &p->where, &q->where);
9794 : 4 : overlap_seen = 1;
9795 : 4 : e = p;
9796 : 4 : p = p->right;
9797 : 4 : psize--;
9798 : : }
9799 : : }
9800 : :
9801 : : /* Add the next element to the merged list. */
9802 : 3510 : if (tail)
9803 : 2487 : tail->right = e;
9804 : : else
9805 : : list = e;
9806 : 3510 : e->left = tail;
9807 : 3510 : tail = e;
9808 : : }
9809 : :
9810 : : /* P has now stepped INSIZE places along, and so has Q. So
9811 : : they're the same. */
9812 : : p = q;
9813 : : }
9814 : 1023 : tail->right = NULL;
9815 : :
9816 : : /* If we have done only one merge or none at all, we've
9817 : : finished sorting the cases. */
9818 : 1023 : if (nmerges <= 1)
9819 : : {
9820 : 667 : if (!overlap_seen)
9821 : : return list;
9822 : : else
9823 : : return NULL;
9824 : : }
9825 : :
9826 : : /* Otherwise repeat, merging lists twice the size. */
9827 : 356 : insize *= 2;
9828 : 356 : }
9829 : : }
9830 : :
9831 : :
9832 : : /* Check to see if an expression is suitable for use in a CASE statement.
9833 : : Makes sure that all case expressions are scalar constants of the same
9834 : : type. Return false if anything is wrong. */
9835 : :
9836 : : static bool
9837 : 3377 : validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
9838 : : {
9839 : 3377 : if (e == NULL) return true;
9840 : :
9841 : 3284 : if (e->ts.type != case_expr->ts.type)
9842 : : {
9843 : 4 : gfc_error ("Expression in CASE statement at %L must be of type %s",
9844 : : &e->where, gfc_basic_typename (case_expr->ts.type));
9845 : 4 : return false;
9846 : : }
9847 : :
9848 : : /* C805 (R808) For a given case-construct, each case-value shall be of
9849 : : the same type as case-expr. For character type, length differences
9850 : : are allowed, but the kind type parameters shall be the same. */
9851 : :
9852 : 3280 : if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
9853 : : {
9854 : 4 : gfc_error ("Expression in CASE statement at %L must be of kind %d",
9855 : : &e->where, case_expr->ts.kind);
9856 : 4 : return false;
9857 : : }
9858 : :
9859 : : /* Convert the case value kind to that of case expression kind,
9860 : : if needed */
9861 : :
9862 : 3276 : if (e->ts.kind != case_expr->ts.kind)
9863 : 14 : gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
9864 : :
9865 : 3276 : if (e->rank != 0)
9866 : : {
9867 : 0 : gfc_error ("Expression in CASE statement at %L must be scalar",
9868 : : &e->where);
9869 : 0 : return false;
9870 : : }
9871 : :
9872 : : return true;
9873 : : }
9874 : :
9875 : :
9876 : : /* Given a completely parsed select statement, we:
9877 : :
9878 : : - Validate all expressions and code within the SELECT.
9879 : : - Make sure that the selection expression is not of the wrong type.
9880 : : - Make sure that no case ranges overlap.
9881 : : - Eliminate unreachable cases and unreachable code resulting from
9882 : : removing case labels.
9883 : :
9884 : : The standard does allow unreachable cases, e.g. CASE (5:3). But
9885 : : they are a hassle for code generation, and to prevent that, we just
9886 : : cut them out here. This is not necessary for overlapping cases
9887 : : because they are illegal and we never even try to generate code.
9888 : :
9889 : : We have the additional caveat that a SELECT construct could have
9890 : : been a computed GOTO in the source code. Fortunately we can fairly
9891 : : easily work around that here: The case_expr for a "real" SELECT CASE
9892 : : is in code->expr1, but for a computed GOTO it is in code->expr2. All
9893 : : we have to do is make sure that the case_expr is a scalar integer
9894 : : expression. */
9895 : :
9896 : : static void
9897 : 708 : resolve_select (gfc_code *code, bool select_type)
9898 : : {
9899 : 708 : gfc_code *body;
9900 : 708 : gfc_expr *case_expr;
9901 : 708 : gfc_case *cp, *default_case, *tail, *head;
9902 : 708 : int seen_unreachable;
9903 : 708 : int seen_logical;
9904 : 708 : int ncases;
9905 : 708 : bt type;
9906 : 708 : bool t;
9907 : :
9908 : 708 : if (code->expr1 == NULL)
9909 : : {
9910 : : /* This was actually a computed GOTO statement. */
9911 : 5 : case_expr = code->expr2;
9912 : 5 : if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
9913 : 3 : gfc_error ("Selection expression in computed GOTO statement "
9914 : : "at %L must be a scalar integer expression",
9915 : : &case_expr->where);
9916 : :
9917 : : /* Further checking is not necessary because this SELECT was built
9918 : : by the compiler, so it should always be OK. Just move the
9919 : : case_expr from expr2 to expr so that we can handle computed
9920 : : GOTOs as normal SELECTs from here on. */
9921 : 5 : code->expr1 = code->expr2;
9922 : 5 : code->expr2 = NULL;
9923 : 5 : return;
9924 : : }
9925 : :
9926 : 703 : case_expr = code->expr1;
9927 : 703 : type = case_expr->ts.type;
9928 : :
9929 : : /* F08:C830. */
9930 : 703 : if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
9931 : 6 : && (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
9932 : :
9933 : : {
9934 : 0 : gfc_error ("Argument of SELECT statement at %L cannot be %s",
9935 : : &case_expr->where, gfc_typename (case_expr));
9936 : :
9937 : : /* Punt. Going on here just produce more garbage error messages. */
9938 : 0 : return;
9939 : : }
9940 : :
9941 : : /* F08:R842. */
9942 : 703 : if (!select_type && case_expr->rank != 0)
9943 : : {
9944 : 1 : gfc_error ("Argument of SELECT statement at %L must be a scalar "
9945 : : "expression", &case_expr->where);
9946 : :
9947 : : /* Punt. */
9948 : 1 : return;
9949 : : }
9950 : :
9951 : : /* Raise a warning if an INTEGER case value exceeds the range of
9952 : : the case-expr. Later, all expressions will be promoted to the
9953 : : largest kind of all case-labels. */
9954 : :
9955 : 702 : if (type == BT_INTEGER)
9956 : 1952 : for (body = code->block; body; body = body->block)
9957 : 2880 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
9958 : : {
9959 : 1476 : if (cp->low
9960 : 1476 : && gfc_check_integer_range (cp->low->value.integer,
9961 : : case_expr->ts.kind) != ARITH_OK)
9962 : 6 : gfc_warning (0, "Expression in CASE statement at %L is "
9963 : 6 : "not in the range of %s", &cp->low->where,
9964 : : gfc_typename (case_expr));
9965 : :
9966 : 1476 : if (cp->high
9967 : 1178 : && cp->low != cp->high
9968 : 1584 : && gfc_check_integer_range (cp->high->value.integer,
9969 : : case_expr->ts.kind) != ARITH_OK)
9970 : 0 : gfc_warning (0, "Expression in CASE statement at %L is "
9971 : 0 : "not in the range of %s", &cp->high->where,
9972 : : gfc_typename (case_expr));
9973 : : }
9974 : :
9975 : : /* PR 19168 has a long discussion concerning a mismatch of the kinds
9976 : : of the SELECT CASE expression and its CASE values. Walk the lists
9977 : : of case values, and if we find a mismatch, promote case_expr to
9978 : : the appropriate kind. */
9979 : :
9980 : 702 : if (type == BT_LOGICAL || type == BT_INTEGER)
9981 : : {
9982 : 2138 : for (body = code->block; body; body = body->block)
9983 : : {
9984 : : /* Walk the case label list. */
9985 : 3141 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
9986 : : {
9987 : : /* Intercept the DEFAULT case. It does not have a kind. */
9988 : 1611 : if (cp->low == NULL && cp->high == NULL)
9989 : 306 : continue;
9990 : :
9991 : : /* Unreachable case ranges are discarded, so ignore. */
9992 : 1260 : if (cp->low != NULL && cp->high != NULL
9993 : 1212 : && cp->low != cp->high
9994 : 1370 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
9995 : 33 : continue;
9996 : :
9997 : 1272 : if (cp->low != NULL
9998 : 1272 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
9999 : 17 : gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
10000 : :
10001 : 1272 : if (cp->high != NULL
10002 : 1272 : && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
10003 : 4 : gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
10004 : : }
10005 : : }
10006 : : }
10007 : :
10008 : : /* Assume there is no DEFAULT case. */
10009 : 702 : default_case = NULL;
10010 : 702 : head = tail = NULL;
10011 : 702 : ncases = 0;
10012 : 702 : seen_logical = 0;
10013 : :
10014 : 2577 : for (body = code->block; body; body = body->block)
10015 : : {
10016 : : /* Assume the CASE list is OK, and all CASE labels can be matched. */
10017 : 1875 : t = true;
10018 : 1875 : seen_unreachable = 0;
10019 : :
10020 : : /* Walk the case label list, making sure that all case labels
10021 : : are legal. */
10022 : 3942 : for (cp = body->ext.block.case_list; cp; cp = cp->next)
10023 : : {
10024 : : /* Count the number of cases in the whole construct. */
10025 : 2078 : ncases++;
10026 : :
10027 : : /* Intercept the DEFAULT case. */
10028 : 2078 : if (cp->low == NULL && cp->high == NULL)
10029 : : {
10030 : 386 : if (default_case != NULL)
10031 : : {
10032 : 0 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10033 : : "by a second DEFAULT CASE at %L",
10034 : : &default_case->where, &cp->where);
10035 : 0 : t = false;
10036 : 0 : break;
10037 : : }
10038 : : else
10039 : : {
10040 : 386 : default_case = cp;
10041 : 386 : continue;
10042 : : }
10043 : : }
10044 : :
10045 : : /* Deal with single value cases and case ranges. Errors are
10046 : : issued from the validation function. */
10047 : 1692 : if (!validate_case_label_expr (cp->low, case_expr)
10048 : 1692 : || !validate_case_label_expr (cp->high, case_expr))
10049 : : {
10050 : : t = false;
10051 : : break;
10052 : : }
10053 : :
10054 : 1684 : if (type == BT_LOGICAL
10055 : 78 : && ((cp->low == NULL || cp->high == NULL)
10056 : 76 : || cp->low != cp->high))
10057 : : {
10058 : 2 : gfc_error ("Logical range in CASE statement at %L is not "
10059 : : "allowed",
10060 : 1 : cp->low ? &cp->low->where : &cp->high->where);
10061 : 2 : t = false;
10062 : 2 : break;
10063 : : }
10064 : :
10065 : 76 : if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
10066 : : {
10067 : 76 : int value;
10068 : 76 : value = cp->low->value.logical == 0 ? 2 : 1;
10069 : 76 : if (value & seen_logical)
10070 : : {
10071 : 1 : gfc_error ("Constant logical value in CASE statement "
10072 : : "is repeated at %L",
10073 : : &cp->low->where);
10074 : 1 : t = false;
10075 : 1 : break;
10076 : : }
10077 : 75 : seen_logical |= value;
10078 : : }
10079 : :
10080 : 1637 : if (cp->low != NULL && cp->high != NULL
10081 : 1590 : && cp->low != cp->high
10082 : 1803 : && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
10083 : : {
10084 : 35 : if (warn_surprising)
10085 : 1 : gfc_warning (OPT_Wsurprising,
10086 : : "Range specification at %L can never be matched",
10087 : : &cp->where);
10088 : :
10089 : 35 : cp->unreachable = 1;
10090 : 35 : seen_unreachable = 1;
10091 : : }
10092 : : else
10093 : : {
10094 : : /* If the case range can be matched, it can also overlap with
10095 : : other cases. To make sure it does not, we put it in a
10096 : : double linked list here. We sort that with a merge sort
10097 : : later on to detect any overlapping cases. */
10098 : 1646 : if (!head)
10099 : : {
10100 : 667 : head = tail = cp;
10101 : 667 : head->right = head->left = NULL;
10102 : : }
10103 : : else
10104 : : {
10105 : 979 : tail->right = cp;
10106 : 979 : tail->right->left = tail;
10107 : 979 : tail = tail->right;
10108 : 979 : tail->right = NULL;
10109 : : }
10110 : : }
10111 : : }
10112 : :
10113 : : /* It there was a failure in the previous case label, give up
10114 : : for this case label list. Continue with the next block. */
10115 : 1875 : if (!t)
10116 : 11 : continue;
10117 : :
10118 : : /* See if any case labels that are unreachable have been seen.
10119 : : If so, we eliminate them. This is a bit of a kludge because
10120 : : the case lists for a single case statement (label) is a
10121 : : single forward linked lists. */
10122 : 1864 : if (seen_unreachable)
10123 : : {
10124 : : /* Advance until the first case in the list is reachable. */
10125 : 69 : while (body->ext.block.case_list != NULL
10126 : 69 : && body->ext.block.case_list->unreachable)
10127 : : {
10128 : 34 : gfc_case *n = body->ext.block.case_list;
10129 : 34 : body->ext.block.case_list = body->ext.block.case_list->next;
10130 : 34 : n->next = NULL;
10131 : 34 : gfc_free_case_list (n);
10132 : : }
10133 : :
10134 : : /* Strip all other unreachable cases. */
10135 : 35 : if (body->ext.block.case_list)
10136 : : {
10137 : 2 : for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
10138 : : {
10139 : 1 : if (cp->next->unreachable)
10140 : : {
10141 : 1 : gfc_case *n = cp->next;
10142 : 1 : cp->next = cp->next->next;
10143 : 1 : n->next = NULL;
10144 : 1 : gfc_free_case_list (n);
10145 : : }
10146 : : }
10147 : : }
10148 : : }
10149 : : }
10150 : :
10151 : : /* See if there were overlapping cases. If the check returns NULL,
10152 : : there was overlap. In that case we don't do anything. If head
10153 : : is non-NULL, we prepend the DEFAULT case. The sorted list can
10154 : : then used during code generation for SELECT CASE constructs with
10155 : : a case expression of a CHARACTER type. */
10156 : 702 : if (head)
10157 : : {
10158 : 667 : head = check_case_overlap (head);
10159 : :
10160 : : /* Prepend the default_case if it is there. */
10161 : 667 : if (head != NULL && default_case)
10162 : : {
10163 : 369 : default_case->left = NULL;
10164 : 369 : default_case->right = head;
10165 : 369 : head->left = default_case;
10166 : : }
10167 : : }
10168 : :
10169 : : /* Eliminate dead blocks that may be the result if we've seen
10170 : : unreachable case labels for a block. */
10171 : 2543 : for (body = code; body && body->block; body = body->block)
10172 : : {
10173 : 1841 : if (body->block->ext.block.case_list == NULL)
10174 : : {
10175 : : /* Cut the unreachable block from the code chain. */
10176 : 34 : gfc_code *c = body->block;
10177 : 34 : body->block = c->block;
10178 : :
10179 : : /* Kill the dead block, but not the blocks below it. */
10180 : 34 : c->block = NULL;
10181 : 34 : gfc_free_statements (c);
10182 : : }
10183 : : }
10184 : :
10185 : : /* More than two cases is legal but insane for logical selects.
10186 : : Issue a warning for it. */
10187 : 702 : if (warn_surprising && type == BT_LOGICAL && ncases > 2)
10188 : 0 : gfc_warning (OPT_Wsurprising,
10189 : : "Logical SELECT CASE block at %L has more that two cases",
10190 : : &code->loc);
10191 : : }
10192 : :
10193 : :
10194 : : /* Check if a derived type is extensible. */
10195 : :
10196 : : bool
10197 : 22666 : gfc_type_is_extensible (gfc_symbol *sym)
10198 : : {
10199 : 22666 : return !(sym->attr.is_bind_c || sym->attr.sequence
10200 : 22650 : || (sym->attr.is_class
10201 : 2052 : && sym->components->ts.u.derived->attr.unlimited_polymorphic));
10202 : : }
10203 : :
10204 : :
10205 : : static void
10206 : : resolve_types (gfc_namespace *ns);
10207 : :
10208 : : /* Resolve an associate-name: Resolve target and ensure the type-spec is
10209 : : correct as well as possibly the array-spec. */
10210 : :
10211 : : static void
10212 : 12134 : resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
10213 : : {
10214 : 12134 : gfc_expr* target;
10215 : 12134 : bool parentheses = false;
10216 : :
10217 : 12134 : gcc_assert (sym->assoc);
10218 : 12134 : gcc_assert (sym->attr.flavor == FL_VARIABLE);
10219 : :
10220 : : /* If this is for SELECT TYPE, the target may not yet be set. In that
10221 : : case, return. Resolution will be called later manually again when
10222 : : this is done. */
10223 : 12134 : target = sym->assoc->target;
10224 : 12134 : if (!target)
10225 : : return;
10226 : 7177 : gcc_assert (!sym->assoc->dangling);
10227 : :
10228 : 7177 : if (target->expr_type == EXPR_OP
10229 : 198 : && target->value.op.op == INTRINSIC_PARENTHESES
10230 : 42 : && target->value.op.op1->expr_type == EXPR_VARIABLE)
10231 : : {
10232 : 23 : sym->assoc->target = gfc_copy_expr (target->value.op.op1);
10233 : 23 : gfc_free_expr (target);
10234 : 23 : target = sym->assoc->target;
10235 : 23 : parentheses = true;
10236 : : }
10237 : :
10238 : 7177 : if (resolve_target && !gfc_resolve_expr (target))
10239 : : return;
10240 : :
10241 : 7173 : if (sym->assoc->ar)
10242 : : {
10243 : : int dim;
10244 : : gfc_array_ref *ar = sym->assoc->ar;
10245 : 65 : for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
10246 : : {
10247 : 39 : if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
10248 : 39 : && ar->start[dim]->ts.type == BT_INTEGER)
10249 : 78 : || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
10250 : 39 : && ar->end[dim]->ts.type == BT_INTEGER))
10251 : 0 : gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
10252 : : "remapping of associate name %s at %L",
10253 : : sym->name, &sym->declared_at);
10254 : : }
10255 : : }
10256 : :
10257 : : /* For variable targets, we get some attributes from the target. */
10258 : 7173 : if (target->expr_type == EXPR_VARIABLE)
10259 : : {
10260 : 6337 : gfc_symbol *tsym, *dsym;
10261 : :
10262 : 6337 : gcc_assert (target->symtree);
10263 : 6337 : tsym = target->symtree->n.sym;
10264 : :
10265 : 6337 : if (gfc_expr_attr (target).proc_pointer)
10266 : : {
10267 : 0 : gfc_error ("Associating entity %qs at %L is a procedure pointer",
10268 : : tsym->name, &target->where);
10269 : 0 : return;
10270 : : }
10271 : :
10272 : 74 : if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
10273 : 2 : && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
10274 : 6338 : && dsym->attr.flavor == FL_DERIVED)
10275 : : {
10276 : 1 : gfc_error ("Derived type %qs cannot be used as a variable at %L",
10277 : : tsym->name, &target->where);
10278 : 1 : return;
10279 : : }
10280 : :
10281 : 6336 : if (tsym->attr.flavor == FL_PROCEDURE)
10282 : : {
10283 : 73 : bool is_error = true;
10284 : 73 : if (tsym->attr.function && tsym->result == tsym)
10285 : 141 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
10286 : 137 : if (tsym == ns->proc_name)
10287 : : {
10288 : : is_error = false;
10289 : : break;
10290 : : }
10291 : 64 : if (is_error)
10292 : : {
10293 : 13 : gfc_error ("Associating entity %qs at %L is a procedure name",
10294 : : tsym->name, &target->where);
10295 : 13 : return;
10296 : : }
10297 : : }
10298 : :
10299 : 6323 : sym->attr.asynchronous = tsym->attr.asynchronous;
10300 : 6323 : sym->attr.volatile_ = tsym->attr.volatile_;
10301 : :
10302 : 12646 : sym->attr.target = tsym->attr.target
10303 : 6323 : || gfc_expr_attr (target).pointer;
10304 : 6323 : if (is_subref_array (target))
10305 : 378 : sym->attr.subref_array_pointer = 1;
10306 : : }
10307 : 836 : else if (target->ts.type == BT_PROCEDURE)
10308 : : {
10309 : 0 : gfc_error ("Associating selector-expression at %L yields a procedure",
10310 : : &target->where);
10311 : 0 : return;
10312 : : }
10313 : :
10314 : 7159 : if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
10315 : : {
10316 : : /* By now, the type of the target has been fixed up. */
10317 : 284 : symbol_attribute attr;
10318 : :
10319 : 284 : if (sym->ts.type == BT_DERIVED
10320 : 157 : && target->ts.type == BT_CLASS
10321 : 31 : && !UNLIMITED_POLY (target))
10322 : : {
10323 : : /* Inferred to be derived type but the target has type class. */
10324 : 31 : sym->ts = CLASS_DATA (target)->ts;
10325 : 31 : if (!sym->as)
10326 : 31 : sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
10327 : 31 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10328 : 31 : sym->attr.dimension = target->rank ? 1 : 0;
10329 : 31 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10330 : : target->corank);
10331 : 31 : sym->as = NULL;
10332 : : }
10333 : 253 : else if (target->ts.type == BT_DERIVED
10334 : 126 : && target->symtree && target->symtree->n.sym
10335 : 102 : && target->symtree->n.sym->ts.type == BT_CLASS
10336 : 0 : && IS_INFERRED_TYPE (target)
10337 : 0 : && target->ref && target->ref->next
10338 : 0 : && target->ref->next->type == REF_ARRAY
10339 : 0 : && !target->ref->next->next)
10340 : : {
10341 : : /* A inferred type selector whose symbol has been determined to be
10342 : : a class array but which only has an array reference. Change the
10343 : : associate name and the selector to class type. */
10344 : 0 : sym->ts = target->ts;
10345 : 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10346 : 0 : sym->attr.dimension = target->rank ? 1 : 0;
10347 : 0 : gfc_change_class (&sym->ts, &attr, sym->as, target->rank,
10348 : : target->corank);
10349 : 0 : sym->as = NULL;
10350 : 0 : target->ts = sym->ts;
10351 : : }
10352 : 253 : else if ((target->ts.type == BT_DERIVED)
10353 : 127 : || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
10354 : 61 : && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
10355 : : /* Confirmed to be either a derived type or misidentified to be a
10356 : : scalar class object, when the selector is a class array. */
10357 : 132 : sym->ts = target->ts;
10358 : : }
10359 : :
10360 : :
10361 : 7159 : if (target->expr_type == EXPR_NULL)
10362 : : {
10363 : 1 : gfc_error ("Selector at %L cannot be NULL()", &target->where);
10364 : 1 : return;
10365 : : }
10366 : 7158 : else if (target->ts.type == BT_UNKNOWN)
10367 : : {
10368 : 2 : gfc_error ("Selector at %L has no type", &target->where);
10369 : 2 : return;
10370 : : }
10371 : :
10372 : : /* Get type if this was not already set. Note that it can be
10373 : : some other type than the target in case this is a SELECT TYPE
10374 : : selector! So we must not update when the type is already there. */
10375 : 7156 : if (sym->ts.type == BT_UNKNOWN)
10376 : 208 : sym->ts = target->ts;
10377 : :
10378 : 7156 : gcc_assert (sym->ts.type != BT_UNKNOWN);
10379 : :
10380 : : /* See if this is a valid association-to-variable. */
10381 : 14312 : sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
10382 : 6323 : && !parentheses
10383 : 6302 : && !gfc_has_vector_subscript (target))
10384 : 7198 : || gfc_is_ptr_fcn (target));
10385 : :
10386 : : /* Finally resolve if this is an array or not. */
10387 : 7156 : if (target->expr_type == EXPR_FUNCTION
10388 : 425 : && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
10389 : : {
10390 : 297 : gfc_expression_rank (target);
10391 : 297 : if (target->ts.type == BT_DERIVED
10392 : 129 : && !sym->as
10393 : 63 : && target->symtree->n.sym->as)
10394 : : {
10395 : 24 : sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
10396 : 24 : sym->attr.dimension = 1;
10397 : : }
10398 : 273 : else if (target->ts.type == BT_CLASS
10399 : 168 : && CLASS_DATA (target)->as)
10400 : : {
10401 : 121 : target->rank = CLASS_DATA (target)->as->rank;
10402 : 121 : target->corank = CLASS_DATA (target)->as->corank;
10403 : 121 : if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
10404 : : {
10405 : 0 : sym->ts = target->ts;
10406 : 0 : sym->attr.dimension = 0;
10407 : : }
10408 : : }
10409 : : }
10410 : :
10411 : :
10412 : 7156 : if (sym->attr.dimension && target->rank == 0)
10413 : : {
10414 : : /* primary.cc makes the assumption that a reference to an associate
10415 : : name followed by a left parenthesis is an array reference. */
10416 : 17 : if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
10417 : : {
10418 : 12 : gfc_expression_rank (sym->assoc->target);
10419 : 12 : sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
10420 : 12 : if (!sym->attr.dimension && sym->as)
10421 : 0 : sym->as = NULL;
10422 : : }
10423 : :
10424 : 17 : if (sym->attr.dimension && target->rank == 0)
10425 : : {
10426 : 5 : if (sym->ts.type != BT_CHARACTER)
10427 : 5 : gfc_error ("Associate-name %qs at %L is used as array",
10428 : : sym->name, &sym->declared_at);
10429 : 5 : sym->attr.dimension = 0;
10430 : 5 : return;
10431 : : }
10432 : : }
10433 : :
10434 : : /* We cannot deal with class selectors that need temporaries. */
10435 : 7151 : if (target->ts.type == BT_CLASS
10436 : 7151 : && gfc_ref_needs_temporary_p (target->ref))
10437 : : {
10438 : 1 : gfc_error ("CLASS selector at %L needs a temporary which is not "
10439 : : "yet implemented", &target->where);
10440 : 1 : return;
10441 : : }
10442 : :
10443 : 7150 : if (target->ts.type == BT_CLASS)
10444 : 2676 : gfc_fix_class_refs (target);
10445 : :
10446 : 7150 : if ((target->rank > 0 || target->corank > 0)
10447 : 2612 : && !sym->attr.select_rank_temporary)
10448 : : {
10449 : 2612 : gfc_array_spec *as;
10450 : : /* The rank may be incorrectly guessed at parsing, therefore make sure
10451 : : it is corrected now. */
10452 : 2612 : if (sym->ts.type != BT_CLASS
10453 : 2057 : && (!sym->as || sym->as->corank != target->corank))
10454 : : {
10455 : 104 : if (!sym->as)
10456 : 97 : sym->as = gfc_get_array_spec ();
10457 : 104 : as = sym->as;
10458 : 104 : as->rank = target->rank;
10459 : 104 : as->type = AS_DEFERRED;
10460 : 104 : as->corank = target->corank;
10461 : 104 : sym->attr.dimension = 1;
10462 : 104 : if (as->corank != 0)
10463 : 7 : sym->attr.codimension = 1;
10464 : : }
10465 : 2508 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
10466 : 554 : && (!CLASS_DATA (sym)->as
10467 : 554 : || CLASS_DATA (sym)->as->corank != target->corank))
10468 : : {
10469 : 0 : if (!CLASS_DATA (sym)->as)
10470 : 0 : CLASS_DATA (sym)->as = gfc_get_array_spec ();
10471 : 0 : as = CLASS_DATA (sym)->as;
10472 : 0 : as->rank = target->rank;
10473 : 0 : as->type = AS_DEFERRED;
10474 : 0 : as->corank = target->corank;
10475 : 0 : CLASS_DATA (sym)->attr.dimension = 1;
10476 : 0 : if (as->corank != 0)
10477 : 0 : CLASS_DATA (sym)->attr.codimension = 1;
10478 : : }
10479 : : }
10480 : 4538 : else if (!sym->attr.select_rank_temporary)
10481 : : {
10482 : : /* target's rank is 0, but the type of the sym is still array valued,
10483 : : which has to be corrected. */
10484 : 3155 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived
10485 : 653 : && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
10486 : : {
10487 : 24 : gfc_array_spec *as;
10488 : 24 : symbol_attribute attr;
10489 : : /* The associated variable's type is still the array type
10490 : : correct this now. */
10491 : 24 : gfc_typespec *ts = &target->ts;
10492 : 24 : gfc_ref *ref;
10493 : : /* Internal_ref is true, when this is ref'ing only _data and co-ref.
10494 : : */
10495 : 24 : bool internal_ref = true;
10496 : :
10497 : 72 : for (ref = target->ref; ref != NULL; ref = ref->next)
10498 : : {
10499 : 48 : switch (ref->type)
10500 : : {
10501 : 24 : case REF_COMPONENT:
10502 : 24 : ts = &ref->u.c.component->ts;
10503 : 24 : internal_ref
10504 : 24 : = target->ref == ref && ref->next
10505 : 48 : && strncmp ("_data", ref->u.c.component->name, 5) == 0;
10506 : : break;
10507 : 24 : case REF_ARRAY:
10508 : 24 : if (ts->type == BT_CLASS)
10509 : 0 : ts = &ts->u.derived->components->ts;
10510 : 24 : if (internal_ref && ref->u.ar.codimen > 0)
10511 : 0 : for (int i = ref->u.ar.dimen;
10512 : : internal_ref
10513 : 0 : && i < ref->u.ar.dimen + ref->u.ar.codimen;
10514 : : ++i)
10515 : 0 : internal_ref
10516 : 0 : = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
10517 : : break;
10518 : : default:
10519 : : break;
10520 : : }
10521 : : }
10522 : : /* Only rewrite the type of this symbol, when the refs are not the
10523 : : internal ones for class and co-array this-image. */
10524 : 24 : if (!internal_ref)
10525 : : {
10526 : : /* Create a scalar instance of the current class type. Because
10527 : : the rank of a class array goes into its name, the type has to
10528 : : be rebuilt. The alternative of (re-)setting just the
10529 : : attributes and as in the current type, destroys the type also
10530 : : in other places. */
10531 : 0 : as = NULL;
10532 : 0 : sym->ts = *ts;
10533 : 0 : sym->ts.type = BT_CLASS;
10534 : 0 : attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
10535 : 0 : gfc_change_class (&sym->ts, &attr, as, 0, 0);
10536 : 0 : sym->as = NULL;
10537 : : }
10538 : : }
10539 : : }
10540 : :
10541 : : /* Mark this as an associate variable. */
10542 : 7150 : sym->attr.associate_var = 1;
10543 : :
10544 : : /* Fix up the type-spec for CHARACTER types. */
10545 : 7150 : if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
10546 : : {
10547 : 442 : gfc_ref *ref;
10548 : 709 : for (ref = target->ref; ref; ref = ref->next)
10549 : 293 : if (ref->type == REF_SUBSTRING
10550 : 68 : && (ref->u.ss.start == NULL
10551 : 68 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
10552 : 68 : || ref->u.ss.end == NULL
10553 : 48 : || ref->u.ss.end->expr_type != EXPR_CONSTANT))
10554 : : break;
10555 : :
10556 : 442 : if (!sym->ts.u.cl)
10557 : 122 : sym->ts.u.cl = target->ts.u.cl;
10558 : :
10559 : 442 : if (sym->ts.deferred
10560 : 189 : && sym->ts.u.cl == target->ts.u.cl)
10561 : : {
10562 : 110 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10563 : 110 : sym->ts.deferred = 1;
10564 : : }
10565 : :
10566 : 442 : if (!sym->ts.u.cl->length
10567 : 326 : && !sym->ts.deferred
10568 : 137 : && target->expr_type == EXPR_CONSTANT)
10569 : : {
10570 : 30 : sym->ts.u.cl->length =
10571 : 30 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
10572 : : target->value.character.length);
10573 : : }
10574 : 412 : else if (((!sym->ts.u.cl->length
10575 : 116 : || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10576 : 302 : && target->expr_type != EXPR_VARIABLE)
10577 : 290 : || ref)
10578 : : {
10579 : 148 : if (!sym->ts.deferred)
10580 : : {
10581 : 44 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
10582 : 44 : sym->ts.deferred = 1;
10583 : : }
10584 : :
10585 : : /* This is reset in trans-stmt.cc after the assignment
10586 : : of the target expression to the associate name. */
10587 : 148 : if (ref && sym->as)
10588 : 26 : sym->attr.pointer = 1;
10589 : : else
10590 : 122 : sym->attr.allocatable = 1;
10591 : : }
10592 : : }
10593 : :
10594 : 7150 : if (sym->ts.type == BT_CLASS
10595 : 1353 : && IS_INFERRED_TYPE (target)
10596 : 13 : && target->ts.type == BT_DERIVED
10597 : 0 : && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
10598 : 0 : && target->ref && target->ref->next && !target->ref->next->next
10599 : 0 : && target->ref->next->type == REF_ARRAY)
10600 : 0 : target->ts = target->symtree->n.sym->ts;
10601 : :
10602 : : /* If the target is a good class object, so is the associate variable. */
10603 : 7150 : if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
10604 : 666 : sym->attr.class_ok = 1;
10605 : : }
10606 : :
10607 : :
10608 : : /* Ensure that SELECT TYPE expressions have the correct rank and a full
10609 : : array reference, where necessary. The symbols are artificial and so
10610 : : the dimension attribute and arrayspec can also be set. In addition,
10611 : : sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
10612 : : This is corrected here as well.*/
10613 : :
10614 : : static void
10615 : 1644 : fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, int corank,
10616 : : gfc_ref *ref)
10617 : : {
10618 : 1644 : gfc_ref *nref = (*expr1)->ref;
10619 : 1644 : gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
10620 : 1644 : gfc_symbol *sym2;
10621 : 1644 : gfc_expr *selector = gfc_copy_expr (expr2);
10622 : :
10623 : 1644 : (*expr1)->rank = rank;
10624 : 1644 : (*expr1)->corank = corank;
10625 : 1644 : if (selector)
10626 : : {
10627 : 309 : gfc_resolve_expr (selector);
10628 : 309 : if (selector->expr_type == EXPR_OP
10629 : 2 : && selector->value.op.op == INTRINSIC_PARENTHESES)
10630 : 2 : sym2 = selector->value.op.op1->symtree->n.sym;
10631 : 307 : else if (selector->expr_type == EXPR_VARIABLE
10632 : 7 : || selector->expr_type == EXPR_FUNCTION)
10633 : 307 : sym2 = selector->symtree->n.sym;
10634 : : else
10635 : 0 : gcc_unreachable ();
10636 : : }
10637 : : else
10638 : : sym2 = NULL;
10639 : :
10640 : 1644 : if (sym1->ts.type == BT_CLASS)
10641 : : {
10642 : 1644 : if ((*expr1)->ts.type != BT_CLASS)
10643 : 13 : (*expr1)->ts = sym1->ts;
10644 : :
10645 : 1644 : CLASS_DATA (sym1)->attr.dimension = rank > 0 ? 1 : 0;
10646 : 1644 : CLASS_DATA (sym1)->attr.codimension = corank > 0 ? 1 : 0;
10647 : 1644 : if (CLASS_DATA (sym1)->as == NULL && sym2)
10648 : 1 : CLASS_DATA (sym1)->as
10649 : 1 : = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
10650 : : }
10651 : : else
10652 : : {
10653 : 0 : sym1->attr.dimension = rank > 0 ? 1 : 0;
10654 : 0 : sym1->attr.codimension = corank > 0 ? 1 : 0;
10655 : 0 : if (sym1->as == NULL && sym2)
10656 : 0 : sym1->as = gfc_copy_array_spec (sym2->as);
10657 : : }
10658 : :
10659 : 2973 : for (; nref; nref = nref->next)
10660 : 2664 : if (nref->next == NULL)
10661 : : break;
10662 : :
10663 : 1644 : if (ref && nref && nref->type != REF_ARRAY)
10664 : 6 : nref->next = gfc_copy_ref (ref);
10665 : 1638 : else if (ref && !nref)
10666 : 300 : (*expr1)->ref = gfc_copy_ref (ref);
10667 : 1338 : else if (ref && nref->u.ar.codimen != corank)
10668 : : {
10669 : 912 : for (int i = nref->u.ar.dimen; i < GFC_MAX_DIMENSIONS; ++i)
10670 : 855 : nref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
10671 : 57 : nref->u.ar.codimen = corank;
10672 : : }
10673 : 1644 : }
10674 : :
10675 : :
10676 : : static gfc_expr *
10677 : 6385 : build_loc_call (gfc_expr *sym_expr)
10678 : : {
10679 : 6385 : gfc_expr *loc_call;
10680 : 6385 : loc_call = gfc_get_expr ();
10681 : 6385 : loc_call->expr_type = EXPR_FUNCTION;
10682 : 6385 : gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
10683 : 6385 : loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
10684 : 6385 : loc_call->symtree->n.sym->attr.intrinsic = 1;
10685 : 6385 : loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
10686 : 6385 : gfc_commit_symbol (loc_call->symtree->n.sym);
10687 : 6385 : loc_call->ts.type = BT_INTEGER;
10688 : 6385 : loc_call->ts.kind = gfc_index_integer_kind;
10689 : 6385 : loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
10690 : 6385 : loc_call->value.function.actual = gfc_get_actual_arglist ();
10691 : 6385 : loc_call->value.function.actual->expr = sym_expr;
10692 : 6385 : loc_call->where = sym_expr->where;
10693 : 6385 : return loc_call;
10694 : : }
10695 : :
10696 : : /* Resolve a SELECT TYPE statement. */
10697 : :
10698 : : static void
10699 : 2857 : resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
10700 : : {
10701 : 2857 : gfc_symbol *selector_type;
10702 : 2857 : gfc_code *body, *new_st, *if_st, *tail;
10703 : 2857 : gfc_code *class_is = NULL, *default_case = NULL;
10704 : 2857 : gfc_case *c;
10705 : 2857 : gfc_symtree *st;
10706 : 2857 : char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
10707 : 2857 : gfc_namespace *ns;
10708 : 2857 : int error = 0;
10709 : 2857 : int rank = 0, corank = 0;
10710 : 2857 : gfc_ref* ref = NULL;
10711 : 2857 : gfc_expr *selector_expr = NULL;
10712 : :
10713 : 2857 : ns = code->ext.block.ns;
10714 : 2857 : if (code->expr2)
10715 : : {
10716 : : /* Set this, or coarray checks in resolve will fail. */
10717 : 614 : code->expr1->symtree->n.sym->attr.select_type_temporary = 1;
10718 : : }
10719 : 2857 : gfc_resolve (ns);
10720 : :
10721 : : /* Check for F03:C813. */
10722 : 2857 : if (code->expr1->ts.type != BT_CLASS
10723 : 36 : && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
10724 : : {
10725 : 13 : gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
10726 : : "at %L", &code->loc);
10727 : 41 : return;
10728 : : }
10729 : :
10730 : : /* Prevent segfault, when class type is not initialized due to previous
10731 : : error. */
10732 : 2844 : if (!code->expr1->symtree->n.sym->attr.class_ok
10733 : 2842 : || (code->expr1->ts.type == BT_CLASS && !code->expr1->ts.u.derived))
10734 : : return;
10735 : :
10736 : 2837 : if (code->expr2)
10737 : : {
10738 : 605 : gfc_ref *ref2 = NULL;
10739 : 1430 : for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
10740 : 825 : if (ref->type == REF_COMPONENT
10741 : 425 : && ref->u.c.component->ts.type == BT_CLASS)
10742 : 825 : ref2 = ref;
10743 : :
10744 : 605 : if (ref2)
10745 : : {
10746 : 333 : if (code->expr1->symtree->n.sym->attr.untyped)
10747 : 1 : code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
10748 : 333 : selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
10749 : : }
10750 : : else
10751 : : {
10752 : 272 : if (code->expr1->symtree->n.sym->attr.untyped)
10753 : 28 : code->expr1->symtree->n.sym->ts = code->expr2->ts;
10754 : : /* Sometimes the selector expression is given the typespec of the
10755 : : '_data' field, which is logical enough but inappropriate here. */
10756 : 272 : if (code->expr2->ts.type == BT_DERIVED
10757 : 80 : && code->expr2->symtree
10758 : 80 : && code->expr2->symtree->n.sym->ts.type == BT_CLASS)
10759 : 80 : code->expr2->ts = code->expr2->symtree->n.sym->ts;
10760 : 272 : selector_type = CLASS_DATA (code->expr2)
10761 : 272 : ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
10762 : : }
10763 : :
10764 : 605 : if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->as)
10765 : : {
10766 : 295 : CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
10767 : 295 : CLASS_DATA (code->expr1)->as->corank = code->expr2->corank;
10768 : 295 : CLASS_DATA (code->expr1)->as->cotype = AS_DEFERRED;
10769 : : }
10770 : :
10771 : : /* F2008: C803 The selector expression must not be coindexed. */
10772 : 605 : if (gfc_is_coindexed (code->expr2))
10773 : : {
10774 : 3 : gfc_error ("Selector at %L must not be coindexed",
10775 : 3 : &code->expr2->where);
10776 : 3 : return;
10777 : : }
10778 : :
10779 : : }
10780 : : else
10781 : : {
10782 : 2232 : selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
10783 : :
10784 : 2232 : if (gfc_is_coindexed (code->expr1))
10785 : : {
10786 : 0 : gfc_error ("Selector at %L must not be coindexed",
10787 : 0 : &code->expr1->where);
10788 : 0 : return;
10789 : : }
10790 : : }
10791 : :
10792 : : /* Loop over TYPE IS / CLASS IS cases. */
10793 : 7957 : for (body = code->block; body; body = body->block)
10794 : : {
10795 : 5124 : c = body->ext.block.case_list;
10796 : :
10797 : 5124 : if (!error)
10798 : : {
10799 : : /* Check for repeated cases. */
10800 : 7966 : for (tail = code->block; tail; tail = tail->block)
10801 : : {
10802 : 7966 : gfc_case *d = tail->ext.block.case_list;
10803 : 7966 : if (tail == body)
10804 : : break;
10805 : :
10806 : 2851 : if (c->ts.type == d->ts.type
10807 : 513 : && ((c->ts.type == BT_DERIVED
10808 : 415 : && c->ts.u.derived && d->ts.u.derived
10809 : 415 : && !strcmp (c->ts.u.derived->name,
10810 : : d->ts.u.derived->name))
10811 : 512 : || c->ts.type == BT_UNKNOWN
10812 : 512 : || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10813 : 55 : && c->ts.kind == d->ts.kind)))
10814 : : {
10815 : 1 : gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
10816 : : &c->where, &d->where);
10817 : 1 : return;
10818 : : }
10819 : : }
10820 : : }
10821 : :
10822 : : /* Check F03:C815. */
10823 : 3218 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10824 : 2215 : && selector_type
10825 : 2215 : && !selector_type->attr.unlimited_polymorphic
10826 : 7043 : && !gfc_type_is_extensible (c->ts.u.derived))
10827 : : {
10828 : 1 : gfc_error ("Derived type %qs at %L must be extensible",
10829 : 1 : c->ts.u.derived->name, &c->where);
10830 : 1 : error++;
10831 : 1 : continue;
10832 : : }
10833 : :
10834 : : /* Check F03:C816. */
10835 : 5128 : if (c->ts.type != BT_UNKNOWN
10836 : 3567 : && selector_type && !selector_type->attr.unlimited_polymorphic
10837 : 7045 : && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
10838 : 1919 : || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
10839 : : {
10840 : 6 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10841 : 2 : gfc_error ("Derived type %qs at %L must be an extension of %qs",
10842 : 2 : c->ts.u.derived->name, &c->where, selector_type->name);
10843 : : else
10844 : 4 : gfc_error ("Unexpected intrinsic type %qs at %L",
10845 : : gfc_basic_typename (c->ts.type), &c->where);
10846 : 6 : error++;
10847 : 6 : continue;
10848 : : }
10849 : :
10850 : : /* Check F03:C814. */
10851 : 5116 : if (c->ts.type == BT_CHARACTER
10852 : 730 : && (c->ts.u.cl->length != NULL || c->ts.deferred))
10853 : : {
10854 : 0 : gfc_error ("The type-spec at %L shall specify that each length "
10855 : : "type parameter is assumed", &c->where);
10856 : 0 : error++;
10857 : 0 : continue;
10858 : : }
10859 : :
10860 : : /* Intercept the DEFAULT case. */
10861 : 5116 : if (c->ts.type == BT_UNKNOWN)
10862 : : {
10863 : : /* Check F03:C818. */
10864 : 1555 : if (default_case)
10865 : : {
10866 : 1 : gfc_error ("The DEFAULT CASE at %L cannot be followed "
10867 : : "by a second DEFAULT CASE at %L",
10868 : 1 : &default_case->ext.block.case_list->where, &c->where);
10869 : 1 : error++;
10870 : 1 : continue;
10871 : : }
10872 : :
10873 : : default_case = body;
10874 : : }
10875 : : }
10876 : :
10877 : 2833 : if (error > 0)
10878 : : return;
10879 : :
10880 : : /* Transform SELECT TYPE statement to BLOCK and associate selector to
10881 : : target if present. If there are any EXIT statements referring to the
10882 : : SELECT TYPE construct, this is no problem because the gfc_code
10883 : : reference stays the same and EXIT is equally possible from the BLOCK
10884 : : it is changed to. */
10885 : 2830 : code->op = EXEC_BLOCK;
10886 : 2830 : if (code->expr2)
10887 : : {
10888 : 602 : gfc_association_list* assoc;
10889 : :
10890 : 602 : assoc = gfc_get_association_list ();
10891 : 602 : assoc->st = code->expr1->symtree;
10892 : 602 : assoc->target = gfc_copy_expr (code->expr2);
10893 : 602 : assoc->target->where = code->expr2->where;
10894 : : /* assoc->variable will be set by resolve_assoc_var. */
10895 : :
10896 : 602 : code->ext.block.assoc = assoc;
10897 : 602 : code->expr1->symtree->n.sym->assoc = assoc;
10898 : :
10899 : 602 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
10900 : : }
10901 : : else
10902 : 2228 : code->ext.block.assoc = NULL;
10903 : :
10904 : : /* Ensure that the selector rank and arrayspec are available to
10905 : : correct expressions in which they might be missing. */
10906 : 2830 : if (code->expr2 && (code->expr2->rank || code->expr2->corank))
10907 : : {
10908 : 309 : rank = code->expr2->rank;
10909 : 309 : corank = code->expr2->corank;
10910 : 582 : for (ref = code->expr2->ref; ref; ref = ref->next)
10911 : 573 : if (ref->next == NULL)
10912 : : break;
10913 : 309 : if (ref && ref->type == REF_ARRAY)
10914 : 300 : ref = gfc_copy_ref (ref);
10915 : :
10916 : : /* Fixup expr1 if necessary. */
10917 : 309 : if (rank || corank)
10918 : 309 : fixup_array_ref (&code->expr1, code->expr2, rank, corank, ref);
10919 : : }
10920 : 2521 : else if (code->expr1->rank || code->expr1->corank)
10921 : : {
10922 : 827 : rank = code->expr1->rank;
10923 : 827 : corank = code->expr1->corank;
10924 : 827 : for (ref = code->expr1->ref; ref; ref = ref->next)
10925 : 827 : if (ref->next == NULL)
10926 : : break;
10927 : 827 : if (ref && ref->type == REF_ARRAY)
10928 : 827 : ref = gfc_copy_ref (ref);
10929 : : }
10930 : :
10931 : : /* Add EXEC_SELECT to switch on type. */
10932 : 2830 : new_st = gfc_get_code (code->op);
10933 : 2830 : new_st->expr1 = code->expr1;
10934 : 2830 : new_st->expr2 = code->expr2;
10935 : 2830 : new_st->block = code->block;
10936 : 2830 : code->expr1 = code->expr2 = NULL;
10937 : 2830 : code->block = NULL;
10938 : 2830 : if (!ns->code)
10939 : 2830 : ns->code = new_st;
10940 : : else
10941 : 0 : ns->code->next = new_st;
10942 : 2830 : code = new_st;
10943 : 2830 : code->op = EXEC_SELECT_TYPE;
10944 : :
10945 : : /* Use the intrinsic LOC function to generate an integer expression
10946 : : for the vtable of the selector. Note that the rank of the selector
10947 : : expression has to be set to zero. */
10948 : 2830 : gfc_add_vptr_component (code->expr1);
10949 : 2830 : code->expr1->rank = 0;
10950 : 2830 : code->expr1->corank = 0;
10951 : 2830 : code->expr1 = build_loc_call (code->expr1);
10952 : 2830 : selector_expr = code->expr1->value.function.actual->expr;
10953 : :
10954 : : /* Loop over TYPE IS / CLASS IS cases. */
10955 : 7938 : for (body = code->block; body; body = body->block)
10956 : : {
10957 : 5108 : gfc_symbol *vtab;
10958 : 5108 : gfc_expr *e;
10959 : 5108 : c = body->ext.block.case_list;
10960 : :
10961 : : /* Generate an index integer expression for address of the
10962 : : TYPE/CLASS vtable and store it in c->low. The hash expression
10963 : : is stored in c->high and is used to resolve intrinsic cases. */
10964 : 5108 : if (c->ts.type != BT_UNKNOWN)
10965 : : {
10966 : 3555 : if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
10967 : : {
10968 : 2206 : vtab = gfc_find_derived_vtab (c->ts.u.derived);
10969 : 2206 : gcc_assert (vtab);
10970 : 2206 : c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
10971 : 2206 : c->ts.u.derived->hash_value);
10972 : : }
10973 : : else
10974 : : {
10975 : 1349 : vtab = gfc_find_vtab (&c->ts);
10976 : 1349 : gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
10977 : 1349 : e = CLASS_DATA (vtab)->initializer;
10978 : 1349 : c->high = gfc_copy_expr (e);
10979 : 1349 : if (c->high->ts.kind != gfc_integer_4_kind)
10980 : : {
10981 : 1 : gfc_typespec ts;
10982 : 1 : ts.kind = gfc_integer_4_kind;
10983 : 1 : ts.type = BT_INTEGER;
10984 : 1 : gfc_convert_type_warn (c->high, &ts, 2, 0);
10985 : : }
10986 : : }
10987 : :
10988 : 3555 : e = gfc_lval_expr_from_sym (vtab);
10989 : 3555 : c->low = build_loc_call (e);
10990 : : }
10991 : : else
10992 : 1553 : continue;
10993 : :
10994 : : /* Associate temporary to selector. This should only be done
10995 : : when this case is actually true, so build a new ASSOCIATE
10996 : : that does precisely this here (instead of using the
10997 : : 'global' one). */
10998 : :
10999 : 3555 : if (c->ts.type == BT_CLASS)
11000 : 308 : sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
11001 : 3247 : else if (c->ts.type == BT_DERIVED)
11002 : 1898 : sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
11003 : 1349 : else if (c->ts.type == BT_CHARACTER)
11004 : : {
11005 : 730 : HOST_WIDE_INT charlen = 0;
11006 : 730 : if (c->ts.u.cl && c->ts.u.cl->length
11007 : 0 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11008 : 0 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11009 : 730 : snprintf (name, sizeof (name),
11010 : : "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11011 : : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11012 : : }
11013 : : else
11014 : 619 : sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
11015 : : c->ts.kind);
11016 : :
11017 : 3555 : st = gfc_find_symtree (ns->sym_root, name);
11018 : 3555 : gcc_assert (st->n.sym->assoc);
11019 : 3555 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11020 : 3555 : st->n.sym->assoc->target->where = selector_expr->where;
11021 : 3555 : if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
11022 : : {
11023 : 3247 : gfc_add_data_component (st->n.sym->assoc->target);
11024 : : /* Fixup the target expression if necessary. */
11025 : 3247 : if (rank || corank)
11026 : 1335 : fixup_array_ref (&st->n.sym->assoc->target, nullptr, rank, corank,
11027 : : ref);
11028 : : }
11029 : :
11030 : 3555 : new_st = gfc_get_code (EXEC_BLOCK);
11031 : 3555 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11032 : 3555 : new_st->ext.block.ns->code = body->next;
11033 : 3555 : body->next = new_st;
11034 : :
11035 : : /* Chain in the new list only if it is marked as dangling. Otherwise
11036 : : there is a CASE label overlap and this is already used. Just ignore,
11037 : : the error is diagnosed elsewhere. */
11038 : 3555 : if (st->n.sym->assoc->dangling)
11039 : : {
11040 : 3554 : new_st->ext.block.assoc = st->n.sym->assoc;
11041 : 3554 : st->n.sym->assoc->dangling = 0;
11042 : : }
11043 : :
11044 : 3555 : resolve_assoc_var (st->n.sym, false);
11045 : : }
11046 : :
11047 : : /* Take out CLASS IS cases for separate treatment. */
11048 : : body = code;
11049 : 7938 : while (body && body->block)
11050 : : {
11051 : 5108 : if (body->block->ext.block.case_list->ts.type == BT_CLASS)
11052 : : {
11053 : : /* Add to class_is list. */
11054 : 308 : if (class_is == NULL)
11055 : : {
11056 : 277 : class_is = body->block;
11057 : 277 : tail = class_is;
11058 : : }
11059 : : else
11060 : : {
11061 : 43 : for (tail = class_is; tail->block; tail = tail->block) ;
11062 : 31 : tail->block = body->block;
11063 : 31 : tail = tail->block;
11064 : : }
11065 : : /* Remove from EXEC_SELECT list. */
11066 : 308 : body->block = body->block->block;
11067 : 308 : tail->block = NULL;
11068 : : }
11069 : : else
11070 : : body = body->block;
11071 : : }
11072 : :
11073 : 2830 : if (class_is)
11074 : : {
11075 : 277 : gfc_symbol *vtab;
11076 : :
11077 : 277 : if (!default_case)
11078 : : {
11079 : : /* Add a default case to hold the CLASS IS cases. */
11080 : 275 : for (tail = code; tail->block; tail = tail->block) ;
11081 : 167 : tail->block = gfc_get_code (EXEC_SELECT_TYPE);
11082 : 167 : tail = tail->block;
11083 : 167 : tail->ext.block.case_list = gfc_get_case ();
11084 : 167 : tail->ext.block.case_list->ts.type = BT_UNKNOWN;
11085 : 167 : tail->next = NULL;
11086 : 167 : default_case = tail;
11087 : : }
11088 : :
11089 : : /* More than one CLASS IS block? */
11090 : 277 : if (class_is->block)
11091 : : {
11092 : 37 : gfc_code **c1,*c2;
11093 : 37 : bool swapped;
11094 : : /* Sort CLASS IS blocks by extension level. */
11095 : 36 : do
11096 : : {
11097 : 37 : swapped = false;
11098 : 97 : for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
11099 : : {
11100 : 61 : c2 = (*c1)->block;
11101 : : /* F03:C817 (check for doubles). */
11102 : 61 : if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
11103 : 61 : == c2->ext.block.case_list->ts.u.derived->hash_value)
11104 : : {
11105 : 1 : gfc_error ("Double CLASS IS block in SELECT TYPE "
11106 : : "statement at %L",
11107 : : &c2->ext.block.case_list->where);
11108 : 1 : return;
11109 : : }
11110 : 60 : if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
11111 : 60 : < c2->ext.block.case_list->ts.u.derived->attr.extension)
11112 : : {
11113 : : /* Swap. */
11114 : 24 : (*c1)->block = c2->block;
11115 : 24 : c2->block = *c1;
11116 : 24 : *c1 = c2;
11117 : 24 : swapped = true;
11118 : : }
11119 : : }
11120 : : }
11121 : : while (swapped);
11122 : : }
11123 : :
11124 : : /* Generate IF chain. */
11125 : 276 : if_st = gfc_get_code (EXEC_IF);
11126 : 276 : new_st = if_st;
11127 : 582 : for (body = class_is; body; body = body->block)
11128 : : {
11129 : 306 : new_st->block = gfc_get_code (EXEC_IF);
11130 : 306 : new_st = new_st->block;
11131 : : /* Set up IF condition: Call _gfortran_is_extension_of. */
11132 : 306 : new_st->expr1 = gfc_get_expr ();
11133 : 306 : new_st->expr1->expr_type = EXPR_FUNCTION;
11134 : 306 : new_st->expr1->ts.type = BT_LOGICAL;
11135 : 306 : new_st->expr1->ts.kind = 4;
11136 : 306 : new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
11137 : 306 : new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
11138 : 306 : new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
11139 : : /* Set up arguments. */
11140 : 306 : new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
11141 : 306 : new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
11142 : 306 : new_st->expr1->value.function.actual->expr->where = code->loc;
11143 : 306 : new_st->expr1->where = code->loc;
11144 : 306 : gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
11145 : 306 : vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
11146 : 306 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
11147 : 306 : new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
11148 : 306 : new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
11149 : 306 : new_st->expr1->value.function.actual->next->expr->where = code->loc;
11150 : : /* Set up types in formal arg list. */
11151 : 306 : new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
11152 : 306 : new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
11153 : 306 : new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
11154 : 306 : new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
11155 : :
11156 : 306 : new_st->next = body->next;
11157 : : }
11158 : 276 : if (default_case->next)
11159 : : {
11160 : 110 : new_st->block = gfc_get_code (EXEC_IF);
11161 : 110 : new_st = new_st->block;
11162 : 110 : new_st->next = default_case->next;
11163 : : }
11164 : :
11165 : : /* Replace CLASS DEFAULT code by the IF chain. */
11166 : 276 : default_case->next = if_st;
11167 : : }
11168 : :
11169 : : /* Resolve the internal code. This cannot be done earlier because
11170 : : it requires that the sym->assoc of selectors is set already. */
11171 : 2829 : gfc_current_ns = ns;
11172 : 2829 : gfc_resolve_blocks (code->block, gfc_current_ns);
11173 : 2829 : gfc_current_ns = old_ns;
11174 : :
11175 : 2829 : free (ref);
11176 : : }
11177 : :
11178 : :
11179 : : /* Resolve a SELECT RANK statement. */
11180 : :
11181 : : static void
11182 : 1018 : resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
11183 : : {
11184 : 1018 : gfc_namespace *ns;
11185 : 1018 : gfc_code *body, *new_st, *tail;
11186 : 1018 : gfc_case *c;
11187 : 1018 : char tname[GFC_MAX_SYMBOL_LEN + 7];
11188 : 1018 : char name[2 * GFC_MAX_SYMBOL_LEN];
11189 : 1018 : gfc_symtree *st;
11190 : 1018 : gfc_expr *selector_expr = NULL;
11191 : 1018 : int case_value;
11192 : 1018 : HOST_WIDE_INT charlen = 0;
11193 : :
11194 : 1018 : ns = code->ext.block.ns;
11195 : 1018 : gfc_resolve (ns);
11196 : :
11197 : 1018 : code->op = EXEC_BLOCK;
11198 : 1018 : if (code->expr2)
11199 : : {
11200 : 42 : gfc_association_list* assoc;
11201 : :
11202 : 42 : assoc = gfc_get_association_list ();
11203 : 42 : assoc->st = code->expr1->symtree;
11204 : 42 : assoc->target = gfc_copy_expr (code->expr2);
11205 : 42 : assoc->target->where = code->expr2->where;
11206 : : /* assoc->variable will be set by resolve_assoc_var. */
11207 : :
11208 : 42 : code->ext.block.assoc = assoc;
11209 : 42 : code->expr1->symtree->n.sym->assoc = assoc;
11210 : :
11211 : 42 : resolve_assoc_var (code->expr1->symtree->n.sym, false);
11212 : : }
11213 : : else
11214 : 976 : code->ext.block.assoc = NULL;
11215 : :
11216 : : /* Loop over RANK cases. Note that returning on the errors causes a
11217 : : cascade of further errors because the case blocks do not compile
11218 : : correctly. */
11219 : 3320 : for (body = code->block; body; body = body->block)
11220 : : {
11221 : 2302 : c = body->ext.block.case_list;
11222 : 2302 : if (c->low)
11223 : 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11224 : : else
11225 : : case_value = -2;
11226 : :
11227 : : /* Check for repeated cases. */
11228 : 5836 : for (tail = code->block; tail; tail = tail->block)
11229 : : {
11230 : 5836 : gfc_case *d = tail->ext.block.case_list;
11231 : 5836 : int case_value2;
11232 : :
11233 : 5836 : if (tail == body)
11234 : : break;
11235 : :
11236 : : /* Check F2018: C1153. */
11237 : 3534 : if (!c->low && !d->low)
11238 : 1 : gfc_error ("RANK DEFAULT at %L is repeated at %L",
11239 : : &c->where, &d->where);
11240 : :
11241 : 3534 : if (!c->low || !d->low)
11242 : 1253 : continue;
11243 : :
11244 : : /* Check F2018: C1153. */
11245 : 2281 : case_value2 = (int) mpz_get_si (d->low->value.integer);
11246 : 2281 : if ((case_value == case_value2) && case_value == -1)
11247 : 1 : gfc_error ("RANK (*) at %L is repeated at %L",
11248 : : &c->where, &d->where);
11249 : 2280 : else if (case_value == case_value2)
11250 : 1 : gfc_error ("RANK (%i) at %L is repeated at %L",
11251 : : case_value, &c->where, &d->where);
11252 : : }
11253 : :
11254 : 2302 : if (!c->low)
11255 : 919 : continue;
11256 : :
11257 : : /* Check F2018: C1155. */
11258 : 1383 : if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
11259 : 1381 : || gfc_expr_attr (code->expr1).pointer))
11260 : 3 : gfc_error ("RANK (*) at %L cannot be used with the pointer or "
11261 : 3 : "allocatable selector at %L", &c->where, &code->expr1->where);
11262 : : }
11263 : :
11264 : : /* Add EXEC_SELECT to switch on rank. */
11265 : 1018 : new_st = gfc_get_code (code->op);
11266 : 1018 : new_st->expr1 = code->expr1;
11267 : 1018 : new_st->expr2 = code->expr2;
11268 : 1018 : new_st->block = code->block;
11269 : 1018 : code->expr1 = code->expr2 = NULL;
11270 : 1018 : code->block = NULL;
11271 : 1018 : if (!ns->code)
11272 : 1018 : ns->code = new_st;
11273 : : else
11274 : 0 : ns->code->next = new_st;
11275 : 1018 : code = new_st;
11276 : 1018 : code->op = EXEC_SELECT_RANK;
11277 : :
11278 : 1018 : selector_expr = code->expr1;
11279 : :
11280 : : /* Loop over SELECT RANK cases. */
11281 : 3320 : for (body = code->block; body; body = body->block)
11282 : : {
11283 : 2302 : c = body->ext.block.case_list;
11284 : 2302 : int case_value;
11285 : :
11286 : : /* Pass on the default case. */
11287 : 2302 : if (c->low == NULL)
11288 : 919 : continue;
11289 : :
11290 : : /* Associate temporary to selector. This should only be done
11291 : : when this case is actually true, so build a new ASSOCIATE
11292 : : that does precisely this here (instead of using the
11293 : : 'global' one). */
11294 : 1383 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
11295 : 265 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11296 : 186 : charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
11297 : :
11298 : 1383 : if (c->ts.type == BT_CLASS)
11299 : 145 : sprintf (tname, "class_%s", c->ts.u.derived->name);
11300 : 1238 : else if (c->ts.type == BT_DERIVED)
11301 : 110 : sprintf (tname, "type_%s", c->ts.u.derived->name);
11302 : 1128 : else if (c->ts.type != BT_CHARACTER)
11303 : 569 : sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
11304 : : else
11305 : 559 : sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
11306 : : gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
11307 : :
11308 : 1383 : case_value = (int) mpz_get_si (c->low->value.integer);
11309 : 1383 : if (case_value >= 0)
11310 : 1350 : sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
11311 : : else
11312 : 33 : sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
11313 : :
11314 : 1383 : st = gfc_find_symtree (ns->sym_root, name);
11315 : 1383 : gcc_assert (st->n.sym->assoc);
11316 : :
11317 : 1383 : st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
11318 : 1383 : st->n.sym->assoc->target->where = selector_expr->where;
11319 : :
11320 : 1383 : new_st = gfc_get_code (EXEC_BLOCK);
11321 : 1383 : new_st->ext.block.ns = gfc_build_block_ns (ns);
11322 : 1383 : new_st->ext.block.ns->code = body->next;
11323 : 1383 : body->next = new_st;
11324 : :
11325 : : /* Chain in the new list only if it is marked as dangling. Otherwise
11326 : : there is a CASE label overlap and this is already used. Just ignore,
11327 : : the error is diagnosed elsewhere. */
11328 : 1383 : if (st->n.sym->assoc->dangling)
11329 : : {
11330 : 1381 : new_st->ext.block.assoc = st->n.sym->assoc;
11331 : 1381 : st->n.sym->assoc->dangling = 0;
11332 : : }
11333 : :
11334 : 1383 : resolve_assoc_var (st->n.sym, false);
11335 : : }
11336 : :
11337 : 1018 : gfc_current_ns = ns;
11338 : 1018 : gfc_resolve_blocks (code->block, gfc_current_ns);
11339 : 1018 : gfc_current_ns = old_ns;
11340 : 1018 : }
11341 : :
11342 : :
11343 : : /* Resolve a transfer statement. This is making sure that:
11344 : : -- a derived type being transferred has only non-pointer components
11345 : : -- a derived type being transferred doesn't have private components, unless
11346 : : it's being transferred from the module where the type was defined
11347 : : -- we're not trying to transfer a whole assumed size array. */
11348 : :
11349 : : static void
11350 : 44961 : resolve_transfer (gfc_code *code)
11351 : : {
11352 : 44961 : gfc_symbol *sym, *derived;
11353 : 44961 : gfc_ref *ref;
11354 : 44961 : gfc_expr *exp;
11355 : 44961 : bool write = false;
11356 : 44961 : bool formatted = false;
11357 : 44961 : gfc_dt *dt = code->ext.dt;
11358 : 44961 : gfc_symbol *dtio_sub = NULL;
11359 : :
11360 : 44961 : exp = code->expr1;
11361 : :
11362 : 89928 : while (exp != NULL && exp->expr_type == EXPR_OP
11363 : 45852 : && exp->value.op.op == INTRINSIC_PARENTHESES)
11364 : 6 : exp = exp->value.op.op1;
11365 : :
11366 : 44961 : if (exp && exp->expr_type == EXPR_NULL
11367 : 2 : && code->ext.dt)
11368 : : {
11369 : 2 : gfc_error ("Invalid context for NULL () intrinsic at %L",
11370 : : &exp->where);
11371 : 2 : return;
11372 : : }
11373 : :
11374 : : if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
11375 : : && exp->expr_type != EXPR_FUNCTION
11376 : : && exp->expr_type != EXPR_ARRAY
11377 : : && exp->expr_type != EXPR_STRUCTURE))
11378 : : return;
11379 : :
11380 : : /* If we are reading, the variable will be changed. Note that
11381 : : code->ext.dt may be NULL if the TRANSFER is related to
11382 : : an INQUIRE statement -- but in this case, we are not reading, either. */
11383 : 24335 : if (dt && dt->dt_io_kind->value.iokind == M_READ
11384 : 31686 : && !gfc_check_vardef_context (exp, false, false, false,
11385 : 7203 : _("item in READ")))
11386 : : return;
11387 : :
11388 : 24479 : const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
11389 : 24479 : || exp->expr_type == EXPR_FUNCTION
11390 : 20166 : || exp->expr_type == EXPR_ARRAY
11391 : 44645 : ? &exp->ts : &exp->symtree->n.sym->ts;
11392 : :
11393 : : /* Go to actual component transferred. */
11394 : 31740 : for (ref = exp->ref; ref; ref = ref->next)
11395 : 7261 : if (ref->type == REF_COMPONENT)
11396 : 2142 : ts = &ref->u.c.component->ts;
11397 : :
11398 : 24479 : if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
11399 : 24331 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
11400 : : {
11401 : 709 : derived = ts->u.derived;
11402 : :
11403 : : /* Determine when to use the formatted DTIO procedure. */
11404 : 709 : if (dt && (dt->format_expr || dt->format_label))
11405 : 634 : formatted = true;
11406 : :
11407 : 709 : write = dt->dt_io_kind->value.iokind == M_WRITE
11408 : 709 : || dt->dt_io_kind->value.iokind == M_PRINT;
11409 : 709 : dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
11410 : :
11411 : 709 : if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
11412 : : {
11413 : 425 : dt->udtio = exp;
11414 : 425 : sym = exp->symtree->n.sym->ns->proc_name;
11415 : : /* Check to see if this is a nested DTIO call, with the
11416 : : dummy as the io-list object. */
11417 : 425 : if (sym && sym == dtio_sub && sym->formal
11418 : 30 : && sym->formal->sym == exp->symtree->n.sym
11419 : 30 : && exp->ref == NULL)
11420 : : {
11421 : 0 : if (!sym->attr.recursive)
11422 : : {
11423 : 0 : gfc_error ("DTIO %s procedure at %L must be recursive",
11424 : : sym->name, &sym->declared_at);
11425 : 0 : return;
11426 : : }
11427 : : }
11428 : : }
11429 : : }
11430 : :
11431 : 24479 : if (ts->type == BT_CLASS && dtio_sub == NULL)
11432 : : {
11433 : 3 : gfc_error ("Data transfer element at %L cannot be polymorphic unless "
11434 : : "it is processed by a defined input/output procedure",
11435 : : &code->loc);
11436 : 3 : return;
11437 : : }
11438 : :
11439 : 24476 : if (ts->type == BT_DERIVED)
11440 : : {
11441 : : /* Check that transferred derived type doesn't contain POINTER
11442 : : components unless it is processed by a defined input/output
11443 : : procedure". */
11444 : 677 : if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
11445 : : {
11446 : 2 : gfc_error ("Data transfer element at %L cannot have POINTER "
11447 : : "components unless it is processed by a defined "
11448 : : "input/output procedure", &code->loc);
11449 : 2 : return;
11450 : : }
11451 : :
11452 : : /* F08:C935. */
11453 : 675 : if (ts->u.derived->attr.proc_pointer_comp)
11454 : : {
11455 : 2 : gfc_error ("Data transfer element at %L cannot have "
11456 : : "procedure pointer components", &code->loc);
11457 : 2 : return;
11458 : : }
11459 : :
11460 : 673 : if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
11461 : : {
11462 : 6 : gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
11463 : : "components unless it is processed by a defined "
11464 : : "input/output procedure", &code->loc);
11465 : 6 : return;
11466 : : }
11467 : :
11468 : : /* C_PTR and C_FUNPTR have private components which means they cannot
11469 : : be printed. However, if -std=gnu and not -pedantic, allow
11470 : : the component to be printed to help debugging. */
11471 : 667 : if (ts->u.derived->ts.f90_type == BT_VOID)
11472 : : {
11473 : 27 : if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L "
11474 : : "cannot have PRIVATE components", &code->loc))
11475 : : return;
11476 : : }
11477 : 640 : else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
11478 : : {
11479 : 4 : gfc_error ("Data transfer element at %L cannot have "
11480 : : "PRIVATE components unless it is processed by "
11481 : : "a defined input/output procedure", &code->loc);
11482 : 4 : return;
11483 : : }
11484 : : }
11485 : :
11486 : 24458 : if (exp->expr_type == EXPR_STRUCTURE)
11487 : : return;
11488 : :
11489 : 24406 : if (exp->expr_type == EXPR_ARRAY)
11490 : : return;
11491 : :
11492 : 24024 : sym = exp->symtree->n.sym;
11493 : :
11494 : 24024 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
11495 : 75 : && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
11496 : : {
11497 : 1 : gfc_error ("Data transfer element at %L cannot be a full reference to "
11498 : : "an assumed-size array", &code->loc);
11499 : 1 : return;
11500 : : }
11501 : : }
11502 : :
11503 : :
11504 : : /*********** Toplevel code resolution subroutines ***********/
11505 : :
11506 : : /* Find the set of labels that are reachable from this block. We also
11507 : : record the last statement in each block. */
11508 : :
11509 : : static void
11510 : 624078 : find_reachable_labels (gfc_code *block)
11511 : : {
11512 : 624078 : gfc_code *c;
11513 : :
11514 : 624078 : if (!block)
11515 : : return;
11516 : :
11517 : 388569 : cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
11518 : :
11519 : : /* Collect labels in this block. We don't keep those corresponding
11520 : : to END {IF|SELECT}, these are checked in resolve_branch by going
11521 : : up through the code_stack. */
11522 : 1349840 : for (c = block; c; c = c->next)
11523 : : {
11524 : 961271 : if (c->here && c->op != EXEC_END_NESTED_BLOCK)
11525 : 3572 : bitmap_set_bit (cs_base->reachable_labels, c->here->value);
11526 : : }
11527 : :
11528 : : /* Merge with labels from parent block. */
11529 : 388569 : if (cs_base->prev)
11530 : : {
11531 : 315797 : gcc_assert (cs_base->prev->reachable_labels);
11532 : 315797 : bitmap_ior_into (cs_base->reachable_labels,
11533 : : cs_base->prev->reachable_labels);
11534 : : }
11535 : : }
11536 : :
11537 : : static void
11538 : 136 : resolve_lock_unlock_event (gfc_code *code)
11539 : : {
11540 : 136 : if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
11541 : 136 : && (code->expr1->ts.type != BT_DERIVED
11542 : 95 : || code->expr1->expr_type != EXPR_VARIABLE
11543 : 95 : || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11544 : 95 : || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
11545 : 94 : || code->expr1->rank != 0
11546 : 124 : || (!gfc_is_coarray (code->expr1) &&
11547 : 31 : !gfc_is_coindexed (code->expr1))))
11548 : 4 : gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
11549 : 4 : &code->expr1->where);
11550 : 132 : else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
11551 : 39 : && (code->expr1->ts.type != BT_DERIVED
11552 : 39 : || code->expr1->expr_type != EXPR_VARIABLE
11553 : 39 : || code->expr1->ts.u.derived->from_intmod
11554 : : != INTMOD_ISO_FORTRAN_ENV
11555 : 39 : || code->expr1->ts.u.derived->intmod_sym_id
11556 : : != ISOFORTRAN_EVENT_TYPE
11557 : 39 : || code->expr1->rank != 0))
11558 : 0 : gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
11559 : : &code->expr1->where);
11560 : 23 : else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
11561 : 143 : && !gfc_is_coindexed (code->expr1))
11562 : 0 : gfc_error ("Event variable argument at %L must be a coarray or coindexed",
11563 : 0 : &code->expr1->where);
11564 : 132 : else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
11565 : 0 : gfc_error ("Event variable argument at %L must be a coarray but not "
11566 : 0 : "coindexed", &code->expr1->where);
11567 : :
11568 : : /* Check STAT. */
11569 : 136 : if (code->expr2
11570 : 38 : && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
11571 : 38 : || code->expr2->expr_type != EXPR_VARIABLE))
11572 : 0 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
11573 : : &code->expr2->where);
11574 : :
11575 : 136 : if (code->expr2
11576 : 174 : && !gfc_check_vardef_context (code->expr2, false, false, false,
11577 : 38 : _("STAT variable")))
11578 : : return;
11579 : :
11580 : : /* Check ERRMSG. */
11581 : 136 : if (code->expr3
11582 : 2 : && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
11583 : 2 : || code->expr3->expr_type != EXPR_VARIABLE))
11584 : 0 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
11585 : : &code->expr3->where);
11586 : :
11587 : 136 : if (code->expr3
11588 : 138 : && !gfc_check_vardef_context (code->expr3, false, false, false,
11589 : 2 : _("ERRMSG variable")))
11590 : : return;
11591 : :
11592 : : /* Check for LOCK the ACQUIRED_LOCK. */
11593 : 136 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11594 : 16 : && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
11595 : 16 : || code->expr4->expr_type != EXPR_VARIABLE))
11596 : 0 : gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
11597 : : "variable", &code->expr4->where);
11598 : :
11599 : 120 : if (code->op != EXEC_EVENT_WAIT && code->expr4
11600 : 152 : && !gfc_check_vardef_context (code->expr4, false, false, false,
11601 : 16 : _("ACQUIRED_LOCK variable")))
11602 : : return;
11603 : :
11604 : : /* Check for EVENT WAIT the UNTIL_COUNT. */
11605 : 136 : if (code->op == EXEC_EVENT_WAIT && code->expr4)
11606 : : {
11607 : 24 : if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
11608 : 24 : || code->expr4->rank != 0)
11609 : 0 : gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
11610 : 0 : "expression", &code->expr4->where);
11611 : : }
11612 : : }
11613 : :
11614 : :
11615 : : static void
11616 : 33 : resolve_critical (gfc_code *code)
11617 : : {
11618 : 33 : gfc_symtree *symtree;
11619 : 33 : gfc_symbol *lock_type;
11620 : 33 : char name[GFC_MAX_SYMBOL_LEN];
11621 : 33 : static int serial = 0;
11622 : :
11623 : 33 : if (flag_coarray != GFC_FCOARRAY_LIB)
11624 : 28 : return;
11625 : :
11626 : 5 : symtree = gfc_find_symtree (gfc_current_ns->sym_root,
11627 : : GFC_PREFIX ("lock_type"));
11628 : 5 : if (symtree)
11629 : 2 : lock_type = symtree->n.sym;
11630 : : else
11631 : : {
11632 : 3 : if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
11633 : : false) != 0)
11634 : 0 : gcc_unreachable ();
11635 : 3 : lock_type = symtree->n.sym;
11636 : 3 : lock_type->attr.flavor = FL_DERIVED;
11637 : 3 : lock_type->attr.zero_comp = 1;
11638 : 3 : lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
11639 : 3 : lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
11640 : : }
11641 : :
11642 : 5 : sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
11643 : 5 : if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
11644 : 0 : gcc_unreachable ();
11645 : :
11646 : 5 : code->resolved_sym = symtree->n.sym;
11647 : 5 : symtree->n.sym->attr.flavor = FL_VARIABLE;
11648 : 5 : symtree->n.sym->attr.referenced = 1;
11649 : 5 : symtree->n.sym->attr.artificial = 1;
11650 : 5 : symtree->n.sym->attr.codimension = 1;
11651 : 5 : symtree->n.sym->ts.type = BT_DERIVED;
11652 : 5 : symtree->n.sym->ts.u.derived = lock_type;
11653 : 5 : symtree->n.sym->as = gfc_get_array_spec ();
11654 : 5 : symtree->n.sym->as->corank = 1;
11655 : 5 : symtree->n.sym->as->type = AS_EXPLICIT;
11656 : 5 : symtree->n.sym->as->cotype = AS_EXPLICIT;
11657 : 5 : symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
11658 : : NULL, 1);
11659 : 5 : gfc_commit_symbols();
11660 : : }
11661 : :
11662 : :
11663 : : static void
11664 : 747 : resolve_sync (gfc_code *code)
11665 : : {
11666 : : /* Check imageset. The * case matches expr1 == NULL. */
11667 : 747 : if (code->expr1)
11668 : : {
11669 : 48 : if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
11670 : 1 : gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
11671 : : "INTEGER expression", &code->expr1->where);
11672 : 48 : if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
11673 : 23 : && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
11674 : 1 : gfc_error ("Imageset argument at %L must between 1 and num_images()",
11675 : : &code->expr1->where);
11676 : 47 : else if (code->expr1->expr_type == EXPR_ARRAY
11677 : 47 : && gfc_simplify_expr (code->expr1, 0))
11678 : : {
11679 : 18 : gfc_constructor *cons;
11680 : 18 : cons = gfc_constructor_first (code->expr1->value.constructor);
11681 : 54 : for (; cons; cons = gfc_constructor_next (cons))
11682 : 18 : if (cons->expr->expr_type == EXPR_CONSTANT
11683 : 18 : && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
11684 : 0 : gfc_error ("Imageset argument at %L must between 1 and "
11685 : : "num_images()", &cons->expr->where);
11686 : : }
11687 : : }
11688 : :
11689 : : /* Check STAT. */
11690 : 747 : gfc_resolve_expr (code->expr2);
11691 : 747 : if (code->expr2)
11692 : : {
11693 : 84 : if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
11694 : 1 : gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
11695 : : &code->expr2->where);
11696 : : else
11697 : 83 : gfc_check_vardef_context (code->expr2, false, false, false,
11698 : 83 : _("STAT variable"));
11699 : : }
11700 : :
11701 : : /* Check ERRMSG. */
11702 : 747 : gfc_resolve_expr (code->expr3);
11703 : 747 : if (code->expr3)
11704 : : {
11705 : 75 : if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
11706 : 4 : gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
11707 : : &code->expr3->where);
11708 : : else
11709 : 71 : gfc_check_vardef_context (code->expr3, false, false, false,
11710 : 71 : _("ERRMSG variable"));
11711 : : }
11712 : 747 : }
11713 : :
11714 : :
11715 : : /* Given a branch to a label, see if the branch is conforming.
11716 : : The code node describes where the branch is located. */
11717 : :
11718 : : static void
11719 : 105205 : resolve_branch (gfc_st_label *label, gfc_code *code)
11720 : : {
11721 : 105205 : code_stack *stack;
11722 : :
11723 : 105205 : if (label == NULL)
11724 : : return;
11725 : :
11726 : : /* Step one: is this a valid branching target? */
11727 : :
11728 : 2440 : if (label->defined == ST_LABEL_UNKNOWN)
11729 : : {
11730 : 4 : gfc_error ("Label %d referenced at %L is never defined", label->value,
11731 : : &code->loc);
11732 : 4 : return;
11733 : : }
11734 : :
11735 : 2436 : if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
11736 : : {
11737 : 4 : gfc_error ("Statement at %L is not a valid branch target statement "
11738 : : "for the branch statement at %L", &label->where, &code->loc);
11739 : 4 : return;
11740 : : }
11741 : :
11742 : : /* Step two: make sure this branch is not a branch to itself ;-) */
11743 : :
11744 : 2432 : if (code->here == label)
11745 : : {
11746 : 0 : gfc_warning (0,
11747 : : "Branch at %L may result in an infinite loop", &code->loc);
11748 : 0 : return;
11749 : : }
11750 : :
11751 : : /* Step three: See if the label is in the same block as the
11752 : : branching statement. The hard work has been done by setting up
11753 : : the bitmap reachable_labels. */
11754 : :
11755 : 2432 : if (bitmap_bit_p (cs_base->reachable_labels, label->value))
11756 : : {
11757 : : /* Check now whether there is a CRITICAL construct; if so, check
11758 : : whether the label is still visible outside of the CRITICAL block,
11759 : : which is invalid. */
11760 : 6184 : for (stack = cs_base; stack; stack = stack->prev)
11761 : : {
11762 : 3820 : if (stack->current->op == EXEC_CRITICAL
11763 : 3820 : && bitmap_bit_p (stack->reachable_labels, label->value))
11764 : 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
11765 : : "label at %L", &code->loc, &label->where);
11766 : 3818 : else if (stack->current->op == EXEC_DO_CONCURRENT
11767 : 3818 : && bitmap_bit_p (stack->reachable_labels, label->value))
11768 : 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
11769 : : "for label at %L", &code->loc, &label->where);
11770 : : }
11771 : :
11772 : : return;
11773 : : }
11774 : :
11775 : : /* Step four: If we haven't found the label in the bitmap, it may
11776 : : still be the label of the END of the enclosing block, in which
11777 : : case we find it by going up the code_stack. */
11778 : :
11779 : 167 : for (stack = cs_base; stack; stack = stack->prev)
11780 : : {
11781 : 131 : if (stack->current->next && stack->current->next->here == label)
11782 : : break;
11783 : 101 : if (stack->current->op == EXEC_CRITICAL)
11784 : : {
11785 : : /* Note: A label at END CRITICAL does not leave the CRITICAL
11786 : : construct as END CRITICAL is still part of it. */
11787 : 2 : gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
11788 : : " at %L", &code->loc, &label->where);
11789 : 2 : return;
11790 : : }
11791 : 99 : else if (stack->current->op == EXEC_DO_CONCURRENT)
11792 : : {
11793 : 0 : gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
11794 : : "label at %L", &code->loc, &label->where);
11795 : 0 : return;
11796 : : }
11797 : : }
11798 : :
11799 : 66 : if (stack)
11800 : : {
11801 : 30 : gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
11802 : : return;
11803 : : }
11804 : :
11805 : : /* The label is not in an enclosing block, so illegal. This was
11806 : : allowed in Fortran 66, so we allow it as extension. No
11807 : : further checks are necessary in this case. */
11808 : 36 : gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
11809 : : "as the GOTO statement at %L", &label->where,
11810 : : &code->loc);
11811 : 36 : return;
11812 : : }
11813 : :
11814 : :
11815 : : /* Check whether EXPR1 has the same shape as EXPR2. */
11816 : :
11817 : : static bool
11818 : 1461 : resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
11819 : : {
11820 : 1461 : mpz_t shape[GFC_MAX_DIMENSIONS];
11821 : 1461 : mpz_t shape2[GFC_MAX_DIMENSIONS];
11822 : 1461 : bool result = false;
11823 : 1461 : int i;
11824 : :
11825 : : /* Compare the rank. */
11826 : 1461 : if (expr1->rank != expr2->rank)
11827 : : return result;
11828 : :
11829 : : /* Compare the size of each dimension. */
11830 : 2795 : for (i=0; i<expr1->rank; i++)
11831 : : {
11832 : 1484 : if (!gfc_array_dimen_size (expr1, i, &shape[i]))
11833 : 150 : goto ignore;
11834 : :
11835 : 1334 : if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
11836 : 0 : goto ignore;
11837 : :
11838 : 1334 : if (mpz_cmp (shape[i], shape2[i]))
11839 : 0 : goto over;
11840 : : }
11841 : :
11842 : : /* When either of the two expression is an assumed size array, we
11843 : : ignore the comparison of dimension sizes. */
11844 : 1311 : ignore:
11845 : : result = true;
11846 : :
11847 : 1461 : over:
11848 : 1461 : gfc_clear_shape (shape, i);
11849 : 1461 : gfc_clear_shape (shape2, i);
11850 : 1461 : return result;
11851 : : }
11852 : :
11853 : :
11854 : : /* Check whether a WHERE assignment target or a WHERE mask expression
11855 : : has the same shape as the outmost WHERE mask expression. */
11856 : :
11857 : : static void
11858 : 506 : resolve_where (gfc_code *code, gfc_expr *mask)
11859 : : {
11860 : 506 : gfc_code *cblock;
11861 : 506 : gfc_code *cnext;
11862 : 506 : gfc_expr *e = NULL;
11863 : :
11864 : 506 : cblock = code->block;
11865 : :
11866 : : /* Store the first WHERE mask-expr of the WHERE statement or construct.
11867 : : In case of nested WHERE, only the outmost one is stored. */
11868 : 506 : if (mask == NULL) /* outmost WHERE */
11869 : 450 : e = cblock->expr1;
11870 : : else /* inner WHERE */
11871 : 506 : e = mask;
11872 : :
11873 : 1381 : while (cblock)
11874 : : {
11875 : 875 : if (cblock->expr1)
11876 : : {
11877 : : /* Check if the mask-expr has a consistent shape with the
11878 : : outmost WHERE mask-expr. */
11879 : 711 : if (!resolve_where_shape (cblock->expr1, e))
11880 : 0 : gfc_error ("WHERE mask at %L has inconsistent shape",
11881 : 0 : &cblock->expr1->where);
11882 : : }
11883 : :
11884 : : /* the assignment statement of a WHERE statement, or the first
11885 : : statement in where-body-construct of a WHERE construct */
11886 : 875 : cnext = cblock->next;
11887 : 1727 : while (cnext)
11888 : : {
11889 : 852 : switch (cnext->op)
11890 : : {
11891 : : /* WHERE assignment statement */
11892 : 750 : case EXEC_ASSIGN:
11893 : :
11894 : : /* Check shape consistent for WHERE assignment target. */
11895 : 750 : if (e && !resolve_where_shape (cnext->expr1, e))
11896 : 0 : gfc_error ("WHERE assignment target at %L has "
11897 : 0 : "inconsistent shape", &cnext->expr1->where);
11898 : :
11899 : 750 : if (cnext->op == EXEC_ASSIGN
11900 : 750 : && gfc_may_be_finalized (cnext->expr1->ts))
11901 : 0 : cnext->expr1->must_finalize = 1;
11902 : :
11903 : : break;
11904 : :
11905 : :
11906 : 46 : case EXEC_ASSIGN_CALL:
11907 : 46 : resolve_call (cnext);
11908 : 46 : if (!cnext->resolved_sym->attr.elemental)
11909 : 2 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
11910 : 2 : &cnext->ext.actual->expr->where);
11911 : : break;
11912 : :
11913 : : /* WHERE or WHERE construct is part of a where-body-construct */
11914 : 56 : case EXEC_WHERE:
11915 : 56 : resolve_where (cnext, e);
11916 : 56 : break;
11917 : :
11918 : 0 : default:
11919 : 0 : gfc_error ("Unsupported statement inside WHERE at %L",
11920 : : &cnext->loc);
11921 : : }
11922 : : /* the next statement within the same where-body-construct */
11923 : 852 : cnext = cnext->next;
11924 : : }
11925 : : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
11926 : 875 : cblock = cblock->block;
11927 : : }
11928 : 506 : }
11929 : :
11930 : :
11931 : : /* Resolve assignment in FORALL construct.
11932 : : NVAR is the number of FORALL index variables, and VAR_EXPR records the
11933 : : FORALL index variables. */
11934 : :
11935 : : static void
11936 : 1953 : gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
11937 : : {
11938 : 1953 : int n;
11939 : :
11940 : 5904 : for (n = 0; n < nvar; n++)
11941 : : {
11942 : 3951 : gfc_symbol *forall_index;
11943 : :
11944 : 3951 : forall_index = var_expr[n]->symtree->n.sym;
11945 : :
11946 : : /* Check whether the assignment target is one of the FORALL index
11947 : : variable. */
11948 : 3951 : if ((code->expr1->expr_type == EXPR_VARIABLE)
11949 : 3951 : && (code->expr1->symtree->n.sym == forall_index))
11950 : 0 : gfc_error ("Assignment to a FORALL index variable at %L",
11951 : : &code->expr1->where);
11952 : : else
11953 : : {
11954 : : /* If one of the FORALL index variables doesn't appear in the
11955 : : assignment variable, then there could be a many-to-one
11956 : : assignment. Emit a warning rather than an error because the
11957 : : mask could be resolving this problem. */
11958 : 3951 : if (!find_forall_index (code->expr1, forall_index, 0))
11959 : 0 : gfc_warning (0, "The FORALL with index %qs is not used on the "
11960 : : "left side of the assignment at %L and so might "
11961 : : "cause multiple assignment to this object",
11962 : 0 : var_expr[n]->symtree->name, &code->expr1->where);
11963 : : }
11964 : : }
11965 : 1953 : }
11966 : :
11967 : :
11968 : : /* Resolve WHERE statement in FORALL construct. */
11969 : :
11970 : : static void
11971 : 46 : gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
11972 : : gfc_expr **var_expr)
11973 : : {
11974 : 46 : gfc_code *cblock;
11975 : 46 : gfc_code *cnext;
11976 : :
11977 : 46 : cblock = code->block;
11978 : 111 : while (cblock)
11979 : : {
11980 : : /* the assignment statement of a WHERE statement, or the first
11981 : : statement in where-body-construct of a WHERE construct */
11982 : 65 : cnext = cblock->next;
11983 : 130 : while (cnext)
11984 : : {
11985 : 65 : switch (cnext->op)
11986 : : {
11987 : : /* WHERE assignment statement */
11988 : 65 : case EXEC_ASSIGN:
11989 : 65 : gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
11990 : :
11991 : 65 : if (cnext->op == EXEC_ASSIGN
11992 : 65 : && gfc_may_be_finalized (cnext->expr1->ts))
11993 : 0 : cnext->expr1->must_finalize = 1;
11994 : :
11995 : : break;
11996 : :
11997 : : /* WHERE operator assignment statement */
11998 : 0 : case EXEC_ASSIGN_CALL:
11999 : 0 : resolve_call (cnext);
12000 : 0 : if (!cnext->resolved_sym->attr.elemental)
12001 : 0 : gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
12002 : 0 : &cnext->ext.actual->expr->where);
12003 : : break;
12004 : :
12005 : : /* WHERE or WHERE construct is part of a where-body-construct */
12006 : 0 : case EXEC_WHERE:
12007 : 0 : gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
12008 : 0 : break;
12009 : :
12010 : 0 : default:
12011 : 0 : gfc_error ("Unsupported statement inside WHERE at %L",
12012 : : &cnext->loc);
12013 : : }
12014 : : /* the next statement within the same where-body-construct */
12015 : 65 : cnext = cnext->next;
12016 : : }
12017 : : /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
12018 : 65 : cblock = cblock->block;
12019 : : }
12020 : 46 : }
12021 : :
12022 : :
12023 : : /* Traverse the FORALL body to check whether the following errors exist:
12024 : : 1. For assignment, check if a many-to-one assignment happens.
12025 : : 2. For WHERE statement, check the WHERE body to see if there is any
12026 : : many-to-one assignment. */
12027 : :
12028 : : static void
12029 : 2004 : gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
12030 : : {
12031 : 2004 : gfc_code *c;
12032 : :
12033 : 2004 : c = code->block->next;
12034 : 4021 : while (c)
12035 : : {
12036 : 2017 : switch (c->op)
12037 : : {
12038 : 1888 : case EXEC_ASSIGN:
12039 : 1888 : case EXEC_POINTER_ASSIGN:
12040 : 1888 : gfc_resolve_assign_in_forall (c, nvar, var_expr);
12041 : :
12042 : 1888 : if (c->op == EXEC_ASSIGN
12043 : 1888 : && gfc_may_be_finalized (c->expr1->ts))
12044 : 0 : c->expr1->must_finalize = 1;
12045 : :
12046 : : break;
12047 : :
12048 : 0 : case EXEC_ASSIGN_CALL:
12049 : 0 : resolve_call (c);
12050 : 0 : break;
12051 : :
12052 : : /* Because the gfc_resolve_blocks() will handle the nested FORALL,
12053 : : there is no need to handle it here. */
12054 : : case EXEC_FORALL:
12055 : : break;
12056 : 46 : case EXEC_WHERE:
12057 : 46 : gfc_resolve_where_code_in_forall(c, nvar, var_expr);
12058 : 46 : break;
12059 : : default:
12060 : : break;
12061 : : }
12062 : : /* The next statement in the FORALL body. */
12063 : 2017 : c = c->next;
12064 : : }
12065 : 2004 : }
12066 : :
12067 : :
12068 : : /* Counts the number of iterators needed inside a forall construct, including
12069 : : nested forall constructs. This is used to allocate the needed memory
12070 : : in gfc_resolve_forall. */
12071 : :
12072 : : static int
12073 : 2004 : gfc_count_forall_iterators (gfc_code *code)
12074 : : {
12075 : 2004 : int max_iters, sub_iters, current_iters;
12076 : 2004 : gfc_forall_iterator *fa;
12077 : :
12078 : 2004 : gcc_assert(code->op == EXEC_FORALL);
12079 : 2004 : max_iters = 0;
12080 : 2004 : current_iters = 0;
12081 : :
12082 : 5916 : for (fa = code->ext.forall_iterator; fa; fa = fa->next)
12083 : 3912 : current_iters ++;
12084 : :
12085 : 2004 : code = code->block->next;
12086 : :
12087 : 4021 : while (code)
12088 : : {
12089 : 2017 : if (code->op == EXEC_FORALL)
12090 : : {
12091 : 83 : sub_iters = gfc_count_forall_iterators (code);
12092 : 83 : if (sub_iters > max_iters)
12093 : 2017 : max_iters = sub_iters;
12094 : : }
12095 : 2017 : code = code->next;
12096 : : }
12097 : :
12098 : 2004 : return current_iters + max_iters;
12099 : : }
12100 : :
12101 : :
12102 : : /* Given a FORALL construct, first resolve the FORALL iterator, then call
12103 : : gfc_resolve_forall_body to resolve the FORALL body. */
12104 : :
12105 : : static void
12106 : 2004 : gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
12107 : : {
12108 : 2004 : static gfc_expr **var_expr;
12109 : 2004 : static int total_var = 0;
12110 : 2004 : static int nvar = 0;
12111 : 2004 : int i, old_nvar, tmp;
12112 : 2004 : gfc_forall_iterator *fa;
12113 : :
12114 : 2004 : old_nvar = nvar;
12115 : :
12116 : 2004 : if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
12117 : : return;
12118 : :
12119 : : /* Start to resolve a FORALL construct */
12120 : 2004 : if (forall_save == 0)
12121 : : {
12122 : : /* Count the total number of FORALL indices in the nested FORALL
12123 : : construct in order to allocate the VAR_EXPR with proper size. */
12124 : 1921 : total_var = gfc_count_forall_iterators (code);
12125 : :
12126 : : /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
12127 : 1921 : var_expr = XCNEWVEC (gfc_expr *, total_var);
12128 : : }
12129 : :
12130 : : /* The information about FORALL iterator, including FORALL indices start, end
12131 : : and stride. An outer FORALL indice cannot appear in start, end or stride. */
12132 : 5916 : for (fa = code->ext.forall_iterator; fa; fa = fa->next)
12133 : : {
12134 : : /* Fortran 20008: C738 (R753). */
12135 : 3912 : if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
12136 : : {
12137 : 2 : gfc_error ("FORALL index-name at %L must be a scalar variable "
12138 : : "of type integer", &fa->var->where);
12139 : 2 : continue;
12140 : : }
12141 : :
12142 : : /* Check if any outer FORALL index name is the same as the current
12143 : : one. */
12144 : 6913 : for (i = 0; i < nvar; i++)
12145 : : {
12146 : 3003 : if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
12147 : 0 : gfc_error ("An outer FORALL construct already has an index "
12148 : : "with this name %L", &fa->var->where);
12149 : : }
12150 : :
12151 : : /* Record the current FORALL index. */
12152 : 3910 : var_expr[nvar] = gfc_copy_expr (fa->var);
12153 : :
12154 : 3910 : nvar++;
12155 : :
12156 : : /* No memory leak. */
12157 : 3910 : gcc_assert (nvar <= total_var);
12158 : : }
12159 : :
12160 : : /* Resolve the FORALL body. */
12161 : 2004 : gfc_resolve_forall_body (code, nvar, var_expr);
12162 : :
12163 : : /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
12164 : 2004 : gfc_resolve_blocks (code->block, ns);
12165 : :
12166 : 2004 : tmp = nvar;
12167 : 2004 : nvar = old_nvar;
12168 : : /* Free only the VAR_EXPRs allocated in this frame. */
12169 : 5914 : for (i = nvar; i < tmp; i++)
12170 : 3910 : gfc_free_expr (var_expr[i]);
12171 : :
12172 : 2004 : if (nvar == 0)
12173 : : {
12174 : : /* We are in the outermost FORALL construct. */
12175 : 1921 : gcc_assert (forall_save == 0);
12176 : :
12177 : : /* VAR_EXPR is not needed any more. */
12178 : 1921 : free (var_expr);
12179 : 1921 : total_var = 0;
12180 : : }
12181 : : }
12182 : :
12183 : :
12184 : : /* Resolve a BLOCK construct statement. */
12185 : :
12186 : : static void
12187 : 7420 : resolve_block_construct (gfc_code* code)
12188 : : {
12189 : 7420 : gfc_namespace *ns = code->ext.block.ns;
12190 : :
12191 : : /* For an ASSOCIATE block, the associations (and their targets) will be
12192 : : resolved by gfc_resolve_symbol, during resolution of the BLOCK's
12193 : : namespace. */
12194 : 7420 : gfc_resolve (ns);
12195 : 7420 : }
12196 : :
12197 : :
12198 : : /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
12199 : : DO code nodes. */
12200 : :
12201 : : void
12202 : 299395 : gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
12203 : : {
12204 : 299395 : bool t;
12205 : :
12206 : 610007 : for (; b; b = b->block)
12207 : : {
12208 : 310612 : t = gfc_resolve_expr (b->expr1);
12209 : 310612 : if (!gfc_resolve_expr (b->expr2))
12210 : 0 : t = false;
12211 : :
12212 : 310612 : switch (b->op)
12213 : : {
12214 : 209542 : case EXEC_IF:
12215 : 209542 : if (t && b->expr1 != NULL
12216 : 205421 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
12217 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
12218 : : &b->expr1->where);
12219 : : break;
12220 : :
12221 : 761 : case EXEC_WHERE:
12222 : 761 : if (t
12223 : 761 : && b->expr1 != NULL
12224 : 628 : && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
12225 : 0 : gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
12226 : : &b->expr1->where);
12227 : : break;
12228 : :
12229 : 76 : case EXEC_GOTO:
12230 : 76 : resolve_branch (b->label1, b);
12231 : 76 : break;
12232 : :
12233 : 0 : case EXEC_BLOCK:
12234 : 0 : resolve_block_construct (b);
12235 : 0 : break;
12236 : :
12237 : : case EXEC_SELECT:
12238 : : case EXEC_SELECT_TYPE:
12239 : : case EXEC_SELECT_RANK:
12240 : : case EXEC_FORALL:
12241 : : case EXEC_DO:
12242 : : case EXEC_DO_WHILE:
12243 : : case EXEC_DO_CONCURRENT:
12244 : : case EXEC_CRITICAL:
12245 : : case EXEC_READ:
12246 : : case EXEC_WRITE:
12247 : : case EXEC_IOLENGTH:
12248 : : case EXEC_WAIT:
12249 : : break;
12250 : :
12251 : 2707 : case EXEC_OMP_ATOMIC:
12252 : 2707 : case EXEC_OACC_ATOMIC:
12253 : 2707 : {
12254 : : /* Verify this before calling gfc_resolve_code, which might
12255 : : change it. */
12256 : 2707 : gcc_assert (b->op == EXEC_OMP_ATOMIC
12257 : : || (b->next && b->next->op == EXEC_ASSIGN));
12258 : : }
12259 : : break;
12260 : :
12261 : : case EXEC_OACC_PARALLEL_LOOP:
12262 : : case EXEC_OACC_PARALLEL:
12263 : : case EXEC_OACC_KERNELS_LOOP:
12264 : : case EXEC_OACC_KERNELS:
12265 : : case EXEC_OACC_SERIAL_LOOP:
12266 : : case EXEC_OACC_SERIAL:
12267 : : case EXEC_OACC_DATA:
12268 : : case EXEC_OACC_HOST_DATA:
12269 : : case EXEC_OACC_LOOP:
12270 : : case EXEC_OACC_UPDATE:
12271 : : case EXEC_OACC_WAIT:
12272 : : case EXEC_OACC_CACHE:
12273 : : case EXEC_OACC_ENTER_DATA:
12274 : : case EXEC_OACC_EXIT_DATA:
12275 : : case EXEC_OACC_ROUTINE:
12276 : : case EXEC_OMP_ALLOCATE:
12277 : : case EXEC_OMP_ALLOCATORS:
12278 : : case EXEC_OMP_ASSUME:
12279 : : case EXEC_OMP_CRITICAL:
12280 : : case EXEC_OMP_DISPATCH:
12281 : : case EXEC_OMP_DISTRIBUTE:
12282 : : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12283 : : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12284 : : case EXEC_OMP_DISTRIBUTE_SIMD:
12285 : : case EXEC_OMP_DO:
12286 : : case EXEC_OMP_DO_SIMD:
12287 : : case EXEC_OMP_ERROR:
12288 : : case EXEC_OMP_LOOP:
12289 : : case EXEC_OMP_MASKED:
12290 : : case EXEC_OMP_MASKED_TASKLOOP:
12291 : : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12292 : : case EXEC_OMP_MASTER:
12293 : : case EXEC_OMP_MASTER_TASKLOOP:
12294 : : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12295 : : case EXEC_OMP_ORDERED:
12296 : : case EXEC_OMP_PARALLEL:
12297 : : case EXEC_OMP_PARALLEL_DO:
12298 : : case EXEC_OMP_PARALLEL_DO_SIMD:
12299 : : case EXEC_OMP_PARALLEL_LOOP:
12300 : : case EXEC_OMP_PARALLEL_MASKED:
12301 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12302 : : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12303 : : case EXEC_OMP_PARALLEL_MASTER:
12304 : : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12305 : : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12306 : : case EXEC_OMP_PARALLEL_SECTIONS:
12307 : : case EXEC_OMP_PARALLEL_WORKSHARE:
12308 : : case EXEC_OMP_SECTIONS:
12309 : : case EXEC_OMP_SIMD:
12310 : : case EXEC_OMP_SCOPE:
12311 : : case EXEC_OMP_SINGLE:
12312 : : case EXEC_OMP_TARGET:
12313 : : case EXEC_OMP_TARGET_DATA:
12314 : : case EXEC_OMP_TARGET_ENTER_DATA:
12315 : : case EXEC_OMP_TARGET_EXIT_DATA:
12316 : : case EXEC_OMP_TARGET_PARALLEL:
12317 : : case EXEC_OMP_TARGET_PARALLEL_DO:
12318 : : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12319 : : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12320 : : case EXEC_OMP_TARGET_SIMD:
12321 : : case EXEC_OMP_TARGET_TEAMS:
12322 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12323 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12324 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12325 : : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12326 : : case EXEC_OMP_TARGET_TEAMS_LOOP:
12327 : : case EXEC_OMP_TARGET_UPDATE:
12328 : : case EXEC_OMP_TASK:
12329 : : case EXEC_OMP_TASKGROUP:
12330 : : case EXEC_OMP_TASKLOOP:
12331 : : case EXEC_OMP_TASKLOOP_SIMD:
12332 : : case EXEC_OMP_TASKWAIT:
12333 : : case EXEC_OMP_TASKYIELD:
12334 : : case EXEC_OMP_TEAMS:
12335 : : case EXEC_OMP_TEAMS_DISTRIBUTE:
12336 : : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12337 : : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12338 : : case EXEC_OMP_TEAMS_LOOP:
12339 : : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12340 : : case EXEC_OMP_TILE:
12341 : : case EXEC_OMP_UNROLL:
12342 : : case EXEC_OMP_WORKSHARE:
12343 : : break;
12344 : :
12345 : 0 : default:
12346 : 0 : gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
12347 : : }
12348 : :
12349 : 310612 : gfc_resolve_code (b->next, ns);
12350 : : }
12351 : 299395 : }
12352 : :
12353 : : bool
12354 : 2307 : caf_possible_reallocate (gfc_expr *e)
12355 : : {
12356 : 2307 : symbol_attribute caf_attr;
12357 : 2307 : gfc_ref *last_arr_ref = nullptr;
12358 : :
12359 : 2307 : caf_attr = gfc_caf_attr (e);
12360 : 2307 : if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
12361 : : return false;
12362 : :
12363 : : /* Only full array refs can indicate a needed reallocation. */
12364 : 330 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
12365 : 237 : if (ref->type == REF_ARRAY && ref->u.ar.dimen)
12366 : 237 : last_arr_ref = ref;
12367 : :
12368 : 93 : return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
12369 : : }
12370 : :
12371 : : /* Does everything to resolve an ordinary assignment. Returns true
12372 : : if this is an interface assignment. */
12373 : : static bool
12374 : 185933 : resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
12375 : : {
12376 : 185933 : bool rval = false;
12377 : 185933 : gfc_expr *lhs;
12378 : 185933 : gfc_expr *rhs;
12379 : 185933 : int n;
12380 : 185933 : gfc_ref *ref;
12381 : 185933 : symbol_attribute attr;
12382 : :
12383 : 185933 : if (gfc_extend_assign (code, ns))
12384 : : {
12385 : 752 : gfc_expr** rhsptr;
12386 : :
12387 : 752 : if (code->op == EXEC_ASSIGN_CALL)
12388 : : {
12389 : 336 : lhs = code->ext.actual->expr;
12390 : 336 : rhsptr = &code->ext.actual->next->expr;
12391 : : }
12392 : : else
12393 : : {
12394 : 416 : gfc_actual_arglist* args;
12395 : 416 : gfc_typebound_proc* tbp;
12396 : :
12397 : 416 : gcc_assert (code->op == EXEC_COMPCALL);
12398 : :
12399 : 416 : args = code->expr1->value.compcall.actual;
12400 : 416 : lhs = args->expr;
12401 : 416 : rhsptr = &args->next->expr;
12402 : :
12403 : 416 : tbp = code->expr1->value.compcall.tbp;
12404 : 416 : gcc_assert (!tbp->is_generic);
12405 : : }
12406 : :
12407 : : /* Make a temporary rhs when there is a default initializer
12408 : : and rhs is the same symbol as the lhs. */
12409 : 752 : if ((*rhsptr)->expr_type == EXPR_VARIABLE
12410 : 380 : && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
12411 : 327 : && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
12412 : 931 : && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
12413 : 24 : *rhsptr = gfc_get_parentheses (*rhsptr);
12414 : :
12415 : 752 : return true;
12416 : : }
12417 : :
12418 : 185181 : lhs = code->expr1;
12419 : 185181 : rhs = code->expr2;
12420 : :
12421 : 185181 : if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
12422 : 167994 : || lhs->symtree->n.sym->ts.type == BT_CLASS)
12423 : 19520 : && !lhs->symtree->n.sym->attr.proc_pointer
12424 : 204701 : && gfc_expr_attr (lhs).proc_pointer)
12425 : : {
12426 : 1 : gfc_error ("Variable in the ordinary assignment at %L is a procedure "
12427 : : "pointer component",
12428 : : &lhs->where);
12429 : 1 : return false;
12430 : : }
12431 : :
12432 : 232938 : if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
12433 : 152352 : && rhs->ts.type == BT_CHARACTER
12434 : 185573 : && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
12435 : : {
12436 : : /* Use of -fdec-char-conversions allows assignment of character data
12437 : : to non-character variables. This not permitted for nonconstant
12438 : : strings. */
12439 : 29 : gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
12440 : : gfc_typename (lhs), &rhs->where);
12441 : 29 : return false;
12442 : : }
12443 : :
12444 : 185151 : if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
12445 : : {
12446 : 0 : gfc_error ("Cannot assign %s to %s at %L", gfc_typename (rhs),
12447 : : gfc_typename (lhs), &rhs->where);
12448 : 0 : return false;
12449 : : }
12450 : :
12451 : : /* Handle the case of a BOZ literal on the RHS. */
12452 : 185151 : if (rhs->ts.type == BT_BOZ)
12453 : : {
12454 : 3 : if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
12455 : : "statement value nor an actual argument of "
12456 : : "INT/REAL/DBLE/CMPLX intrinsic subprogram",
12457 : : &rhs->where))
12458 : : return false;
12459 : :
12460 : 1 : switch (lhs->ts.type)
12461 : : {
12462 : 0 : case BT_INTEGER:
12463 : 0 : if (!gfc_boz2int (rhs, lhs->ts.kind))
12464 : : return false;
12465 : : break;
12466 : 1 : case BT_REAL:
12467 : 1 : if (!gfc_boz2real (rhs, lhs->ts.kind))
12468 : : return false;
12469 : : break;
12470 : 0 : default:
12471 : 0 : gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
12472 : 0 : return false;
12473 : : }
12474 : : }
12475 : :
12476 : 185149 : if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
12477 : : {
12478 : 64 : HOST_WIDE_INT llen = 0, rlen = 0;
12479 : 64 : if (lhs->ts.u.cl != NULL
12480 : 64 : && lhs->ts.u.cl->length != NULL
12481 : 53 : && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
12482 : 53 : llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
12483 : :
12484 : 64 : if (rhs->expr_type == EXPR_CONSTANT)
12485 : 26 : rlen = rhs->value.character.length;
12486 : :
12487 : 38 : else if (rhs->ts.u.cl != NULL
12488 : 38 : && rhs->ts.u.cl->length != NULL
12489 : 35 : && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
12490 : 35 : rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
12491 : :
12492 : 64 : if (rlen && llen && rlen > llen)
12493 : 28 : gfc_warning_now (OPT_Wcharacter_truncation,
12494 : : "CHARACTER expression will be truncated "
12495 : : "in assignment (%wd/%wd) at %L",
12496 : : llen, rlen, &code->loc);
12497 : : }
12498 : :
12499 : : /* Ensure that a vector index expression for the lvalue is evaluated
12500 : : to a temporary if the lvalue symbol is referenced in it. */
12501 : 185149 : if (lhs->rank)
12502 : : {
12503 : 103496 : for (ref = lhs->ref; ref; ref= ref->next)
12504 : 54334 : if (ref->type == REF_ARRAY)
12505 : : {
12506 : 123759 : for (n = 0; n < ref->u.ar.dimen; n++)
12507 : 73455 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
12508 : 73455 : && gfc_find_sym_in_expr (lhs->symtree->n.sym,
12509 : : ref->u.ar.start[n]))
12510 : 24 : ref->u.ar.start[n]
12511 : 24 : = gfc_get_parentheses (ref->u.ar.start[n]);
12512 : : }
12513 : : }
12514 : :
12515 : 185149 : if (gfc_pure (NULL))
12516 : : {
12517 : 3089 : if (lhs->ts.type == BT_DERIVED
12518 : 83 : && lhs->expr_type == EXPR_VARIABLE
12519 : 83 : && lhs->ts.u.derived->attr.pointer_comp
12520 : 4 : && rhs->expr_type == EXPR_VARIABLE
12521 : 3092 : && (gfc_impure_variable (rhs->symtree->n.sym)
12522 : 2 : || gfc_is_coindexed (rhs)))
12523 : : {
12524 : : /* F2008, C1283. */
12525 : 2 : if (gfc_is_coindexed (rhs))
12526 : 1 : gfc_error ("Coindexed expression at %L is assigned to "
12527 : : "a derived type variable with a POINTER "
12528 : : "component in a PURE procedure",
12529 : : &rhs->where);
12530 : : else
12531 : : /* F2008, C1283 (4). */
12532 : 1 : gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
12533 : : "shall not be used as the expr at %L of an intrinsic "
12534 : : "assignment statement in which the variable is of a "
12535 : : "derived type if the derived type has a pointer "
12536 : : "component at any level of component selection.",
12537 : : &rhs->where);
12538 : 2 : return rval;
12539 : : }
12540 : :
12541 : : /* Fortran 2008, C1283. */
12542 : 3087 : if (gfc_is_coindexed (lhs))
12543 : : {
12544 : 1 : gfc_error ("Assignment to coindexed variable at %L in a PURE "
12545 : : "procedure", &rhs->where);
12546 : 1 : return rval;
12547 : : }
12548 : : }
12549 : :
12550 : 185146 : if (gfc_implicit_pure (NULL))
12551 : : {
12552 : 6911 : if (lhs->expr_type == EXPR_VARIABLE
12553 : 6911 : && lhs->symtree->n.sym != gfc_current_ns->proc_name
12554 : 4969 : && lhs->symtree->n.sym->ns != gfc_current_ns)
12555 : 231 : gfc_unset_implicit_pure (NULL);
12556 : :
12557 : 6911 : if (lhs->ts.type == BT_DERIVED
12558 : 293 : && lhs->expr_type == EXPR_VARIABLE
12559 : 293 : && lhs->ts.u.derived->attr.pointer_comp
12560 : 7 : && rhs->expr_type == EXPR_VARIABLE
12561 : 6918 : && (gfc_impure_variable (rhs->symtree->n.sym)
12562 : 7 : || gfc_is_coindexed (rhs)))
12563 : 0 : gfc_unset_implicit_pure (NULL);
12564 : :
12565 : : /* Fortran 2008, C1283. */
12566 : 6911 : if (gfc_is_coindexed (lhs))
12567 : 0 : gfc_unset_implicit_pure (NULL);
12568 : : }
12569 : :
12570 : : /* F2008, 7.2.1.2. */
12571 : 185146 : attr = gfc_expr_attr (lhs);
12572 : 185146 : if (lhs->ts.type == BT_CLASS && attr.allocatable)
12573 : : {
12574 : 836 : if (attr.codimension)
12575 : : {
12576 : 1 : gfc_error ("Assignment to polymorphic coarray at %L is not "
12577 : : "permitted", &lhs->where);
12578 : 1 : return false;
12579 : : }
12580 : 835 : if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
12581 : : "polymorphic variable at %L", &lhs->where))
12582 : : return false;
12583 : 834 : if (!flag_realloc_lhs)
12584 : : {
12585 : 1 : gfc_error ("Assignment to an allocatable polymorphic variable at %L "
12586 : : "requires %<-frealloc-lhs%>", &lhs->where);
12587 : 1 : return false;
12588 : : }
12589 : : }
12590 : 184310 : else if (lhs->ts.type == BT_CLASS)
12591 : : {
12592 : 9 : gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
12593 : : "assignment at %L - check that there is a matching specific "
12594 : : "subroutine for %<=%> operator", &lhs->where);
12595 : 9 : return false;
12596 : : }
12597 : :
12598 : 185134 : bool lhs_coindexed = gfc_is_coindexed (lhs);
12599 : :
12600 : : /* F2008, Section 7.2.1.2. */
12601 : 185134 : if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
12602 : : {
12603 : 1 : gfc_error ("Coindexed variable must not have an allocatable ultimate "
12604 : : "component in assignment at %L", &lhs->where);
12605 : 1 : return false;
12606 : : }
12607 : :
12608 : : /* Assign the 'data' of a class object to a derived type. */
12609 : 185133 : if (lhs->ts.type == BT_DERIVED
12610 : 6412 : && rhs->ts.type == BT_CLASS
12611 : 131 : && rhs->expr_type != EXPR_ARRAY)
12612 : 125 : gfc_add_data_component (rhs);
12613 : :
12614 : : /* Make sure there is a vtable and, in particular, a _copy for the
12615 : : rhs type. */
12616 : 185133 : if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
12617 : 482 : gfc_find_vtab (&rhs->ts);
12618 : :
12619 : 185133 : gfc_check_assign (lhs, rhs, 1);
12620 : :
12621 : 185133 : return false;
12622 : : }
12623 : :
12624 : :
12625 : : /* Add a component reference onto an expression. */
12626 : :
12627 : : static void
12628 : 663 : add_comp_ref (gfc_expr *e, gfc_component *c)
12629 : : {
12630 : 663 : gfc_ref **ref;
12631 : 663 : ref = &(e->ref);
12632 : 887 : while (*ref)
12633 : 224 : ref = &((*ref)->next);
12634 : 663 : *ref = gfc_get_ref ();
12635 : 663 : (*ref)->type = REF_COMPONENT;
12636 : 663 : (*ref)->u.c.sym = e->ts.u.derived;
12637 : 663 : (*ref)->u.c.component = c;
12638 : 663 : e->ts = c->ts;
12639 : :
12640 : : /* Add a full array ref, as necessary. */
12641 : 663 : if (c->as)
12642 : : {
12643 : 84 : gfc_add_full_array_ref (e, c->as);
12644 : 84 : e->rank = c->as->rank;
12645 : 84 : e->corank = c->as->corank;
12646 : : }
12647 : 663 : }
12648 : :
12649 : :
12650 : : /* Build an assignment. Keep the argument 'op' for future use, so that
12651 : : pointer assignments can be made. */
12652 : :
12653 : : static gfc_code *
12654 : 895 : build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
12655 : : gfc_component *comp1, gfc_component *comp2, locus loc)
12656 : : {
12657 : 895 : gfc_code *this_code;
12658 : :
12659 : 895 : this_code = gfc_get_code (op);
12660 : 895 : this_code->next = NULL;
12661 : 895 : this_code->expr1 = gfc_copy_expr (expr1);
12662 : 895 : this_code->expr2 = gfc_copy_expr (expr2);
12663 : 895 : this_code->loc = loc;
12664 : 895 : if (comp1 && comp2)
12665 : : {
12666 : 287 : add_comp_ref (this_code->expr1, comp1);
12667 : 287 : add_comp_ref (this_code->expr2, comp2);
12668 : : }
12669 : :
12670 : 895 : return this_code;
12671 : : }
12672 : :
12673 : :
12674 : : /* Makes a temporary variable expression based on the characteristics of
12675 : : a given variable expression. */
12676 : :
12677 : : static gfc_expr*
12678 : 391 : get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
12679 : : {
12680 : 391 : static int serial = 0;
12681 : 391 : char name[GFC_MAX_SYMBOL_LEN];
12682 : 391 : gfc_symtree *tmp;
12683 : 391 : gfc_array_spec *as;
12684 : 391 : gfc_array_ref *aref;
12685 : 391 : gfc_ref *ref;
12686 : :
12687 : 391 : sprintf (name, GFC_PREFIX("DA%d"), serial++);
12688 : 391 : gfc_get_sym_tree (name, ns, &tmp, false);
12689 : 391 : gfc_add_type (tmp->n.sym, &e->ts, NULL);
12690 : :
12691 : 391 : if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
12692 : 0 : tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
12693 : : NULL,
12694 : : e->value.character.length);
12695 : :
12696 : 391 : as = NULL;
12697 : 391 : ref = NULL;
12698 : 391 : aref = NULL;
12699 : :
12700 : : /* Obtain the arrayspec for the temporary. */
12701 : 391 : if (e->rank && e->expr_type != EXPR_ARRAY
12702 : : && e->expr_type != EXPR_FUNCTION
12703 : : && e->expr_type != EXPR_OP)
12704 : : {
12705 : 52 : aref = gfc_find_array_ref (e);
12706 : 52 : if (e->expr_type == EXPR_VARIABLE
12707 : 52 : && e->symtree->n.sym->as == aref->as)
12708 : : as = aref->as;
12709 : : else
12710 : : {
12711 : 0 : for (ref = e->ref; ref; ref = ref->next)
12712 : 0 : if (ref->type == REF_COMPONENT
12713 : 0 : && ref->u.c.component->as == aref->as)
12714 : : {
12715 : : as = aref->as;
12716 : : break;
12717 : : }
12718 : : }
12719 : : }
12720 : :
12721 : : /* Add the attributes and the arrayspec to the temporary. */
12722 : 391 : tmp->n.sym->attr = gfc_expr_attr (e);
12723 : 391 : tmp->n.sym->attr.function = 0;
12724 : 391 : tmp->n.sym->attr.proc_pointer = 0;
12725 : 391 : tmp->n.sym->attr.result = 0;
12726 : 391 : tmp->n.sym->attr.flavor = FL_VARIABLE;
12727 : 391 : tmp->n.sym->attr.dummy = 0;
12728 : 391 : tmp->n.sym->attr.use_assoc = 0;
12729 : 391 : tmp->n.sym->attr.intent = INTENT_UNKNOWN;
12730 : :
12731 : :
12732 : 391 : if (as)
12733 : : {
12734 : 52 : tmp->n.sym->as = gfc_copy_array_spec (as);
12735 : 52 : if (!ref)
12736 : 52 : ref = e->ref;
12737 : 52 : if (as->type == AS_DEFERRED)
12738 : 46 : tmp->n.sym->attr.allocatable = 1;
12739 : : }
12740 : 339 : else if ((e->rank || e->corank)
12741 : 48 : && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
12742 : 0 : || e->expr_type == EXPR_OP))
12743 : : {
12744 : 48 : tmp->n.sym->as = gfc_get_array_spec ();
12745 : 48 : tmp->n.sym->as->type = AS_DEFERRED;
12746 : 48 : tmp->n.sym->as->rank = e->rank;
12747 : 48 : tmp->n.sym->as->corank = e->corank;
12748 : 48 : tmp->n.sym->attr.allocatable = 1;
12749 : 48 : tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
12750 : 96 : tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
12751 : : }
12752 : : else
12753 : 291 : tmp->n.sym->attr.dimension = 0;
12754 : :
12755 : 391 : gfc_set_sym_referenced (tmp->n.sym);
12756 : 391 : gfc_commit_symbol (tmp->n.sym);
12757 : 391 : e = gfc_lval_expr_from_sym (tmp->n.sym);
12758 : :
12759 : : /* Should the lhs be a section, use its array ref for the
12760 : : temporary expression. */
12761 : 391 : if (aref && aref->type != AR_FULL)
12762 : : {
12763 : 6 : gfc_free_ref_list (e->ref);
12764 : 6 : e->ref = gfc_copy_ref (ref);
12765 : : }
12766 : 391 : return e;
12767 : : }
12768 : :
12769 : :
12770 : : /* Add one line of code to the code chain, making sure that 'head' and
12771 : : 'tail' are appropriately updated. */
12772 : :
12773 : : static void
12774 : 654 : add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
12775 : : {
12776 : 654 : gcc_assert (this_code);
12777 : 654 : if (*head == NULL)
12778 : 306 : *head = *tail = *this_code;
12779 : : else
12780 : 348 : *tail = gfc_append_code (*tail, *this_code);
12781 : 654 : *this_code = NULL;
12782 : 654 : }
12783 : :
12784 : :
12785 : : /* Generate a final call from a variable expression */
12786 : :
12787 : : static void
12788 : 80 : generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
12789 : : {
12790 : 80 : gfc_code *this_code;
12791 : 80 : gfc_expr *final_expr = NULL;
12792 : 80 : gfc_expr *size_expr;
12793 : 80 : gfc_expr *fini_coarray;
12794 : :
12795 : 80 : gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
12796 : 80 : if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
12797 : 74 : return;
12798 : :
12799 : : /* Now generate the finalizer call. */
12800 : 6 : this_code = gfc_get_code (EXEC_CALL);
12801 : 6 : this_code->symtree = final_expr->symtree;
12802 : 6 : this_code->resolved_sym = final_expr->symtree->n.sym;
12803 : :
12804 : : //* Expression to be finalized */
12805 : 6 : this_code->ext.actual = gfc_get_actual_arglist ();
12806 : 6 : this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
12807 : :
12808 : : /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
12809 : 6 : this_code->ext.actual->next = gfc_get_actual_arglist ();
12810 : 6 : size_expr = gfc_get_expr ();
12811 : 6 : size_expr->where = gfc_current_locus;
12812 : 6 : size_expr->expr_type = EXPR_OP;
12813 : 6 : size_expr->value.op.op = INTRINSIC_DIVIDE;
12814 : 6 : size_expr->value.op.op1
12815 : 12 : = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
12816 : : "storage_size", gfc_current_locus, 2,
12817 : 6 : gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
12818 : : gfc_get_int_expr (gfc_index_integer_kind,
12819 : : NULL, 0));
12820 : 6 : size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
12821 : : gfc_character_storage_size);
12822 : 6 : size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
12823 : 6 : size_expr->ts = size_expr->value.op.op1->ts;
12824 : 6 : this_code->ext.actual->next->expr = size_expr;
12825 : :
12826 : : /* fini_coarray */
12827 : 6 : this_code->ext.actual->next->next = gfc_get_actual_arglist ();
12828 : 6 : fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
12829 : : &tmp_expr->where);
12830 : 6 : fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
12831 : 6 : this_code->ext.actual->next->next->expr = fini_coarray;
12832 : :
12833 : 6 : add_code_to_chain (&this_code, head, tail);
12834 : :
12835 : : }
12836 : :
12837 : : /* Counts the potential number of part array references that would
12838 : : result from resolution of typebound defined assignments. */
12839 : :
12840 : :
12841 : : static int
12842 : 242 : nonscalar_typebound_assign (gfc_symbol *derived, int depth)
12843 : : {
12844 : 242 : gfc_component *c;
12845 : 242 : int c_depth = 0, t_depth;
12846 : :
12847 : 582 : for (c= derived->components; c; c = c->next)
12848 : : {
12849 : 340 : if ((!gfc_bt_struct (c->ts.type)
12850 : : || c->attr.pointer
12851 : 260 : || c->attr.allocatable
12852 : 259 : || c->attr.proc_pointer_comp
12853 : : || c->attr.class_pointer
12854 : 259 : || c->attr.proc_pointer)
12855 : 81 : && !c->attr.defined_assign_comp)
12856 : 81 : continue;
12857 : :
12858 : 259 : if (c->as && c_depth == 0)
12859 : 259 : c_depth = 1;
12860 : :
12861 : 259 : if (c->ts.u.derived->attr.defined_assign_comp)
12862 : 110 : t_depth = nonscalar_typebound_assign (c->ts.u.derived,
12863 : : c->as ? 1 : 0);
12864 : : else
12865 : : t_depth = 0;
12866 : :
12867 : 259 : c_depth = t_depth > c_depth ? t_depth : c_depth;
12868 : : }
12869 : 242 : return depth + c_depth;
12870 : : }
12871 : :
12872 : :
12873 : : /* Implement 10.2.1.3 paragraph 13 of the F18 standard:
12874 : : "An intrinsic assignment where the variable is of derived type is performed
12875 : : as if each component of the variable were assigned from the corresponding
12876 : : component of expr using pointer assignment (10.2.2) for each pointer
12877 : : component, defined assignment for each nonpointer nonallocatable component
12878 : : of a type that has a type-bound defined assignment consistent with the
12879 : : component, intrinsic assignment for each other nonpointer nonallocatable
12880 : : component, and intrinsic assignment for each allocated coarray component.
12881 : : For unallocated coarray components, the corresponding component of the
12882 : : variable shall be unallocated. For a noncoarray allocatable component the
12883 : : following sequence of operations is applied.
12884 : : (1) If the component of the variable is allocated, it is deallocated.
12885 : : (2) If the component of the value of expr is allocated, the
12886 : : corresponding component of the variable is allocated with the same
12887 : : dynamic type and type parameters as the component of the value of
12888 : : expr. If it is an array, it is allocated with the same bounds. The
12889 : : value of the component of the value of expr is then assigned to the
12890 : : corresponding component of the variable using defined assignment if
12891 : : the declared type of the component has a type-bound defined
12892 : : assignment consistent with the component, and intrinsic assignment
12893 : : for the dynamic type of that component otherwise."
12894 : :
12895 : : The pointer assignments are taken care of by the intrinsic assignment of the
12896 : : structure itself. This function recursively adds defined assignments where
12897 : : required. The recursion is accomplished by calling gfc_resolve_code.
12898 : :
12899 : : When the lhs in a defined assignment has intent INOUT or is intent OUT
12900 : : and the component of 'var' is finalizable, we need a temporary for the
12901 : : lhs. In pseudo-code for an assignment var = expr:
12902 : :
12903 : : ! Confine finalization of temporaries, as far as possible.
12904 : : Enclose the code for the assignment in a block
12905 : : ! Only call function 'expr' once.
12906 : : #if ('expr is not a constant or an variable)
12907 : : temp_expr = expr
12908 : : expr = temp_x
12909 : : ! Do the intrinsic assignment
12910 : : #if typeof ('var') has a typebound final subroutine
12911 : : finalize (var)
12912 : : var = expr
12913 : : ! Now do the component assignments
12914 : : #do over derived type components [%cmp]
12915 : : #if (cmp is a pointer of any kind)
12916 : : continue
12917 : : build the assignment
12918 : : resolve the code
12919 : : #if the code is a typebound assignment
12920 : : #if (arg1 is INOUT or finalizable OUT && !t1)
12921 : : t1 = var
12922 : : arg1 = t1
12923 : : deal with allocatation or not of var and this component
12924 : : #elseif the code is an assignment by itself
12925 : : #if this component does not need finalization
12926 : : delete code and continue
12927 : : #else
12928 : : remove the leading assignment
12929 : : #endif
12930 : : commit the code
12931 : : #if (t1 and (arg1 is INOUT or finalizable OUT))
12932 : : var%cmp = t1%cmp
12933 : : #enddo
12934 : : put all code chunks involving t1 to the top of the generated code
12935 : : insert the generated block in place of the original code
12936 : : */
12937 : :
12938 : : static bool
12939 : 379 : is_finalizable_type (gfc_typespec ts)
12940 : : {
12941 : 379 : gfc_component *c;
12942 : :
12943 : 379 : if (ts.type != BT_DERIVED)
12944 : : return false;
12945 : :
12946 : : /* (1) Check for FINAL subroutines. */
12947 : 379 : if (ts.u.derived->f2k_derived && ts.u.derived->f2k_derived->finalizers)
12948 : : return true;
12949 : :
12950 : : /* (2) Check for components of finalizable type. */
12951 : 806 : for (c = ts.u.derived->components; c; c = c->next)
12952 : 469 : if (c->ts.type == BT_DERIVED
12953 : 242 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
12954 : 241 : && c->ts.u.derived->f2k_derived
12955 : 241 : && c->ts.u.derived->f2k_derived->finalizers)
12956 : : return true;
12957 : :
12958 : : return false;
12959 : : }
12960 : :
12961 : : /* The temporary assignments have to be put on top of the additional
12962 : : code to avoid the result being changed by the intrinsic assignment.
12963 : : */
12964 : : static int component_assignment_level = 0;
12965 : : static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
12966 : : static bool finalizable_comp;
12967 : :
12968 : : static void
12969 : 187 : generate_component_assignments (gfc_code **code, gfc_namespace *ns)
12970 : : {
12971 : 187 : gfc_component *comp1, *comp2;
12972 : 187 : gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
12973 : 187 : gfc_code *tmp_code = NULL;
12974 : 187 : gfc_expr *t1 = NULL;
12975 : 187 : gfc_expr *tmp_expr = NULL;
12976 : 187 : int error_count, depth;
12977 : 187 : bool finalizable_lhs;
12978 : :
12979 : 187 : gfc_get_errors (NULL, &error_count);
12980 : :
12981 : : /* Filter out continuing processing after an error. */
12982 : 187 : if (error_count
12983 : 187 : || (*code)->expr1->ts.type != BT_DERIVED
12984 : 187 : || (*code)->expr2->ts.type != BT_DERIVED)
12985 : 139 : return;
12986 : :
12987 : : /* TODO: Handle more than one part array reference in assignments. */
12988 : 187 : depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
12989 : 187 : (*code)->expr1->rank ? 1 : 0);
12990 : 187 : if (depth > 1)
12991 : : {
12992 : 6 : gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
12993 : : "done because multiple part array references would "
12994 : : "occur in intermediate expressions.", &(*code)->loc);
12995 : 6 : return;
12996 : : }
12997 : :
12998 : 181 : if (!component_assignment_level)
12999 : 133 : finalizable_comp = true;
13000 : :
13001 : : /* Build a block so that function result temporaries are finalized
13002 : : locally on exiting the rather than enclosing scope. */
13003 : 181 : if (!component_assignment_level)
13004 : : {
13005 : 133 : ns = gfc_build_block_ns (ns);
13006 : 133 : tmp_code = gfc_get_code (EXEC_NOP);
13007 : 133 : *tmp_code = **code;
13008 : 133 : tmp_code->next = NULL;
13009 : 133 : (*code)->op = EXEC_BLOCK;
13010 : 133 : (*code)->ext.block.ns = ns;
13011 : 133 : (*code)->ext.block.assoc = NULL;
13012 : 133 : (*code)->expr1 = (*code)->expr2 = NULL;
13013 : 133 : ns->code = tmp_code;
13014 : 133 : code = &ns->code;
13015 : : }
13016 : :
13017 : 181 : component_assignment_level++;
13018 : :
13019 : 181 : finalizable_lhs = is_finalizable_type ((*code)->expr1->ts);
13020 : :
13021 : : /* Create a temporary so that functions get called only once. */
13022 : 181 : if ((*code)->expr2->expr_type != EXPR_VARIABLE
13023 : 181 : && (*code)->expr2->expr_type != EXPR_CONSTANT)
13024 : : {
13025 : : /* Assign the rhs to the temporary. */
13026 : 80 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13027 : 80 : if (tmp_expr->symtree->n.sym->attr.pointer)
13028 : : {
13029 : 24 : tmp_expr->symtree->n.sym->attr.pointer = 0;
13030 : 24 : tmp_expr->symtree->n.sym->attr.allocatable = 1;
13031 : : }
13032 : 160 : this_code = build_assignment (EXEC_ASSIGN,
13033 : : tmp_expr, (*code)->expr2,
13034 : 80 : NULL, NULL, (*code)->loc);
13035 : 80 : this_code->expr2->must_finalize = 1;
13036 : : /* Add the code and substitute the rhs expression. */
13037 : 80 : add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
13038 : 80 : gfc_free_expr ((*code)->expr2);
13039 : 80 : (*code)->expr2 = tmp_expr;
13040 : : }
13041 : :
13042 : : /* Do the intrinsic assignment. This is not needed if the lhs is one
13043 : : of the temporaries generated here, since the intrinsic assignment
13044 : : to the final result already does this. */
13045 : 181 : if ((*code)->expr1->symtree->n.sym->name[2] != '.')
13046 : : {
13047 : 181 : if (finalizable_lhs)
13048 : 18 : (*code)->expr1->must_finalize = 1;
13049 : 181 : this_code = build_assignment (EXEC_ASSIGN,
13050 : : (*code)->expr1, (*code)->expr2,
13051 : : NULL, NULL, (*code)->loc);
13052 : 181 : add_code_to_chain (&this_code, &head, &tail);
13053 : : }
13054 : :
13055 : 181 : comp1 = (*code)->expr1->ts.u.derived->components;
13056 : 181 : comp2 = (*code)->expr2->ts.u.derived->components;
13057 : :
13058 : 447 : for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
13059 : : {
13060 : 266 : bool inout = false;
13061 : 266 : bool finalizable_out = false;
13062 : :
13063 : : /* The intrinsic assignment does the right thing for pointers
13064 : : of all kinds and allocatable components. */
13065 : 266 : if (!gfc_bt_struct (comp1->ts.type)
13066 : : || comp1->attr.pointer
13067 : 199 : || comp1->attr.allocatable
13068 : 198 : || comp1->attr.proc_pointer_comp
13069 : : || comp1->attr.class_pointer
13070 : 198 : || comp1->attr.proc_pointer)
13071 : 68 : continue;
13072 : :
13073 : 396 : finalizable_comp = is_finalizable_type (comp1->ts)
13074 : 198 : && !finalizable_lhs;
13075 : :
13076 : : /* Make an assignment for this component. */
13077 : 396 : this_code = build_assignment (EXEC_ASSIGN,
13078 : : (*code)->expr1, (*code)->expr2,
13079 : 198 : comp1, comp2, (*code)->loc);
13080 : :
13081 : : /* Convert the assignment if there is a defined assignment for
13082 : : this type. Otherwise, using the call from gfc_resolve_code,
13083 : : recurse into its components. */
13084 : 198 : gfc_resolve_code (this_code, ns);
13085 : :
13086 : 198 : if (this_code->op == EXEC_ASSIGN_CALL)
13087 : : {
13088 : 144 : gfc_formal_arglist *dummy_args;
13089 : 144 : gfc_symbol *rsym;
13090 : : /* Check that there is a typebound defined assignment. If not,
13091 : : then this must be a module defined assignment. We cannot
13092 : : use the defined_assign_comp attribute here because it must
13093 : : be this derived type that has the defined assignment and not
13094 : : a parent type. */
13095 : 144 : if (!(comp1->ts.u.derived->f2k_derived
13096 : : && comp1->ts.u.derived->f2k_derived
13097 : 144 : ->tb_op[INTRINSIC_ASSIGN]))
13098 : : {
13099 : 1 : gfc_free_statements (this_code);
13100 : 1 : this_code = NULL;
13101 : 1 : continue;
13102 : : }
13103 : :
13104 : : /* If the first argument of the subroutine has intent INOUT
13105 : : a temporary must be generated and used instead. */
13106 : 143 : rsym = this_code->resolved_sym;
13107 : 143 : dummy_args = gfc_sym_get_dummy_args (rsym);
13108 : 268 : finalizable_out = gfc_may_be_finalized (comp1->ts)
13109 : 18 : && dummy_args
13110 : 161 : && dummy_args->sym->attr.intent == INTENT_OUT;
13111 : 286 : inout = dummy_args
13112 : 268 : && dummy_args->sym->attr.intent == INTENT_INOUT;
13113 : 72 : if ((inout || finalizable_out)
13114 : 89 : && !comp1->attr.allocatable)
13115 : : {
13116 : 89 : gfc_code *temp_code;
13117 : 89 : inout = true;
13118 : :
13119 : : /* Build the temporary required for the assignment and put
13120 : : it at the head of the generated code. */
13121 : 89 : if (!t1)
13122 : : {
13123 : 89 : gfc_namespace *tmp_ns = ns;
13124 : 89 : if (ns->parent && gfc_may_be_finalized (comp1->ts))
13125 : 18 : tmp_ns = (*code)->expr1->symtree->n.sym->ns;
13126 : 89 : t1 = get_temp_from_expr ((*code)->expr1, tmp_ns);
13127 : 89 : t1->symtree->n.sym->attr.artificial = 1;
13128 : 178 : temp_code = build_assignment (EXEC_ASSIGN,
13129 : : t1, (*code)->expr1,
13130 : 89 : NULL, NULL, (*code)->loc);
13131 : :
13132 : : /* For allocatable LHS, check whether it is allocated. Note
13133 : : that allocatable components with defined assignment are
13134 : : not yet support. See PR 57696. */
13135 : 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable)
13136 : : {
13137 : 24 : gfc_code *block;
13138 : 24 : gfc_expr *e =
13139 : 24 : gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13140 : 24 : block = gfc_get_code (EXEC_IF);
13141 : 24 : block->block = gfc_get_code (EXEC_IF);
13142 : 24 : block->block->expr1
13143 : 48 : = gfc_build_intrinsic_call (ns,
13144 : : GFC_ISYM_ALLOCATED, "allocated",
13145 : 24 : (*code)->loc, 1, e);
13146 : 24 : block->block->next = temp_code;
13147 : 24 : temp_code = block;
13148 : : }
13149 : 89 : add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
13150 : : }
13151 : :
13152 : : /* Replace the first actual arg with the component of the
13153 : : temporary. */
13154 : 89 : gfc_free_expr (this_code->ext.actual->expr);
13155 : 89 : this_code->ext.actual->expr = gfc_copy_expr (t1);
13156 : 89 : add_comp_ref (this_code->ext.actual->expr, comp1);
13157 : :
13158 : : /* If the LHS variable is allocatable and wasn't allocated and
13159 : : the temporary is allocatable, pointer assign the address of
13160 : : the freshly allocated LHS to the temporary. */
13161 : 89 : if ((*code)->expr1->symtree->n.sym->attr.allocatable
13162 : 89 : && gfc_expr_attr ((*code)->expr1).allocatable)
13163 : : {
13164 : 18 : gfc_code *block;
13165 : 18 : gfc_expr *cond;
13166 : :
13167 : 18 : cond = gfc_get_expr ();
13168 : 18 : cond->ts.type = BT_LOGICAL;
13169 : 18 : cond->ts.kind = gfc_default_logical_kind;
13170 : 18 : cond->expr_type = EXPR_OP;
13171 : 18 : cond->where = (*code)->loc;
13172 : 18 : cond->value.op.op = INTRINSIC_NOT;
13173 : 18 : cond->value.op.op1 = gfc_build_intrinsic_call (ns,
13174 : : GFC_ISYM_ALLOCATED, "allocated",
13175 : 18 : (*code)->loc, 1, gfc_copy_expr (t1));
13176 : 18 : block = gfc_get_code (EXEC_IF);
13177 : 18 : block->block = gfc_get_code (EXEC_IF);
13178 : 18 : block->block->expr1 = cond;
13179 : 36 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13180 : : t1, (*code)->expr1,
13181 : 18 : NULL, NULL, (*code)->loc);
13182 : 18 : add_code_to_chain (&block, &head, &tail);
13183 : : }
13184 : : }
13185 : : }
13186 : 54 : else if (this_code->op == EXEC_ASSIGN && !this_code->next)
13187 : : {
13188 : : /* Don't add intrinsic assignments since they are already
13189 : : effected by the intrinsic assignment of the structure, unless
13190 : : finalization is required. */
13191 : 6 : if (finalizable_comp)
13192 : 0 : this_code->expr1->must_finalize = 1;
13193 : : else
13194 : : {
13195 : 6 : gfc_free_statements (this_code);
13196 : 6 : this_code = NULL;
13197 : 6 : continue;
13198 : : }
13199 : : }
13200 : : else
13201 : : {
13202 : : /* Resolution has expanded an assignment of a derived type with
13203 : : defined assigned components. Remove the redundant, leading
13204 : : assignment. */
13205 : 48 : gcc_assert (this_code->op == EXEC_ASSIGN);
13206 : 48 : gfc_code *tmp = this_code;
13207 : 48 : this_code = this_code->next;
13208 : 48 : tmp->next = NULL;
13209 : 48 : gfc_free_statements (tmp);
13210 : : }
13211 : :
13212 : 191 : add_code_to_chain (&this_code, &head, &tail);
13213 : :
13214 : 191 : if (t1 && (inout || finalizable_out))
13215 : : {
13216 : : /* Transfer the value to the final result. */
13217 : 178 : this_code = build_assignment (EXEC_ASSIGN,
13218 : : (*code)->expr1, t1,
13219 : 89 : comp1, comp2, (*code)->loc);
13220 : 89 : this_code->expr1->must_finalize = 0;
13221 : 89 : add_code_to_chain (&this_code, &head, &tail);
13222 : : }
13223 : : }
13224 : :
13225 : : /* Put the temporary assignments at the top of the generated code. */
13226 : 181 : if (tmp_head && component_assignment_level == 1)
13227 : : {
13228 : 125 : gfc_append_code (tmp_head, head);
13229 : 125 : head = tmp_head;
13230 : 125 : tmp_head = tmp_tail = NULL;
13231 : : }
13232 : :
13233 : : /* If we did a pointer assignment - thus, we need to ensure that the LHS is
13234 : : not accidentally deallocated. Hence, nullify t1. */
13235 : 89 : if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
13236 : 270 : && gfc_expr_attr ((*code)->expr1).allocatable)
13237 : : {
13238 : 18 : gfc_code *block;
13239 : 18 : gfc_expr *cond;
13240 : 18 : gfc_expr *e;
13241 : :
13242 : 18 : e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
13243 : 18 : cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
13244 : 18 : (*code)->loc, 2, gfc_copy_expr (t1), e);
13245 : 18 : block = gfc_get_code (EXEC_IF);
13246 : 18 : block->block = gfc_get_code (EXEC_IF);
13247 : 18 : block->block->expr1 = cond;
13248 : 18 : block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
13249 : : t1, gfc_get_null_expr (&(*code)->loc),
13250 : 18 : NULL, NULL, (*code)->loc);
13251 : 18 : gfc_append_code (tail, block);
13252 : 18 : tail = block;
13253 : : }
13254 : :
13255 : 181 : component_assignment_level--;
13256 : :
13257 : : /* Make an explicit final call for the function result. */
13258 : 181 : if (tmp_expr)
13259 : 80 : generate_final_call (tmp_expr, &head, &tail);
13260 : :
13261 : 181 : if (tmp_code)
13262 : : {
13263 : 133 : ns->code = head;
13264 : 133 : return;
13265 : : }
13266 : :
13267 : : /* Now attach the remaining code chain to the input code. Step on
13268 : : to the end of the new code since resolution is complete. */
13269 : 48 : gcc_assert ((*code)->op == EXEC_ASSIGN);
13270 : 48 : tail->next = (*code)->next;
13271 : : /* Overwrite 'code' because this would place the intrinsic assignment
13272 : : before the temporary for the lhs is created. */
13273 : 48 : gfc_free_expr ((*code)->expr1);
13274 : 48 : gfc_free_expr ((*code)->expr2);
13275 : 48 : **code = *head;
13276 : 48 : if (head != tail)
13277 : 48 : free (head);
13278 : 48 : *code = tail;
13279 : : }
13280 : :
13281 : :
13282 : : /* F2008: Pointer function assignments are of the form:
13283 : : ptr_fcn (args) = expr
13284 : : This function breaks these assignments into two statements:
13285 : : temporary_pointer => ptr_fcn(args)
13286 : : temporary_pointer = expr */
13287 : :
13288 : : static bool
13289 : 186176 : resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
13290 : : {
13291 : 186176 : gfc_expr *tmp_ptr_expr;
13292 : 186176 : gfc_code *this_code;
13293 : 186176 : gfc_component *comp;
13294 : 186176 : gfc_symbol *s;
13295 : :
13296 : 186176 : if ((*code)->expr1->expr_type != EXPR_FUNCTION)
13297 : : return false;
13298 : :
13299 : : /* Even if standard does not support this feature, continue to build
13300 : : the two statements to avoid upsetting frontend_passes.c. */
13301 : 205 : gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
13302 : : "%L", &(*code)->loc);
13303 : :
13304 : 205 : comp = gfc_get_proc_ptr_comp ((*code)->expr1);
13305 : :
13306 : 205 : if (comp)
13307 : 6 : s = comp->ts.interface;
13308 : : else
13309 : 199 : s = (*code)->expr1->symtree->n.sym;
13310 : :
13311 : 205 : if (s == NULL || !s->result->attr.pointer)
13312 : : {
13313 : 5 : gfc_error ("The function result on the lhs of the assignment at "
13314 : : "%L must have the pointer attribute.",
13315 : 5 : &(*code)->expr1->where);
13316 : 5 : (*code)->op = EXEC_NOP;
13317 : 5 : return false;
13318 : : }
13319 : :
13320 : 200 : tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
13321 : :
13322 : : /* get_temp_from_expression is set up for ordinary assignments. To that
13323 : : end, where array bounds are not known, arrays are made allocatable.
13324 : : Change the temporary to a pointer here. */
13325 : 200 : tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
13326 : 200 : tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
13327 : 200 : tmp_ptr_expr->where = (*code)->loc;
13328 : :
13329 : : /* A new charlen is required to ensure that the variable string length
13330 : : is different to that of the original lhs for deferred results. */
13331 : 200 : if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
13332 : : {
13333 : 60 : tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
13334 : 60 : tmp_ptr_expr->ts.deferred = 1;
13335 : 60 : tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
13336 : 60 : gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
13337 : 60 : tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
13338 : : }
13339 : :
13340 : 400 : this_code = build_assignment (EXEC_ASSIGN,
13341 : : tmp_ptr_expr, (*code)->expr2,
13342 : 200 : NULL, NULL, (*code)->loc);
13343 : 200 : this_code->next = (*code)->next;
13344 : 200 : (*code)->next = this_code;
13345 : 200 : (*code)->op = EXEC_POINTER_ASSIGN;
13346 : 200 : (*code)->expr2 = (*code)->expr1;
13347 : 200 : (*code)->expr1 = tmp_ptr_expr;
13348 : :
13349 : 200 : return true;
13350 : : }
13351 : :
13352 : :
13353 : : /* Deferred character length assignments from an operator expression
13354 : : require a temporary because the character length of the lhs can
13355 : : change in the course of the assignment. */
13356 : :
13357 : : static bool
13358 : 185181 : deferred_op_assign (gfc_code **code, gfc_namespace *ns)
13359 : : {
13360 : 185181 : gfc_expr *tmp_expr;
13361 : 185181 : gfc_code *this_code;
13362 : :
13363 : 185181 : if (!((*code)->expr1->ts.type == BT_CHARACTER
13364 : 25569 : && (*code)->expr1->ts.deferred && (*code)->expr1->rank
13365 : 713 : && (*code)->expr2->ts.type == BT_CHARACTER
13366 : 712 : && (*code)->expr2->expr_type == EXPR_OP))
13367 : : return false;
13368 : :
13369 : 34 : if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
13370 : : return false;
13371 : :
13372 : 28 : if (gfc_expr_attr ((*code)->expr1).pointer)
13373 : : return false;
13374 : :
13375 : 22 : tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
13376 : 22 : tmp_expr->where = (*code)->loc;
13377 : :
13378 : : /* A new charlen is required to ensure that the variable string
13379 : : length is different to that of the original lhs. */
13380 : 22 : tmp_expr->ts.u.cl = gfc_get_charlen();
13381 : 22 : tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
13382 : 22 : tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
13383 : 22 : (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
13384 : :
13385 : 22 : tmp_expr->symtree->n.sym->ts.deferred = 1;
13386 : :
13387 : 22 : this_code = build_assignment (EXEC_ASSIGN,
13388 : 22 : (*code)->expr1,
13389 : : gfc_copy_expr (tmp_expr),
13390 : : NULL, NULL, (*code)->loc);
13391 : :
13392 : 22 : (*code)->expr1 = tmp_expr;
13393 : :
13394 : 22 : this_code->next = (*code)->next;
13395 : 22 : (*code)->next = this_code;
13396 : :
13397 : 22 : return true;
13398 : : }
13399 : :
13400 : :
13401 : : static bool
13402 : 51 : check_team (gfc_expr *team, const char *intrinsic)
13403 : : {
13404 : 51 : if (team->rank != 0
13405 : 50 : || team->ts.type != BT_DERIVED
13406 : 47 : || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
13407 : 47 : || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
13408 : : {
13409 : 4 : gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
13410 : : "of type TEAM_TYPE", intrinsic, &team->where);
13411 : 4 : return false;
13412 : : }
13413 : :
13414 : : return true;
13415 : : }
13416 : :
13417 : :
13418 : : /* Given a block of code, recursively resolve everything pointed to by this
13419 : : code block. */
13420 : :
13421 : : void
13422 : 624078 : gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
13423 : : {
13424 : 624078 : int omp_workshare_save;
13425 : 624078 : int forall_save, do_concurrent_save;
13426 : 624078 : code_stack frame;
13427 : 624078 : bool t;
13428 : :
13429 : 624078 : frame.prev = cs_base;
13430 : 624078 : frame.head = code;
13431 : 624078 : cs_base = &frame;
13432 : :
13433 : 624078 : find_reachable_labels (code);
13434 : :
13435 : 1585569 : for (; code; code = code->next)
13436 : : {
13437 : 961492 : frame.current = code;
13438 : 961492 : forall_save = forall_flag;
13439 : 961492 : do_concurrent_save = gfc_do_concurrent_flag;
13440 : :
13441 : 961492 : if (code->op == EXEC_FORALL)
13442 : : {
13443 : 2004 : forall_flag = 1;
13444 : 2004 : gfc_resolve_forall (code, ns, forall_save);
13445 : 2004 : forall_flag = 2;
13446 : : }
13447 : 959488 : else if (code->block)
13448 : : {
13449 : 297394 : omp_workshare_save = -1;
13450 : 297394 : switch (code->op)
13451 : : {
13452 : 9273 : case EXEC_OACC_PARALLEL_LOOP:
13453 : 9273 : case EXEC_OACC_PARALLEL:
13454 : 9273 : case EXEC_OACC_KERNELS_LOOP:
13455 : 9273 : case EXEC_OACC_KERNELS:
13456 : 9273 : case EXEC_OACC_SERIAL_LOOP:
13457 : 9273 : case EXEC_OACC_SERIAL:
13458 : 9273 : case EXEC_OACC_DATA:
13459 : 9273 : case EXEC_OACC_HOST_DATA:
13460 : 9273 : case EXEC_OACC_LOOP:
13461 : 9273 : gfc_resolve_oacc_blocks (code, ns);
13462 : 9273 : break;
13463 : 54 : case EXEC_OMP_PARALLEL_WORKSHARE:
13464 : 54 : omp_workshare_save = omp_workshare_flag;
13465 : 54 : omp_workshare_flag = 1;
13466 : 54 : gfc_resolve_omp_parallel_blocks (code, ns);
13467 : 54 : break;
13468 : 5709 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13469 : 5709 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13470 : 5709 : case EXEC_OMP_MASKED_TASKLOOP:
13471 : 5709 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13472 : 5709 : case EXEC_OMP_MASTER_TASKLOOP:
13473 : 5709 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13474 : 5709 : case EXEC_OMP_PARALLEL:
13475 : 5709 : case EXEC_OMP_PARALLEL_DO:
13476 : 5709 : case EXEC_OMP_PARALLEL_DO_SIMD:
13477 : 5709 : case EXEC_OMP_PARALLEL_LOOP:
13478 : 5709 : case EXEC_OMP_PARALLEL_MASKED:
13479 : 5709 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13480 : 5709 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13481 : 5709 : case EXEC_OMP_PARALLEL_MASTER:
13482 : 5709 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13483 : 5709 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13484 : 5709 : case EXEC_OMP_PARALLEL_SECTIONS:
13485 : 5709 : case EXEC_OMP_TARGET_PARALLEL:
13486 : 5709 : case EXEC_OMP_TARGET_PARALLEL_DO:
13487 : 5709 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13488 : 5709 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13489 : 5709 : case EXEC_OMP_TARGET_TEAMS:
13490 : 5709 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13491 : 5709 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13492 : 5709 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13493 : 5709 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13494 : 5709 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13495 : 5709 : case EXEC_OMP_TASK:
13496 : 5709 : case EXEC_OMP_TASKLOOP:
13497 : 5709 : case EXEC_OMP_TASKLOOP_SIMD:
13498 : 5709 : case EXEC_OMP_TEAMS:
13499 : 5709 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13500 : 5709 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13501 : 5709 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13502 : 5709 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13503 : 5709 : case EXEC_OMP_TEAMS_LOOP:
13504 : 5709 : omp_workshare_save = omp_workshare_flag;
13505 : 5709 : omp_workshare_flag = 0;
13506 : 5709 : gfc_resolve_omp_parallel_blocks (code, ns);
13507 : 5709 : break;
13508 : 2937 : case EXEC_OMP_DISTRIBUTE:
13509 : 2937 : case EXEC_OMP_DISTRIBUTE_SIMD:
13510 : 2937 : case EXEC_OMP_DO:
13511 : 2937 : case EXEC_OMP_DO_SIMD:
13512 : 2937 : case EXEC_OMP_LOOP:
13513 : 2937 : case EXEC_OMP_SIMD:
13514 : 2937 : case EXEC_OMP_TARGET_SIMD:
13515 : 2937 : case EXEC_OMP_TILE:
13516 : 2937 : case EXEC_OMP_UNROLL:
13517 : 2937 : gfc_resolve_omp_do_blocks (code, ns);
13518 : 2937 : break;
13519 : : case EXEC_SELECT_TYPE:
13520 : : case EXEC_SELECT_RANK:
13521 : : /* Blocks are handled in resolve_select_type/rank because we
13522 : : have to transform the SELECT TYPE into ASSOCIATE first. */
13523 : : break;
13524 : 70 : case EXEC_DO_CONCURRENT:
13525 : 70 : gfc_do_concurrent_flag = 1;
13526 : 70 : gfc_resolve_blocks (code->block, ns);
13527 : 70 : gfc_do_concurrent_flag = 2;
13528 : 70 : break;
13529 : 39 : case EXEC_OMP_WORKSHARE:
13530 : 39 : omp_workshare_save = omp_workshare_flag;
13531 : 39 : omp_workshare_flag = 1;
13532 : : /* FALL THROUGH */
13533 : 275501 : default:
13534 : 275501 : gfc_resolve_blocks (code->block, ns);
13535 : 275501 : break;
13536 : : }
13537 : :
13538 : 293544 : if (omp_workshare_save != -1)
13539 : 5802 : omp_workshare_flag = omp_workshare_save;
13540 : : }
13541 : 662094 : start:
13542 : 961697 : t = true;
13543 : 961697 : if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
13544 : : {
13545 : 960317 : switch (code->op)
13546 : : {
13547 : 187356 : case EXEC_ASSIGN:
13548 : 187356 : case EXEC_LOCK:
13549 : 187356 : case EXEC_UNLOCK:
13550 : 187356 : case EXEC_EVENT_POST:
13551 : 187356 : case EXEC_EVENT_WAIT:
13552 : 187356 : caf_lhs = gfc_is_coindexed (code->expr1);
13553 : 187356 : break;
13554 : : default:
13555 : : break;
13556 : : }
13557 : 960317 : t = gfc_resolve_expr (code->expr1);
13558 : 960317 : caf_lhs = false;
13559 : : }
13560 : 961697 : forall_flag = forall_save;
13561 : 961697 : gfc_do_concurrent_flag = do_concurrent_save;
13562 : :
13563 : 961697 : if (!gfc_resolve_expr (code->expr2))
13564 : 551 : t = false;
13565 : :
13566 : 961697 : if (code->op == EXEC_ALLOCATE
13567 : 961697 : && !gfc_resolve_expr (code->expr3))
13568 : : t = false;
13569 : :
13570 : 961697 : switch (code->op)
13571 : : {
13572 : : case EXEC_NOP:
13573 : : case EXEC_END_BLOCK:
13574 : : case EXEC_END_NESTED_BLOCK:
13575 : : case EXEC_CYCLE:
13576 : : case EXEC_PAUSE:
13577 : : break;
13578 : :
13579 : 190843 : case EXEC_STOP:
13580 : 190843 : case EXEC_ERROR_STOP:
13581 : 190843 : if (code->expr2 != NULL
13582 : 37 : && (code->expr2->ts.type != BT_LOGICAL
13583 : 37 : || code->expr2->rank != 0))
13584 : 0 : gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
13585 : : &code->expr2->where);
13586 : : break;
13587 : :
13588 : : case EXEC_EXIT:
13589 : : case EXEC_CONTINUE:
13590 : : case EXEC_DT_END:
13591 : : case EXEC_ASSIGN_CALL:
13592 : : break;
13593 : :
13594 : 33 : case EXEC_CRITICAL:
13595 : 33 : resolve_critical (code);
13596 : 33 : break;
13597 : :
13598 : 747 : case EXEC_SYNC_ALL:
13599 : 747 : case EXEC_SYNC_IMAGES:
13600 : 747 : case EXEC_SYNC_MEMORY:
13601 : 747 : resolve_sync (code);
13602 : 747 : break;
13603 : :
13604 : 136 : case EXEC_LOCK:
13605 : 136 : case EXEC_UNLOCK:
13606 : 136 : case EXEC_EVENT_POST:
13607 : 136 : case EXEC_EVENT_WAIT:
13608 : 136 : resolve_lock_unlock_event (code);
13609 : 136 : break;
13610 : :
13611 : : case EXEC_FAIL_IMAGE:
13612 : : break;
13613 : :
13614 : 30 : case EXEC_FORM_TEAM:
13615 : 30 : if (code->expr1 != NULL
13616 : 30 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
13617 : 2 : gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
13618 : : "a scalar INTEGER", &code->expr1->where);
13619 : 30 : check_team (code->expr2, "FORM TEAM");
13620 : 30 : break;
13621 : :
13622 : 20 : case EXEC_CHANGE_TEAM:
13623 : 20 : check_team (code->expr1, "CHANGE TEAM");
13624 : 20 : break;
13625 : :
13626 : : case EXEC_END_TEAM:
13627 : : break;
13628 : :
13629 : 1 : case EXEC_SYNC_TEAM:
13630 : 1 : check_team (code->expr1, "SYNC TEAM");
13631 : 1 : break;
13632 : :
13633 : 1420 : case EXEC_ENTRY:
13634 : : /* Keep track of which entry we are up to. */
13635 : 1420 : current_entry_id = code->ext.entry->id;
13636 : 1420 : break;
13637 : :
13638 : 450 : case EXEC_WHERE:
13639 : 450 : resolve_where (code, NULL);
13640 : 450 : break;
13641 : :
13642 : 1236 : case EXEC_GOTO:
13643 : 1236 : if (code->expr1 != NULL)
13644 : : {
13645 : 78 : if (code->expr1->expr_type != EXPR_VARIABLE
13646 : 76 : || code->expr1->ts.type != BT_INTEGER
13647 : 76 : || (code->expr1->ref
13648 : 1 : && code->expr1->ref->type == REF_ARRAY)
13649 : 75 : || code->expr1->symtree == NULL
13650 : 75 : || (code->expr1->symtree->n.sym
13651 : 75 : && (code->expr1->symtree->n.sym->attr.flavor
13652 : 75 : == FL_PARAMETER)))
13653 : 4 : gfc_error ("ASSIGNED GOTO statement at %L requires a "
13654 : : "scalar INTEGER variable", &code->expr1->where);
13655 : 74 : else if (code->expr1->symtree->n.sym
13656 : 74 : && code->expr1->symtree->n.sym->attr.assign != 1)
13657 : 1 : gfc_error ("Variable %qs has not been assigned a target "
13658 : : "label at %L", code->expr1->symtree->n.sym->name,
13659 : : &code->expr1->where);
13660 : : }
13661 : : else
13662 : 1158 : resolve_branch (code->label1, code);
13663 : : break;
13664 : :
13665 : 3094 : case EXEC_RETURN:
13666 : 3094 : if (code->expr1 != NULL
13667 : 53 : && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
13668 : 1 : gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
13669 : : "INTEGER return specifier", &code->expr1->where);
13670 : : break;
13671 : :
13672 : : case EXEC_INIT_ASSIGN:
13673 : : case EXEC_END_PROCEDURE:
13674 : : break;
13675 : :
13676 : 187220 : case EXEC_ASSIGN:
13677 : 187220 : if (!t)
13678 : : break;
13679 : :
13680 : 186635 : if (flag_coarray == GFC_FCOARRAY_LIB
13681 : 186635 : && (gfc_is_coindexed (code->expr1)
13682 : 2307 : || caf_possible_reallocate (code->expr1)))
13683 : : {
13684 : : /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
13685 : : coindexed variable. */
13686 : 459 : code->op = EXEC_CALL;
13687 : 459 : gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
13688 : : true);
13689 : 459 : code->resolved_sym = code->symtree->n.sym;
13690 : 459 : code->resolved_sym->attr.flavor = FL_PROCEDURE;
13691 : 459 : code->resolved_sym->attr.intrinsic = 1;
13692 : 459 : code->resolved_sym->attr.subroutine = 1;
13693 : 459 : code->resolved_isym
13694 : 459 : = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
13695 : 459 : gfc_commit_symbol (code->resolved_sym);
13696 : 459 : code->ext.actual = gfc_get_actual_arglist ();
13697 : 459 : code->ext.actual->expr = code->expr1;
13698 : 459 : code->ext.actual->next = gfc_get_actual_arglist ();
13699 : 459 : code->ext.actual->next->expr = code->expr2;
13700 : :
13701 : 459 : code->expr1 = NULL;
13702 : 459 : code->expr2 = NULL;
13703 : 459 : break;
13704 : : }
13705 : :
13706 : 186176 : if (code->expr1->ts.type == BT_CLASS)
13707 : 951 : gfc_find_vtab (&code->expr2->ts);
13708 : :
13709 : : /* If this is a pointer function in an lvalue variable context,
13710 : : the new code will have to be resolved afresh. This is also the
13711 : : case with an error, where the code is transformed into NOP to
13712 : : prevent ICEs downstream. */
13713 : 186176 : if (resolve_ptr_fcn_assign (&code, ns)
13714 : 186176 : || code->op == EXEC_NOP)
13715 : 205 : goto start;
13716 : :
13717 : 185971 : if (!gfc_check_vardef_context (code->expr1, false, false, false,
13718 : 185971 : _("assignment")))
13719 : : break;
13720 : :
13721 : 185933 : if (resolve_ordinary_assign (code, ns))
13722 : : {
13723 : 752 : if (omp_workshare_flag)
13724 : : {
13725 : 1 : gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
13726 : 1 : "at %L", &code->loc);
13727 : 1 : break;
13728 : : }
13729 : 751 : if (code->op == EXEC_COMPCALL)
13730 : 416 : goto compcall;
13731 : : else
13732 : 335 : goto call;
13733 : : }
13734 : :
13735 : : /* Check for dependencies in deferred character length array
13736 : : assignments and generate a temporary, if necessary. */
13737 : 185181 : if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
13738 : : break;
13739 : :
13740 : : /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
13741 : 185159 : if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
13742 : 6415 : && code->expr1->ts.u.derived
13743 : 6415 : && code->expr1->ts.u.derived->attr.defined_assign_comp)
13744 : 187 : generate_component_assignments (&code, ns);
13745 : 184972 : else if (code->op == EXEC_ASSIGN)
13746 : : {
13747 : 184972 : if (gfc_may_be_finalized (code->expr1->ts))
13748 : 1059 : code->expr1->must_finalize = 1;
13749 : 184972 : if (code->expr2->expr_type == EXPR_ARRAY
13750 : 184972 : && gfc_may_be_finalized (code->expr2->ts))
13751 : 43 : code->expr2->must_finalize = 1;
13752 : : }
13753 : :
13754 : : break;
13755 : :
13756 : 126 : case EXEC_LABEL_ASSIGN:
13757 : 126 : if (code->label1->defined == ST_LABEL_UNKNOWN)
13758 : 0 : gfc_error ("Label %d referenced at %L is never defined",
13759 : : code->label1->value, &code->label1->where);
13760 : 126 : if (t
13761 : 126 : && (code->expr1->expr_type != EXPR_VARIABLE
13762 : 126 : || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
13763 : 126 : || code->expr1->symtree->n.sym->ts.kind
13764 : 126 : != gfc_default_integer_kind
13765 : 126 : || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
13766 : 125 : || code->expr1->symtree->n.sym->as != NULL))
13767 : 2 : gfc_error ("ASSIGN statement at %L requires a scalar "
13768 : : "default INTEGER variable", &code->expr1->where);
13769 : : break;
13770 : :
13771 : 9795 : case EXEC_POINTER_ASSIGN:
13772 : 9795 : {
13773 : 9795 : gfc_expr* e;
13774 : :
13775 : 9795 : if (!t)
13776 : : break;
13777 : :
13778 : : /* This is both a variable definition and pointer assignment
13779 : : context, so check both of them. For rank remapping, a final
13780 : : array ref may be present on the LHS and fool gfc_expr_attr
13781 : : used in gfc_check_vardef_context. Remove it. */
13782 : 9790 : e = remove_last_array_ref (code->expr1);
13783 : 19580 : t = gfc_check_vardef_context (e, true, false, false,
13784 : 9790 : _("pointer assignment"));
13785 : 9790 : if (t)
13786 : 9769 : t = gfc_check_vardef_context (e, false, false, false,
13787 : 9769 : _("pointer assignment"));
13788 : 9790 : gfc_free_expr (e);
13789 : :
13790 : 971147 : t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
13791 : :
13792 : 9656 : if (!t)
13793 : : break;
13794 : :
13795 : : /* Assigning a class object always is a regular assign. */
13796 : 9656 : if (code->expr2->ts.type == BT_CLASS
13797 : 533 : && code->expr1->ts.type == BT_CLASS
13798 : 448 : && CLASS_DATA (code->expr2)
13799 : 447 : && !CLASS_DATA (code->expr2)->attr.dimension
13800 : 10231 : && !(gfc_expr_attr (code->expr1).proc_pointer
13801 : 42 : && code->expr2->expr_type == EXPR_VARIABLE
13802 : 36 : && code->expr2->symtree->n.sym->attr.flavor
13803 : 36 : == FL_PROCEDURE))
13804 : 311 : code->op = EXEC_ASSIGN;
13805 : : break;
13806 : : }
13807 : :
13808 : 72 : case EXEC_ARITHMETIC_IF:
13809 : 72 : {
13810 : 72 : gfc_expr *e = code->expr1;
13811 : :
13812 : 72 : gfc_resolve_expr (e);
13813 : 72 : if (e->expr_type == EXPR_NULL)
13814 : 1 : gfc_error ("Invalid NULL at %L", &e->where);
13815 : :
13816 : 72 : if (t && (e->rank > 0
13817 : 68 : || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
13818 : 5 : gfc_error ("Arithmetic IF statement at %L requires a scalar "
13819 : : "REAL or INTEGER expression", &e->where);
13820 : :
13821 : 72 : resolve_branch (code->label1, code);
13822 : 72 : resolve_branch (code->label2, code);
13823 : 72 : resolve_branch (code->label3, code);
13824 : : }
13825 : 72 : break;
13826 : :
13827 : 203555 : case EXEC_IF:
13828 : 203555 : if (t && code->expr1 != NULL
13829 : 0 : && (code->expr1->ts.type != BT_LOGICAL
13830 : 0 : || code->expr1->rank != 0))
13831 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
13832 : : &code->expr1->where);
13833 : : break;
13834 : :
13835 : 76085 : case EXEC_CALL:
13836 : 76085 : call:
13837 : 76085 : resolve_call (code);
13838 : 76085 : break;
13839 : :
13840 : 1673 : case EXEC_COMPCALL:
13841 : 1673 : compcall:
13842 : 1673 : resolve_typebound_subroutine (code);
13843 : 1673 : break;
13844 : :
13845 : 123 : case EXEC_CALL_PPC:
13846 : 123 : resolve_ppc_call (code);
13847 : 123 : break;
13848 : :
13849 : 708 : case EXEC_SELECT:
13850 : : /* Select is complicated. Also, a SELECT construct could be
13851 : : a transformed computed GOTO. */
13852 : 708 : resolve_select (code, false);
13853 : 708 : break;
13854 : :
13855 : 2857 : case EXEC_SELECT_TYPE:
13856 : 2857 : resolve_select_type (code, ns);
13857 : 2857 : break;
13858 : :
13859 : 1018 : case EXEC_SELECT_RANK:
13860 : 1018 : resolve_select_rank (code, ns);
13861 : 1018 : break;
13862 : :
13863 : 7420 : case EXEC_BLOCK:
13864 : 7420 : resolve_block_construct (code);
13865 : 7420 : break;
13866 : :
13867 : 31308 : case EXEC_DO:
13868 : 31308 : if (code->ext.iterator != NULL)
13869 : : {
13870 : 31308 : gfc_iterator *iter = code->ext.iterator;
13871 : 31308 : if (gfc_resolve_iterator (iter, true, false))
13872 : 31294 : gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
13873 : : true);
13874 : : }
13875 : : break;
13876 : :
13877 : 523 : case EXEC_DO_WHILE:
13878 : 523 : if (code->expr1 == NULL)
13879 : 0 : gfc_internal_error ("gfc_resolve_code(): No expression on "
13880 : : "DO WHILE");
13881 : 523 : if (t
13882 : 523 : && (code->expr1->rank != 0
13883 : 523 : || code->expr1->ts.type != BT_LOGICAL))
13884 : 0 : gfc_error ("Exit condition of DO WHILE loop at %L must be "
13885 : : "a scalar LOGICAL expression", &code->expr1->where);
13886 : : break;
13887 : :
13888 : 13434 : case EXEC_ALLOCATE:
13889 : 13434 : if (t)
13890 : 13432 : resolve_allocate_deallocate (code, "ALLOCATE");
13891 : :
13892 : : break;
13893 : :
13894 : 5616 : case EXEC_DEALLOCATE:
13895 : 5616 : if (t)
13896 : 5616 : resolve_allocate_deallocate (code, "DEALLOCATE");
13897 : :
13898 : : break;
13899 : :
13900 : 3869 : case EXEC_OPEN:
13901 : 3869 : if (!gfc_resolve_open (code->ext.open, &code->loc))
13902 : : break;
13903 : :
13904 : 3642 : resolve_branch (code->ext.open->err, code);
13905 : 3642 : break;
13906 : :
13907 : 3062 : case EXEC_CLOSE:
13908 : 3062 : if (!gfc_resolve_close (code->ext.close, &code->loc))
13909 : : break;
13910 : :
13911 : 3028 : resolve_branch (code->ext.close->err, code);
13912 : 3028 : break;
13913 : :
13914 : 2734 : case EXEC_BACKSPACE:
13915 : 2734 : case EXEC_ENDFILE:
13916 : 2734 : case EXEC_REWIND:
13917 : 2734 : case EXEC_FLUSH:
13918 : 2734 : if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
13919 : : break;
13920 : :
13921 : 2668 : resolve_branch (code->ext.filepos->err, code);
13922 : 2668 : break;
13923 : :
13924 : 817 : case EXEC_INQUIRE:
13925 : 817 : if (!gfc_resolve_inquire (code->ext.inquire))
13926 : : break;
13927 : :
13928 : 769 : resolve_branch (code->ext.inquire->err, code);
13929 : 769 : break;
13930 : :
13931 : 92 : case EXEC_IOLENGTH:
13932 : 92 : gcc_assert (code->ext.inquire != NULL);
13933 : 92 : if (!gfc_resolve_inquire (code->ext.inquire))
13934 : : break;
13935 : :
13936 : 90 : resolve_branch (code->ext.inquire->err, code);
13937 : 90 : break;
13938 : :
13939 : 89 : case EXEC_WAIT:
13940 : 89 : if (!gfc_resolve_wait (code->ext.wait))
13941 : : break;
13942 : :
13943 : 74 : resolve_branch (code->ext.wait->err, code);
13944 : 74 : resolve_branch (code->ext.wait->end, code);
13945 : 74 : resolve_branch (code->ext.wait->eor, code);
13946 : 74 : break;
13947 : :
13948 : 31421 : case EXEC_READ:
13949 : 31421 : case EXEC_WRITE:
13950 : 31421 : if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
13951 : : break;
13952 : :
13953 : 31112 : resolve_branch (code->ext.dt->err, code);
13954 : 31112 : resolve_branch (code->ext.dt->end, code);
13955 : 31112 : resolve_branch (code->ext.dt->eor, code);
13956 : 31112 : break;
13957 : :
13958 : 44961 : case EXEC_TRANSFER:
13959 : 44961 : resolve_transfer (code);
13960 : 44961 : break;
13961 : :
13962 : 2074 : case EXEC_DO_CONCURRENT:
13963 : 2074 : case EXEC_FORALL:
13964 : 2074 : resolve_forall_iterators (code->ext.forall_iterator);
13965 : :
13966 : 2074 : if (code->expr1 != NULL
13967 : 749 : && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
13968 : 2 : gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
13969 : : "expression", &code->expr1->where);
13970 : : break;
13971 : :
13972 : 12260 : case EXEC_OACC_PARALLEL_LOOP:
13973 : 12260 : case EXEC_OACC_PARALLEL:
13974 : 12260 : case EXEC_OACC_KERNELS_LOOP:
13975 : 12260 : case EXEC_OACC_KERNELS:
13976 : 12260 : case EXEC_OACC_SERIAL_LOOP:
13977 : 12260 : case EXEC_OACC_SERIAL:
13978 : 12260 : case EXEC_OACC_DATA:
13979 : 12260 : case EXEC_OACC_HOST_DATA:
13980 : 12260 : case EXEC_OACC_LOOP:
13981 : 12260 : case EXEC_OACC_UPDATE:
13982 : 12260 : case EXEC_OACC_WAIT:
13983 : 12260 : case EXEC_OACC_CACHE:
13984 : 12260 : case EXEC_OACC_ENTER_DATA:
13985 : 12260 : case EXEC_OACC_EXIT_DATA:
13986 : 12260 : case EXEC_OACC_ATOMIC:
13987 : 12260 : case EXEC_OACC_DECLARE:
13988 : 12260 : gfc_resolve_oacc_directive (code, ns);
13989 : 12260 : break;
13990 : :
13991 : 15941 : case EXEC_OMP_ALLOCATE:
13992 : 15941 : case EXEC_OMP_ALLOCATORS:
13993 : 15941 : case EXEC_OMP_ASSUME:
13994 : 15941 : case EXEC_OMP_ATOMIC:
13995 : 15941 : case EXEC_OMP_BARRIER:
13996 : 15941 : case EXEC_OMP_CANCEL:
13997 : 15941 : case EXEC_OMP_CANCELLATION_POINT:
13998 : 15941 : case EXEC_OMP_CRITICAL:
13999 : 15941 : case EXEC_OMP_FLUSH:
14000 : 15941 : case EXEC_OMP_DEPOBJ:
14001 : 15941 : case EXEC_OMP_DISPATCH:
14002 : 15941 : case EXEC_OMP_DISTRIBUTE:
14003 : 15941 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14004 : 15941 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14005 : 15941 : case EXEC_OMP_DISTRIBUTE_SIMD:
14006 : 15941 : case EXEC_OMP_DO:
14007 : 15941 : case EXEC_OMP_DO_SIMD:
14008 : 15941 : case EXEC_OMP_ERROR:
14009 : 15941 : case EXEC_OMP_INTEROP:
14010 : 15941 : case EXEC_OMP_LOOP:
14011 : 15941 : case EXEC_OMP_MASTER:
14012 : 15941 : case EXEC_OMP_MASTER_TASKLOOP:
14013 : 15941 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14014 : 15941 : case EXEC_OMP_MASKED:
14015 : 15941 : case EXEC_OMP_MASKED_TASKLOOP:
14016 : 15941 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14017 : 15941 : case EXEC_OMP_ORDERED:
14018 : 15941 : case EXEC_OMP_SCAN:
14019 : 15941 : case EXEC_OMP_SCOPE:
14020 : 15941 : case EXEC_OMP_SECTIONS:
14021 : 15941 : case EXEC_OMP_SIMD:
14022 : 15941 : case EXEC_OMP_SINGLE:
14023 : 15941 : case EXEC_OMP_TARGET:
14024 : 15941 : case EXEC_OMP_TARGET_DATA:
14025 : 15941 : case EXEC_OMP_TARGET_ENTER_DATA:
14026 : 15941 : case EXEC_OMP_TARGET_EXIT_DATA:
14027 : 15941 : case EXEC_OMP_TARGET_PARALLEL:
14028 : 15941 : case EXEC_OMP_TARGET_PARALLEL_DO:
14029 : 15941 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14030 : 15941 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14031 : 15941 : case EXEC_OMP_TARGET_SIMD:
14032 : 15941 : case EXEC_OMP_TARGET_TEAMS:
14033 : 15941 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14034 : 15941 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14035 : 15941 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14036 : 15941 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14037 : 15941 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14038 : 15941 : case EXEC_OMP_TARGET_UPDATE:
14039 : 15941 : case EXEC_OMP_TASK:
14040 : 15941 : case EXEC_OMP_TASKGROUP:
14041 : 15941 : case EXEC_OMP_TASKLOOP:
14042 : 15941 : case EXEC_OMP_TASKLOOP_SIMD:
14043 : 15941 : case EXEC_OMP_TASKWAIT:
14044 : 15941 : case EXEC_OMP_TASKYIELD:
14045 : 15941 : case EXEC_OMP_TEAMS:
14046 : 15941 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14047 : 15941 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14048 : 15941 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14049 : 15941 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14050 : 15941 : case EXEC_OMP_TEAMS_LOOP:
14051 : 15941 : case EXEC_OMP_TILE:
14052 : 15941 : case EXEC_OMP_UNROLL:
14053 : 15941 : case EXEC_OMP_WORKSHARE:
14054 : 15941 : gfc_resolve_omp_directive (code, ns);
14055 : 15941 : break;
14056 : :
14057 : 3712 : case EXEC_OMP_PARALLEL:
14058 : 3712 : case EXEC_OMP_PARALLEL_DO:
14059 : 3712 : case EXEC_OMP_PARALLEL_DO_SIMD:
14060 : 3712 : case EXEC_OMP_PARALLEL_LOOP:
14061 : 3712 : case EXEC_OMP_PARALLEL_MASKED:
14062 : 3712 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14063 : 3712 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14064 : 3712 : case EXEC_OMP_PARALLEL_MASTER:
14065 : 3712 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14066 : 3712 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14067 : 3712 : case EXEC_OMP_PARALLEL_SECTIONS:
14068 : 3712 : case EXEC_OMP_PARALLEL_WORKSHARE:
14069 : 3712 : omp_workshare_save = omp_workshare_flag;
14070 : 3712 : omp_workshare_flag = 0;
14071 : 3712 : gfc_resolve_omp_directive (code, ns);
14072 : 3712 : omp_workshare_flag = omp_workshare_save;
14073 : 3712 : break;
14074 : :
14075 : 0 : default:
14076 : 0 : gfc_internal_error ("gfc_resolve_code(): Bad statement code");
14077 : : }
14078 : : }
14079 : :
14080 : 624077 : cs_base = frame.prev;
14081 : 624077 : }
14082 : :
14083 : :
14084 : : /* Resolve initial values and make sure they are compatible with
14085 : : the variable. */
14086 : :
14087 : : static void
14088 : 1728845 : resolve_values (gfc_symbol *sym)
14089 : : {
14090 : 1728845 : bool t;
14091 : :
14092 : 1728845 : if (sym->value == NULL)
14093 : : return;
14094 : :
14095 : 406795 : if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
14096 : 4 : gfc_warning (OPT_Wdeprecated_declarations,
14097 : : "Using parameter %qs declared at %L is deprecated",
14098 : : sym->name, &sym->declared_at);
14099 : :
14100 : 406795 : if (sym->value->expr_type == EXPR_STRUCTURE)
14101 : 50372 : t= resolve_structure_cons (sym->value, 1);
14102 : : else
14103 : 356423 : t = gfc_resolve_expr (sym->value);
14104 : :
14105 : 406795 : if (!t)
14106 : : return;
14107 : :
14108 : 406793 : gfc_check_assign_symbol (sym, NULL, sym->value);
14109 : : }
14110 : :
14111 : :
14112 : : /* Verify any BIND(C) derived types in the namespace so we can report errors
14113 : : for them once, rather than for each variable declared of that type. */
14114 : :
14115 : : static void
14116 : 1702512 : resolve_bind_c_derived_types (gfc_symbol *derived_sym)
14117 : : {
14118 : 1702512 : if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
14119 : 75553 : && derived_sym->attr.is_bind_c == 1)
14120 : 23787 : verify_bind_c_derived_type (derived_sym);
14121 : :
14122 : 1702512 : return;
14123 : : }
14124 : :
14125 : :
14126 : : /* Check the interfaces of DTIO procedures associated with derived
14127 : : type 'sym'. These procedures can either have typebound bindings or
14128 : : can appear in DTIO generic interfaces. */
14129 : :
14130 : : static void
14131 : 1729819 : gfc_verify_DTIO_procedures (gfc_symbol *sym)
14132 : : {
14133 : 1729819 : if (!sym || sym->attr.flavor != FL_DERIVED)
14134 : : return;
14135 : :
14136 : 83980 : gfc_check_dtio_interfaces (sym);
14137 : :
14138 : 83980 : return;
14139 : : }
14140 : :
14141 : : /* Verify that any binding labels used in a given namespace do not collide
14142 : : with the names or binding labels of any global symbols. Multiple INTERFACE
14143 : : for the same procedure are permitted. */
14144 : :
14145 : : static void
14146 : 1729819 : gfc_verify_binding_labels (gfc_symbol *sym)
14147 : : {
14148 : 1729819 : gfc_gsymbol *gsym;
14149 : 1729819 : const char *module;
14150 : :
14151 : 1729819 : if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
14152 : 52576 : || sym->attr.flavor == FL_DERIVED || !sym->binding_label)
14153 : : return;
14154 : :
14155 : 27875 : gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
14156 : :
14157 : 27875 : if (sym->module)
14158 : : module = sym->module;
14159 : 10641 : else if (sym->ns && sym->ns->proc_name
14160 : 10641 : && sym->ns->proc_name->attr.flavor == FL_MODULE)
14161 : 4417 : module = sym->ns->proc_name->name;
14162 : 6224 : else if (sym->ns && sym->ns->parent
14163 : 403 : && sym->ns && sym->ns->parent->proc_name
14164 : 403 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
14165 : 306 : module = sym->ns->parent->proc_name->name;
14166 : : else
14167 : : module = NULL;
14168 : :
14169 : 27875 : if (!gsym
14170 : 10051 : || (!gsym->defined
14171 : 7233 : && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
14172 : : {
14173 : 17824 : if (!gsym)
14174 : 17824 : gsym = gfc_get_gsymbol (sym->binding_label, true);
14175 : 25057 : gsym->where = sym->declared_at;
14176 : 25057 : gsym->sym_name = sym->name;
14177 : 25057 : gsym->binding_label = sym->binding_label;
14178 : 25057 : gsym->ns = sym->ns;
14179 : 25057 : gsym->mod_name = module;
14180 : 25057 : if (sym->attr.function)
14181 : 17481 : gsym->type = GSYM_FUNCTION;
14182 : 7576 : else if (sym->attr.subroutine)
14183 : 7436 : gsym->type = GSYM_SUBROUTINE;
14184 : : /* Mark as variable/procedure as defined, unless its an INTERFACE. */
14185 : 25057 : gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
14186 : 25057 : return;
14187 : : }
14188 : :
14189 : 2818 : if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
14190 : : {
14191 : 1 : gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
14192 : : "identifier as entity at %L", sym->name,
14193 : : sym->binding_label, &sym->declared_at, &gsym->where);
14194 : : /* Clear the binding label to prevent checking multiple times. */
14195 : 1 : sym->binding_label = NULL;
14196 : 1 : return;
14197 : : }
14198 : :
14199 : 2817 : if (sym->attr.flavor == FL_VARIABLE && module
14200 : 37 : && (strcmp (module, gsym->mod_name) != 0
14201 : 35 : || strcmp (sym->name, gsym->sym_name) != 0))
14202 : : {
14203 : : /* This can only happen if the variable is defined in a module - if it
14204 : : isn't the same module, reject it. */
14205 : 3 : gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
14206 : : "uses the same global identifier as entity at %L from module %qs",
14207 : : sym->name, module, sym->binding_label,
14208 : : &sym->declared_at, &gsym->where, gsym->mod_name);
14209 : 3 : sym->binding_label = NULL;
14210 : 3 : return;
14211 : : }
14212 : :
14213 : 2814 : if ((sym->attr.function || sym->attr.subroutine)
14214 : 2777 : && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
14215 : 2774 : || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
14216 : 2462 : && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
14217 : 2075 : && (module != gsym->mod_name
14218 : 2070 : || strcmp (gsym->sym_name, sym->name) != 0
14219 : 2070 : || (module && strcmp (module, gsym->mod_name) != 0)))
14220 : : {
14221 : : /* Print an error if the procedure is defined multiple times; we have to
14222 : : exclude references to the same procedure via module association or
14223 : : multiple checks for the same procedure. */
14224 : 5 : gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
14225 : : "global identifier as entity at %L", sym->name,
14226 : : sym->binding_label, &sym->declared_at, &gsym->where);
14227 : 5 : sym->binding_label = NULL;
14228 : : }
14229 : : }
14230 : :
14231 : :
14232 : : /* Resolve an index expression. */
14233 : :
14234 : : static bool
14235 : 257349 : resolve_index_expr (gfc_expr *e)
14236 : : {
14237 : 257349 : if (!gfc_resolve_expr (e))
14238 : : return false;
14239 : :
14240 : 257339 : if (!gfc_simplify_expr (e, 0))
14241 : : return false;
14242 : :
14243 : 257337 : if (!gfc_specification_expr (e))
14244 : : return false;
14245 : :
14246 : : return true;
14247 : : }
14248 : :
14249 : :
14250 : : /* Resolve a charlen structure. */
14251 : :
14252 : : static bool
14253 : 98625 : resolve_charlen (gfc_charlen *cl)
14254 : : {
14255 : 98625 : int k;
14256 : 98625 : bool saved_specification_expr;
14257 : :
14258 : 98625 : if (cl->resolved)
14259 : : return true;
14260 : :
14261 : 90709 : cl->resolved = 1;
14262 : 90709 : saved_specification_expr = specification_expr;
14263 : 90709 : specification_expr = true;
14264 : :
14265 : 90709 : if (cl->length_from_typespec)
14266 : : {
14267 : 1058 : if (!gfc_resolve_expr (cl->length))
14268 : : {
14269 : 1 : specification_expr = saved_specification_expr;
14270 : 1 : return false;
14271 : : }
14272 : :
14273 : 1057 : if (!gfc_simplify_expr (cl->length, 0))
14274 : : {
14275 : 0 : specification_expr = saved_specification_expr;
14276 : 0 : return false;
14277 : : }
14278 : :
14279 : : /* cl->length has been resolved. It should have an integer type. */
14280 : 1057 : if (cl->length
14281 : 1056 : && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
14282 : : {
14283 : 4 : gfc_error ("Scalar INTEGER expression expected at %L",
14284 : : &cl->length->where);
14285 : 4 : return false;
14286 : : }
14287 : : }
14288 : : else
14289 : : {
14290 : 89651 : if (!resolve_index_expr (cl->length))
14291 : : {
14292 : 19 : specification_expr = saved_specification_expr;
14293 : 19 : return false;
14294 : : }
14295 : : }
14296 : :
14297 : : /* F2008, 4.4.3.2: If the character length parameter value evaluates to
14298 : : a negative value, the length of character entities declared is zero. */
14299 : 90685 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14300 : 54515 : && mpz_sgn (cl->length->value.integer) < 0)
14301 : 0 : gfc_replace_expr (cl->length,
14302 : : gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
14303 : :
14304 : : /* Check that the character length is not too large. */
14305 : 90685 : k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
14306 : 90685 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT
14307 : 54515 : && cl->length->ts.type == BT_INTEGER
14308 : 54515 : && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
14309 : : {
14310 : 4 : gfc_error ("String length at %L is too large", &cl->length->where);
14311 : 4 : specification_expr = saved_specification_expr;
14312 : 4 : return false;
14313 : : }
14314 : :
14315 : 90681 : specification_expr = saved_specification_expr;
14316 : 90681 : return true;
14317 : : }
14318 : :
14319 : :
14320 : : /* Test for non-constant shape arrays. */
14321 : :
14322 : : static bool
14323 : 114969 : is_non_constant_shape_array (gfc_symbol *sym)
14324 : : {
14325 : 114969 : gfc_expr *e;
14326 : 114969 : int i;
14327 : 114969 : bool not_constant;
14328 : :
14329 : 114969 : not_constant = false;
14330 : 114969 : if (sym->as != NULL)
14331 : : {
14332 : : /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
14333 : : has not been simplified; parameter array references. Do the
14334 : : simplification now. */
14335 : 150998 : for (i = 0; i < sym->as->rank + sym->as->corank; i++)
14336 : : {
14337 : 87075 : if (i == GFC_MAX_DIMENSIONS)
14338 : : break;
14339 : :
14340 : 87073 : e = sym->as->lower[i];
14341 : 87073 : if (e && (!resolve_index_expr(e)
14342 : 84327 : || !gfc_is_constant_expr (e)))
14343 : : not_constant = true;
14344 : 87073 : e = sym->as->upper[i];
14345 : 87073 : if (e && (!resolve_index_expr(e)
14346 : 83344 : || !gfc_is_constant_expr (e)))
14347 : : not_constant = true;
14348 : : }
14349 : : }
14350 : 114969 : return not_constant;
14351 : : }
14352 : :
14353 : : /* Given a symbol and an initialization expression, add code to initialize
14354 : : the symbol to the function entry. */
14355 : : static void
14356 : 1573 : build_init_assign (gfc_symbol *sym, gfc_expr *init)
14357 : : {
14358 : 1573 : gfc_expr *lval;
14359 : 1573 : gfc_code *init_st;
14360 : 1573 : gfc_namespace *ns = sym->ns;
14361 : :
14362 : : /* Search for the function namespace if this is a contained
14363 : : function without an explicit result. */
14364 : 1573 : if (sym->attr.function && sym == sym->result
14365 : 185 : && sym->name != sym->ns->proc_name->name)
14366 : : {
14367 : 184 : ns = ns->contained;
14368 : 650 : for (;ns; ns = ns->sibling)
14369 : 553 : if (strcmp (ns->proc_name->name, sym->name) == 0)
14370 : : break;
14371 : : }
14372 : :
14373 : 1573 : if (ns == NULL)
14374 : : {
14375 : 97 : gfc_free_expr (init);
14376 : 97 : return;
14377 : : }
14378 : :
14379 : : /* Build an l-value expression for the result. */
14380 : 1476 : lval = gfc_lval_expr_from_sym (sym);
14381 : :
14382 : : /* Add the code at scope entry. */
14383 : 1476 : init_st = gfc_get_code (EXEC_INIT_ASSIGN);
14384 : 1476 : init_st->next = ns->code;
14385 : 1476 : ns->code = init_st;
14386 : :
14387 : : /* Assign the default initializer to the l-value. */
14388 : 1476 : init_st->loc = sym->declared_at;
14389 : 1476 : init_st->expr1 = lval;
14390 : 1476 : init_st->expr2 = init;
14391 : : }
14392 : :
14393 : :
14394 : : /* Whether or not we can generate a default initializer for a symbol. */
14395 : :
14396 : : static bool
14397 : 49901 : can_generate_init (gfc_symbol *sym)
14398 : : {
14399 : 49901 : symbol_attribute *a;
14400 : 49901 : if (!sym)
14401 : : return false;
14402 : 49901 : a = &sym->attr;
14403 : :
14404 : : /* These symbols should never have a default initialization. */
14405 : 67016 : return !(
14406 : : a->allocatable
14407 : : || a->external
14408 : 49901 : || a->pointer
14409 : 42582 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
14410 : 5426 : && (CLASS_DATA (sym)->attr.class_pointer
14411 : 5426 : || CLASS_DATA (sym)->attr.proc_pointer))
14412 : : || a->in_equivalence
14413 : : || a->in_common
14414 : 40711 : || a->data
14415 : 40357 : || sym->module
14416 : : || a->cray_pointee
14417 : 20600 : || a->cray_pointer
14418 : 20538 : || sym->assoc
14419 : 17993 : || (!a->referenced && !a->result)
14420 : 17115 : || (a->dummy && (a->intent != INTENT_OUT
14421 : 844 : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
14422 : 17115 : || (a->function && sym != sym->result)
14423 : : );
14424 : : }
14425 : :
14426 : :
14427 : : /* Assign the default initializer to a derived type variable or result. */
14428 : :
14429 : : static void
14430 : 18965 : apply_default_init (gfc_symbol *sym)
14431 : : {
14432 : 18965 : gfc_expr *init = NULL;
14433 : :
14434 : 18965 : if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
14435 : : return;
14436 : :
14437 : 18965 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
14438 : 18161 : init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
14439 : :
14440 : 18965 : if (init == NULL && sym->ts.type != BT_CLASS)
14441 : : return;
14442 : :
14443 : 1191 : build_init_assign (sym, init);
14444 : 1191 : sym->attr.referenced = 1;
14445 : : }
14446 : :
14447 : :
14448 : : /* Build an initializer for a local. Returns null if the symbol should not have
14449 : : a default initialization. */
14450 : :
14451 : : static gfc_expr *
14452 : 189181 : build_default_init_expr (gfc_symbol *sym)
14453 : : {
14454 : : /* These symbols should never have a default initialization. */
14455 : 189181 : if (sym->attr.allocatable
14456 : : || sym->attr.external
14457 : : || sym->attr.dummy
14458 : : || sym->attr.pointer
14459 : : || sym->attr.in_equivalence
14460 : : || sym->attr.in_common
14461 : 189181 : || sym->attr.data
14462 : 104717 : || sym->module
14463 : : || sym->attr.cray_pointee
14464 : 102291 : || sym->attr.cray_pointer
14465 : 101688 : || sym->assoc)
14466 : : return NULL;
14467 : :
14468 : : /* Get the appropriate init expression. */
14469 : 97328 : return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
14470 : : }
14471 : :
14472 : : /* Add an initialization expression to a local variable. */
14473 : : static void
14474 : 189181 : apply_default_init_local (gfc_symbol *sym)
14475 : : {
14476 : 189181 : gfc_expr *init = NULL;
14477 : :
14478 : : /* The symbol should be a variable or a function return value. */
14479 : 189181 : if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
14480 : 189181 : || (sym->attr.function && sym->result != sym))
14481 : : return;
14482 : :
14483 : : /* Try to build the initializer expression. If we can't initialize
14484 : : this symbol, then init will be NULL. */
14485 : 189181 : init = build_default_init_expr (sym);
14486 : 189181 : if (init == NULL)
14487 : : return;
14488 : :
14489 : : /* For saved variables, we don't want to add an initializer at function
14490 : : entry, so we just add a static initializer. Note that automatic variables
14491 : : are stack allocated even with -fno-automatic; we have also to exclude
14492 : : result variable, which are also nonstatic. */
14493 : 419 : if (!sym->attr.automatic
14494 : 419 : && (sym->attr.save || sym->ns->save_all
14495 : 377 : || (flag_max_stack_var_size == 0 && !sym->attr.result
14496 : 27 : && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
14497 : 14 : && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
14498 : : {
14499 : : /* Don't clobber an existing initializer! */
14500 : 37 : gcc_assert (sym->value == NULL);
14501 : 37 : sym->value = init;
14502 : 37 : return;
14503 : : }
14504 : :
14505 : 382 : build_init_assign (sym, init);
14506 : : }
14507 : :
14508 : :
14509 : : /* Resolution of common features of flavors variable and procedure. */
14510 : :
14511 : : static bool
14512 : 924764 : resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
14513 : : {
14514 : 924764 : gfc_array_spec *as;
14515 : :
14516 : 924764 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
14517 : 18204 : && sym->ts.u.derived && CLASS_DATA (sym))
14518 : 18198 : as = CLASS_DATA (sym)->as;
14519 : : else
14520 : 906566 : as = sym->as;
14521 : :
14522 : : /* Constraints on deferred shape variable. */
14523 : 924764 : if (as == NULL || as->type != AS_DEFERRED)
14524 : : {
14525 : 901377 : bool pointer, allocatable, dimension;
14526 : :
14527 : 901377 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
14528 : 15130 : && sym->ts.u.derived && CLASS_DATA (sym))
14529 : : {
14530 : 15124 : pointer = CLASS_DATA (sym)->attr.class_pointer;
14531 : 15124 : allocatable = CLASS_DATA (sym)->attr.allocatable;
14532 : 15124 : dimension = CLASS_DATA (sym)->attr.dimension;
14533 : : }
14534 : : else
14535 : : {
14536 : 886253 : pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
14537 : 886253 : allocatable = sym->attr.allocatable;
14538 : 886253 : dimension = sym->attr.dimension;
14539 : : }
14540 : :
14541 : 901377 : if (allocatable)
14542 : : {
14543 : 7625 : if (dimension
14544 : 7625 : && as
14545 : 523 : && as->type != AS_ASSUMED_RANK
14546 : 5 : && !sym->attr.select_rank_temporary)
14547 : : {
14548 : 3 : gfc_error ("Allocatable array %qs at %L must have a deferred "
14549 : : "shape or assumed rank", sym->name, &sym->declared_at);
14550 : 3 : return false;
14551 : : }
14552 : 7622 : else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
14553 : : "%qs at %L may not be ALLOCATABLE",
14554 : : sym->name, &sym->declared_at))
14555 : : return false;
14556 : : }
14557 : :
14558 : 901373 : if (pointer && dimension && as->type != AS_ASSUMED_RANK)
14559 : : {
14560 : 4 : gfc_error ("Array pointer %qs at %L must have a deferred shape or "
14561 : : "assumed rank", sym->name, &sym->declared_at);
14562 : 4 : sym->error = 1;
14563 : 4 : return false;
14564 : : }
14565 : : }
14566 : : else
14567 : : {
14568 : 23387 : if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
14569 : 4473 : && sym->ts.type != BT_CLASS && !sym->assoc)
14570 : : {
14571 : 3 : gfc_error ("Array %qs at %L cannot have a deferred shape",
14572 : : sym->name, &sym->declared_at);
14573 : 3 : return false;
14574 : : }
14575 : : }
14576 : :
14577 : : /* Constraints on polymorphic variables. */
14578 : 924753 : if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
14579 : : {
14580 : : /* F03:C502. */
14581 : 17570 : if (sym->attr.class_ok
14582 : 17514 : && sym->ts.u.derived
14583 : 17509 : && !sym->attr.select_type_temporary
14584 : 16471 : && !UNLIMITED_POLY (sym)
14585 : 14201 : && CLASS_DATA (sym)
14586 : 14200 : && CLASS_DATA (sym)->ts.u.derived
14587 : 31769 : && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
14588 : : {
14589 : 5 : gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
14590 : 5 : CLASS_DATA (sym)->ts.u.derived->name, sym->name,
14591 : : &sym->declared_at);
14592 : 5 : return false;
14593 : : }
14594 : :
14595 : : /* F03:C509. */
14596 : : /* Assume that use associated symbols were checked in the module ns.
14597 : : Class-variables that are associate-names are also something special
14598 : : and excepted from the test. */
14599 : 17565 : if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc
14600 : : && !sym->attr.select_type_temporary
14601 : 54 : && !sym->attr.select_rank_temporary)
14602 : : {
14603 : 54 : gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
14604 : : "or pointer", sym->name, &sym->declared_at);
14605 : 54 : return false;
14606 : : }
14607 : : }
14608 : :
14609 : : return true;
14610 : : }
14611 : :
14612 : :
14613 : : /* Additional checks for symbols with flavor variable and derived
14614 : : type. To be called from resolve_fl_variable. */
14615 : :
14616 : : static bool
14617 : 88213 : resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
14618 : : {
14619 : 88213 : gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
14620 : :
14621 : : /* Check to see if a derived type is blocked from being host
14622 : : associated by the presence of another class I symbol in the same
14623 : : namespace. 14.6.1.3 of the standard and the discussion on
14624 : : comp.lang.fortran. */
14625 : 88213 : if (sym->ts.u.derived
14626 : 88208 : && sym->ns != sym->ts.u.derived->ns
14627 : 43876 : && !sym->ts.u.derived->attr.use_assoc
14628 : 15935 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
14629 : : {
14630 : 15063 : gfc_symbol *s;
14631 : 15063 : gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
14632 : 15063 : if (s && s->attr.generic)
14633 : 0 : s = gfc_find_dt_in_generic (s);
14634 : 15063 : if (s && !gfc_fl_struct (s->attr.flavor))
14635 : : {
14636 : 1 : gfc_error ("The type %qs cannot be host associated at %L "
14637 : : "because it is blocked by an incompatible object "
14638 : : "of the same name declared at %L",
14639 : 1 : sym->ts.u.derived->name, &sym->declared_at,
14640 : : &s->declared_at);
14641 : 1 : return false;
14642 : : }
14643 : : }
14644 : :
14645 : : /* 4th constraint in section 11.3: "If an object of a type for which
14646 : : component-initialization is specified (R429) appears in the
14647 : : specification-part of a module and does not have the ALLOCATABLE
14648 : : or POINTER attribute, the object shall have the SAVE attribute."
14649 : :
14650 : : The check for initializers is performed with
14651 : : gfc_has_default_initializer because gfc_default_initializer generates
14652 : : a hidden default for allocatable components. */
14653 : 86913 : if (!(sym->value || no_init_flag) && sym->ns->proc_name
14654 : 30500 : && sym->ns->proc_name->attr.flavor == FL_MODULE
14655 : 1787 : && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
14656 : 1779 : && !sym->attr.pointer && !sym->attr.allocatable
14657 : 20 : && gfc_has_default_initializer (sym->ts.u.derived)
14658 : 88221 : && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
14659 : : "%qs at %L, needed due to the default "
14660 : : "initialization", sym->name, &sym->declared_at))
14661 : : return false;
14662 : :
14663 : : /* Assign default initializer. */
14664 : 88210 : if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
14665 : 81740 : && (!no_init_flag
14666 : 52972 : || (sym->attr.intent == INTENT_OUT
14667 : 3138 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
14668 : 31740 : sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
14669 : :
14670 : : return true;
14671 : : }
14672 : :
14673 : :
14674 : : /* F2008, C402 (R401): A colon shall not be used as a type-param-value
14675 : : except in the declaration of an entity or component that has the POINTER
14676 : : or ALLOCATABLE attribute. */
14677 : :
14678 : : static bool
14679 : 1432475 : deferred_requirements (gfc_symbol *sym)
14680 : : {
14681 : 1432475 : if (sym->ts.deferred
14682 : 92 : && !(sym->attr.pointer
14683 : 7400 : || sym->attr.allocatable
14684 : : || sym->attr.associate_var
14685 : : || sym->attr.omp_udr_artificial_var))
14686 : : {
14687 : : /* If a function has a result variable, only check the variable. */
14688 : 7 : if (sym->result && sym->name != sym->result->name)
14689 : : return true;
14690 : :
14691 : 6 : gfc_error ("Entity %qs at %L has a deferred type parameter and "
14692 : : "requires either the POINTER or ALLOCATABLE attribute",
14693 : : sym->name, &sym->declared_at);
14694 : 6 : return false;
14695 : : }
14696 : : return true;
14697 : : }
14698 : :
14699 : :
14700 : : /* Resolve symbols with flavor variable. */
14701 : :
14702 : : static bool
14703 : 621134 : resolve_fl_variable (gfc_symbol *sym, int mp_flag)
14704 : : {
14705 : 621134 : const char *auto_save_msg = G_("Automatic object %qs at %L cannot have the "
14706 : : "SAVE attribute");
14707 : :
14708 : 621134 : if (!resolve_fl_var_and_proc (sym, mp_flag))
14709 : : return false;
14710 : :
14711 : : /* Set this flag to check that variables are parameters of all entries.
14712 : : This check is effected by the call to gfc_resolve_expr through
14713 : : is_non_constant_shape_array. */
14714 : 621074 : bool saved_specification_expr = specification_expr;
14715 : 621074 : specification_expr = true;
14716 : :
14717 : 621074 : if (sym->ns->proc_name
14718 : 620984 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
14719 : 614543 : || sym->ns->proc_name->attr.is_main_program)
14720 : : && !sym->attr.use_assoc
14721 : : && !sym->attr.allocatable
14722 : 88838 : && !sym->attr.pointer
14723 : 689630 : && is_non_constant_shape_array (sym))
14724 : : {
14725 : : /* F08:C541. The shape of an array defined in a main program or module
14726 : : * needs to be constant. */
14727 : 3 : gfc_error ("The module or main program array %qs at %L must "
14728 : : "have constant shape", sym->name, &sym->declared_at);
14729 : 3 : specification_expr = saved_specification_expr;
14730 : 3 : return false;
14731 : : }
14732 : :
14733 : : /* Constraints on deferred type parameter. */
14734 : 621071 : if (!deferred_requirements (sym))
14735 : : return false;
14736 : :
14737 : 621067 : if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
14738 : : {
14739 : : /* Make sure that character string variables with assumed length are
14740 : : dummy arguments. */
14741 : 34861 : gfc_expr *e = NULL;
14742 : :
14743 : 34861 : if (sym->ts.u.cl)
14744 : 34861 : e = sym->ts.u.cl->length;
14745 : : else
14746 : : return false;
14747 : :
14748 : 34861 : if (e == NULL && !sym->attr.dummy && !sym->attr.result
14749 : 2398 : && !sym->ts.deferred && !sym->attr.select_type_temporary
14750 : 907 : && !sym->attr.omp_udr_artificial_var)
14751 : : {
14752 : 2 : gfc_error ("Entity with assumed character length at %L must be a "
14753 : : "dummy argument or a PARAMETER", &sym->declared_at);
14754 : 2 : specification_expr = saved_specification_expr;
14755 : 2 : return false;
14756 : : }
14757 : :
14758 : 20393 : if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
14759 : : {
14760 : 1 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
14761 : 1 : specification_expr = saved_specification_expr;
14762 : 1 : return false;
14763 : : }
14764 : :
14765 : 34858 : if (!gfc_is_constant_expr (e)
14766 : 34858 : && !(e->expr_type == EXPR_VARIABLE
14767 : 1388 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
14768 : : {
14769 : 2180 : if (!sym->attr.use_assoc && sym->ns->proc_name
14770 : 1676 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
14771 : 1675 : || sym->ns->proc_name->attr.is_main_program))
14772 : : {
14773 : 3 : gfc_error ("%qs at %L must have constant character length "
14774 : : "in this context", sym->name, &sym->declared_at);
14775 : 3 : specification_expr = saved_specification_expr;
14776 : 3 : return false;
14777 : : }
14778 : 2177 : if (sym->attr.in_common)
14779 : : {
14780 : 1 : gfc_error ("COMMON variable %qs at %L must have constant "
14781 : : "character length", sym->name, &sym->declared_at);
14782 : 1 : specification_expr = saved_specification_expr;
14783 : 1 : return false;
14784 : : }
14785 : : }
14786 : : }
14787 : :
14788 : 621060 : if (sym->value == NULL && sym->attr.referenced
14789 : 191044 : && !(sym->as && sym->as->type == AS_ASSUMED_RANK))
14790 : 189181 : apply_default_init_local (sym); /* Try to apply a default initialization. */
14791 : :
14792 : : /* Determine if the symbol may not have an initializer. */
14793 : 621060 : int no_init_flag = 0, automatic_flag = 0;
14794 : 621060 : if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
14795 : 621060 : || sym->attr.intrinsic || sym->attr.result)
14796 : : no_init_flag = 1;
14797 : 38497 : else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
14798 : 180963 : && is_non_constant_shape_array (sym))
14799 : : {
14800 : 1367 : no_init_flag = automatic_flag = 1;
14801 : :
14802 : : /* Also, they must not have the SAVE attribute.
14803 : : SAVE_IMPLICIT is checked below. */
14804 : 1367 : if (sym->as && sym->attr.codimension)
14805 : : {
14806 : 7 : int corank = sym->as->corank;
14807 : 7 : sym->as->corank = 0;
14808 : 7 : no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
14809 : 7 : sym->as->corank = corank;
14810 : : }
14811 : 1367 : if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
14812 : : {
14813 : 2 : gfc_error (auto_save_msg, sym->name, &sym->declared_at);
14814 : 2 : specification_expr = saved_specification_expr;
14815 : 2 : return false;
14816 : : }
14817 : : }
14818 : :
14819 : : /* Ensure that any initializer is simplified. */
14820 : 621058 : if (sym->value)
14821 : 8072 : gfc_simplify_expr (sym->value, 1);
14822 : :
14823 : : /* Reject illegal initializers. */
14824 : 621058 : if (!sym->mark && sym->value)
14825 : : {
14826 : 8072 : if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
14827 : 67 : && CLASS_DATA (sym)->attr.allocatable))
14828 : 1 : gfc_error ("Allocatable %qs at %L cannot have an initializer",
14829 : : sym->name, &sym->declared_at);
14830 : 8071 : else if (sym->attr.external)
14831 : 0 : gfc_error ("External %qs at %L cannot have an initializer",
14832 : : sym->name, &sym->declared_at);
14833 : 8071 : else if (sym->attr.dummy)
14834 : 3 : gfc_error ("Dummy %qs at %L cannot have an initializer",
14835 : : sym->name, &sym->declared_at);
14836 : 8068 : else if (sym->attr.intrinsic)
14837 : 0 : gfc_error ("Intrinsic %qs at %L cannot have an initializer",
14838 : : sym->name, &sym->declared_at);
14839 : 8068 : else if (sym->attr.result)
14840 : 1 : gfc_error ("Function result %qs at %L cannot have an initializer",
14841 : : sym->name, &sym->declared_at);
14842 : 8067 : else if (automatic_flag)
14843 : 5 : gfc_error ("Automatic array %qs at %L cannot have an initializer",
14844 : : sym->name, &sym->declared_at);
14845 : : else
14846 : 8062 : goto no_init_error;
14847 : 10 : specification_expr = saved_specification_expr;
14848 : 10 : return false;
14849 : : }
14850 : :
14851 : 612986 : no_init_error:
14852 : 621048 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
14853 : : {
14854 : 88213 : bool res = resolve_fl_variable_derived (sym, no_init_flag);
14855 : 88213 : specification_expr = saved_specification_expr;
14856 : 88213 : return res;
14857 : : }
14858 : :
14859 : 532835 : specification_expr = saved_specification_expr;
14860 : 532835 : return true;
14861 : : }
14862 : :
14863 : :
14864 : : /* Compare the dummy characteristics of a module procedure interface
14865 : : declaration with the corresponding declaration in a submodule. */
14866 : : static gfc_formal_arglist *new_formal;
14867 : : static char errmsg[200];
14868 : :
14869 : : static void
14870 : 908 : compare_fsyms (gfc_symbol *sym)
14871 : : {
14872 : 908 : gfc_symbol *fsym;
14873 : :
14874 : 908 : if (sym == NULL || new_formal == NULL)
14875 : : return;
14876 : :
14877 : 908 : fsym = new_formal->sym;
14878 : :
14879 : 908 : if (sym == fsym)
14880 : : return;
14881 : :
14882 : 884 : if (strcmp (sym->name, fsym->name) == 0)
14883 : : {
14884 : 353 : if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
14885 : 2 : gfc_error ("%s at %L", errmsg, &fsym->declared_at);
14886 : : }
14887 : : }
14888 : :
14889 : :
14890 : : /* Resolve a procedure. */
14891 : :
14892 : : static bool
14893 : 448409 : resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
14894 : : {
14895 : 448409 : gfc_formal_arglist *arg;
14896 : 448409 : bool allocatable_or_pointer = false;
14897 : :
14898 : 448409 : if (sym->attr.function
14899 : 448409 : && !resolve_fl_var_and_proc (sym, mp_flag))
14900 : : return false;
14901 : :
14902 : : /* Constraints on deferred type parameter. */
14903 : 448399 : if (!deferred_requirements (sym))
14904 : : return false;
14905 : :
14906 : 448398 : if (sym->ts.type == BT_CHARACTER)
14907 : : {
14908 : 11012 : gfc_charlen *cl = sym->ts.u.cl;
14909 : :
14910 : 7066 : if (cl && cl->length && gfc_is_constant_expr (cl->length)
14911 : 12081 : && !resolve_charlen (cl))
14912 : : return false;
14913 : :
14914 : 11011 : if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
14915 : 9943 : && sym->attr.proc == PROC_ST_FUNCTION)
14916 : : {
14917 : 0 : gfc_error ("Character-valued statement function %qs at %L must "
14918 : : "have constant length", sym->name, &sym->declared_at);
14919 : 0 : return false;
14920 : : }
14921 : : }
14922 : :
14923 : : /* Ensure that derived type for are not of a private type. Internal
14924 : : module procedures are excluded by 2.2.3.3 - i.e., they are not
14925 : : externally accessible and can access all the objects accessible in
14926 : : the host. */
14927 : 105924 : if (!(sym->ns->parent && sym->ns->parent->proc_name
14928 : 105924 : && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
14929 : 531958 : && gfc_check_symbol_access (sym))
14930 : : {
14931 : 419374 : gfc_interface *iface;
14932 : :
14933 : 873090 : for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
14934 : : {
14935 : 453717 : if (arg->sym
14936 : 453576 : && arg->sym->ts.type == BT_DERIVED
14937 : 37756 : && arg->sym->ts.u.derived
14938 : 37756 : && !arg->sym->ts.u.derived->attr.use_assoc
14939 : 3927 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
14940 : 453726 : && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
14941 : : "and cannot be a dummy argument"
14942 : : " of %qs, which is PUBLIC at %L",
14943 : 9 : arg->sym->name, sym->name,
14944 : : &sym->declared_at))
14945 : : {
14946 : : /* Stop this message from recurring. */
14947 : 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
14948 : 1 : return false;
14949 : : }
14950 : : }
14951 : :
14952 : : /* PUBLIC interfaces may expose PRIVATE procedures that take types
14953 : : PRIVATE to the containing module. */
14954 : 598233 : for (iface = sym->generic; iface; iface = iface->next)
14955 : : {
14956 : 416277 : for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
14957 : : {
14958 : 237417 : if (arg->sym
14959 : 237385 : && arg->sym->ts.type == BT_DERIVED
14960 : 7758 : && !arg->sym->ts.u.derived->attr.use_assoc
14961 : 208 : && !gfc_check_symbol_access (arg->sym->ts.u.derived)
14962 : 237421 : && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
14963 : : "PUBLIC interface %qs at %L "
14964 : : "takes dummy arguments of %qs which "
14965 : : "is PRIVATE", iface->sym->name,
14966 : 4 : sym->name, &iface->sym->declared_at,
14967 : 4 : gfc_typename(&arg->sym->ts)))
14968 : : {
14969 : : /* Stop this message from recurring. */
14970 : 1 : arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
14971 : 1 : return false;
14972 : : }
14973 : : }
14974 : : }
14975 : : }
14976 : :
14977 : 448395 : if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
14978 : 67 : && !sym->attr.proc_pointer)
14979 : : {
14980 : 2 : gfc_error ("Function %qs at %L cannot have an initializer",
14981 : : sym->name, &sym->declared_at);
14982 : :
14983 : : /* Make sure no second error is issued for this. */
14984 : 2 : sym->value->error = 1;
14985 : 2 : return false;
14986 : : }
14987 : :
14988 : : /* An external symbol may not have an initializer because it is taken to be
14989 : : a procedure. Exception: Procedure Pointers. */
14990 : 448393 : if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
14991 : : {
14992 : 0 : gfc_error ("External object %qs at %L may not have an initializer",
14993 : : sym->name, &sym->declared_at);
14994 : 0 : return false;
14995 : : }
14996 : :
14997 : : /* An elemental function is required to return a scalar 12.7.1 */
14998 : 448393 : if (sym->attr.elemental && sym->attr.function
14999 : 84933 : && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
15000 : 2 : && CLASS_DATA (sym)->as)))
15001 : : {
15002 : 3 : gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
15003 : : "result", sym->name, &sym->declared_at);
15004 : : /* Reset so that the error only occurs once. */
15005 : 3 : sym->attr.elemental = 0;
15006 : 3 : return false;
15007 : : }
15008 : :
15009 : 448390 : if (sym->attr.proc == PROC_ST_FUNCTION
15010 : 220 : && (sym->attr.allocatable || sym->attr.pointer))
15011 : : {
15012 : 2 : gfc_error ("Statement function %qs at %L may not have pointer or "
15013 : : "allocatable attribute", sym->name, &sym->declared_at);
15014 : 2 : return false;
15015 : : }
15016 : :
15017 : : /* 5.1.1.5 of the Standard: A function name declared with an asterisk
15018 : : char-len-param shall not be array-valued, pointer-valued, recursive
15019 : : or pure. ....snip... A character value of * may only be used in the
15020 : : following ways: (i) Dummy arg of procedure - dummy associates with
15021 : : actual length; (ii) To declare a named constant; or (iii) External
15022 : : function - but length must be declared in calling scoping unit. */
15023 : 448388 : if (sym->attr.function
15024 : 303611 : && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
15025 : 6297 : && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
15026 : : {
15027 : 178 : if ((sym->as && sym->as->rank) || (sym->attr.pointer)
15028 : 177 : || (sym->attr.recursive) || (sym->attr.pure))
15029 : : {
15030 : 4 : if (sym->as && sym->as->rank)
15031 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15032 : : "array-valued", sym->name, &sym->declared_at);
15033 : :
15034 : 4 : if (sym->attr.pointer)
15035 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15036 : : "pointer-valued", sym->name, &sym->declared_at);
15037 : :
15038 : 4 : if (sym->attr.pure)
15039 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15040 : : "pure", sym->name, &sym->declared_at);
15041 : :
15042 : 4 : if (sym->attr.recursive)
15043 : 1 : gfc_error ("CHARACTER(*) function %qs at %L cannot be "
15044 : : "recursive", sym->name, &sym->declared_at);
15045 : :
15046 : 4 : return false;
15047 : : }
15048 : :
15049 : : /* Appendix B.2 of the standard. Contained functions give an
15050 : : error anyway. Deferred character length is an F2003 feature.
15051 : : Don't warn on intrinsic conversion functions, which start
15052 : : with two underscores. */
15053 : 174 : if (!sym->attr.contained && !sym->ts.deferred
15054 : 170 : && (sym->name[0] != '_' || sym->name[1] != '_'))
15055 : 170 : gfc_notify_std (GFC_STD_F95_OBS,
15056 : : "CHARACTER(*) function %qs at %L",
15057 : : sym->name, &sym->declared_at);
15058 : : }
15059 : :
15060 : : /* F2008, C1218. */
15061 : 448384 : if (sym->attr.elemental)
15062 : : {
15063 : 88032 : if (sym->attr.proc_pointer)
15064 : : {
15065 : 7 : const char* name = (sym->attr.result ? sym->ns->proc_name->name
15066 : : : sym->name);
15067 : 7 : gfc_error ("Procedure pointer %qs at %L shall not be elemental",
15068 : : name, &sym->declared_at);
15069 : 7 : return false;
15070 : : }
15071 : 88025 : if (sym->attr.dummy)
15072 : : {
15073 : 3 : gfc_error ("Dummy procedure %qs at %L shall not be elemental",
15074 : : sym->name, &sym->declared_at);
15075 : 3 : return false;
15076 : : }
15077 : : }
15078 : :
15079 : : /* F2018, C15100: "The result of an elemental function shall be scalar,
15080 : : and shall not have the POINTER or ALLOCATABLE attribute." The scalar
15081 : : pointer is tested and caught elsewhere. */
15082 : 448374 : if (sym->result)
15083 : 255196 : allocatable_or_pointer = sym->result->ts.type == BT_CLASS
15084 : 255196 : && CLASS_DATA (sym->result) ?
15085 : : (CLASS_DATA (sym->result)->attr.allocatable
15086 : 1563 : || CLASS_DATA (sym->result)->attr.pointer) :
15087 : : (sym->result->attr.allocatable
15088 : 253633 : || sym->result->attr.pointer);
15089 : :
15090 : 448374 : if (sym->attr.elemental && sym->result
15091 : 84549 : && allocatable_or_pointer)
15092 : : {
15093 : 4 : gfc_error ("Function result variable %qs at %L of elemental "
15094 : : "function %qs shall not have an ALLOCATABLE or POINTER "
15095 : : "attribute", sym->result->name,
15096 : : &sym->result->declared_at, sym->name);
15097 : 4 : return false;
15098 : : }
15099 : :
15100 : 448370 : if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
15101 : : {
15102 : 5877 : gfc_formal_arglist *curr_arg;
15103 : 5877 : int has_non_interop_arg = 0;
15104 : :
15105 : 5877 : if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
15106 : : sym->common_block))
15107 : : {
15108 : : /* Clear these to prevent looking at them again if there was an
15109 : : error. */
15110 : 2 : sym->attr.is_bind_c = 0;
15111 : 2 : sym->attr.is_c_interop = 0;
15112 : 2 : sym->ts.is_c_interop = 0;
15113 : : }
15114 : : else
15115 : : {
15116 : : /* So far, no errors have been found. */
15117 : 5875 : sym->attr.is_c_interop = 1;
15118 : 5875 : sym->ts.is_c_interop = 1;
15119 : : }
15120 : :
15121 : 5877 : curr_arg = gfc_sym_get_dummy_args (sym);
15122 : 26440 : while (curr_arg != NULL)
15123 : : {
15124 : : /* Skip implicitly typed dummy args here. */
15125 : 14686 : if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
15126 : 14630 : if (!gfc_verify_c_interop_param (curr_arg->sym))
15127 : : /* If something is found to fail, record the fact so we
15128 : : can mark the symbol for the procedure as not being
15129 : : BIND(C) to try and prevent multiple errors being
15130 : : reported. */
15131 : 14686 : has_non_interop_arg = 1;
15132 : :
15133 : 14686 : curr_arg = curr_arg->next;
15134 : : }
15135 : :
15136 : : /* See if any of the arguments were not interoperable and if so, clear
15137 : : the procedure symbol to prevent duplicate error messages. */
15138 : 5877 : if (has_non_interop_arg != 0)
15139 : : {
15140 : 128 : sym->attr.is_c_interop = 0;
15141 : 128 : sym->ts.is_c_interop = 0;
15142 : 128 : sym->attr.is_bind_c = 0;
15143 : : }
15144 : : }
15145 : :
15146 : 448370 : if (!sym->attr.proc_pointer)
15147 : : {
15148 : 447348 : if (sym->attr.save == SAVE_EXPLICIT)
15149 : : {
15150 : 5 : gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
15151 : : "in %qs at %L", sym->name, &sym->declared_at);
15152 : 5 : return false;
15153 : : }
15154 : 447343 : if (sym->attr.intent)
15155 : : {
15156 : 1 : gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
15157 : : "in %qs at %L", sym->name, &sym->declared_at);
15158 : 1 : return false;
15159 : : }
15160 : 447342 : if (sym->attr.subroutine && sym->attr.result)
15161 : : {
15162 : 2 : gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
15163 : 2 : "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
15164 : 2 : return false;
15165 : : }
15166 : 447340 : if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
15167 : 128516 : && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
15168 : 128513 : || sym->attr.contained))
15169 : : {
15170 : 3 : gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
15171 : : "in %qs at %L", sym->name, &sym->declared_at);
15172 : 3 : return false;
15173 : : }
15174 : 447337 : if (strcmp ("ppr@", sym->name) == 0)
15175 : : {
15176 : 0 : gfc_error ("Procedure pointer result %qs at %L "
15177 : : "is missing the pointer attribute",
15178 : 0 : sym->ns->proc_name->name, &sym->declared_at);
15179 : 0 : return false;
15180 : : }
15181 : : }
15182 : :
15183 : : /* Assume that a procedure whose body is not known has references
15184 : : to external arrays. */
15185 : 448359 : if (sym->attr.if_source != IFSRC_DECL)
15186 : 307065 : sym->attr.array_outer_dependency = 1;
15187 : :
15188 : : /* Compare the characteristics of a module procedure with the
15189 : : interface declaration. Ideally this would be done with
15190 : : gfc_compare_interfaces but, at present, the formal interface
15191 : : cannot be copied to the ts.interface. */
15192 : 448359 : if (sym->attr.module_procedure
15193 : 448359 : && sym->attr.if_source == IFSRC_DECL)
15194 : : {
15195 : 501 : gfc_symbol *iface;
15196 : 501 : char name[2*GFC_MAX_SYMBOL_LEN + 1];
15197 : 501 : char *module_name;
15198 : 501 : char *submodule_name;
15199 : 501 : strcpy (name, sym->ns->proc_name->name);
15200 : 501 : module_name = strtok (name, ".");
15201 : 501 : submodule_name = strtok (NULL, ".");
15202 : :
15203 : 501 : iface = sym->tlink;
15204 : 501 : sym->tlink = NULL;
15205 : :
15206 : : /* Make sure that the result uses the correct charlen for deferred
15207 : : length results. */
15208 : 501 : if (iface && sym->result
15209 : 110 : && iface->ts.type == BT_CHARACTER
15210 : 19 : && iface->ts.deferred)
15211 : 6 : sym->result->ts.u.cl = iface->ts.u.cl;
15212 : :
15213 : 6 : if (iface == NULL)
15214 : 157 : goto check_formal;
15215 : :
15216 : : /* Check the procedure characteristics. */
15217 : 344 : if (sym->attr.elemental != iface->attr.elemental)
15218 : : {
15219 : 1 : gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
15220 : : "PROCEDURE at %L and its interface in %s",
15221 : : &sym->declared_at, module_name);
15222 : 10 : return false;
15223 : : }
15224 : :
15225 : 343 : if (sym->attr.pure != iface->attr.pure)
15226 : : {
15227 : 2 : gfc_error ("Mismatch in PURE attribute between MODULE "
15228 : : "PROCEDURE at %L and its interface in %s",
15229 : : &sym->declared_at, module_name);
15230 : 2 : return false;
15231 : : }
15232 : :
15233 : 341 : if (sym->attr.recursive != iface->attr.recursive)
15234 : : {
15235 : 2 : gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
15236 : : "PROCEDURE at %L and its interface in %s",
15237 : : &sym->declared_at, module_name);
15238 : 2 : return false;
15239 : : }
15240 : :
15241 : : /* Check the result characteristics. */
15242 : 339 : if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
15243 : : {
15244 : 5 : gfc_error ("%s between the MODULE PROCEDURE declaration "
15245 : : "in MODULE %qs and the declaration at %L in "
15246 : : "(SUB)MODULE %qs",
15247 : : errmsg, module_name, &sym->declared_at,
15248 : : submodule_name ? submodule_name : module_name);
15249 : 5 : return false;
15250 : : }
15251 : :
15252 : 334 : check_formal:
15253 : : /* Check the characteristics of the formal arguments. */
15254 : 491 : if (sym->formal && sym->formal_ns)
15255 : : {
15256 : 901 : for (arg = sym->formal; arg && arg->sym; arg = arg->next)
15257 : : {
15258 : 509 : new_formal = arg;
15259 : 509 : gfc_traverse_ns (sym->formal_ns, compare_fsyms);
15260 : : }
15261 : : }
15262 : : }
15263 : :
15264 : : /* F2018:15.4.2.2 requires an explicit interface for procedures with the
15265 : : BIND(C) attribute. */
15266 : 448349 : if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN)
15267 : : {
15268 : 1 : gfc_error ("Interface of %qs at %L must be explicit",
15269 : : sym->name, &sym->declared_at);
15270 : 1 : return false;
15271 : : }
15272 : :
15273 : : return true;
15274 : : }
15275 : :
15276 : :
15277 : : /* Resolve a list of finalizer procedures. That is, after they have hopefully
15278 : : been defined and we now know their defined arguments, check that they fulfill
15279 : : the requirements of the standard for procedures used as finalizers. */
15280 : :
15281 : : static bool
15282 : 103513 : gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
15283 : : {
15284 : 103513 : gfc_finalizer* list;
15285 : 103513 : gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
15286 : 103513 : bool result = true;
15287 : 103513 : bool seen_scalar = false;
15288 : 103513 : gfc_symbol *vtab;
15289 : 103513 : gfc_component *c;
15290 : 103513 : gfc_symbol *parent = gfc_get_derived_super_type (derived);
15291 : :
15292 : 103513 : if (parent)
15293 : 14604 : gfc_resolve_finalizers (parent, finalizable);
15294 : :
15295 : : /* Ensure that derived-type components have a their finalizers resolved. */
15296 : 103513 : bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
15297 : 335365 : for (c = derived->components; c; c = c->next)
15298 : 231852 : if (c->ts.type == BT_DERIVED
15299 : 65302 : && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
15300 : : {
15301 : 7660 : bool has_final2 = false;
15302 : 7660 : if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
15303 : 0 : return false; /* Error. */
15304 : 7660 : has_final = has_final || has_final2;
15305 : : }
15306 : : /* Return early if not finalizable. */
15307 : 103513 : if (!has_final)
15308 : : {
15309 : 101285 : if (finalizable)
15310 : 7618 : *finalizable = false;
15311 : 101285 : return true;
15312 : : }
15313 : :
15314 : : /* Walk over the list of finalizer-procedures, check them, and if any one
15315 : : does not fit in with the standard's definition, print an error and remove
15316 : : it from the list. */
15317 : 2228 : prev_link = &derived->f2k_derived->finalizers;
15318 : 4600 : for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
15319 : : {
15320 : 2372 : gfc_formal_arglist *dummy_args;
15321 : 2372 : gfc_symbol* arg;
15322 : 2372 : gfc_finalizer* i;
15323 : 2372 : int my_rank;
15324 : :
15325 : : /* Skip this finalizer if we already resolved it. */
15326 : 2372 : if (list->proc_tree)
15327 : : {
15328 : 1921 : if (list->proc_tree->n.sym->formal->sym->as == NULL
15329 : 566 : || list->proc_tree->n.sym->formal->sym->as->rank == 0)
15330 : 1355 : seen_scalar = true;
15331 : 1921 : prev_link = &(list->next);
15332 : 1921 : continue;
15333 : : }
15334 : :
15335 : : /* Check this exists and is a SUBROUTINE. */
15336 : 451 : if (!list->proc_sym->attr.subroutine)
15337 : : {
15338 : 3 : gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
15339 : : list->proc_sym->name, &list->where);
15340 : 3 : goto error;
15341 : : }
15342 : :
15343 : : /* We should have exactly one argument. */
15344 : 448 : dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
15345 : 448 : if (!dummy_args || dummy_args->next)
15346 : : {
15347 : 2 : gfc_error ("FINAL procedure at %L must have exactly one argument",
15348 : : &list->where);
15349 : 2 : goto error;
15350 : : }
15351 : 446 : arg = dummy_args->sym;
15352 : :
15353 : 446 : if (!arg)
15354 : : {
15355 : 1 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
15356 : 1 : &list->proc_sym->declared_at, derived->name);
15357 : 1 : goto error;
15358 : : }
15359 : :
15360 : 445 : if (arg->as && arg->as->type == AS_ASSUMED_RANK
15361 : 6 : && ((list != derived->f2k_derived->finalizers) || list->next))
15362 : : {
15363 : 0 : gfc_error ("FINAL procedure at %L with assumed rank argument must "
15364 : : "be the only finalizer with the same kind/type "
15365 : : "(F2018: C790)", &list->where);
15366 : 0 : goto error;
15367 : : }
15368 : :
15369 : : /* This argument must be of our type. */
15370 : 445 : if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
15371 : : {
15372 : 2 : gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
15373 : : &arg->declared_at, derived->name);
15374 : 2 : goto error;
15375 : : }
15376 : :
15377 : : /* It must neither be a pointer nor allocatable nor optional. */
15378 : 443 : if (arg->attr.pointer)
15379 : : {
15380 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
15381 : : &arg->declared_at);
15382 : 1 : goto error;
15383 : : }
15384 : 442 : if (arg->attr.allocatable)
15385 : : {
15386 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
15387 : : " ALLOCATABLE", &arg->declared_at);
15388 : 1 : goto error;
15389 : : }
15390 : 441 : if (arg->attr.optional)
15391 : : {
15392 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
15393 : : &arg->declared_at);
15394 : 1 : goto error;
15395 : : }
15396 : :
15397 : : /* It must not be INTENT(OUT). */
15398 : 440 : if (arg->attr.intent == INTENT_OUT)
15399 : : {
15400 : 1 : gfc_error ("Argument of FINAL procedure at %L must not be"
15401 : : " INTENT(OUT)", &arg->declared_at);
15402 : 1 : goto error;
15403 : : }
15404 : :
15405 : : /* Warn if the procedure is non-scalar and not assumed shape. */
15406 : 439 : if (warn_surprising && arg->as && arg->as->rank != 0
15407 : 3 : && arg->as->type != AS_ASSUMED_SHAPE)
15408 : 2 : gfc_warning (OPT_Wsurprising,
15409 : : "Non-scalar FINAL procedure at %L should have assumed"
15410 : : " shape argument", &arg->declared_at);
15411 : :
15412 : : /* Check that it does not match in kind and rank with a FINAL procedure
15413 : : defined earlier. To really loop over the *earlier* declarations,
15414 : : we need to walk the tail of the list as new ones were pushed at the
15415 : : front. */
15416 : : /* TODO: Handle kind parameters once they are implemented. */
15417 : 439 : my_rank = (arg->as ? arg->as->rank : 0);
15418 : 528 : for (i = list->next; i; i = i->next)
15419 : : {
15420 : 91 : gfc_formal_arglist *dummy_args;
15421 : :
15422 : : /* Argument list might be empty; that is an error signalled earlier,
15423 : : but we nevertheless continued resolving. */
15424 : 91 : dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
15425 : 91 : if (dummy_args)
15426 : : {
15427 : 89 : gfc_symbol* i_arg = dummy_args->sym;
15428 : 89 : const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
15429 : 89 : if (i_rank == my_rank)
15430 : : {
15431 : 2 : gfc_error ("FINAL procedure %qs declared at %L has the same"
15432 : : " rank (%d) as %qs",
15433 : 2 : list->proc_sym->name, &list->where, my_rank,
15434 : 2 : i->proc_sym->name);
15435 : 2 : goto error;
15436 : : }
15437 : : }
15438 : : }
15439 : :
15440 : : /* Is this the/a scalar finalizer procedure? */
15441 : 437 : if (my_rank == 0)
15442 : 317 : seen_scalar = true;
15443 : :
15444 : : /* Find the symtree for this procedure. */
15445 : 437 : gcc_assert (!list->proc_tree);
15446 : 437 : list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
15447 : :
15448 : 437 : prev_link = &list->next;
15449 : 437 : continue;
15450 : :
15451 : : /* Remove wrong nodes immediately from the list so we don't risk any
15452 : : troubles in the future when they might fail later expectations. */
15453 : 14 : error:
15454 : 14 : i = list;
15455 : 14 : *prev_link = list->next;
15456 : 14 : gfc_free_finalizer (i);
15457 : 14 : result = false;
15458 : 437 : }
15459 : :
15460 : 2228 : if (result == false)
15461 : : return false;
15462 : :
15463 : : /* Warn if we haven't seen a scalar finalizer procedure (but we know there
15464 : : were nodes in the list, must have been for arrays. It is surely a good
15465 : : idea to have a scalar version there if there's something to finalize. */
15466 : 2224 : if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
15467 : 1 : gfc_warning (OPT_Wsurprising,
15468 : : "Only array FINAL procedures declared for derived type %qs"
15469 : : " defined at %L, suggest also scalar one unless an assumed"
15470 : : " rank finalizer has been declared",
15471 : : derived->name, &derived->declared_at);
15472 : :
15473 : 2224 : vtab = gfc_find_derived_vtab (derived);
15474 : 2224 : c = vtab->ts.u.derived->components->next->next->next->next->next;
15475 : 2224 : gfc_set_sym_referenced (c->initializer->symtree->n.sym);
15476 : :
15477 : 2224 : if (finalizable)
15478 : 590 : *finalizable = true;
15479 : :
15480 : : return true;
15481 : : }
15482 : :
15483 : :
15484 : : /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
15485 : :
15486 : : static bool
15487 : 380 : check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
15488 : : const char* generic_name, locus where)
15489 : : {
15490 : 380 : gfc_symbol *sym1, *sym2;
15491 : 380 : const char *pass1, *pass2;
15492 : 380 : gfc_formal_arglist *dummy_args;
15493 : :
15494 : 380 : gcc_assert (t1->specific && t2->specific);
15495 : 380 : gcc_assert (!t1->specific->is_generic);
15496 : 380 : gcc_assert (!t2->specific->is_generic);
15497 : 380 : gcc_assert (t1->is_operator == t2->is_operator);
15498 : :
15499 : 380 : sym1 = t1->specific->u.specific->n.sym;
15500 : 380 : sym2 = t2->specific->u.specific->n.sym;
15501 : :
15502 : 380 : if (sym1 == sym2)
15503 : : return true;
15504 : :
15505 : : /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
15506 : 380 : if (sym1->attr.subroutine != sym2->attr.subroutine
15507 : 378 : || sym1->attr.function != sym2->attr.function)
15508 : : {
15509 : 2 : gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
15510 : : " GENERIC %qs at %L",
15511 : : sym1->name, sym2->name, generic_name, &where);
15512 : 2 : return false;
15513 : : }
15514 : :
15515 : : /* Determine PASS arguments. */
15516 : 378 : if (t1->specific->nopass)
15517 : : pass1 = NULL;
15518 : 327 : else if (t1->specific->pass_arg)
15519 : : pass1 = t1->specific->pass_arg;
15520 : : else
15521 : : {
15522 : 212 : dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
15523 : 212 : if (dummy_args)
15524 : 211 : pass1 = dummy_args->sym->name;
15525 : : else
15526 : : pass1 = NULL;
15527 : : }
15528 : 378 : if (t2->specific->nopass)
15529 : : pass2 = NULL;
15530 : 326 : else if (t2->specific->pass_arg)
15531 : : pass2 = t2->specific->pass_arg;
15532 : : else
15533 : : {
15534 : 207 : dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
15535 : 207 : if (dummy_args)
15536 : 206 : pass2 = dummy_args->sym->name;
15537 : : else
15538 : : pass2 = NULL;
15539 : : }
15540 : :
15541 : : /* Compare the interfaces. */
15542 : 378 : if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
15543 : : NULL, 0, pass1, pass2))
15544 : : {
15545 : 8 : gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
15546 : : sym1->name, sym2->name, generic_name, &where);
15547 : 8 : return false;
15548 : : }
15549 : :
15550 : : return true;
15551 : : }
15552 : :
15553 : :
15554 : : /* Worker function for resolving a generic procedure binding; this is used to
15555 : : resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
15556 : :
15557 : : The difference between those cases is finding possible inherited bindings
15558 : : that are overridden, as one has to look for them in tb_sym_root,
15559 : : tb_uop_root or tb_op, respectively. Thus the caller must already find
15560 : : the super-type and set p->overridden correctly. */
15561 : :
15562 : : static bool
15563 : 2042 : resolve_tb_generic_targets (gfc_symbol* super_type,
15564 : : gfc_typebound_proc* p, const char* name)
15565 : : {
15566 : 2042 : gfc_tbp_generic* target;
15567 : 2042 : gfc_symtree* first_target;
15568 : 2042 : gfc_symtree* inherited;
15569 : :
15570 : 2042 : gcc_assert (p && p->is_generic);
15571 : :
15572 : : /* Try to find the specific bindings for the symtrees in our target-list. */
15573 : 2042 : gcc_assert (p->u.generic);
15574 : 4328 : for (target = p->u.generic; target; target = target->next)
15575 : 2303 : if (!target->specific)
15576 : : {
15577 : 2165 : gfc_typebound_proc* overridden_tbp;
15578 : 2165 : gfc_tbp_generic* g;
15579 : 2165 : const char* target_name;
15580 : :
15581 : 2165 : target_name = target->specific_st->name;
15582 : :
15583 : : /* Defined for this type directly. */
15584 : 2165 : if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
15585 : : {
15586 : 2156 : target->specific = target->specific_st->n.tb;
15587 : 2156 : goto specific_found;
15588 : : }
15589 : :
15590 : : /* Look for an inherited specific binding. */
15591 : 9 : if (super_type)
15592 : : {
15593 : 5 : inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
15594 : : true, NULL);
15595 : :
15596 : 5 : if (inherited)
15597 : : {
15598 : 5 : gcc_assert (inherited->n.tb);
15599 : 5 : target->specific = inherited->n.tb;
15600 : 5 : goto specific_found;
15601 : : }
15602 : : }
15603 : :
15604 : 4 : gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
15605 : : " at %L", target_name, name, &p->where);
15606 : 4 : return false;
15607 : :
15608 : : /* Once we've found the specific binding, check it is not ambiguous with
15609 : : other specifics already found or inherited for the same GENERIC. */
15610 : 2161 : specific_found:
15611 : 2161 : gcc_assert (target->specific);
15612 : :
15613 : : /* This must really be a specific binding! */
15614 : 2161 : if (target->specific->is_generic)
15615 : : {
15616 : 3 : gfc_error ("GENERIC %qs at %L must target a specific binding,"
15617 : : " %qs is GENERIC, too", name, &p->where, target_name);
15618 : 3 : return false;
15619 : : }
15620 : :
15621 : : /* Check those already resolved on this type directly. */
15622 : 5026 : for (g = p->u.generic; g; g = g->next)
15623 : 724 : if (g != target && g->specific
15624 : 3237 : && !check_generic_tbp_ambiguity (target, g, name, p->where))
15625 : : return false;
15626 : :
15627 : : /* Check for ambiguity with inherited specific targets. */
15628 : 2167 : for (overridden_tbp = p->overridden; overridden_tbp;
15629 : 16 : overridden_tbp = overridden_tbp->overridden)
15630 : 19 : if (overridden_tbp->is_generic)
15631 : : {
15632 : 33 : for (g = overridden_tbp->u.generic; g; g = g->next)
15633 : : {
15634 : 18 : gcc_assert (g->specific);
15635 : 18 : if (!check_generic_tbp_ambiguity (target, g, name, p->where))
15636 : : return false;
15637 : : }
15638 : : }
15639 : : }
15640 : :
15641 : : /* If we attempt to "overwrite" a specific binding, this is an error. */
15642 : 2025 : if (p->overridden && !p->overridden->is_generic)
15643 : : {
15644 : 1 : gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
15645 : : " the same name", name, &p->where);
15646 : 1 : return false;
15647 : : }
15648 : :
15649 : : /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
15650 : : all must have the same attributes here. */
15651 : 2024 : first_target = p->u.generic->specific->u.specific;
15652 : 2024 : gcc_assert (first_target);
15653 : 2024 : p->subroutine = first_target->n.sym->attr.subroutine;
15654 : 2024 : p->function = first_target->n.sym->attr.function;
15655 : :
15656 : 2024 : return true;
15657 : : }
15658 : :
15659 : :
15660 : : /* Resolve a GENERIC procedure binding for a derived type. */
15661 : :
15662 : : static bool
15663 : 1045 : resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
15664 : : {
15665 : 1045 : gfc_symbol* super_type;
15666 : :
15667 : : /* Find the overridden binding if any. */
15668 : 1045 : st->n.tb->overridden = NULL;
15669 : 1045 : super_type = gfc_get_derived_super_type (derived);
15670 : 1045 : if (super_type)
15671 : : {
15672 : 40 : gfc_symtree* overridden;
15673 : 40 : overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
15674 : : true, NULL);
15675 : :
15676 : 40 : if (overridden && overridden->n.tb)
15677 : 21 : st->n.tb->overridden = overridden->n.tb;
15678 : : }
15679 : :
15680 : : /* Resolve using worker function. */
15681 : 1045 : return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
15682 : : }
15683 : :
15684 : :
15685 : : /* Retrieve the target-procedure of an operator binding and do some checks in
15686 : : common for intrinsic and user-defined type-bound operators. */
15687 : :
15688 : : static gfc_symbol*
15689 : 1061 : get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
15690 : : {
15691 : 1061 : gfc_symbol* target_proc;
15692 : :
15693 : 1061 : gcc_assert (target->specific && !target->specific->is_generic);
15694 : 1061 : target_proc = target->specific->u.specific->n.sym;
15695 : 1061 : gcc_assert (target_proc);
15696 : :
15697 : : /* F08:C468. All operator bindings must have a passed-object dummy argument. */
15698 : 1061 : if (target->specific->nopass)
15699 : : {
15700 : 2 : gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
15701 : 2 : return NULL;
15702 : : }
15703 : :
15704 : : return target_proc;
15705 : : }
15706 : :
15707 : :
15708 : : /* Resolve a type-bound intrinsic operator. */
15709 : :
15710 : : static bool
15711 : 955 : resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
15712 : : gfc_typebound_proc* p)
15713 : : {
15714 : 955 : gfc_symbol* super_type;
15715 : 955 : gfc_tbp_generic* target;
15716 : :
15717 : : /* If there's already an error here, do nothing (but don't fail again). */
15718 : 955 : if (p->error)
15719 : : return true;
15720 : :
15721 : : /* Operators should always be GENERIC bindings. */
15722 : 955 : gcc_assert (p->is_generic);
15723 : :
15724 : : /* Look for an overridden binding. */
15725 : 955 : super_type = gfc_get_derived_super_type (derived);
15726 : 955 : if (super_type && super_type->f2k_derived)
15727 : 1 : p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
15728 : : op, true, NULL);
15729 : : else
15730 : 954 : p->overridden = NULL;
15731 : :
15732 : : /* Resolve general GENERIC properties using worker function. */
15733 : 955 : if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
15734 : 1 : goto error;
15735 : :
15736 : : /* Check the targets to be procedures of correct interface. */
15737 : 1952 : for (target = p->u.generic; target; target = target->next)
15738 : : {
15739 : 1018 : gfc_symbol* target_proc;
15740 : :
15741 : 1018 : target_proc = get_checked_tb_operator_target (target, p->where);
15742 : 1018 : if (!target_proc)
15743 : 1 : goto error;
15744 : :
15745 : 1017 : if (!gfc_check_operator_interface (target_proc, op, p->where))
15746 : 3 : goto error;
15747 : :
15748 : : /* Add target to non-typebound operator list. */
15749 : 1014 : if (!target->specific->deferred && !derived->attr.use_assoc
15750 : 357 : && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
15751 : : {
15752 : 355 : gfc_interface *head, *intr;
15753 : :
15754 : : /* Preempt 'gfc_check_new_interface' for submodules, where the
15755 : : mechanism for handling module procedures winds up resolving
15756 : : operator interfaces twice and would otherwise cause an error. */
15757 : 423 : for (intr = derived->ns->op[op]; intr; intr = intr->next)
15758 : 82 : if (intr->sym == target_proc
15759 : 16 : && target_proc->attr.used_in_submodule)
15760 : : return true;
15761 : :
15762 : 341 : if (!gfc_check_new_interface (derived->ns->op[op],
15763 : : target_proc, p->where))
15764 : : return false;
15765 : 339 : head = derived->ns->op[op];
15766 : 339 : intr = gfc_get_interface ();
15767 : 339 : intr->sym = target_proc;
15768 : 339 : intr->where = p->where;
15769 : 339 : intr->next = head;
15770 : 339 : derived->ns->op[op] = intr;
15771 : : }
15772 : : }
15773 : :
15774 : : return true;
15775 : :
15776 : 5 : error:
15777 : 5 : p->error = 1;
15778 : 5 : return false;
15779 : : }
15780 : :
15781 : :
15782 : : /* Resolve a type-bound user operator (tree-walker callback). */
15783 : :
15784 : : static gfc_symbol* resolve_bindings_derived;
15785 : : static bool resolve_bindings_result;
15786 : :
15787 : : static bool check_uop_procedure (gfc_symbol* sym, locus where);
15788 : :
15789 : : static void
15790 : 42 : resolve_typebound_user_op (gfc_symtree* stree)
15791 : : {
15792 : 42 : gfc_symbol* super_type;
15793 : 42 : gfc_tbp_generic* target;
15794 : :
15795 : 42 : gcc_assert (stree && stree->n.tb);
15796 : :
15797 : 42 : if (stree->n.tb->error)
15798 : : return;
15799 : :
15800 : : /* Operators should always be GENERIC bindings. */
15801 : 42 : gcc_assert (stree->n.tb->is_generic);
15802 : :
15803 : : /* Find overridden procedure, if any. */
15804 : 42 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
15805 : 42 : if (super_type && super_type->f2k_derived)
15806 : : {
15807 : 0 : gfc_symtree* overridden;
15808 : 0 : overridden = gfc_find_typebound_user_op (super_type, NULL,
15809 : : stree->name, true, NULL);
15810 : :
15811 : 0 : if (overridden && overridden->n.tb)
15812 : 0 : stree->n.tb->overridden = overridden->n.tb;
15813 : : }
15814 : : else
15815 : 42 : stree->n.tb->overridden = NULL;
15816 : :
15817 : : /* Resolve basically using worker function. */
15818 : 42 : if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
15819 : 0 : goto error;
15820 : :
15821 : : /* Check the targets to be functions of correct interface. */
15822 : 82 : for (target = stree->n.tb->u.generic; target; target = target->next)
15823 : : {
15824 : 43 : gfc_symbol* target_proc;
15825 : :
15826 : 43 : target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
15827 : 43 : if (!target_proc)
15828 : 1 : goto error;
15829 : :
15830 : 42 : if (!check_uop_procedure (target_proc, stree->n.tb->where))
15831 : 2 : goto error;
15832 : : }
15833 : :
15834 : : return;
15835 : :
15836 : 3 : error:
15837 : 3 : resolve_bindings_result = false;
15838 : 3 : stree->n.tb->error = 1;
15839 : : }
15840 : :
15841 : :
15842 : : /* Resolve the type-bound procedures for a derived type. */
15843 : :
15844 : : static void
15845 : 9052 : resolve_typebound_procedure (gfc_symtree* stree)
15846 : : {
15847 : 9052 : gfc_symbol* proc;
15848 : 9052 : locus where;
15849 : 9052 : gfc_symbol* me_arg;
15850 : 9052 : gfc_symbol* super_type;
15851 : 9052 : gfc_component* comp;
15852 : :
15853 : 9052 : gcc_assert (stree);
15854 : :
15855 : : /* Undefined specific symbol from GENERIC target definition. */
15856 : 9052 : if (!stree->n.tb)
15857 : 8970 : return;
15858 : :
15859 : 9046 : if (stree->n.tb->error)
15860 : : return;
15861 : :
15862 : : /* If this is a GENERIC binding, use that routine. */
15863 : 9030 : if (stree->n.tb->is_generic)
15864 : : {
15865 : 1045 : if (!resolve_typebound_generic (resolve_bindings_derived, stree))
15866 : 17 : goto error;
15867 : : return;
15868 : : }
15869 : :
15870 : : /* Get the target-procedure to check it. */
15871 : 7985 : gcc_assert (!stree->n.tb->is_generic);
15872 : 7985 : gcc_assert (stree->n.tb->u.specific);
15873 : 7985 : proc = stree->n.tb->u.specific->n.sym;
15874 : 7985 : where = stree->n.tb->where;
15875 : :
15876 : : /* Default access should already be resolved from the parser. */
15877 : 7985 : gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
15878 : :
15879 : 7985 : if (stree->n.tb->deferred)
15880 : : {
15881 : 667 : if (!check_proc_interface (proc, &where))
15882 : 5 : goto error;
15883 : : }
15884 : : else
15885 : : {
15886 : : /* If proc has not been resolved at this point, proc->name may
15887 : : actually be a USE associated entity. See PR fortran/89647. */
15888 : 7318 : if (!proc->resolve_symbol_called
15889 : 4964 : && proc->attr.function == 0 && proc->attr.subroutine == 0)
15890 : : {
15891 : 11 : gfc_symbol *tmp;
15892 : 11 : gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
15893 : 11 : if (tmp && tmp->attr.use_assoc)
15894 : : {
15895 : 1 : proc->module = tmp->module;
15896 : 1 : proc->attr.proc = tmp->attr.proc;
15897 : 1 : proc->attr.function = tmp->attr.function;
15898 : 1 : proc->attr.subroutine = tmp->attr.subroutine;
15899 : 1 : proc->attr.use_assoc = tmp->attr.use_assoc;
15900 : 1 : proc->ts = tmp->ts;
15901 : 1 : proc->result = tmp->result;
15902 : : }
15903 : : }
15904 : :
15905 : : /* Check for F08:C465. */
15906 : 7318 : if ((!proc->attr.subroutine && !proc->attr.function)
15907 : 7308 : || (proc->attr.proc != PROC_MODULE
15908 : 21 : && proc->attr.if_source != IFSRC_IFBODY
15909 : 7 : && !proc->attr.module_procedure)
15910 : 7307 : || proc->attr.abstract)
15911 : : {
15912 : 12 : gfc_error ("%qs must be a module procedure or an external "
15913 : : "procedure with an explicit interface at %L",
15914 : : proc->name, &where);
15915 : 12 : goto error;
15916 : : }
15917 : : }
15918 : :
15919 : 7968 : stree->n.tb->subroutine = proc->attr.subroutine;
15920 : 7968 : stree->n.tb->function = proc->attr.function;
15921 : :
15922 : : /* Find the super-type of the current derived type. We could do this once and
15923 : : store in a global if speed is needed, but as long as not I believe this is
15924 : : more readable and clearer. */
15925 : 7968 : super_type = gfc_get_derived_super_type (resolve_bindings_derived);
15926 : :
15927 : : /* If PASS, resolve and check arguments if not already resolved / loaded
15928 : : from a .mod file. */
15929 : 7968 : if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
15930 : : {
15931 : 2638 : gfc_formal_arglist *dummy_args;
15932 : :
15933 : 2638 : dummy_args = gfc_sym_get_dummy_args (proc);
15934 : 2638 : if (stree->n.tb->pass_arg)
15935 : : {
15936 : 453 : gfc_formal_arglist *i;
15937 : :
15938 : : /* If an explicit passing argument name is given, walk the arg-list
15939 : : and look for it. */
15940 : :
15941 : 453 : me_arg = NULL;
15942 : 453 : stree->n.tb->pass_arg_num = 1;
15943 : 573 : for (i = dummy_args; i; i = i->next)
15944 : : {
15945 : 571 : if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
15946 : : {
15947 : : me_arg = i->sym;
15948 : : break;
15949 : : }
15950 : 120 : ++stree->n.tb->pass_arg_num;
15951 : : }
15952 : :
15953 : 453 : if (!me_arg)
15954 : : {
15955 : 2 : gfc_error ("Procedure %qs with PASS(%s) at %L has no"
15956 : : " argument %qs",
15957 : : proc->name, stree->n.tb->pass_arg, &where,
15958 : : stree->n.tb->pass_arg);
15959 : 2 : goto error;
15960 : : }
15961 : : }
15962 : : else
15963 : : {
15964 : : /* Otherwise, take the first one; there should in fact be at least
15965 : : one. */
15966 : 2185 : stree->n.tb->pass_arg_num = 1;
15967 : 2185 : if (!dummy_args)
15968 : : {
15969 : 2 : gfc_error ("Procedure %qs with PASS at %L must have at"
15970 : : " least one argument", proc->name, &where);
15971 : 2 : goto error;
15972 : : }
15973 : 2183 : me_arg = dummy_args->sym;
15974 : : }
15975 : :
15976 : : /* Now check that the argument-type matches and the passed-object
15977 : : dummy argument is generally fine. */
15978 : :
15979 : 2183 : gcc_assert (me_arg);
15980 : :
15981 : 2634 : if (me_arg->ts.type != BT_CLASS)
15982 : : {
15983 : 5 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
15984 : : " at %L", proc->name, &where);
15985 : 5 : goto error;
15986 : : }
15987 : :
15988 : : /* The derived type is not a PDT template. Resolve as usual. */
15989 : 2629 : if (!resolve_bindings_derived->attr.pdt_template
15990 : 2614 : && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived))
15991 : : {
15992 : 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
15993 : : "the derived-type %qs", me_arg->name, proc->name,
15994 : : me_arg->name, &where, resolve_bindings_derived->name);
15995 : 0 : goto error;
15996 : : }
15997 : :
15998 : 2629 : if (resolve_bindings_derived->attr.pdt_template
15999 : 2644 : && !gfc_pdt_is_instance_of (resolve_bindings_derived,
16000 : 15 : CLASS_DATA (me_arg)->ts.u.derived))
16001 : : {
16002 : 0 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of "
16003 : : "the parametric derived-type %qs", me_arg->name,
16004 : : proc->name, me_arg->name, &where,
16005 : : resolve_bindings_derived->name);
16006 : 0 : goto error;
16007 : : }
16008 : :
16009 : 2629 : if (resolve_bindings_derived->attr.pdt_template
16010 : 15 : && gfc_pdt_is_instance_of (resolve_bindings_derived,
16011 : 15 : CLASS_DATA (me_arg)->ts.u.derived)
16012 : 15 : && (me_arg->param_list != NULL)
16013 : 2644 : && (gfc_spec_list_type (me_arg->param_list,
16014 : 15 : CLASS_DATA(me_arg)->ts.u.derived)
16015 : : != SPEC_ASSUMED))
16016 : : {
16017 : :
16018 : : /* Add a check to verify if there are any LEN parameters in the
16019 : : first place. If there are LEN parameters, throw this error.
16020 : : If there are only KIND parameters, then don't trigger
16021 : : this error. */
16022 : 7 : gfc_component *c;
16023 : 7 : bool seen_len_param = false;
16024 : 7 : gfc_actual_arglist *me_arg_param = me_arg->param_list;
16025 : :
16026 : 8 : for (; me_arg_param; me_arg_param = me_arg_param->next)
16027 : : {
16028 : 7 : c = gfc_find_component (CLASS_DATA(me_arg)->ts.u.derived,
16029 : : me_arg_param->name, true, true, NULL);
16030 : :
16031 : 7 : gcc_assert (c != NULL);
16032 : :
16033 : 7 : if (c->attr.pdt_kind)
16034 : 1 : continue;
16035 : :
16036 : : /* Getting here implies that there is a pdt_len parameter
16037 : : in the list. */
16038 : : seen_len_param = true;
16039 : : break;
16040 : : }
16041 : :
16042 : 7 : if (seen_len_param)
16043 : : {
16044 : 6 : gfc_error ("All LEN type parameters of the passed dummy "
16045 : : "argument %qs of %qs at %L must be ASSUMED.",
16046 : : me_arg->name, proc->name, &where);
16047 : 6 : goto error;
16048 : : }
16049 : : }
16050 : :
16051 : 2623 : gcc_assert (me_arg->ts.type == BT_CLASS);
16052 : 2623 : if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
16053 : : {
16054 : 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be"
16055 : : " scalar", proc->name, &where);
16056 : 1 : goto error;
16057 : : }
16058 : 2622 : if (CLASS_DATA (me_arg)->attr.allocatable)
16059 : : {
16060 : 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16061 : : " be ALLOCATABLE", proc->name, &where);
16062 : 2 : goto error;
16063 : : }
16064 : 2620 : if (CLASS_DATA (me_arg)->attr.class_pointer)
16065 : : {
16066 : 2 : gfc_error ("Passed-object dummy argument of %qs at %L must not"
16067 : : " be POINTER", proc->name, &where);
16068 : 2 : goto error;
16069 : : }
16070 : : }
16071 : :
16072 : : /* If we are extending some type, check that we don't override a procedure
16073 : : flagged NON_OVERRIDABLE. */
16074 : 7948 : stree->n.tb->overridden = NULL;
16075 : 7948 : if (super_type)
16076 : : {
16077 : 1480 : gfc_symtree* overridden;
16078 : 1480 : overridden = gfc_find_typebound_proc (super_type, NULL,
16079 : : stree->name, true, NULL);
16080 : :
16081 : 1480 : if (overridden)
16082 : : {
16083 : 1210 : if (overridden->n.tb)
16084 : 1210 : stree->n.tb->overridden = overridden->n.tb;
16085 : :
16086 : 1210 : if (!gfc_check_typebound_override (stree, overridden))
16087 : 26 : goto error;
16088 : : }
16089 : : }
16090 : :
16091 : : /* See if there's a name collision with a component directly in this type. */
16092 : 18951 : for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
16093 : 11030 : if (!strcmp (comp->name, stree->name))
16094 : : {
16095 : 1 : gfc_error ("Procedure %qs at %L has the same name as a component of"
16096 : : " %qs",
16097 : : stree->name, &where, resolve_bindings_derived->name);
16098 : 1 : goto error;
16099 : : }
16100 : :
16101 : : /* Try to find a name collision with an inherited component. */
16102 : 7921 : if (super_type && gfc_find_component (super_type, stree->name, true, true,
16103 : : NULL))
16104 : : {
16105 : 1 : gfc_error ("Procedure %qs at %L has the same name as an inherited"
16106 : : " component of %qs",
16107 : : stree->name, &where, resolve_bindings_derived->name);
16108 : 1 : goto error;
16109 : : }
16110 : :
16111 : 7920 : stree->n.tb->error = 0;
16112 : 7920 : return;
16113 : :
16114 : 82 : error:
16115 : 82 : resolve_bindings_result = false;
16116 : 82 : stree->n.tb->error = 1;
16117 : : }
16118 : :
16119 : :
16120 : : static bool
16121 : 79285 : resolve_typebound_procedures (gfc_symbol* derived)
16122 : : {
16123 : 79285 : int op;
16124 : 79285 : gfc_symbol* super_type;
16125 : :
16126 : 79285 : if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
16127 : : return true;
16128 : :
16129 : 4433 : super_type = gfc_get_derived_super_type (derived);
16130 : 4433 : if (super_type)
16131 : 847 : resolve_symbol (super_type);
16132 : :
16133 : 4433 : resolve_bindings_derived = derived;
16134 : 4433 : resolve_bindings_result = true;
16135 : :
16136 : 4433 : if (derived->f2k_derived->tb_sym_root)
16137 : 4433 : gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
16138 : : &resolve_typebound_procedure);
16139 : :
16140 : 4433 : if (derived->f2k_derived->tb_uop_root)
16141 : 38 : gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
16142 : : &resolve_typebound_user_op);
16143 : :
16144 : 128557 : for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
16145 : : {
16146 : 124124 : gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
16147 : 124124 : if (p && !resolve_typebound_intrinsic_op (derived,
16148 : : (gfc_intrinsic_op)op, p))
16149 : 7 : resolve_bindings_result = false;
16150 : : }
16151 : :
16152 : 4433 : return resolve_bindings_result;
16153 : : }
16154 : :
16155 : :
16156 : : /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
16157 : : to give all identical derived types the same backend_decl. */
16158 : : static void
16159 : 177774 : add_dt_to_dt_list (gfc_symbol *derived)
16160 : : {
16161 : 177774 : if (!derived->dt_next)
16162 : : {
16163 : 74222 : if (gfc_derived_types)
16164 : : {
16165 : 60699 : derived->dt_next = gfc_derived_types->dt_next;
16166 : 60699 : gfc_derived_types->dt_next = derived;
16167 : : }
16168 : : else
16169 : : {
16170 : 13523 : derived->dt_next = derived;
16171 : : }
16172 : 74222 : gfc_derived_types = derived;
16173 : : }
16174 : 177774 : }
16175 : :
16176 : :
16177 : : /* Ensure that a derived-type is really not abstract, meaning that every
16178 : : inherited DEFERRED binding is overridden by a non-DEFERRED one. */
16179 : :
16180 : : static bool
16181 : 6904 : ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
16182 : : {
16183 : 6904 : if (!st)
16184 : : return true;
16185 : :
16186 : 2711 : if (!ensure_not_abstract_walker (sub, st->left))
16187 : : return false;
16188 : 2709 : if (!ensure_not_abstract_walker (sub, st->right))
16189 : : return false;
16190 : :
16191 : 2708 : if (st->n.tb && st->n.tb->deferred)
16192 : : {
16193 : 1957 : gfc_symtree* overriding;
16194 : 1957 : overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
16195 : 1957 : if (!overriding)
16196 : : return false;
16197 : 1956 : gcc_assert (overriding->n.tb);
16198 : 1956 : if (overriding->n.tb->deferred)
16199 : : {
16200 : 4 : gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
16201 : : " %qs is DEFERRED and not overridden",
16202 : : sub->name, &sub->declared_at, st->name);
16203 : 4 : return false;
16204 : : }
16205 : : }
16206 : :
16207 : : return true;
16208 : : }
16209 : :
16210 : : static bool
16211 : 1342 : ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
16212 : : {
16213 : : /* The algorithm used here is to recursively travel up the ancestry of sub
16214 : : and for each ancestor-type, check all bindings. If any of them is
16215 : : DEFERRED, look it up starting from sub and see if the found (overriding)
16216 : : binding is not DEFERRED.
16217 : : This is not the most efficient way to do this, but it should be ok and is
16218 : : clearer than something sophisticated. */
16219 : :
16220 : 1485 : gcc_assert (ancestor && !sub->attr.abstract);
16221 : :
16222 : 1485 : if (!ancestor->attr.abstract)
16223 : : return true;
16224 : :
16225 : : /* Walk bindings of this ancestor. */
16226 : 1484 : if (ancestor->f2k_derived)
16227 : : {
16228 : 1484 : bool t;
16229 : 1484 : t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
16230 : 1484 : if (!t)
16231 : : return false;
16232 : : }
16233 : :
16234 : : /* Find next ancestor type and recurse on it. */
16235 : 1479 : ancestor = gfc_get_derived_super_type (ancestor);
16236 : 1479 : if (ancestor)
16237 : : return ensure_not_abstract (sub, ancestor);
16238 : :
16239 : : return true;
16240 : : }
16241 : :
16242 : :
16243 : : /* This check for typebound defined assignments is done recursively
16244 : : since the order in which derived types are resolved is not always in
16245 : : order of the declarations. */
16246 : :
16247 : : static void
16248 : 180436 : check_defined_assignments (gfc_symbol *derived)
16249 : : {
16250 : 180436 : gfc_component *c;
16251 : :
16252 : 679437 : for (c = derived->components; c; c = c->next)
16253 : : {
16254 : 500532 : if (!gfc_bt_struct (c->ts.type)
16255 : 124611 : || c->attr.pointer
16256 : 18033 : || c->attr.proc_pointer_comp
16257 : : || c->attr.class_pointer
16258 : 18033 : || c->attr.proc_pointer)
16259 : 482988 : continue;
16260 : :
16261 : 17544 : if (c->ts.u.derived->attr.defined_assign_comp
16262 : 17333 : || (c->ts.u.derived->f2k_derived
16263 : 16764 : && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
16264 : : {
16265 : 1507 : derived->attr.defined_assign_comp = 1;
16266 : 1507 : return;
16267 : : }
16268 : :
16269 : 16037 : if (c->attr.allocatable)
16270 : 5441 : continue;
16271 : :
16272 : 10596 : check_defined_assignments (c->ts.u.derived);
16273 : 10596 : if (c->ts.u.derived->attr.defined_assign_comp)
16274 : : {
16275 : 24 : derived->attr.defined_assign_comp = 1;
16276 : 24 : return;
16277 : : }
16278 : : }
16279 : : }
16280 : :
16281 : :
16282 : : /* Resolve a single component of a derived type or structure. */
16283 : :
16284 : : static bool
16285 : 482933 : resolve_component (gfc_component *c, gfc_symbol *sym)
16286 : : {
16287 : 482933 : gfc_symbol *super_type;
16288 : 482933 : symbol_attribute *attr;
16289 : :
16290 : 482933 : if (c->attr.artificial)
16291 : : return true;
16292 : :
16293 : : /* Do not allow vtype components to be resolved in nameless namespaces
16294 : : such as block data because the procedure pointers will cause ICEs
16295 : : and vtables are not needed in these contexts. */
16296 : 391655 : if (sym->attr.vtype && sym->attr.use_assoc
16297 : 150841 : && sym->ns->proc_name == NULL)
16298 : : return true;
16299 : :
16300 : : /* F2008, C442. */
16301 : 391625 : if ((!sym->attr.is_class || c != sym->components)
16302 : 391625 : && c->attr.codimension
16303 : 167 : && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
16304 : : {
16305 : 4 : gfc_error ("Coarray component %qs at %L must be allocatable with "
16306 : : "deferred shape", c->name, &c->loc);
16307 : 4 : return false;
16308 : : }
16309 : :
16310 : : /* F2008, C443. */
16311 : 391621 : if (c->attr.codimension && c->ts.type == BT_DERIVED
16312 : 77 : && c->ts.u.derived->ts.is_iso_c)
16313 : : {
16314 : 1 : gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
16315 : : "shall not be a coarray", c->name, &c->loc);
16316 : 1 : return false;
16317 : : }
16318 : :
16319 : : /* F2008, C444. */
16320 : 391620 : if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
16321 : 22 : && (c->attr.codimension || c->attr.pointer || c->attr.dimension
16322 : 22 : || c->attr.allocatable))
16323 : : {
16324 : 3 : gfc_error ("Component %qs at %L with coarray component "
16325 : : "shall be a nonpointer, nonallocatable scalar",
16326 : : c->name, &c->loc);
16327 : 3 : return false;
16328 : : }
16329 : :
16330 : : /* F2008, C448. */
16331 : 391617 : if (c->ts.type == BT_CLASS)
16332 : : {
16333 : 7079 : if (c->attr.class_ok && CLASS_DATA (c))
16334 : : {
16335 : 7071 : attr = &(CLASS_DATA (c)->attr);
16336 : :
16337 : : /* Fix up contiguous attribute. */
16338 : 7071 : if (c->attr.contiguous)
16339 : 3 : attr->contiguous = 1;
16340 : : }
16341 : : else
16342 : : attr = NULL;
16343 : : }
16344 : : else
16345 : 384538 : attr = &c->attr;
16346 : :
16347 : 391612 : if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
16348 : : {
16349 : 5 : gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
16350 : : "is not an array pointer", c->name, &c->loc);
16351 : 5 : return false;
16352 : : }
16353 : :
16354 : : /* F2003, 15.2.1 - length has to be one. */
16355 : 36718 : if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
16356 : 391631 : && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
16357 : 19 : || !gfc_is_constant_expr (c->ts.u.cl->length)
16358 : 19 : || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
16359 : : {
16360 : 1 : gfc_error ("Component %qs of BIND(C) type at %L must have length one",
16361 : : c->name, &c->loc);
16362 : 1 : return false;
16363 : : }
16364 : :
16365 : 391611 : if (c->attr.proc_pointer && c->ts.interface)
16366 : : {
16367 : 59525 : gfc_symbol *ifc = c->ts.interface;
16368 : :
16369 : 59525 : if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
16370 : : {
16371 : 6 : c->tb->error = 1;
16372 : 6 : return false;
16373 : : }
16374 : :
16375 : 59519 : if (ifc->attr.if_source || ifc->attr.intrinsic)
16376 : : {
16377 : : /* Resolve interface and copy attributes. */
16378 : 59488 : if (ifc->formal && !ifc->formal_ns)
16379 : 43684 : resolve_symbol (ifc);
16380 : 59488 : if (ifc->attr.intrinsic)
16381 : 0 : gfc_resolve_intrinsic (ifc, &ifc->declared_at);
16382 : :
16383 : 59488 : if (ifc->result)
16384 : : {
16385 : 8563 : c->ts = ifc->result->ts;
16386 : 8563 : c->attr.allocatable = ifc->result->attr.allocatable;
16387 : 8563 : c->attr.pointer = ifc->result->attr.pointer;
16388 : 8563 : c->attr.dimension = ifc->result->attr.dimension;
16389 : 8563 : c->as = gfc_copy_array_spec (ifc->result->as);
16390 : 8563 : c->attr.class_ok = ifc->result->attr.class_ok;
16391 : : }
16392 : : else
16393 : : {
16394 : 50925 : c->ts = ifc->ts;
16395 : 50925 : c->attr.allocatable = ifc->attr.allocatable;
16396 : 50925 : c->attr.pointer = ifc->attr.pointer;
16397 : 50925 : c->attr.dimension = ifc->attr.dimension;
16398 : 50925 : c->as = gfc_copy_array_spec (ifc->as);
16399 : 50925 : c->attr.class_ok = ifc->attr.class_ok;
16400 : : }
16401 : 59488 : c->ts.interface = ifc;
16402 : 59488 : c->attr.function = ifc->attr.function;
16403 : 59488 : c->attr.subroutine = ifc->attr.subroutine;
16404 : :
16405 : 59488 : c->attr.pure = ifc->attr.pure;
16406 : 59488 : c->attr.elemental = ifc->attr.elemental;
16407 : 59488 : c->attr.recursive = ifc->attr.recursive;
16408 : 59488 : c->attr.always_explicit = ifc->attr.always_explicit;
16409 : 59488 : c->attr.ext_attr |= ifc->attr.ext_attr;
16410 : : /* Copy char length. */
16411 : 59488 : if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
16412 : : {
16413 : 301 : gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
16414 : 256 : if (cl->length && !cl->resolved
16415 : 321 : && !gfc_resolve_expr (cl->length))
16416 : : {
16417 : 0 : c->tb->error = 1;
16418 : 0 : return false;
16419 : : }
16420 : 301 : c->ts.u.cl = cl;
16421 : : }
16422 : : }
16423 : : }
16424 : 332086 : else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
16425 : : {
16426 : : /* Since PPCs are not implicitly typed, a PPC without an explicit
16427 : : interface must be a subroutine. */
16428 : 46987 : gfc_add_subroutine (&c->attr, c->name, &c->loc);
16429 : : }
16430 : :
16431 : : /* Procedure pointer components: Check PASS arg. */
16432 : 391605 : if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
16433 : 89299 : && !sym->attr.vtype)
16434 : : {
16435 : 94 : gfc_symbol* me_arg;
16436 : :
16437 : 94 : if (c->tb->pass_arg)
16438 : : {
16439 : 19 : gfc_formal_arglist* i;
16440 : :
16441 : : /* If an explicit passing argument name is given, walk the arg-list
16442 : : and look for it. */
16443 : :
16444 : 19 : me_arg = NULL;
16445 : 19 : c->tb->pass_arg_num = 1;
16446 : 33 : for (i = c->ts.interface->formal; i; i = i->next)
16447 : : {
16448 : 32 : if (!strcmp (i->sym->name, c->tb->pass_arg))
16449 : : {
16450 : : me_arg = i->sym;
16451 : : break;
16452 : : }
16453 : 14 : c->tb->pass_arg_num++;
16454 : : }
16455 : :
16456 : 19 : if (!me_arg)
16457 : : {
16458 : 1 : gfc_error ("Procedure pointer component %qs with PASS(%s) "
16459 : : "at %L has no argument %qs", c->name,
16460 : : c->tb->pass_arg, &c->loc, c->tb->pass_arg);
16461 : 1 : c->tb->error = 1;
16462 : 1 : return false;
16463 : : }
16464 : : }
16465 : : else
16466 : : {
16467 : : /* Otherwise, take the first one; there should in fact be at least
16468 : : one. */
16469 : 75 : c->tb->pass_arg_num = 1;
16470 : 75 : if (!c->ts.interface->formal)
16471 : : {
16472 : 3 : gfc_error ("Procedure pointer component %qs with PASS at %L "
16473 : : "must have at least one argument",
16474 : : c->name, &c->loc);
16475 : 3 : c->tb->error = 1;
16476 : 3 : return false;
16477 : : }
16478 : 72 : me_arg = c->ts.interface->formal->sym;
16479 : : }
16480 : :
16481 : : /* Now check that the argument-type matches. */
16482 : 72 : gcc_assert (me_arg);
16483 : 90 : if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
16484 : 89 : || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
16485 : 89 : || (me_arg->ts.type == BT_CLASS
16486 : 81 : && CLASS_DATA (me_arg)->ts.u.derived != sym))
16487 : : {
16488 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
16489 : : " the derived type %qs", me_arg->name, c->name,
16490 : : me_arg->name, &c->loc, sym->name);
16491 : 1 : c->tb->error = 1;
16492 : 1 : return false;
16493 : : }
16494 : :
16495 : : /* Check for F03:C453. */
16496 : 89 : if (CLASS_DATA (me_arg)->attr.dimension)
16497 : : {
16498 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
16499 : : "must be scalar", me_arg->name, c->name, me_arg->name,
16500 : : &c->loc);
16501 : 1 : c->tb->error = 1;
16502 : 1 : return false;
16503 : : }
16504 : :
16505 : 88 : if (CLASS_DATA (me_arg)->attr.class_pointer)
16506 : : {
16507 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
16508 : : "may not have the POINTER attribute", me_arg->name,
16509 : : c->name, me_arg->name, &c->loc);
16510 : 1 : c->tb->error = 1;
16511 : 1 : return false;
16512 : : }
16513 : :
16514 : 87 : if (CLASS_DATA (me_arg)->attr.allocatable)
16515 : : {
16516 : 1 : gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
16517 : : "may not be ALLOCATABLE", me_arg->name, c->name,
16518 : : me_arg->name, &c->loc);
16519 : 1 : c->tb->error = 1;
16520 : 1 : return false;
16521 : : }
16522 : :
16523 : 86 : if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
16524 : : {
16525 : 2 : gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
16526 : : " at %L", c->name, &c->loc);
16527 : 2 : return false;
16528 : : }
16529 : :
16530 : : }
16531 : :
16532 : : /* Check type-spec if this is not the parent-type component. */
16533 : 391595 : if (((sym->attr.is_class
16534 : 11448 : && (!sym->components->ts.u.derived->attr.extension
16535 : 2318 : || c != CLASS_DATA (sym->components)))
16536 : 381443 : || (!sym->attr.is_class
16537 : 380147 : && (!sym->attr.extension || c != sym->components)))
16538 : 383855 : && !sym->attr.vtype
16539 : 537802 : && !resolve_typespec_used (&c->ts, &c->loc, c->name))
16540 : : return false;
16541 : :
16542 : 391594 : super_type = gfc_get_derived_super_type (sym);
16543 : :
16544 : : /* If this type is an extension, set the accessibility of the parent
16545 : : component. */
16546 : 391594 : if (super_type
16547 : 23969 : && ((sym->attr.is_class
16548 : 11448 : && c == CLASS_DATA (sym->components))
16549 : 15991 : || (!sym->attr.is_class && c == sym->components))
16550 : 14422 : && strcmp (super_type->name, c->name) == 0)
16551 : 6314 : c->attr.access = super_type->attr.access;
16552 : :
16553 : : /* If this type is an extension, see if this component has the same name
16554 : : as an inherited type-bound procedure. */
16555 : 23969 : if (super_type && !sym->attr.is_class
16556 : 12521 : && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
16557 : : {
16558 : 1 : gfc_error ("Component %qs of %qs at %L has the same name as an"
16559 : : " inherited type-bound procedure",
16560 : : c->name, sym->name, &c->loc);
16561 : 1 : return false;
16562 : : }
16563 : :
16564 : 391593 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
16565 : 8895 : && !c->ts.deferred)
16566 : : {
16567 : 6840 : if (c->ts.u.cl->length == NULL
16568 : 6834 : || (!resolve_charlen(c->ts.u.cl))
16569 : 13673 : || !gfc_is_constant_expr (c->ts.u.cl->length))
16570 : : {
16571 : 9 : gfc_error ("Character length of component %qs needs to "
16572 : : "be a constant specification expression at %L",
16573 : : c->name,
16574 : 9 : c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
16575 : 9 : return false;
16576 : : }
16577 : :
16578 : 6831 : if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
16579 : : {
16580 : 2 : if (!c->ts.u.cl->length->error)
16581 : : {
16582 : 1 : gfc_error ("Character length expression of component %qs at %L "
16583 : : "must be of INTEGER type, found %s",
16584 : 1 : c->name, &c->ts.u.cl->length->where,
16585 : : gfc_basic_typename (c->ts.u.cl->length->ts.type));
16586 : 1 : c->ts.u.cl->length->error = 1;
16587 : : }
16588 : 2 : return false;
16589 : : }
16590 : : }
16591 : :
16592 : 391582 : if (c->ts.type == BT_CHARACTER && c->ts.deferred
16593 : 2099 : && !c->attr.pointer && !c->attr.allocatable)
16594 : : {
16595 : 1 : gfc_error ("Character component %qs of %qs at %L with deferred "
16596 : : "length must be a POINTER or ALLOCATABLE",
16597 : : c->name, sym->name, &c->loc);
16598 : 1 : return false;
16599 : : }
16600 : :
16601 : : /* Add the hidden deferred length field. */
16602 : 391581 : if (c->ts.type == BT_CHARACTER
16603 : 9204 : && (c->ts.deferred || c->attr.pdt_string)
16604 : 2234 : && !c->attr.function
16605 : 2190 : && !sym->attr.is_class)
16606 : : {
16607 : 2050 : char name[GFC_MAX_SYMBOL_LEN+9];
16608 : 2050 : gfc_component *strlen;
16609 : 2050 : sprintf (name, "_%s_length", c->name);
16610 : 2050 : strlen = gfc_find_component (sym, name, true, true, NULL);
16611 : 2050 : if (strlen == NULL)
16612 : : {
16613 : 428 : if (!gfc_add_component (sym, name, &strlen))
16614 : 0 : return false;
16615 : 428 : strlen->ts.type = BT_INTEGER;
16616 : 428 : strlen->ts.kind = gfc_charlen_int_kind;
16617 : 428 : strlen->attr.access = ACCESS_PRIVATE;
16618 : 428 : strlen->attr.artificial = 1;
16619 : : }
16620 : : }
16621 : :
16622 : 391581 : if (c->ts.type == BT_DERIVED
16623 : 62379 : && sym->component_access != ACCESS_PRIVATE
16624 : 61425 : && gfc_check_symbol_access (sym)
16625 : 120968 : && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
16626 : 60432 : && !c->ts.u.derived->attr.use_assoc
16627 : 24141 : && !gfc_check_symbol_access (c->ts.u.derived)
16628 : 391775 : && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
16629 : : "PRIVATE type and cannot be a component of "
16630 : : "%qs, which is PUBLIC at %L", c->name,
16631 : : sym->name, &sym->declared_at))
16632 : : return false;
16633 : :
16634 : 391580 : if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
16635 : : {
16636 : 2 : gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
16637 : : "type %s", c->name, &c->loc, sym->name);
16638 : 2 : return false;
16639 : : }
16640 : :
16641 : 391578 : if (sym->attr.sequence)
16642 : : {
16643 : 2511 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
16644 : : {
16645 : 0 : gfc_error ("Component %s of SEQUENCE type declared at %L does "
16646 : : "not have the SEQUENCE attribute",
16647 : : c->ts.u.derived->name, &sym->declared_at);
16648 : 0 : return false;
16649 : : }
16650 : : }
16651 : :
16652 : 391578 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
16653 : 0 : c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
16654 : 391578 : else if (c->ts.type == BT_CLASS && c->attr.class_ok
16655 : 7405 : && CLASS_DATA (c)->ts.u.derived->attr.generic)
16656 : 0 : CLASS_DATA (c)->ts.u.derived
16657 : 0 : = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
16658 : :
16659 : : /* If an allocatable component derived type is of the same type as
16660 : : the enclosing derived type, we need a vtable generating so that
16661 : : the __deallocate procedure is created. */
16662 : 391578 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
16663 : 69794 : && c->ts.u.derived == sym && c->attr.allocatable == 1)
16664 : 190 : gfc_find_vtab (&c->ts);
16665 : :
16666 : : /* Ensure that all the derived type components are put on the
16667 : : derived type list; even in formal namespaces, where derived type
16668 : : pointer components might not have been declared. */
16669 : 391578 : if (c->ts.type == BT_DERIVED
16670 : 62378 : && c->ts.u.derived
16671 : 62378 : && c->ts.u.derived->components
16672 : 59252 : && c->attr.pointer
16673 : 45834 : && sym != c->ts.u.derived)
16674 : 5194 : add_dt_to_dt_list (c->ts.u.derived);
16675 : :
16676 : 391578 : if (c->as && c->as->type != AS_DEFERRED
16677 : 5554 : && (c->attr.pointer || c->attr.allocatable))
16678 : : return false;
16679 : :
16680 : 391564 : if (!gfc_resolve_array_spec (c->as,
16681 : 391564 : !(c->attr.pointer || c->attr.proc_pointer
16682 : : || c->attr.allocatable)))
16683 : : return false;
16684 : :
16685 : 141010 : if (c->initializer && !sym->attr.vtype
16686 : 27377 : && !c->attr.pdt_kind && !c->attr.pdt_len
16687 : 417770 : && !gfc_check_assign_symbol (sym, c, c->initializer))
16688 : : return false;
16689 : :
16690 : : return true;
16691 : : }
16692 : :
16693 : :
16694 : : /* Be nice about the locus for a structure expression - show the locus of the
16695 : : first non-null sub-expression if we can. */
16696 : :
16697 : : static locus *
16698 : 4 : cons_where (gfc_expr *struct_expr)
16699 : : {
16700 : 4 : gfc_constructor *cons;
16701 : :
16702 : 4 : gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
16703 : :
16704 : 4 : cons = gfc_constructor_first (struct_expr->value.constructor);
16705 : 12 : for (; cons; cons = gfc_constructor_next (cons))
16706 : : {
16707 : 8 : if (cons->expr && cons->expr->expr_type != EXPR_NULL)
16708 : 4 : return &cons->expr->where;
16709 : : }
16710 : :
16711 : 0 : return &struct_expr->where;
16712 : : }
16713 : :
16714 : : /* Resolve the components of a structure type. Much less work than derived
16715 : : types. */
16716 : :
16717 : : static bool
16718 : 913 : resolve_fl_struct (gfc_symbol *sym)
16719 : : {
16720 : 913 : gfc_component *c;
16721 : 913 : gfc_expr *init = NULL;
16722 : 913 : bool success;
16723 : :
16724 : : /* Make sure UNIONs do not have overlapping initializers. */
16725 : 913 : if (sym->attr.flavor == FL_UNION)
16726 : : {
16727 : 498 : for (c = sym->components; c; c = c->next)
16728 : : {
16729 : 331 : if (init && c->initializer)
16730 : : {
16731 : 2 : gfc_error ("Conflicting initializers in union at %L and %L",
16732 : : cons_where (init), cons_where (c->initializer));
16733 : 2 : gfc_free_expr (c->initializer);
16734 : 2 : c->initializer = NULL;
16735 : : }
16736 : 291 : if (init == NULL)
16737 : 291 : init = c->initializer;
16738 : : }
16739 : : }
16740 : :
16741 : 913 : success = true;
16742 : 2830 : for (c = sym->components; c; c = c->next)
16743 : 1917 : if (!resolve_component (c, sym))
16744 : 0 : success = false;
16745 : :
16746 : 913 : if (!success)
16747 : : return false;
16748 : :
16749 : 913 : if (sym->components)
16750 : 862 : add_dt_to_dt_list (sym);
16751 : :
16752 : : return true;
16753 : : }
16754 : :
16755 : : /* Figure if the derived type is using itself directly in one of its components
16756 : : or through referencing other derived types. The information is required to
16757 : : generate the __deallocate and __final type bound procedures to ensure
16758 : : freeing larger hierarchies of derived types with allocatable objects. */
16759 : :
16760 : : static void
16761 : 125507 : resolve_cyclic_derived_type (gfc_symbol *derived)
16762 : : {
16763 : 125507 : hash_set<gfc_symbol *> seen, to_examin;
16764 : 125507 : gfc_component *c;
16765 : 125507 : seen.add (derived);
16766 : 125507 : to_examin.add (derived);
16767 : 421110 : while (!to_examin.is_empty ())
16768 : : {
16769 : 171988 : gfc_symbol *cand = *to_examin.begin ();
16770 : 171988 : to_examin.remove (cand);
16771 : 463319 : for (c = cand->components; c; c = c->next)
16772 : 293223 : if (c->ts.type == BT_DERIVED)
16773 : : {
16774 : 64812 : if (c->ts.u.derived == derived)
16775 : : {
16776 : 976 : derived->attr.recursive = 1;
16777 : 1892 : return;
16778 : : }
16779 : 63836 : else if (!seen.contains (c->ts.u.derived))
16780 : : {
16781 : 42257 : seen.add (c->ts.u.derived);
16782 : 42257 : to_examin.add (c->ts.u.derived);
16783 : : }
16784 : : }
16785 : 228411 : else if (c->ts.type == BT_CLASS)
16786 : : {
16787 : 8554 : if (!c->attr.class_ok)
16788 : 7 : continue;
16789 : 8547 : if (CLASS_DATA (c)->ts.u.derived == derived)
16790 : : {
16791 : 916 : derived->attr.recursive = 1;
16792 : 916 : return;
16793 : : }
16794 : 7631 : else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
16795 : : {
16796 : 4441 : seen.add (CLASS_DATA (c)->ts.u.derived);
16797 : 4441 : to_examin.add (CLASS_DATA (c)->ts.u.derived);
16798 : : }
16799 : : }
16800 : : }
16801 : 125507 : }
16802 : :
16803 : : /* Resolve the components of a derived type. This does not have to wait until
16804 : : resolution stage, but can be done as soon as the dt declaration has been
16805 : : parsed. */
16806 : :
16807 : : static bool
16808 : 169924 : resolve_fl_derived0 (gfc_symbol *sym)
16809 : : {
16810 : 169924 : gfc_symbol* super_type;
16811 : 169924 : gfc_component *c;
16812 : 169924 : gfc_formal_arglist *f;
16813 : 169924 : bool success;
16814 : :
16815 : 169924 : if (sym->attr.unlimited_polymorphic)
16816 : : return true;
16817 : :
16818 : 169924 : super_type = gfc_get_derived_super_type (sym);
16819 : :
16820 : : /* F2008, C432. */
16821 : 169924 : if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
16822 : : {
16823 : 2 : gfc_error ("As extending type %qs at %L has a coarray component, "
16824 : : "parent type %qs shall also have one", sym->name,
16825 : : &sym->declared_at, super_type->name);
16826 : 2 : return false;
16827 : : }
16828 : :
16829 : : /* Ensure the extended type gets resolved before we do. */
16830 : 16277 : if (super_type && !resolve_fl_derived0 (super_type))
16831 : : return false;
16832 : :
16833 : : /* An ABSTRACT type must be extensible. */
16834 : 169916 : if (sym->attr.abstract && !gfc_type_is_extensible (sym))
16835 : : {
16836 : 2 : gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
16837 : : sym->name, &sym->declared_at);
16838 : 2 : return false;
16839 : : }
16840 : :
16841 : : /* Resolving components below, may create vtabs for which the cyclic type
16842 : : information needs to be present. */
16843 : 169914 : if (!sym->attr.vtype)
16844 : 125507 : resolve_cyclic_derived_type (sym);
16845 : :
16846 : 169914 : c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
16847 : : : sym->components;
16848 : :
16849 : : success = true;
16850 : 650930 : for ( ; c != NULL; c = c->next)
16851 : 481016 : if (!resolve_component (c, sym))
16852 : 83 : success = false;
16853 : :
16854 : 169914 : if (!success)
16855 : : return false;
16856 : :
16857 : : /* Now add the caf token field, where needed. */
16858 : 169840 : if (flag_coarray != GFC_FCOARRAY_NONE
16859 : 3195 : && !sym->attr.is_class && !sym->attr.vtype)
16860 : : {
16861 : 4713 : for (c = sym->components; c; c = c->next)
16862 : 2925 : if (!c->attr.dimension && !c->attr.codimension
16863 : 2177 : && (c->attr.allocatable || c->attr.pointer))
16864 : : {
16865 : 612 : char name[GFC_MAX_SYMBOL_LEN+9];
16866 : 612 : gfc_component *token;
16867 : 612 : sprintf (name, "_caf_%s", c->name);
16868 : 612 : token = gfc_find_component (sym, name, true, true, NULL);
16869 : 612 : if (token == NULL)
16870 : : {
16871 : 134 : if (!gfc_add_component (sym, name, &token))
16872 : 0 : return false;
16873 : 134 : token->ts.type = BT_VOID;
16874 : 134 : token->ts.kind = gfc_default_integer_kind;
16875 : 134 : token->attr.access = ACCESS_PRIVATE;
16876 : 134 : token->attr.artificial = 1;
16877 : 134 : token->attr.caf_token = 1;
16878 : : }
16879 : 612 : c->caf_token = token;
16880 : : }
16881 : : }
16882 : :
16883 : 169840 : check_defined_assignments (sym);
16884 : :
16885 : 169840 : if (!sym->attr.defined_assign_comp && super_type)
16886 : 15453 : sym->attr.defined_assign_comp
16887 : 15453 : = super_type->attr.defined_assign_comp;
16888 : :
16889 : : /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
16890 : : all DEFERRED bindings are overridden. */
16891 : 16270 : if (super_type && super_type->attr.abstract && !sym->attr.abstract
16892 : 1345 : && !sym->attr.is_class
16893 : 2849 : && !ensure_not_abstract (sym, super_type))
16894 : : return false;
16895 : :
16896 : : /* Check that there is a component for every PDT parameter. */
16897 : 169835 : if (sym->attr.pdt_template)
16898 : : {
16899 : 970 : for (f = sym->formal; f; f = f->next)
16900 : : {
16901 : 642 : if (!f->sym)
16902 : 1 : continue;
16903 : 641 : c = gfc_find_component (sym, f->sym->name, true, true, NULL);
16904 : 641 : if (c == NULL)
16905 : : {
16906 : 9 : gfc_error ("Parameterized type %qs does not have a component "
16907 : : "corresponding to parameter %qs at %L", sym->name,
16908 : 9 : f->sym->name, &sym->declared_at);
16909 : 9 : break;
16910 : : }
16911 : : }
16912 : : }
16913 : :
16914 : : /* Add derived type to the derived type list. */
16915 : 169835 : add_dt_to_dt_list (sym);
16916 : :
16917 : 169835 : return true;
16918 : : }
16919 : :
16920 : : /* The following procedure does the full resolution of a derived type,
16921 : : including resolution of all type-bound procedures (if present). In contrast
16922 : : to 'resolve_fl_derived0' this can only be done after the module has been
16923 : : parsed completely. */
16924 : :
16925 : : static bool
16926 : 81266 : resolve_fl_derived (gfc_symbol *sym)
16927 : : {
16928 : 81266 : gfc_symbol *gen_dt = NULL;
16929 : :
16930 : 81266 : if (sym->attr.unlimited_polymorphic)
16931 : : return true;
16932 : :
16933 : 81266 : if (!sym->attr.is_class)
16934 : 69551 : gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
16935 : 53483 : if (gen_dt && gen_dt->generic && gen_dt->generic->next
16936 : 2157 : && (!gen_dt->generic->sym->attr.use_assoc
16937 : 2057 : || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
16938 : 81399 : && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
16939 : : "%qs at %L being the same name as derived "
16940 : : "type at %L", sym->name,
16941 : : gen_dt->generic->sym == sym
16942 : 11 : ? gen_dt->generic->next->sym->name
16943 : : : gen_dt->generic->sym->name,
16944 : : gen_dt->generic->sym == sym
16945 : 11 : ? &gen_dt->generic->next->sym->declared_at
16946 : : : &gen_dt->generic->sym->declared_at,
16947 : : &sym->declared_at))
16948 : : return false;
16949 : :
16950 : 81262 : if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
16951 : : {
16952 : 13 : gfc_error ("Derived type %qs at %L has not been declared",
16953 : : sym->name, &sym->declared_at);
16954 : 13 : return false;
16955 : : }
16956 : :
16957 : : /* Resolve the finalizer procedures. */
16958 : 81249 : if (!gfc_resolve_finalizers (sym, NULL))
16959 : : return false;
16960 : :
16961 : 81246 : if (sym->attr.is_class && sym->ts.u.derived == NULL)
16962 : : {
16963 : : /* Fix up incomplete CLASS symbols. */
16964 : 11715 : gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
16965 : 11715 : gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
16966 : :
16967 : : /* Nothing more to do for unlimited polymorphic entities. */
16968 : 11715 : if (data->ts.u.derived->attr.unlimited_polymorphic)
16969 : : {
16970 : 1883 : add_dt_to_dt_list (sym);
16971 : 1883 : return true;
16972 : : }
16973 : 9832 : else if (vptr->ts.u.derived == NULL)
16974 : : {
16975 : 5903 : gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
16976 : 5903 : gcc_assert (vtab);
16977 : 5903 : vptr->ts.u.derived = vtab->ts.u.derived;
16978 : 5903 : if (!resolve_fl_derived0 (vptr->ts.u.derived))
16979 : : return false;
16980 : : }
16981 : : }
16982 : :
16983 : 79363 : if (!resolve_fl_derived0 (sym))
16984 : : return false;
16985 : :
16986 : : /* Resolve the type-bound procedures. */
16987 : 79285 : if (!resolve_typebound_procedures (sym))
16988 : : return false;
16989 : :
16990 : : /* Generate module vtables subject to their accessibility and their not
16991 : : being vtables or pdt templates. If this is not done class declarations
16992 : : in external procedures wind up with their own version and so SELECT TYPE
16993 : : fails because the vptrs do not have the same address. */
16994 : 79244 : if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
16995 : 79183 : && (sym->ns->proc_name->attr.flavor == FL_MODULE
16996 : 58228 : || (sym->attr.recursive && sym->attr.alloc_comp))
16997 : 21059 : && sym->attr.access != ACCESS_PRIVATE
16998 : 21026 : && !(sym->attr.vtype || sym->attr.pdt_template))
16999 : : {
17000 : 17871 : gfc_symbol *vtab = gfc_find_derived_vtab (sym);
17001 : 17871 : gfc_set_sym_referenced (vtab);
17002 : : }
17003 : :
17004 : : return true;
17005 : : }
17006 : :
17007 : :
17008 : : static bool
17009 : 810 : resolve_fl_namelist (gfc_symbol *sym)
17010 : : {
17011 : 810 : gfc_namelist *nl;
17012 : 810 : gfc_symbol *nlsym;
17013 : :
17014 : 2902 : for (nl = sym->namelist; nl; nl = nl->next)
17015 : : {
17016 : : /* Check again, the check in match only works if NAMELIST comes
17017 : : after the decl. */
17018 : 2097 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
17019 : : {
17020 : 1 : gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
17021 : : "allowed", nl->sym->name, sym->name, &sym->declared_at);
17022 : 1 : return false;
17023 : : }
17024 : :
17025 : 652 : if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
17026 : 2104 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17027 : : "with assumed shape in namelist %qs at %L",
17028 : : nl->sym->name, sym->name, &sym->declared_at))
17029 : : return false;
17030 : :
17031 : 2095 : if (is_non_constant_shape_array (nl->sym)
17032 : 2145 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
17033 : : "with nonconstant shape in namelist %qs at %L",
17034 : 50 : nl->sym->name, sym->name, &sym->declared_at))
17035 : : return false;
17036 : :
17037 : 2094 : if (nl->sym->ts.type == BT_CHARACTER
17038 : 570 : && (nl->sym->ts.u.cl->length == NULL
17039 : 531 : || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
17040 : 2176 : && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
17041 : : "nonconstant character length in "
17042 : 82 : "namelist %qs at %L", nl->sym->name,
17043 : : sym->name, &sym->declared_at))
17044 : : return false;
17045 : :
17046 : : }
17047 : :
17048 : : /* Reject PRIVATE objects in a PUBLIC namelist. */
17049 : 805 : if (gfc_check_symbol_access (sym))
17050 : : {
17051 : 2883 : for (nl = sym->namelist; nl; nl = nl->next)
17052 : : {
17053 : 2091 : if (!nl->sym->attr.use_assoc
17054 : 3958 : && !is_sym_host_assoc (nl->sym, sym->ns)
17055 : 4048 : && !gfc_check_symbol_access (nl->sym))
17056 : : {
17057 : 2 : gfc_error ("NAMELIST object %qs was declared PRIVATE and "
17058 : : "cannot be member of PUBLIC namelist %qs at %L",
17059 : 2 : nl->sym->name, sym->name, &sym->declared_at);
17060 : 2 : return false;
17061 : : }
17062 : :
17063 : 2089 : if (nl->sym->ts.type == BT_DERIVED
17064 : 466 : && (nl->sym->ts.u.derived->attr.alloc_comp
17065 : 466 : || nl->sym->ts.u.derived->attr.pointer_comp))
17066 : : {
17067 : 5 : if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
17068 : : "namelist %qs at %L with ALLOCATABLE "
17069 : : "or POINTER components", nl->sym->name,
17070 : : sym->name, &sym->declared_at))
17071 : : return false;
17072 : : return true;
17073 : : }
17074 : :
17075 : : /* Types with private components that came here by USE-association. */
17076 : 2084 : if (nl->sym->ts.type == BT_DERIVED
17077 : 2084 : && derived_inaccessible (nl->sym->ts.u.derived))
17078 : : {
17079 : 6 : gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
17080 : : "components and cannot be member of namelist %qs at %L",
17081 : : nl->sym->name, sym->name, &sym->declared_at);
17082 : 6 : return false;
17083 : : }
17084 : :
17085 : : /* Types with private components that are defined in the same module. */
17086 : 2078 : if (nl->sym->ts.type == BT_DERIVED
17087 : 910 : && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
17088 : 2356 : && nl->sym->ts.u.derived->attr.private_comp)
17089 : : {
17090 : 0 : gfc_error ("NAMELIST object %qs has PRIVATE components and "
17091 : : "cannot be a member of PUBLIC namelist %qs at %L",
17092 : : nl->sym->name, sym->name, &sym->declared_at);
17093 : 0 : return false;
17094 : : }
17095 : : }
17096 : : }
17097 : :
17098 : :
17099 : : /* 14.1.2 A module or internal procedure represent local entities
17100 : : of the same type as a namelist member and so are not allowed. */
17101 : 2867 : for (nl = sym->namelist; nl; nl = nl->next)
17102 : : {
17103 : 2078 : if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
17104 : 1514 : continue;
17105 : :
17106 : 564 : if (nl->sym->attr.function && nl->sym == nl->sym->result)
17107 : 7 : if ((nl->sym == sym->ns->proc_name)
17108 : 1 : ||
17109 : 1 : (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
17110 : 6 : continue;
17111 : :
17112 : 558 : nlsym = NULL;
17113 : 558 : if (nl->sym->name)
17114 : 558 : gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
17115 : 558 : if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
17116 : : {
17117 : 3 : gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
17118 : : "attribute in %qs at %L", nlsym->name,
17119 : : &sym->declared_at);
17120 : 3 : return false;
17121 : : }
17122 : : }
17123 : :
17124 : : return true;
17125 : : }
17126 : :
17127 : :
17128 : : static bool
17129 : 363022 : resolve_fl_parameter (gfc_symbol *sym)
17130 : : {
17131 : : /* A parameter array's shape needs to be constant. */
17132 : 363022 : if (sym->as != NULL
17133 : 363022 : && (sym->as->type == AS_DEFERRED
17134 : 5923 : || is_non_constant_shape_array (sym)))
17135 : : {
17136 : 17 : gfc_error ("Parameter array %qs at %L cannot be automatic "
17137 : : "or of deferred shape", sym->name, &sym->declared_at);
17138 : 17 : return false;
17139 : : }
17140 : :
17141 : : /* Constraints on deferred type parameter. */
17142 : 363005 : if (!deferred_requirements (sym))
17143 : : return false;
17144 : :
17145 : : /* Make sure a parameter that has been implicitly typed still
17146 : : matches the implicit type, since PARAMETER statements can precede
17147 : : IMPLICIT statements. */
17148 : 363004 : if (sym->attr.implicit_type
17149 : 363004 : && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
17150 : : sym->ns)))
17151 : : {
17152 : 0 : gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
17153 : : "later IMPLICIT type", sym->name, &sym->declared_at);
17154 : 0 : return false;
17155 : : }
17156 : :
17157 : : /* Make sure the types of derived parameters are consistent. This
17158 : : type checking is deferred until resolution because the type may
17159 : : refer to a derived type from the host. */
17160 : 363004 : if (sym->ts.type == BT_DERIVED
17161 : 363004 : && !gfc_compare_types (&sym->ts, &sym->value->ts))
17162 : : {
17163 : 0 : gfc_error ("Incompatible derived type in PARAMETER at %L",
17164 : 0 : &sym->value->where);
17165 : 0 : return false;
17166 : : }
17167 : :
17168 : : /* F03:C509,C514. */
17169 : 363004 : if (sym->ts.type == BT_CLASS)
17170 : : {
17171 : 0 : gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
17172 : : sym->name, &sym->declared_at);
17173 : 0 : return false;
17174 : : }
17175 : :
17176 : : return true;
17177 : : }
17178 : :
17179 : :
17180 : : /* Called by resolve_symbol to check PDTs. */
17181 : :
17182 : : static void
17183 : 522 : resolve_pdt (gfc_symbol* sym)
17184 : : {
17185 : 522 : gfc_symbol *derived = NULL;
17186 : 522 : gfc_actual_arglist *param;
17187 : 522 : gfc_component *c;
17188 : 522 : bool const_len_exprs = true;
17189 : 522 : bool assumed_len_exprs = false;
17190 : 522 : symbol_attribute *attr;
17191 : :
17192 : 522 : if (sym->ts.type == BT_DERIVED)
17193 : : {
17194 : 462 : derived = sym->ts.u.derived;
17195 : 462 : attr = &(sym->attr);
17196 : : }
17197 : 60 : else if (sym->ts.type == BT_CLASS)
17198 : : {
17199 : 60 : derived = CLASS_DATA (sym)->ts.u.derived;
17200 : 60 : attr = &(CLASS_DATA (sym)->attr);
17201 : : }
17202 : : else
17203 : 0 : gcc_unreachable ();
17204 : :
17205 : 522 : gcc_assert (derived->attr.pdt_type);
17206 : :
17207 : 1383 : for (param = sym->param_list; param; param = param->next)
17208 : : {
17209 : 861 : c = gfc_find_component (derived, param->name, false, true, NULL);
17210 : 861 : gcc_assert (c);
17211 : 861 : if (c->attr.pdt_kind)
17212 : 386 : continue;
17213 : :
17214 : 292 : if (param->expr && !gfc_is_constant_expr (param->expr)
17215 : 502 : && c->attr.pdt_len)
17216 : : const_len_exprs = false;
17217 : 448 : else if (param->spec_type == SPEC_ASSUMED)
17218 : 142 : assumed_len_exprs = true;
17219 : :
17220 : 475 : if (param->spec_type == SPEC_DEFERRED && !attr->allocatable
17221 : 10 : && ((sym->ts.type == BT_DERIVED && !attr->pointer)
17222 : 8 : || (sym->ts.type == BT_CLASS && !attr->class_pointer)))
17223 : 3 : gfc_error ("Entity %qs at %L has a deferred LEN "
17224 : : "parameter %qs and requires either the POINTER "
17225 : : "or ALLOCATABLE attribute",
17226 : : sym->name, &sym->declared_at,
17227 : : param->name);
17228 : :
17229 : : }
17230 : :
17231 : 522 : if (!const_len_exprs
17232 : 27 : && (sym->ns->proc_name->attr.is_main_program
17233 : 26 : || sym->ns->proc_name->attr.flavor == FL_MODULE
17234 : 25 : || sym->attr.save != SAVE_NONE))
17235 : 2 : gfc_error ("The AUTOMATIC object %qs at %L must not have the "
17236 : : "SAVE attribute or be a variable declared in the "
17237 : : "main program, a module or a submodule(F08/C513)",
17238 : : sym->name, &sym->declared_at);
17239 : :
17240 : 522 : if (assumed_len_exprs && !(sym->attr.dummy
17241 : : || sym->attr.select_type_temporary || sym->attr.associate_var))
17242 : 1 : gfc_error ("The object %qs at %L with ASSUMED type parameters "
17243 : : "must be a dummy or a SELECT TYPE selector(F08/4.2)",
17244 : : sym->name, &sym->declared_at);
17245 : 522 : }
17246 : :
17247 : :
17248 : : /* Resolve the symbol's array spec. */
17249 : :
17250 : : static bool
17251 : 1608093 : resolve_symbol_array_spec (gfc_symbol *sym, int check_constant)
17252 : : {
17253 : 1608093 : gfc_namespace *orig_current_ns = gfc_current_ns;
17254 : 1608093 : gfc_current_ns = gfc_get_spec_ns (sym);
17255 : :
17256 : 1608093 : bool saved_specification_expr = specification_expr;
17257 : 1608093 : specification_expr = true;
17258 : :
17259 : 1608093 : bool result = gfc_resolve_array_spec (sym->as, check_constant);
17260 : :
17261 : 1608093 : specification_expr = saved_specification_expr;
17262 : 1608093 : gfc_current_ns = orig_current_ns;
17263 : :
17264 : 1608093 : return result;
17265 : : }
17266 : :
17267 : :
17268 : : /* Do anything necessary to resolve a symbol. Right now, we just
17269 : : assume that an otherwise unknown symbol is a variable. This sort
17270 : : of thing commonly happens for symbols in module. */
17271 : :
17272 : : static void
17273 : 1753907 : resolve_symbol (gfc_symbol *sym)
17274 : : {
17275 : 1753907 : int check_constant, mp_flag;
17276 : 1753907 : gfc_symtree *symtree;
17277 : 1753907 : gfc_symtree *this_symtree;
17278 : 1753907 : gfc_namespace *ns;
17279 : 1753907 : gfc_component *c;
17280 : 1753907 : symbol_attribute class_attr;
17281 : 1753907 : gfc_array_spec *as;
17282 : :
17283 : 1753907 : if (sym->resolve_symbol_called >= 1)
17284 : 176396 : return;
17285 : 1660572 : sym->resolve_symbol_called = 1;
17286 : :
17287 : : /* No symbol will ever have union type; only components can be unions.
17288 : : Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
17289 : : (just like derived type declaration symbols have flavor FL_DERIVED). */
17290 : 1660572 : gcc_assert (sym->ts.type != BT_UNION);
17291 : :
17292 : : /* Coarrayed polymorphic objects with allocatable or pointer components are
17293 : : yet unsupported for -fcoarray=lib. */
17294 : 1660572 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
17295 : 85 : && sym->ts.u.derived && CLASS_DATA (sym)
17296 : 85 : && CLASS_DATA (sym)->attr.codimension
17297 : 71 : && CLASS_DATA (sym)->ts.u.derived
17298 : 70 : && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
17299 : 70 : || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
17300 : : {
17301 : 6 : gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
17302 : : "type coarrays at %L are unsupported", &sym->declared_at);
17303 : 6 : return;
17304 : : }
17305 : :
17306 : 1660566 : if (sym->attr.artificial)
17307 : : return;
17308 : :
17309 : 1579984 : if (sym->attr.unlimited_polymorphic)
17310 : : return;
17311 : :
17312 : 1578642 : if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
17313 : : {
17314 : 4 : gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
17315 : : "the OpenMP DEPEND clause", &sym->declared_at);
17316 : 4 : return;
17317 : : }
17318 : :
17319 : 1578638 : if (sym->attr.flavor == FL_UNKNOWN
17320 : 1558257 : || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
17321 : 448903 : && !sym->attr.generic && !sym->attr.external
17322 : 173630 : && sym->attr.if_source == IFSRC_UNKNOWN
17323 : 78030 : && sym->ts.type == BT_UNKNOWN))
17324 : : {
17325 : :
17326 : : /* If we find that a flavorless symbol is an interface in one of the
17327 : : parent namespaces, find its symtree in this namespace, free the
17328 : : symbol and set the symtree to point to the interface symbol. */
17329 : 127810 : for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
17330 : : {
17331 : 38313 : symtree = gfc_find_symtree (ns->sym_root, sym->name);
17332 : 38313 : if (symtree && (symtree->n.sym->generic ||
17333 : 677 : (symtree->n.sym->attr.flavor == FL_PROCEDURE
17334 : 568 : && sym->ns->construct_entities)))
17335 : : {
17336 : 629 : this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
17337 : : sym->name);
17338 : 629 : if (this_symtree->n.sym == sym)
17339 : : {
17340 : 621 : symtree->n.sym->refs++;
17341 : 621 : gfc_release_symbol (sym);
17342 : 621 : this_symtree->n.sym = symtree->n.sym;
17343 : 621 : return;
17344 : : }
17345 : : }
17346 : : }
17347 : :
17348 : : /* Otherwise give it a flavor according to such attributes as
17349 : : it has. */
17350 : 89497 : if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
17351 : 20253 : && sym->attr.intrinsic == 0)
17352 : 20199 : sym->attr.flavor = FL_VARIABLE;
17353 : 69298 : else if (sym->attr.flavor == FL_UNKNOWN)
17354 : : {
17355 : 54 : sym->attr.flavor = FL_PROCEDURE;
17356 : 54 : if (sym->attr.dimension)
17357 : 0 : sym->attr.function = 1;
17358 : : }
17359 : : }
17360 : :
17361 : 1578017 : if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
17362 : 2289 : gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
17363 : :
17364 : 1402 : if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
17365 : 1579419 : && !resolve_procedure_interface (sym))
17366 : : return;
17367 : :
17368 : 1578006 : if (sym->attr.is_protected && !sym->attr.proc_pointer
17369 : 130 : && (sym->attr.procedure || sym->attr.external))
17370 : : {
17371 : 0 : if (sym->attr.external)
17372 : 0 : gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
17373 : : "at %L", &sym->declared_at);
17374 : : else
17375 : 0 : gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
17376 : : "at %L", &sym->declared_at);
17377 : :
17378 : 0 : return;
17379 : : }
17380 : :
17381 : 1578006 : if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
17382 : : return;
17383 : :
17384 : 1577236 : else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
17385 : 1577999 : && !resolve_fl_struct (sym))
17386 : : return;
17387 : :
17388 : : /* Symbols that are module procedures with results (functions) have
17389 : : the types and array specification copied for type checking in
17390 : : procedures that call them, as well as for saving to a module
17391 : : file. These symbols can't stand the scrutiny that their results
17392 : : can. */
17393 : 1577867 : mp_flag = (sym->result != NULL && sym->result != sym);
17394 : :
17395 : : /* Make sure that the intrinsic is consistent with its internal
17396 : : representation. This needs to be done before assigning a default
17397 : : type to avoid spurious warnings. */
17398 : 1545813 : if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
17399 : 1608421 : && !gfc_resolve_intrinsic (sym, &sym->declared_at))
17400 : : return;
17401 : :
17402 : : /* Resolve associate names. */
17403 : 1577838 : if (sym->assoc)
17404 : 6337 : resolve_assoc_var (sym, true);
17405 : :
17406 : : /* Assign default type to symbols that need one and don't have one. */
17407 : 1577838 : if (sym->ts.type == BT_UNKNOWN)
17408 : : {
17409 : 376328 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
17410 : : {
17411 : 11677 : gfc_set_default_type (sym, 1, NULL);
17412 : : }
17413 : :
17414 : 376328 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
17415 : 241890 : && !sym->attr.function && !sym->attr.subroutine
17416 : 377926 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
17417 : 563 : gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
17418 : :
17419 : 376328 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
17420 : : {
17421 : : /* The specific case of an external procedure should emit an error
17422 : : in the case that there is no implicit type. */
17423 : 97113 : if (!mp_flag)
17424 : : {
17425 : 91463 : if (!sym->attr.mixed_entry_master)
17426 : 91357 : gfc_set_default_type (sym, sym->attr.external, NULL);
17427 : : }
17428 : : else
17429 : : {
17430 : : /* Result may be in another namespace. */
17431 : 5650 : resolve_symbol (sym->result);
17432 : :
17433 : 5650 : if (!sym->result->attr.proc_pointer)
17434 : : {
17435 : 5485 : sym->ts = sym->result->ts;
17436 : 5485 : sym->as = gfc_copy_array_spec (sym->result->as);
17437 : 5485 : sym->attr.dimension = sym->result->attr.dimension;
17438 : 5485 : sym->attr.codimension = sym->result->attr.codimension;
17439 : 5485 : sym->attr.pointer = sym->result->attr.pointer;
17440 : 5485 : sym->attr.allocatable = sym->result->attr.allocatable;
17441 : 5485 : sym->attr.contiguous = sym->result->attr.contiguous;
17442 : : }
17443 : : }
17444 : : }
17445 : : }
17446 : 1201510 : else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
17447 : 30579 : resolve_symbol_array_spec (sym->result, false);
17448 : :
17449 : : /* For a CLASS-valued function with a result variable, affirm that it has
17450 : : been resolved also when looking at the symbol 'sym'. */
17451 : 406907 : if (mp_flag && sym->ts.type == BT_CLASS && sym->result->attr.class_ok)
17452 : 687 : sym->attr.class_ok = sym->result->attr.class_ok;
17453 : :
17454 : 1577838 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived
17455 : 18207 : && CLASS_DATA (sym))
17456 : : {
17457 : 18206 : as = CLASS_DATA (sym)->as;
17458 : 18206 : class_attr = CLASS_DATA (sym)->attr;
17459 : 18206 : class_attr.pointer = class_attr.class_pointer;
17460 : : }
17461 : : else
17462 : : {
17463 : 1559632 : class_attr = sym->attr;
17464 : 1559632 : as = sym->as;
17465 : : }
17466 : :
17467 : : /* F2008, C530. */
17468 : 1577838 : if (sym->attr.contiguous
17469 : 6852 : && (!class_attr.dimension
17470 : 6849 : || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
17471 : 123 : && !class_attr.pointer)))
17472 : : {
17473 : 7 : gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
17474 : : "array pointer or an assumed-shape or assumed-rank array",
17475 : : sym->name, &sym->declared_at);
17476 : 7 : return;
17477 : : }
17478 : :
17479 : : /* Assumed size arrays and assumed shape arrays must be dummy
17480 : : arguments. Array-spec's of implied-shape should have been resolved to
17481 : : AS_EXPLICIT already. */
17482 : :
17483 : 1571105 : if (as)
17484 : : {
17485 : : /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
17486 : : specification expression. */
17487 : 136404 : if (as->type == AS_IMPLIED_SHAPE)
17488 : : {
17489 : : int i;
17490 : 1 : for (i=0; i<as->rank; i++)
17491 : : {
17492 : 1 : if (as->lower[i] != NULL && as->upper[i] == NULL)
17493 : : {
17494 : 1 : gfc_error ("Bad specification for assumed size array at %L",
17495 : : &as->lower[i]->where);
17496 : 1 : return;
17497 : : }
17498 : : }
17499 : 0 : gcc_unreachable();
17500 : : }
17501 : :
17502 : 136403 : if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
17503 : 106942 : || as->type == AS_ASSUMED_SHAPE)
17504 : 40676 : && !sym->attr.dummy && !sym->attr.select_type_temporary
17505 : 59 : && !sym->attr.associate_var)
17506 : : {
17507 : 7 : if (as->type == AS_ASSUMED_SIZE)
17508 : 7 : gfc_error ("Assumed size array at %L must be a dummy argument",
17509 : : &sym->declared_at);
17510 : : else
17511 : 0 : gfc_error ("Assumed shape array at %L must be a dummy argument",
17512 : : &sym->declared_at);
17513 : 7 : return;
17514 : : }
17515 : : /* TS 29113, C535a. */
17516 : 136396 : if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
17517 : 60 : && !sym->attr.select_type_temporary
17518 : 60 : && !(cs_base && cs_base->current
17519 : 45 : && (cs_base->current->op == EXEC_SELECT_RANK
17520 : 3 : || ((gfc_option.allow_std & GFC_STD_F202Y)
17521 : 0 : && cs_base->current->op == EXEC_BLOCK))))
17522 : : {
17523 : 18 : gfc_error ("Assumed-rank array at %L must be a dummy argument",
17524 : : &sym->declared_at);
17525 : 18 : return;
17526 : : }
17527 : 136378 : if (as->type == AS_ASSUMED_RANK
17528 : 23209 : && (sym->attr.codimension || sym->attr.value))
17529 : : {
17530 : 2 : gfc_error ("Assumed-rank array at %L may not have the VALUE or "
17531 : : "CODIMENSION attribute", &sym->declared_at);
17532 : 2 : return;
17533 : : }
17534 : : }
17535 : :
17536 : : /* Make sure symbols with known intent or optional are really dummy
17537 : : variable. Because of ENTRY statement, this has to be deferred
17538 : : until resolution time. */
17539 : :
17540 : 1577803 : if (!sym->attr.dummy
17541 : 1145684 : && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
17542 : : {
17543 : 2 : gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
17544 : 2 : return;
17545 : : }
17546 : :
17547 : 1577801 : if (sym->attr.value && !sym->attr.dummy)
17548 : : {
17549 : 2 : gfc_error ("%qs at %L cannot have the VALUE attribute because "
17550 : : "it is not a dummy argument", sym->name, &sym->declared_at);
17551 : 2 : return;
17552 : : }
17553 : :
17554 : 1577799 : if (sym->attr.value && sym->ts.type == BT_CHARACTER)
17555 : : {
17556 : 546 : gfc_charlen *cl = sym->ts.u.cl;
17557 : 546 : if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
17558 : : {
17559 : 2 : gfc_error ("Character dummy variable %qs at %L with VALUE "
17560 : : "attribute must have constant length",
17561 : : sym->name, &sym->declared_at);
17562 : 2 : return;
17563 : : }
17564 : :
17565 : 544 : if (sym->ts.is_c_interop
17566 : 376 : && mpz_cmp_si (cl->length->value.integer, 1) != 0)
17567 : : {
17568 : 1 : gfc_error ("C interoperable character dummy variable %qs at %L "
17569 : : "with VALUE attribute must have length one",
17570 : : sym->name, &sym->declared_at);
17571 : 1 : return;
17572 : : }
17573 : : }
17574 : :
17575 : 1577796 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
17576 : 123554 : && sym->ts.u.derived->attr.generic)
17577 : : {
17578 : 20 : sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
17579 : 20 : if (!sym->ts.u.derived)
17580 : : {
17581 : 0 : gfc_error ("The derived type %qs at %L is of type %qs, "
17582 : : "which has not been defined", sym->name,
17583 : : &sym->declared_at, sym->ts.u.derived->name);
17584 : 0 : sym->ts.type = BT_UNKNOWN;
17585 : 0 : return;
17586 : : }
17587 : : }
17588 : :
17589 : : /* Use the same constraints as TYPE(*), except for the type check
17590 : : and that only scalars and assumed-size arrays are permitted. */
17591 : 1577796 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
17592 : : {
17593 : 11264 : if (!sym->attr.dummy)
17594 : : {
17595 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
17596 : : "a dummy argument", sym->name, &sym->declared_at);
17597 : 1 : return;
17598 : : }
17599 : :
17600 : 11263 : if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
17601 : 8 : && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
17602 : 0 : && sym->ts.type != BT_COMPLEX)
17603 : : {
17604 : 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
17605 : : "of type TYPE(*) or of an numeric intrinsic type",
17606 : : sym->name, &sym->declared_at);
17607 : 0 : return;
17608 : : }
17609 : :
17610 : 11263 : if (sym->attr.allocatable || sym->attr.codimension
17611 : 11263 : || sym->attr.pointer || sym->attr.value)
17612 : : {
17613 : 4 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
17614 : : "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
17615 : : "attribute", sym->name, &sym->declared_at);
17616 : 4 : return;
17617 : : }
17618 : :
17619 : 11259 : if (sym->attr.intent == INTENT_OUT)
17620 : : {
17621 : 0 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
17622 : : "have the INTENT(OUT) attribute",
17623 : : sym->name, &sym->declared_at);
17624 : 0 : return;
17625 : : }
17626 : 11259 : if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
17627 : : {
17628 : 1 : gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
17629 : : "either be a scalar or an assumed-size array",
17630 : : sym->name, &sym->declared_at);
17631 : 1 : return;
17632 : : }
17633 : :
17634 : : /* Set the type to TYPE(*) and add a dimension(*) to ensure
17635 : : NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
17636 : : packing. */
17637 : 11258 : sym->ts.type = BT_ASSUMED;
17638 : 11258 : sym->as = gfc_get_array_spec ();
17639 : 11258 : sym->as->type = AS_ASSUMED_SIZE;
17640 : 11258 : sym->as->rank = 1;
17641 : 11258 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
17642 : : }
17643 : 1566532 : else if (sym->ts.type == BT_ASSUMED)
17644 : : {
17645 : : /* TS 29113, C407a. */
17646 : 8178 : if (!sym->attr.dummy)
17647 : : {
17648 : 7 : gfc_error ("Assumed type of variable %s at %L is only permitted "
17649 : : "for dummy variables", sym->name, &sym->declared_at);
17650 : 7 : return;
17651 : : }
17652 : 8171 : if (sym->attr.allocatable || sym->attr.codimension
17653 : 8171 : || sym->attr.pointer || sym->attr.value)
17654 : : {
17655 : 8 : gfc_error ("Assumed-type variable %s at %L may not have the "
17656 : : "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
17657 : : sym->name, &sym->declared_at);
17658 : 8 : return;
17659 : : }
17660 : 8163 : if (sym->attr.intent == INTENT_OUT)
17661 : : {
17662 : 2 : gfc_error ("Assumed-type variable %s at %L may not have the "
17663 : : "INTENT(OUT) attribute",
17664 : : sym->name, &sym->declared_at);
17665 : 2 : return;
17666 : : }
17667 : 8161 : if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
17668 : : {
17669 : 3 : gfc_error ("Assumed-type variable %s at %L shall not be an "
17670 : : "explicit-shape array", sym->name, &sym->declared_at);
17671 : 3 : return;
17672 : : }
17673 : : }
17674 : :
17675 : : /* If the symbol is marked as bind(c), that it is declared at module level
17676 : : scope and verify its type and kind. Do not do the latter for symbols
17677 : : that are implicitly typed because that is handled in
17678 : : gfc_set_default_type. Handle dummy arguments and procedure definitions
17679 : : separately. Also, anything that is use associated is not handled here
17680 : : but instead is handled in the module it is declared in. Finally, derived
17681 : : type definitions are allowed to be BIND(C) since that only implies that
17682 : : they're interoperable, and they are checked fully for interoperability
17683 : : when a variable is declared of that type. */
17684 : 1577770 : if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
17685 : 1577770 : && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
17686 : 560 : && sym->attr.flavor != FL_DERIVED)
17687 : : {
17688 : 167 : bool t = true;
17689 : :
17690 : : /* First, make sure the variable is declared at the
17691 : : module-level scope (J3/04-007, Section 15.3). */
17692 : 167 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE)
17693 : 7 : && !sym->attr.in_common)
17694 : : {
17695 : 6 : gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
17696 : : "is neither a COMMON block nor declared at the "
17697 : : "module level scope", sym->name, &(sym->declared_at));
17698 : 6 : t = false;
17699 : : }
17700 : 161 : else if (sym->ts.type == BT_CHARACTER
17701 : 161 : && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
17702 : 1 : || !gfc_is_constant_expr (sym->ts.u.cl->length)
17703 : 1 : || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
17704 : : {
17705 : 1 : gfc_error ("BIND(C) Variable %qs at %L must have length one",
17706 : 1 : sym->name, &sym->declared_at);
17707 : 1 : t = false;
17708 : : }
17709 : 160 : else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
17710 : : {
17711 : 1 : t = verify_com_block_vars_c_interop (sym->common_head);
17712 : : }
17713 : 159 : else if (sym->attr.implicit_type == 0)
17714 : : {
17715 : : /* If type() declaration, we need to verify that the components
17716 : : of the given type are all C interoperable, etc. */
17717 : 157 : if (sym->ts.type == BT_DERIVED &&
17718 : 24 : sym->ts.u.derived->attr.is_c_interop != 1)
17719 : : {
17720 : : /* Make sure the user marked the derived type as BIND(C). If
17721 : : not, call the verify routine. This could print an error
17722 : : for the derived type more than once if multiple variables
17723 : : of that type are declared. */
17724 : 14 : if (sym->ts.u.derived->attr.is_bind_c != 1)
17725 : 1 : verify_bind_c_derived_type (sym->ts.u.derived);
17726 : 157 : t = false;
17727 : : }
17728 : :
17729 : : /* Verify the variable itself as C interoperable if it
17730 : : is BIND(C). It is not possible for this to succeed if
17731 : : the verify_bind_c_derived_type failed, so don't have to handle
17732 : : any error returned by verify_bind_c_derived_type. */
17733 : 157 : t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
17734 : : sym->common_block);
17735 : : }
17736 : :
17737 : 165 : if (!t)
17738 : : {
17739 : : /* clear the is_bind_c flag to prevent reporting errors more than
17740 : : once if something failed. */
17741 : 10 : sym->attr.is_bind_c = 0;
17742 : 10 : return;
17743 : : }
17744 : : }
17745 : :
17746 : : /* If a derived type symbol has reached this point, without its
17747 : : type being declared, we have an error. Notice that most
17748 : : conditions that produce undefined derived types have already
17749 : : been dealt with. However, the likes of:
17750 : : implicit type(t) (t) ..... call foo (t) will get us here if
17751 : : the type is not declared in the scope of the implicit
17752 : : statement. Change the type to BT_UNKNOWN, both because it is so
17753 : : and to prevent an ICE. */
17754 : 1577760 : if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
17755 : 123552 : && sym->ts.u.derived->components == NULL
17756 : 1016 : && !sym->ts.u.derived->attr.zero_comp)
17757 : : {
17758 : 3 : gfc_error ("The derived type %qs at %L is of type %qs, "
17759 : : "which has not been defined", sym->name,
17760 : : &sym->declared_at, sym->ts.u.derived->name);
17761 : 3 : sym->ts.type = BT_UNKNOWN;
17762 : 3 : return;
17763 : : }
17764 : :
17765 : : /* Make sure that the derived type has been resolved and that the
17766 : : derived type is visible in the symbol's namespace, if it is a
17767 : : module function and is not PRIVATE. */
17768 : 1577757 : if (sym->ts.type == BT_DERIVED
17769 : 130261 : && sym->ts.u.derived->attr.use_assoc
17770 : 113997 : && sym->ns->proc_name
17771 : 113986 : && sym->ns->proc_name->attr.flavor == FL_MODULE
17772 : 1584595 : && !resolve_fl_derived (sym->ts.u.derived))
17773 : : return;
17774 : :
17775 : : /* Unless the derived-type declaration is use associated, Fortran 95
17776 : : does not allow public entries of private derived types.
17777 : : See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
17778 : : 161 in 95-006r3. */
17779 : 1577757 : if (sym->ts.type == BT_DERIVED
17780 : 130261 : && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
17781 : 8809 : && !sym->ts.u.derived->attr.use_assoc
17782 : 1971 : && gfc_check_symbol_access (sym)
17783 : 1798 : && !gfc_check_symbol_access (sym->ts.u.derived)
17784 : 1577768 : && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
17785 : : "derived type %qs",
17786 : 11 : (sym->attr.flavor == FL_PARAMETER)
17787 : : ? "parameter" : "variable",
17788 : : sym->name, &sym->declared_at,
17789 : 11 : sym->ts.u.derived->name))
17790 : : return;
17791 : :
17792 : : /* F2008, C1302. */
17793 : 1577750 : if (sym->ts.type == BT_DERIVED
17794 : 130254 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
17795 : 130254 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
17796 : 130230 : || sym->ts.u.derived->attr.lock_comp)
17797 : 37 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
17798 : : {
17799 : 4 : gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
17800 : : "type LOCK_TYPE must be a coarray", sym->name,
17801 : : &sym->declared_at);
17802 : 4 : return;
17803 : : }
17804 : :
17805 : : /* TS18508, C702/C703. */
17806 : 1577746 : if (sym->ts.type == BT_DERIVED
17807 : 130250 : && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
17808 : 130250 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
17809 : 130240 : || sym->ts.u.derived->attr.event_comp)
17810 : 10 : && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
17811 : : {
17812 : 1 : gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
17813 : : "type EVENT_TYPE must be a coarray", sym->name,
17814 : : &sym->declared_at);
17815 : 1 : return;
17816 : : }
17817 : :
17818 : : /* An assumed-size array with INTENT(OUT) shall not be of a type for which
17819 : : default initialization is defined (5.1.2.4.4). */
17820 : 1577745 : if (sym->ts.type == BT_DERIVED
17821 : 130249 : && sym->attr.dummy
17822 : 39560 : && sym->attr.intent == INTENT_OUT
17823 : 2316 : && sym->as
17824 : 381 : && sym->as->type == AS_ASSUMED_SIZE)
17825 : : {
17826 : 1 : for (c = sym->ts.u.derived->components; c; c = c->next)
17827 : : {
17828 : 1 : if (c->initializer)
17829 : : {
17830 : 1 : gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
17831 : : "ASSUMED SIZE and so cannot have a default initializer",
17832 : : sym->name, &sym->declared_at);
17833 : 1 : return;
17834 : : }
17835 : : }
17836 : : }
17837 : :
17838 : : /* F2008, C542. */
17839 : 1577744 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
17840 : 39559 : && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
17841 : : {
17842 : 0 : gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
17843 : : "INTENT(OUT)", sym->name, &sym->declared_at);
17844 : 0 : return;
17845 : : }
17846 : :
17847 : : /* TS18508. */
17848 : 1577744 : if (sym->ts.type == BT_DERIVED && sym->attr.dummy
17849 : 39559 : && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
17850 : : {
17851 : 0 : gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
17852 : : "INTENT(OUT)", sym->name, &sym->declared_at);
17853 : 0 : return;
17854 : : }
17855 : :
17856 : : /* F2008, C525. */
17857 : 1577744 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
17858 : 1577659 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
17859 : 18210 : && sym->ts.u.derived && CLASS_DATA (sym)
17860 : 18204 : && CLASS_DATA (sym)->attr.coarray_comp))
17861 : 1577659 : || class_attr.codimension)
17862 : 1478 : && (sym->attr.result || sym->result == sym))
17863 : : {
17864 : 8 : gfc_error ("Function result %qs at %L shall not be a coarray or have "
17865 : : "a coarray component", sym->name, &sym->declared_at);
17866 : 8 : return;
17867 : : }
17868 : :
17869 : : /* F2008, C524. */
17870 : 1577736 : if (sym->attr.codimension && sym->ts.type == BT_DERIVED
17871 : 367 : && sym->ts.u.derived->ts.is_iso_c)
17872 : : {
17873 : 3 : gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
17874 : : "shall not be a coarray", sym->name, &sym->declared_at);
17875 : 3 : return;
17876 : : }
17877 : :
17878 : : /* F2008, C525. */
17879 : 1577733 : if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
17880 : 1577651 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
17881 : 18209 : && sym->ts.u.derived && CLASS_DATA (sym)
17882 : 18203 : && CLASS_DATA (sym)->attr.coarray_comp))
17883 : 82 : && (class_attr.codimension || class_attr.pointer || class_attr.dimension
17884 : 82 : || class_attr.allocatable))
17885 : : {
17886 : 4 : gfc_error ("Variable %qs at %L with coarray component shall be a "
17887 : : "nonpointer, nonallocatable scalar, which is not a coarray",
17888 : : sym->name, &sym->declared_at);
17889 : 4 : return;
17890 : : }
17891 : :
17892 : : /* F2008, C526. The function-result case was handled above. */
17893 : 1577729 : if (class_attr.codimension
17894 : 1390 : && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
17895 : : || sym->attr.select_type_temporary
17896 : 270 : || sym->attr.associate_var
17897 : 188 : || (sym->ns->save_all && !sym->attr.automatic)
17898 : 188 : || sym->ns->proc_name->attr.flavor == FL_MODULE
17899 : 188 : || sym->ns->proc_name->attr.is_main_program
17900 : : || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
17901 : : {
17902 : 4 : gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
17903 : : "nor a dummy argument", sym->name, &sym->declared_at);
17904 : 4 : return;
17905 : : }
17906 : : /* F2008, C528. */
17907 : 1577725 : else if (class_attr.codimension && !sym->attr.select_type_temporary
17908 : 1310 : && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
17909 : : {
17910 : 6 : gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
17911 : : "deferred shape without allocatable", sym->name,
17912 : : &sym->declared_at);
17913 : 6 : return;
17914 : : }
17915 : 1577719 : else if (class_attr.codimension && class_attr.allocatable && as
17916 : 499 : && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
17917 : : {
17918 : 9 : gfc_error ("Allocatable coarray variable %qs at %L must have "
17919 : : "deferred shape", sym->name, &sym->declared_at);
17920 : 9 : return;
17921 : : }
17922 : :
17923 : : /* F2008, C541. */
17924 : 1577710 : if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
17925 : 1577632 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
17926 : 18204 : && sym->ts.u.derived && CLASS_DATA (sym)
17927 : 18198 : && CLASS_DATA (sym)->attr.coarray_comp))
17928 : 1577632 : || (class_attr.codimension && class_attr.allocatable))
17929 : 568 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
17930 : : {
17931 : 3 : gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
17932 : : "allocatable coarray or have coarray components",
17933 : : sym->name, &sym->declared_at);
17934 : 3 : return;
17935 : : }
17936 : :
17937 : 1577707 : if (class_attr.codimension && sym->attr.dummy
17938 : 417 : && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
17939 : : {
17940 : 2 : gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
17941 : : "procedure %qs", sym->name, &sym->declared_at,
17942 : : sym->ns->proc_name->name);
17943 : 2 : return;
17944 : : }
17945 : :
17946 : 1577705 : if (sym->ts.type == BT_LOGICAL
17947 : 109168 : && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
17948 : 109165 : || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
17949 : 30343 : && sym->ns->proc_name->attr.is_bind_c)))
17950 : : {
17951 : : int i;
17952 : 200 : for (i = 0; gfc_logical_kinds[i].kind; i++)
17953 : 200 : if (gfc_logical_kinds[i].kind == sym->ts.kind)
17954 : : break;
17955 : 16 : if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
17956 : 181 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
17957 : : "%L with non-C_Bool kind in BIND(C) procedure "
17958 : : "%qs", sym->name, &sym->declared_at,
17959 : 13 : sym->ns->proc_name->name))
17960 : : return;
17961 : 167 : else if (!gfc_logical_kinds[i].c_bool
17962 : 182 : && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
17963 : : "%qs at %L with non-C_Bool kind in "
17964 : : "BIND(C) procedure %qs", sym->name,
17965 : : &sym->declared_at,
17966 : 15 : sym->attr.function ? sym->name
17967 : 13 : : sym->ns->proc_name->name))
17968 : : return;
17969 : : }
17970 : :
17971 : 1577702 : switch (sym->attr.flavor)
17972 : : {
17973 : 621134 : case FL_VARIABLE:
17974 : 621134 : if (!resolve_fl_variable (sym, mp_flag))
17975 : : return;
17976 : : break;
17977 : :
17978 : 448410 : case FL_PROCEDURE:
17979 : 448410 : if (sym->formal && !sym->formal_ns)
17980 : : {
17981 : : /* Check that none of the arguments are a namelist. */
17982 : : gfc_formal_arglist *formal = sym->formal;
17983 : :
17984 : 102092 : for (; formal; formal = formal->next)
17985 : 69526 : if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
17986 : : {
17987 : 1 : gfc_error ("Namelist %qs cannot be an argument to "
17988 : : "subroutine or function at %L",
17989 : : formal->sym->name, &sym->declared_at);
17990 : 1 : return;
17991 : : }
17992 : : }
17993 : :
17994 : 448409 : if (!resolve_fl_procedure (sym, mp_flag))
17995 : : return;
17996 : : break;
17997 : :
17998 : 810 : case FL_NAMELIST:
17999 : 810 : if (!resolve_fl_namelist (sym))
18000 : : return;
18001 : : break;
18002 : :
18003 : 363022 : case FL_PARAMETER:
18004 : 363022 : if (!resolve_fl_parameter (sym))
18005 : : return;
18006 : : break;
18007 : :
18008 : : default:
18009 : : break;
18010 : : }
18011 : :
18012 : : /* Resolve array specifier. Check as well some constraints
18013 : : on COMMON blocks. */
18014 : :
18015 : 1577514 : check_constant = sym->attr.in_common && !sym->attr.pointer && !sym->error;
18016 : :
18017 : 1577514 : resolve_symbol_array_spec (sym, check_constant);
18018 : :
18019 : : /* Resolve formal namespaces. */
18020 : 1577514 : if (sym->formal_ns && sym->formal_ns != gfc_current_ns
18021 : 242767 : && !sym->attr.contained && !sym->attr.intrinsic)
18022 : 219321 : gfc_resolve (sym->formal_ns);
18023 : :
18024 : : /* Make sure the formal namespace is present. */
18025 : 1577514 : if (sym->formal && !sym->formal_ns)
18026 : : {
18027 : : gfc_formal_arglist *formal = sym->formal;
18028 : 32767 : while (formal && !formal->sym)
18029 : 11 : formal = formal->next;
18030 : :
18031 : 32756 : if (formal)
18032 : : {
18033 : 32745 : sym->formal_ns = formal->sym->ns;
18034 : 32745 : if (sym->formal_ns && sym->ns != formal->sym->ns)
18035 : 24344 : sym->formal_ns->refs++;
18036 : : }
18037 : : }
18038 : :
18039 : : /* Check threadprivate restrictions. */
18040 : 1577514 : if (sym->attr.threadprivate
18041 : 1577514 : && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
18042 : 32 : && !(sym->ns->save_all && !sym->attr.automatic)
18043 : 31 : && sym->module == NULL
18044 : 16 : && (sym->ns->proc_name == NULL
18045 : 16 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18046 : 3 : && !sym->ns->proc_name->attr.is_main_program)))
18047 : 1 : gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
18048 : :
18049 : : /* Check omp declare target restrictions. */
18050 : 1577514 : if (sym->attr.omp_declare_target
18051 : 1577514 : && sym->attr.flavor == FL_VARIABLE
18052 : 629 : && !sym->attr.save
18053 : 195 : && !(sym->ns->save_all && !sym->attr.automatic)
18054 : 195 : && (!sym->attr.in_common
18055 : 182 : && sym->module == NULL
18056 : 92 : && (sym->ns->proc_name == NULL
18057 : 92 : || (sym->ns->proc_name->attr.flavor != FL_MODULE
18058 : 2 : && !sym->ns->proc_name->attr.is_main_program))))
18059 : 1 : gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
18060 : : sym->name, &sym->declared_at);
18061 : :
18062 : : /* If we have come this far we can apply default-initializers, as
18063 : : described in 14.7.5, to those variables that have not already
18064 : : been assigned one. */
18065 : 1577514 : if (sym->ts.type == BT_DERIVED
18066 : 130222 : && !sym->value
18067 : 92449 : && !sym->attr.allocatable
18068 : 89789 : && !sym->attr.alloc_comp)
18069 : : {
18070 : 89789 : symbol_attribute *a = &sym->attr;
18071 : :
18072 : 89789 : if ((!a->save && !a->dummy && !a->pointer
18073 : 89789 : && !a->in_common && !a->use_assoc
18074 : 9091 : && a->referenced
18075 : 7193 : && !((a->function || a->result)
18076 : 1319 : && (!a->dimension
18077 : 120 : || sym->ts.u.derived->attr.alloc_comp
18078 : 120 : || sym->ts.u.derived->attr.pointer_comp))
18079 : 5943 : && !(a->function && sym != sym->result))
18080 : 83866 : || (a->dummy && !a->pointer && a->intent == INTENT_OUT
18081 : 1496 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
18082 : 7328 : apply_default_init (sym);
18083 : 82461 : else if (a->function && sym->result && a->access != ACCESS_PRIVATE
18084 : 11746 : && (sym->ts.u.derived->attr.alloc_comp
18085 : 11746 : || sym->ts.u.derived->attr.pointer_comp))
18086 : : /* Mark the result symbol to be referenced, when it has allocatable
18087 : : components. */
18088 : 777 : sym->result->attr.referenced = 1;
18089 : 81684 : else if (a->function && !a->pointer && !a->allocatable && sym->result)
18090 : : /* Default initialization for function results. */
18091 : 10833 : apply_default_init (sym->result);
18092 : : }
18093 : :
18094 : 1577514 : if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
18095 : 17754 : && sym->attr.dummy && sym->attr.intent == INTENT_OUT
18096 : 1177 : && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
18097 : 1102 : && !CLASS_DATA (sym)->attr.class_pointer
18098 : 1102 : && !CLASS_DATA (sym)->attr.allocatable)
18099 : 804 : apply_default_init (sym);
18100 : :
18101 : : /* If this symbol has a type-spec, check it. */
18102 : 1577514 : if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
18103 : 593465 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
18104 : 1287627 : if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
18105 : : return;
18106 : :
18107 : 1577511 : if (sym->param_list)
18108 : 522 : resolve_pdt (sym);
18109 : : }
18110 : :
18111 : :
18112 : : /************* Resolve DATA statements *************/
18113 : :
18114 : : static struct
18115 : : {
18116 : : gfc_data_value *vnode;
18117 : : mpz_t left;
18118 : : }
18119 : : values;
18120 : :
18121 : :
18122 : : /* Advance the values structure to point to the next value in the data list. */
18123 : :
18124 : : static bool
18125 : 11734 : next_data_value (void)
18126 : : {
18127 : 18152 : while (mpz_cmp_ui (values.left, 0) == 0)
18128 : : {
18129 : :
18130 : 8934 : if (values.vnode->next == NULL)
18131 : : return false;
18132 : :
18133 : 6418 : values.vnode = values.vnode->next;
18134 : 6418 : mpz_set (values.left, values.vnode->repeat);
18135 : : }
18136 : :
18137 : : return true;
18138 : : }
18139 : :
18140 : :
18141 : : static bool
18142 : 3665 : check_data_variable (gfc_data_variable *var, locus *where)
18143 : : {
18144 : 3665 : gfc_expr *e;
18145 : 3665 : mpz_t size;
18146 : 3665 : mpz_t offset;
18147 : 3665 : bool t;
18148 : 3665 : ar_type mark = AR_UNKNOWN;
18149 : 3665 : int i;
18150 : 3665 : mpz_t section_index[GFC_MAX_DIMENSIONS];
18151 : 3665 : int vector_offset[GFC_MAX_DIMENSIONS];
18152 : 3665 : gfc_ref *ref;
18153 : 3665 : gfc_array_ref *ar;
18154 : 3665 : gfc_symbol *sym;
18155 : 3665 : int has_pointer;
18156 : :
18157 : 3665 : if (!gfc_resolve_expr (var->expr))
18158 : : return false;
18159 : :
18160 : 3665 : ar = NULL;
18161 : 3665 : e = var->expr;
18162 : :
18163 : 3665 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
18164 : 2 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
18165 : 2 : e = e->value.function.actual->expr;
18166 : :
18167 : 3665 : if (e->expr_type != EXPR_VARIABLE)
18168 : : {
18169 : 0 : gfc_error ("Expecting definable entity near %L", where);
18170 : 0 : return false;
18171 : : }
18172 : :
18173 : 3665 : sym = e->symtree->n.sym;
18174 : :
18175 : 3665 : if (sym->ns->is_block_data && !sym->attr.in_common)
18176 : : {
18177 : 2 : gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
18178 : : sym->name, &sym->declared_at);
18179 : 2 : return false;
18180 : : }
18181 : :
18182 : 3663 : if (e->ref == NULL && sym->as)
18183 : : {
18184 : 1 : gfc_error ("DATA array %qs at %L must be specified in a previous"
18185 : : " declaration", sym->name, where);
18186 : 1 : return false;
18187 : : }
18188 : :
18189 : 3662 : if (gfc_is_coindexed (e))
18190 : : {
18191 : 5 : gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
18192 : : where);
18193 : 5 : return false;
18194 : : }
18195 : :
18196 : 3657 : has_pointer = sym->attr.pointer;
18197 : :
18198 : 6243 : for (ref = e->ref; ref; ref = ref->next)
18199 : : {
18200 : 2590 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
18201 : : has_pointer = 1;
18202 : :
18203 : 2564 : if (has_pointer)
18204 : : {
18205 : 29 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
18206 : : {
18207 : 1 : gfc_error ("DATA element %qs at %L is a pointer and so must "
18208 : : "be a full array", sym->name, where);
18209 : 1 : return false;
18210 : : }
18211 : :
18212 : 28 : if (values.vnode->expr->expr_type == EXPR_CONSTANT)
18213 : : {
18214 : 1 : gfc_error ("DATA object near %L has the pointer attribute "
18215 : : "and the corresponding DATA value is not a valid "
18216 : : "initial-data-target", where);
18217 : 1 : return false;
18218 : : }
18219 : : }
18220 : :
18221 : 2588 : if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
18222 : : {
18223 : 1 : gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
18224 : : "attribute", ref->u.c.component->name, &e->where);
18225 : 1 : return false;
18226 : : }
18227 : :
18228 : : /* Reject substrings of strings of non-constant length. */
18229 : 2587 : if (ref->type == REF_SUBSTRING
18230 : 93 : && ref->u.ss.length
18231 : 93 : && ref->u.ss.length->length
18232 : 2680 : && !gfc_is_constant_expr (ref->u.ss.length->length))
18233 : 1 : goto bad_charlen;
18234 : : }
18235 : :
18236 : : /* Reject strings with deferred length or non-constant length. */
18237 : 3653 : if (e->ts.type == BT_CHARACTER
18238 : 3653 : && (e->ts.deferred
18239 : 399 : || (e->ts.u.cl->length
18240 : 348 : && !gfc_is_constant_expr (e->ts.u.cl->length))))
18241 : 5 : goto bad_charlen;
18242 : :
18243 : 3648 : mpz_init_set_si (offset, 0);
18244 : :
18245 : 3648 : if (e->rank == 0 || has_pointer)
18246 : : {
18247 : 2695 : mpz_init_set_ui (size, 1);
18248 : 2695 : ref = NULL;
18249 : : }
18250 : : else
18251 : : {
18252 : 953 : ref = e->ref;
18253 : :
18254 : : /* Find the array section reference. */
18255 : 1136 : for (ref = e->ref; ref; ref = ref->next)
18256 : : {
18257 : 1136 : if (ref->type != REF_ARRAY)
18258 : 92 : continue;
18259 : 1044 : if (ref->u.ar.type == AR_ELEMENT)
18260 : 91 : continue;
18261 : : break;
18262 : : }
18263 : 953 : gcc_assert (ref);
18264 : :
18265 : : /* Set marks according to the reference pattern. */
18266 : 953 : switch (ref->u.ar.type)
18267 : : {
18268 : : case AR_FULL:
18269 : : mark = AR_FULL;
18270 : : break;
18271 : :
18272 : 149 : case AR_SECTION:
18273 : 149 : ar = &ref->u.ar;
18274 : : /* Get the start position of array section. */
18275 : 149 : gfc_get_section_index (ar, section_index, &offset, vector_offset);
18276 : 149 : mark = AR_SECTION;
18277 : 149 : break;
18278 : :
18279 : 0 : default:
18280 : 0 : gcc_unreachable ();
18281 : : }
18282 : :
18283 : 953 : if (!gfc_array_size (e, &size))
18284 : : {
18285 : 1 : gfc_error ("Nonconstant array section at %L in DATA statement",
18286 : : where);
18287 : 1 : mpz_clear (offset);
18288 : 1 : return false;
18289 : : }
18290 : : }
18291 : :
18292 : 3647 : t = true;
18293 : :
18294 : 12803 : while (mpz_cmp_ui (size, 0) > 0)
18295 : : {
18296 : 9219 : if (!next_data_value ())
18297 : : {
18298 : 1 : gfc_error ("DATA statement at %L has more variables than values",
18299 : : where);
18300 : 1 : t = false;
18301 : 1 : break;
18302 : : }
18303 : :
18304 : 9218 : t = gfc_check_assign (var->expr, values.vnode->expr, 0);
18305 : 9218 : if (!t)
18306 : : break;
18307 : :
18308 : : /* If we have more than one element left in the repeat count,
18309 : : and we have more than one element left in the target variable,
18310 : : then create a range assignment. */
18311 : : /* FIXME: Only done for full arrays for now, since array sections
18312 : : seem tricky. */
18313 : 9199 : if (mark == AR_FULL && ref && ref->next == NULL
18314 : 6122 : && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
18315 : : {
18316 : 162 : mpz_t range;
18317 : :
18318 : 162 : if (mpz_cmp (size, values.left) >= 0)
18319 : : {
18320 : 141 : mpz_init_set (range, values.left);
18321 : 141 : mpz_sub (size, size, values.left);
18322 : 141 : mpz_set_ui (values.left, 0);
18323 : : }
18324 : : else
18325 : : {
18326 : 21 : mpz_init_set (range, size);
18327 : 21 : mpz_sub (values.left, values.left, size);
18328 : 21 : mpz_set_ui (size, 0);
18329 : : }
18330 : :
18331 : 162 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
18332 : : offset, &range);
18333 : :
18334 : 162 : mpz_add (offset, offset, range);
18335 : 162 : mpz_clear (range);
18336 : :
18337 : 162 : if (!t)
18338 : : break;
18339 : 154 : }
18340 : :
18341 : : /* Assign initial value to symbol. */
18342 : : else
18343 : : {
18344 : 9037 : mpz_sub_ui (values.left, values.left, 1);
18345 : 9037 : mpz_sub_ui (size, size, 1);
18346 : :
18347 : 9037 : t = gfc_assign_data_value (var->expr, values.vnode->expr,
18348 : : offset, NULL);
18349 : 9037 : if (!t)
18350 : : break;
18351 : :
18352 : 9002 : if (mark == AR_FULL)
18353 : 5989 : mpz_add_ui (offset, offset, 1);
18354 : :
18355 : : /* Modify the array section indexes and recalculate the offset
18356 : : for next element. */
18357 : 3013 : else if (mark == AR_SECTION)
18358 : 363 : gfc_advance_section (section_index, ar, &offset, vector_offset);
18359 : : }
18360 : : }
18361 : :
18362 : 3647 : if (mark == AR_SECTION)
18363 : : {
18364 : 340 : for (i = 0; i < ar->dimen; i++)
18365 : 192 : mpz_clear (section_index[i]);
18366 : : }
18367 : :
18368 : 3647 : mpz_clear (size);
18369 : 3647 : mpz_clear (offset);
18370 : :
18371 : 3647 : return t;
18372 : :
18373 : 6 : bad_charlen:
18374 : 6 : gfc_error ("Non-constant character length at %L in DATA statement",
18375 : : &e->where);
18376 : 6 : return false;
18377 : : }
18378 : :
18379 : :
18380 : : static bool traverse_data_var (gfc_data_variable *, locus *);
18381 : :
18382 : : /* Iterate over a list of elements in a DATA statement. */
18383 : :
18384 : : static bool
18385 : 251 : traverse_data_list (gfc_data_variable *var, locus *where)
18386 : : {
18387 : 251 : mpz_t trip;
18388 : 251 : iterator_stack frame;
18389 : 251 : gfc_expr *e, *start, *end, *step;
18390 : 251 : bool retval = true;
18391 : :
18392 : 251 : mpz_init (frame.value);
18393 : 251 : mpz_init (trip);
18394 : :
18395 : 251 : start = gfc_copy_expr (var->iter.start);
18396 : 251 : end = gfc_copy_expr (var->iter.end);
18397 : 251 : step = gfc_copy_expr (var->iter.step);
18398 : :
18399 : 251 : if (!gfc_simplify_expr (start, 1)
18400 : 251 : || start->expr_type != EXPR_CONSTANT)
18401 : : {
18402 : 0 : gfc_error ("start of implied-do loop at %L could not be "
18403 : : "simplified to a constant value", &start->where);
18404 : 0 : retval = false;
18405 : 0 : goto cleanup;
18406 : : }
18407 : 251 : if (!gfc_simplify_expr (end, 1)
18408 : 251 : || end->expr_type != EXPR_CONSTANT)
18409 : : {
18410 : 0 : gfc_error ("end of implied-do loop at %L could not be "
18411 : : "simplified to a constant value", &end->where);
18412 : 0 : retval = false;
18413 : 0 : goto cleanup;
18414 : : }
18415 : 251 : if (!gfc_simplify_expr (step, 1)
18416 : 251 : || step->expr_type != EXPR_CONSTANT)
18417 : : {
18418 : 0 : gfc_error ("step of implied-do loop at %L could not be "
18419 : : "simplified to a constant value", &step->where);
18420 : 0 : retval = false;
18421 : 0 : goto cleanup;
18422 : : }
18423 : 251 : if (mpz_cmp_si (step->value.integer, 0) == 0)
18424 : : {
18425 : 1 : gfc_error ("step of implied-do loop at %L shall not be zero",
18426 : : &step->where);
18427 : 1 : retval = false;
18428 : 1 : goto cleanup;
18429 : : }
18430 : :
18431 : 250 : mpz_set (trip, end->value.integer);
18432 : 250 : mpz_sub (trip, trip, start->value.integer);
18433 : 250 : mpz_add (trip, trip, step->value.integer);
18434 : :
18435 : 250 : mpz_div (trip, trip, step->value.integer);
18436 : :
18437 : 250 : mpz_set (frame.value, start->value.integer);
18438 : :
18439 : 250 : frame.prev = iter_stack;
18440 : 250 : frame.variable = var->iter.var->symtree;
18441 : 250 : iter_stack = &frame;
18442 : :
18443 : 1169 : while (mpz_cmp_ui (trip, 0) > 0)
18444 : : {
18445 : 933 : if (!traverse_data_var (var->list, where))
18446 : : {
18447 : 14 : retval = false;
18448 : 14 : goto cleanup;
18449 : : }
18450 : :
18451 : 919 : e = gfc_copy_expr (var->expr);
18452 : 919 : if (!gfc_simplify_expr (e, 1))
18453 : : {
18454 : 0 : gfc_free_expr (e);
18455 : 0 : retval = false;
18456 : 0 : goto cleanup;
18457 : : }
18458 : :
18459 : 919 : mpz_add (frame.value, frame.value, step->value.integer);
18460 : :
18461 : 919 : mpz_sub_ui (trip, trip, 1);
18462 : : }
18463 : :
18464 : 236 : cleanup:
18465 : 251 : mpz_clear (frame.value);
18466 : 251 : mpz_clear (trip);
18467 : :
18468 : 251 : gfc_free_expr (start);
18469 : 251 : gfc_free_expr (end);
18470 : 251 : gfc_free_expr (step);
18471 : :
18472 : 251 : iter_stack = frame.prev;
18473 : 251 : return retval;
18474 : : }
18475 : :
18476 : :
18477 : : /* Type resolve variables in the variable list of a DATA statement. */
18478 : :
18479 : : static bool
18480 : 3530 : traverse_data_var (gfc_data_variable *var, locus *where)
18481 : : {
18482 : 3530 : bool t;
18483 : :
18484 : 7350 : for (; var; var = var->next)
18485 : : {
18486 : 3916 : if (var->expr == NULL)
18487 : 251 : t = traverse_data_list (var, where);
18488 : : else
18489 : 3665 : t = check_data_variable (var, where);
18490 : :
18491 : 3916 : if (!t)
18492 : : return false;
18493 : : }
18494 : :
18495 : : return true;
18496 : : }
18497 : :
18498 : :
18499 : : /* Resolve the expressions and iterators associated with a data statement.
18500 : : This is separate from the assignment checking because data lists should
18501 : : only be resolved once. */
18502 : :
18503 : : static bool
18504 : 2761 : resolve_data_variables (gfc_data_variable *d)
18505 : : {
18506 : 5903 : for (; d; d = d->next)
18507 : : {
18508 : 3147 : if (d->list == NULL)
18509 : : {
18510 : 2985 : if (!gfc_resolve_expr (d->expr))
18511 : : return false;
18512 : : }
18513 : : else
18514 : : {
18515 : 162 : if (!gfc_resolve_iterator (&d->iter, false, true))
18516 : : return false;
18517 : :
18518 : 159 : if (!resolve_data_variables (d->list))
18519 : : return false;
18520 : : }
18521 : : }
18522 : :
18523 : : return true;
18524 : : }
18525 : :
18526 : :
18527 : : /* Resolve a single DATA statement. We implement this by storing a pointer to
18528 : : the value list into static variables, and then recursively traversing the
18529 : : variables list, expanding iterators and such. */
18530 : :
18531 : : static void
18532 : 2602 : resolve_data (gfc_data *d)
18533 : : {
18534 : :
18535 : 2602 : if (!resolve_data_variables (d->var))
18536 : : return;
18537 : :
18538 : 2597 : values.vnode = d->value;
18539 : 2597 : if (d->value == NULL)
18540 : 0 : mpz_set_ui (values.left, 0);
18541 : : else
18542 : 2597 : mpz_set (values.left, d->value->repeat);
18543 : :
18544 : 2597 : if (!traverse_data_var (d->var, &d->where))
18545 : : return;
18546 : :
18547 : : /* At this point, we better not have any values left. */
18548 : :
18549 : 2515 : if (next_data_value ())
18550 : 0 : gfc_error ("DATA statement at %L has more values than variables",
18551 : : &d->where);
18552 : : }
18553 : :
18554 : :
18555 : : /* 12.6 Constraint: In a pure subprogram any variable which is in common or
18556 : : accessed by host or use association, is a dummy argument to a pure function,
18557 : : is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
18558 : : is storage associated with any such variable, shall not be used in the
18559 : : following contexts: (clients of this function). */
18560 : :
18561 : : /* Determines if a variable is not 'pure', i.e., not assignable within a pure
18562 : : procedure. Returns zero if assignment is OK, nonzero if there is a
18563 : : problem. */
18564 : : bool
18565 : 51796 : gfc_impure_variable (gfc_symbol *sym)
18566 : : {
18567 : 51796 : gfc_symbol *proc;
18568 : 51796 : gfc_namespace *ns;
18569 : :
18570 : 51796 : if (sym->attr.use_assoc || sym->attr.in_common)
18571 : : return 1;
18572 : :
18573 : : /* Check if the symbol's ns is inside the pure procedure. */
18574 : 55539 : for (ns = gfc_current_ns; ns; ns = ns->parent)
18575 : : {
18576 : 55260 : if (ns == sym->ns)
18577 : : break;
18578 : 5699 : if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
18579 : : return 1;
18580 : : }
18581 : :
18582 : 49840 : proc = sym->ns->proc_name;
18583 : 49840 : if (sym->attr.dummy
18584 : 49840 : && !sym->attr.value
18585 : 5394 : && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
18586 : 5247 : || proc->attr.function))
18587 : 607 : return 1;
18588 : :
18589 : : /* TODO: Sort out what can be storage associated, if anything, and include
18590 : : it here. In principle equivalences should be scanned but it does not
18591 : : seem to be possible to storage associate an impure variable this way. */
18592 : : return 0;
18593 : : }
18594 : :
18595 : :
18596 : : /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
18597 : : current namespace is inside a pure procedure. */
18598 : :
18599 : : bool
18600 : 1986176 : gfc_pure (gfc_symbol *sym)
18601 : : {
18602 : 1986176 : symbol_attribute attr;
18603 : 1986176 : gfc_namespace *ns;
18604 : :
18605 : 1986176 : if (sym == NULL)
18606 : : {
18607 : : /* Check if the current namespace or one of its parents
18608 : : belongs to a pure procedure. */
18609 : 2460541 : for (ns = gfc_current_ns; ns; ns = ns->parent)
18610 : : {
18611 : 1409942 : sym = ns->proc_name;
18612 : 1409942 : if (sym == NULL)
18613 : : return 0;
18614 : 1408808 : attr = sym->attr;
18615 : 1408808 : if (attr.flavor == FL_PROCEDURE && attr.pure)
18616 : : return 1;
18617 : : }
18618 : : return 0;
18619 : : }
18620 : :
18621 : 928233 : attr = sym->attr;
18622 : :
18623 : 928233 : return attr.flavor == FL_PROCEDURE && attr.pure;
18624 : : }
18625 : :
18626 : :
18627 : : /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
18628 : : checks if the current namespace is implicitly pure. Note that this
18629 : : function returns false for a PURE procedure. */
18630 : :
18631 : : bool
18632 : 515611 : gfc_implicit_pure (gfc_symbol *sym)
18633 : : {
18634 : 515611 : gfc_namespace *ns;
18635 : :
18636 : 515611 : if (sym == NULL)
18637 : : {
18638 : : /* Check if the current procedure is implicit_pure. Walk up
18639 : : the procedure list until we find a procedure. */
18640 : 776169 : for (ns = gfc_current_ns; ns; ns = ns->parent)
18641 : : {
18642 : 503216 : sym = ns->proc_name;
18643 : 503216 : if (sym == NULL)
18644 : : return 0;
18645 : :
18646 : 503143 : if (sym->attr.flavor == FL_PROCEDURE)
18647 : : break;
18648 : : }
18649 : : }
18650 : :
18651 : 515538 : return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
18652 : 515538 : && !sym->attr.pure;
18653 : : }
18654 : :
18655 : :
18656 : : void
18657 : 388672 : gfc_unset_implicit_pure (gfc_symbol *sym)
18658 : : {
18659 : 388672 : gfc_namespace *ns;
18660 : :
18661 : 388672 : if (sym == NULL)
18662 : : {
18663 : : /* Check if the current procedure is implicit_pure. Walk up
18664 : : the procedure list until we find a procedure. */
18665 : 643162 : for (ns = gfc_current_ns; ns; ns = ns->parent)
18666 : : {
18667 : 392788 : sym = ns->proc_name;
18668 : 392788 : if (sym == NULL)
18669 : : return;
18670 : :
18671 : 391962 : if (sym->attr.flavor == FL_PROCEDURE)
18672 : : break;
18673 : : }
18674 : : }
18675 : :
18676 : 387846 : if (sym->attr.flavor == FL_PROCEDURE)
18677 : 129819 : sym->attr.implicit_pure = 0;
18678 : : else
18679 : 258027 : sym->attr.pure = 0;
18680 : : }
18681 : :
18682 : :
18683 : : /* Test whether the current procedure is elemental or not. */
18684 : :
18685 : : bool
18686 : 1243222 : gfc_elemental (gfc_symbol *sym)
18687 : : {
18688 : 1243222 : symbol_attribute attr;
18689 : :
18690 : 1243222 : if (sym == NULL)
18691 : 0 : sym = gfc_current_ns->proc_name;
18692 : 0 : if (sym == NULL)
18693 : : return 0;
18694 : 1243222 : attr = sym->attr;
18695 : :
18696 : 1243222 : return attr.flavor == FL_PROCEDURE && attr.elemental;
18697 : : }
18698 : :
18699 : :
18700 : : /* Warn about unused labels. */
18701 : :
18702 : : static void
18703 : 4391 : warn_unused_fortran_label (gfc_st_label *label)
18704 : : {
18705 : 4394 : if (label == NULL)
18706 : : return;
18707 : :
18708 : 4 : warn_unused_fortran_label (label->left);
18709 : :
18710 : 4 : if (label->defined == ST_LABEL_UNKNOWN)
18711 : : return;
18712 : :
18713 : 3 : switch (label->referenced)
18714 : : {
18715 : 1 : case ST_LABEL_UNKNOWN:
18716 : 1 : gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
18717 : : label->value, &label->where);
18718 : 1 : break;
18719 : :
18720 : 1 : case ST_LABEL_BAD_TARGET:
18721 : 1 : gfc_warning (OPT_Wunused_label,
18722 : : "Label %d at %L defined but cannot be used",
18723 : : label->value, &label->where);
18724 : 1 : break;
18725 : :
18726 : : default:
18727 : : break;
18728 : : }
18729 : :
18730 : 3 : warn_unused_fortran_label (label->right);
18731 : : }
18732 : :
18733 : :
18734 : : /* Returns the sequence type of a symbol or sequence. */
18735 : :
18736 : : static seq_type
18737 : 1101 : sequence_type (gfc_typespec ts)
18738 : : {
18739 : 1101 : seq_type result;
18740 : 1101 : gfc_component *c;
18741 : :
18742 : 1101 : switch (ts.type)
18743 : : {
18744 : 54 : case BT_DERIVED:
18745 : :
18746 : 54 : if (ts.u.derived->components == NULL)
18747 : : return SEQ_NONDEFAULT;
18748 : :
18749 : 54 : result = sequence_type (ts.u.derived->components->ts);
18750 : 108 : for (c = ts.u.derived->components->next; c; c = c->next)
18751 : 67 : if (sequence_type (c->ts) != result)
18752 : : return SEQ_MIXED;
18753 : :
18754 : : return result;
18755 : :
18756 : 129 : case BT_CHARACTER:
18757 : 129 : if (ts.kind != gfc_default_character_kind)
18758 : 0 : return SEQ_NONDEFAULT;
18759 : :
18760 : : return SEQ_CHARACTER;
18761 : :
18762 : 250 : case BT_INTEGER:
18763 : 250 : if (ts.kind != gfc_default_integer_kind)
18764 : 25 : return SEQ_NONDEFAULT;
18765 : :
18766 : : return SEQ_NUMERIC;
18767 : :
18768 : 569 : case BT_REAL:
18769 : 569 : if (!(ts.kind == gfc_default_real_kind
18770 : 274 : || ts.kind == gfc_default_double_kind))
18771 : 0 : return SEQ_NONDEFAULT;
18772 : :
18773 : : return SEQ_NUMERIC;
18774 : :
18775 : 81 : case BT_COMPLEX:
18776 : 81 : if (ts.kind != gfc_default_complex_kind)
18777 : 48 : return SEQ_NONDEFAULT;
18778 : :
18779 : : return SEQ_NUMERIC;
18780 : :
18781 : 17 : case BT_LOGICAL:
18782 : 17 : if (ts.kind != gfc_default_logical_kind)
18783 : 0 : return SEQ_NONDEFAULT;
18784 : :
18785 : : return SEQ_NUMERIC;
18786 : :
18787 : : default:
18788 : : return SEQ_NONDEFAULT;
18789 : : }
18790 : : }
18791 : :
18792 : :
18793 : : /* Resolve derived type EQUIVALENCE object. */
18794 : :
18795 : : static bool
18796 : 85 : resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
18797 : : {
18798 : 85 : gfc_component *c = derived->components;
18799 : :
18800 : 85 : if (!derived)
18801 : : return true;
18802 : :
18803 : : /* Shall not be an object of nonsequence derived type. */
18804 : 85 : if (!derived->attr.sequence)
18805 : : {
18806 : 0 : gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
18807 : : "attribute to be an EQUIVALENCE object", sym->name,
18808 : : &e->where);
18809 : 0 : return false;
18810 : : }
18811 : :
18812 : : /* Shall not have allocatable components. */
18813 : 85 : if (derived->attr.alloc_comp)
18814 : : {
18815 : 1 : gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
18816 : : "components to be an EQUIVALENCE object",sym->name,
18817 : : &e->where);
18818 : 1 : return false;
18819 : : }
18820 : :
18821 : 84 : if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
18822 : : {
18823 : 1 : gfc_error ("Derived type variable %qs at %L with default "
18824 : : "initialization cannot be in EQUIVALENCE with a variable "
18825 : : "in COMMON", sym->name, &e->where);
18826 : 1 : return false;
18827 : : }
18828 : :
18829 : 255 : for (; c ; c = c->next)
18830 : : {
18831 : 172 : if (gfc_bt_struct (c->ts.type)
18832 : 172 : && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
18833 : : return false;
18834 : :
18835 : : /* Shall not be an object of sequence derived type containing a pointer
18836 : : in the structure. */
18837 : 172 : if (c->attr.pointer)
18838 : : {
18839 : 0 : gfc_error ("Derived type variable %qs at %L with pointer "
18840 : : "component(s) cannot be an EQUIVALENCE object",
18841 : : sym->name, &e->where);
18842 : 0 : return false;
18843 : : }
18844 : : }
18845 : : return true;
18846 : : }
18847 : :
18848 : :
18849 : : /* Resolve equivalence object.
18850 : : An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
18851 : : an allocatable array, an object of nonsequence derived type, an object of
18852 : : sequence derived type containing a pointer at any level of component
18853 : : selection, an automatic object, a function name, an entry name, a result
18854 : : name, a named constant, a structure component, or a subobject of any of
18855 : : the preceding objects. A substring shall not have length zero. A
18856 : : derived type shall not have components with default initialization nor
18857 : : shall two objects of an equivalence group be initialized.
18858 : : Either all or none of the objects shall have an protected attribute.
18859 : : The simple constraints are done in symbol.cc(check_conflict) and the rest
18860 : : are implemented here. */
18861 : :
18862 : : static void
18863 : 1580 : resolve_equivalence (gfc_equiv *eq)
18864 : : {
18865 : 1580 : gfc_symbol *sym;
18866 : 1580 : gfc_symbol *first_sym;
18867 : 1580 : gfc_expr *e;
18868 : 1580 : gfc_ref *r;
18869 : 1580 : locus *last_where = NULL;
18870 : 1580 : seq_type eq_type, last_eq_type;
18871 : 1580 : gfc_typespec *last_ts;
18872 : 1580 : int object, cnt_protected;
18873 : 1580 : const char *msg;
18874 : :
18875 : 1580 : last_ts = &eq->expr->symtree->n.sym->ts;
18876 : :
18877 : 1580 : first_sym = eq->expr->symtree->n.sym;
18878 : :
18879 : 1580 : cnt_protected = 0;
18880 : :
18881 : 4772 : for (object = 1; eq; eq = eq->eq, object++)
18882 : : {
18883 : 3201 : e = eq->expr;
18884 : :
18885 : 3201 : e->ts = e->symtree->n.sym->ts;
18886 : : /* match_varspec might not know yet if it is seeing
18887 : : array reference or substring reference, as it doesn't
18888 : : know the types. */
18889 : 3201 : if (e->ref && e->ref->type == REF_ARRAY)
18890 : : {
18891 : 2167 : gfc_ref *ref = e->ref;
18892 : 2167 : sym = e->symtree->n.sym;
18893 : :
18894 : 2167 : if (sym->attr.dimension)
18895 : : {
18896 : 1870 : ref->u.ar.as = sym->as;
18897 : 1870 : ref = ref->next;
18898 : : }
18899 : :
18900 : : /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
18901 : 2167 : if (e->ts.type == BT_CHARACTER
18902 : 592 : && ref
18903 : 371 : && ref->type == REF_ARRAY
18904 : 371 : && ref->u.ar.dimen == 1
18905 : 371 : && ref->u.ar.dimen_type[0] == DIMEN_RANGE
18906 : 371 : && ref->u.ar.stride[0] == NULL)
18907 : : {
18908 : 370 : gfc_expr *start = ref->u.ar.start[0];
18909 : 370 : gfc_expr *end = ref->u.ar.end[0];
18910 : 370 : void *mem = NULL;
18911 : :
18912 : : /* Optimize away the (:) reference. */
18913 : 370 : if (start == NULL && end == NULL)
18914 : : {
18915 : 9 : if (e->ref == ref)
18916 : 0 : e->ref = ref->next;
18917 : : else
18918 : 9 : e->ref->next = ref->next;
18919 : : mem = ref;
18920 : : }
18921 : : else
18922 : : {
18923 : 361 : ref->type = REF_SUBSTRING;
18924 : 361 : if (start == NULL)
18925 : 9 : start = gfc_get_int_expr (gfc_charlen_int_kind,
18926 : : NULL, 1);
18927 : 361 : ref->u.ss.start = start;
18928 : 361 : if (end == NULL && e->ts.u.cl)
18929 : 27 : end = gfc_copy_expr (e->ts.u.cl->length);
18930 : 361 : ref->u.ss.end = end;
18931 : 361 : ref->u.ss.length = e->ts.u.cl;
18932 : 361 : e->ts.u.cl = NULL;
18933 : : }
18934 : 370 : ref = ref->next;
18935 : 370 : free (mem);
18936 : : }
18937 : :
18938 : : /* Any further ref is an error. */
18939 : 1945 : if (ref)
18940 : : {
18941 : 1 : gcc_assert (ref->type == REF_ARRAY);
18942 : 1 : gfc_error ("Syntax error in EQUIVALENCE statement at %L",
18943 : : &ref->u.ar.where);
18944 : 1 : continue;
18945 : : }
18946 : : }
18947 : :
18948 : 3200 : if (!gfc_resolve_expr (e))
18949 : 2 : continue;
18950 : :
18951 : 3198 : sym = e->symtree->n.sym;
18952 : :
18953 : 3198 : if (sym->attr.is_protected)
18954 : 2 : cnt_protected++;
18955 : 3198 : if (cnt_protected > 0 && cnt_protected != object)
18956 : : {
18957 : 2 : gfc_error ("Either all or none of the objects in the "
18958 : : "EQUIVALENCE set at %L shall have the "
18959 : : "PROTECTED attribute",
18960 : : &e->where);
18961 : 2 : break;
18962 : : }
18963 : :
18964 : : /* Shall not equivalence common block variables in a PURE procedure. */
18965 : 3196 : if (sym->ns->proc_name
18966 : 3180 : && sym->ns->proc_name->attr.pure
18967 : 7 : && sym->attr.in_common)
18968 : : {
18969 : : /* Need to check for symbols that may have entered the pure
18970 : : procedure via a USE statement. */
18971 : 7 : bool saw_sym = false;
18972 : 7 : if (sym->ns->use_stmts)
18973 : : {
18974 : 6 : gfc_use_rename *r;
18975 : 10 : for (r = sym->ns->use_stmts->rename; r; r = r->next)
18976 : 4 : if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
18977 : : }
18978 : : else
18979 : : saw_sym = true;
18980 : :
18981 : 6 : if (saw_sym)
18982 : 3 : gfc_error ("COMMON block member %qs at %L cannot be an "
18983 : : "EQUIVALENCE object in the pure procedure %qs",
18984 : : sym->name, &e->where, sym->ns->proc_name->name);
18985 : : break;
18986 : : }
18987 : :
18988 : : /* Shall not be a named constant. */
18989 : 3189 : if (e->expr_type == EXPR_CONSTANT)
18990 : : {
18991 : 0 : gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
18992 : : "object", sym->name, &e->where);
18993 : 0 : continue;
18994 : : }
18995 : :
18996 : 3191 : if (e->ts.type == BT_DERIVED
18997 : 3189 : && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
18998 : 2 : continue;
18999 : :
19000 : : /* Check that the types correspond correctly:
19001 : : Note 5.28:
19002 : : A numeric sequence structure may be equivalenced to another sequence
19003 : : structure, an object of default integer type, default real type, double
19004 : : precision real type, default logical type such that components of the
19005 : : structure ultimately only become associated to objects of the same
19006 : : kind. A character sequence structure may be equivalenced to an object
19007 : : of default character kind or another character sequence structure.
19008 : : Other objects may be equivalenced only to objects of the same type and
19009 : : kind parameters. */
19010 : :
19011 : : /* Identical types are unconditionally OK. */
19012 : 3187 : if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
19013 : 2697 : goto identical_types;
19014 : :
19015 : 490 : last_eq_type = sequence_type (*last_ts);
19016 : 490 : eq_type = sequence_type (sym->ts);
19017 : :
19018 : : /* Since the pair of objects is not of the same type, mixed or
19019 : : non-default sequences can be rejected. */
19020 : :
19021 : 490 : msg = G_("Sequence %s with mixed components in EQUIVALENCE "
19022 : : "statement at %L with different type objects");
19023 : 491 : if ((object ==2
19024 : 490 : && last_eq_type == SEQ_MIXED
19025 : 7 : && last_where
19026 : 7 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19027 : 496 : || (eq_type == SEQ_MIXED
19028 : 6 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19029 : 1 : continue;
19030 : :
19031 : 489 : msg = G_("Non-default type object or sequence %s in EQUIVALENCE "
19032 : : "statement at %L with objects of different type");
19033 : 493 : if ((object ==2
19034 : 489 : && last_eq_type == SEQ_NONDEFAULT
19035 : 50 : && last_where
19036 : 49 : && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
19037 : 535 : || (eq_type == SEQ_NONDEFAULT
19038 : 24 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
19039 : 4 : continue;
19040 : :
19041 : 485 : msg = G_("Non-CHARACTER object %qs in default CHARACTER "
19042 : : "EQUIVALENCE statement at %L");
19043 : 489 : if (last_eq_type == SEQ_CHARACTER
19044 : 485 : && eq_type != SEQ_CHARACTER
19045 : 485 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19046 : 4 : continue;
19047 : :
19048 : 481 : msg = G_("Non-NUMERIC object %qs in default NUMERIC "
19049 : : "EQUIVALENCE statement at %L");
19050 : 483 : if (last_eq_type == SEQ_NUMERIC
19051 : 481 : && eq_type != SEQ_NUMERIC
19052 : 481 : && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
19053 : 2 : continue;
19054 : :
19055 : 3176 : identical_types:
19056 : :
19057 : 3176 : last_ts =&sym->ts;
19058 : 3176 : last_where = &e->where;
19059 : :
19060 : 3176 : if (!e->ref)
19061 : 1018 : continue;
19062 : :
19063 : : /* Shall not be an automatic array. */
19064 : 2158 : if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
19065 : : {
19066 : 3 : gfc_error ("Array %qs at %L with non-constant bounds cannot be "
19067 : : "an EQUIVALENCE object", sym->name, &e->where);
19068 : 3 : continue;
19069 : : }
19070 : :
19071 : 2155 : r = e->ref;
19072 : 4356 : while (r)
19073 : : {
19074 : : /* Shall not be a structure component. */
19075 : 2202 : if (r->type == REF_COMPONENT)
19076 : : {
19077 : 0 : gfc_error ("Structure component %qs at %L cannot be an "
19078 : : "EQUIVALENCE object",
19079 : 0 : r->u.c.component->name, &e->where);
19080 : 0 : break;
19081 : : }
19082 : :
19083 : : /* A substring shall not have length zero. */
19084 : 2202 : if (r->type == REF_SUBSTRING)
19085 : : {
19086 : 341 : if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
19087 : : {
19088 : 1 : gfc_error ("Substring at %L has length zero",
19089 : : &r->u.ss.start->where);
19090 : 1 : break;
19091 : : }
19092 : : }
19093 : 2201 : r = r->next;
19094 : : }
19095 : : }
19096 : 1580 : }
19097 : :
19098 : :
19099 : : /* Function called by resolve_fntype to flag other symbols used in the
19100 : : length type parameter specification of function results. */
19101 : :
19102 : : static bool
19103 : 4052 : flag_fn_result_spec (gfc_expr *expr,
19104 : : gfc_symbol *sym,
19105 : : int *f ATTRIBUTE_UNUSED)
19106 : : {
19107 : 4052 : gfc_namespace *ns;
19108 : 4052 : gfc_symbol *s;
19109 : :
19110 : 4052 : if (expr->expr_type == EXPR_VARIABLE)
19111 : : {
19112 : 1369 : s = expr->symtree->n.sym;
19113 : 2139 : for (ns = s->ns; ns; ns = ns->parent)
19114 : 2139 : if (!ns->parent)
19115 : : break;
19116 : :
19117 : 1369 : if (sym == s)
19118 : : {
19119 : 1 : gfc_error ("Self reference in character length expression "
19120 : : "for %qs at %L", sym->name, &expr->where);
19121 : 1 : return true;
19122 : : }
19123 : :
19124 : 1368 : if (!s->fn_result_spec
19125 : 1368 : && s->attr.flavor == FL_PARAMETER)
19126 : : {
19127 : : /* Function contained in a module.... */
19128 : 63 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
19129 : : {
19130 : 32 : gfc_symtree *st;
19131 : 32 : s->fn_result_spec = 1;
19132 : : /* Make sure that this symbol is translated as a module
19133 : : variable. */
19134 : 32 : st = gfc_get_unique_symtree (ns);
19135 : 32 : st->n.sym = s;
19136 : 32 : s->refs++;
19137 : 32 : }
19138 : : /* ... which is use associated and called. */
19139 : 31 : else if (s->attr.use_assoc || s->attr.used_in_submodule
19140 : 0 : ||
19141 : : /* External function matched with an interface. */
19142 : 0 : (s->ns->proc_name
19143 : 0 : && ((s->ns == ns
19144 : 0 : && s->ns->proc_name->attr.if_source == IFSRC_DECL)
19145 : 0 : || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
19146 : 0 : && s->ns->proc_name->attr.function))
19147 : 31 : s->fn_result_spec = 1;
19148 : : }
19149 : : }
19150 : : return false;
19151 : : }
19152 : :
19153 : :
19154 : : /* Resolve function and ENTRY types, issue diagnostics if needed. */
19155 : :
19156 : : static void
19157 : 322576 : resolve_fntype (gfc_namespace *ns)
19158 : : {
19159 : 322576 : gfc_entry_list *el;
19160 : 322576 : gfc_symbol *sym;
19161 : :
19162 : 322576 : if (ns->proc_name == NULL || !ns->proc_name->attr.function)
19163 : : return;
19164 : :
19165 : : /* If there are any entries, ns->proc_name is the entry master
19166 : : synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
19167 : 170522 : if (ns->entries)
19168 : 564 : sym = ns->entries->sym;
19169 : : else
19170 : : sym = ns->proc_name;
19171 : 170522 : if (sym->result == sym
19172 : 138639 : && sym->ts.type == BT_UNKNOWN
19173 : 6 : && !gfc_set_default_type (sym, 0, NULL)
19174 : 170526 : && !sym->attr.untyped)
19175 : : {
19176 : 3 : gfc_error ("Function %qs at %L has no IMPLICIT type",
19177 : : sym->name, &sym->declared_at);
19178 : 3 : sym->attr.untyped = 1;
19179 : : }
19180 : :
19181 : 11151 : if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
19182 : 1506 : && !sym->attr.contained
19183 : 250 : && !gfc_check_symbol_access (sym->ts.u.derived)
19184 : 170522 : && gfc_check_symbol_access (sym))
19185 : : {
19186 : 0 : gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
19187 : : "%L of PRIVATE type %qs", sym->name,
19188 : 0 : &sym->declared_at, sym->ts.u.derived->name);
19189 : : }
19190 : :
19191 : 170522 : if (ns->entries)
19192 : 1189 : for (el = ns->entries->next; el; el = el->next)
19193 : : {
19194 : 625 : if (el->sym->result == el->sym
19195 : 413 : && el->sym->ts.type == BT_UNKNOWN
19196 : 2 : && !gfc_set_default_type (el->sym, 0, NULL)
19197 : 627 : && !el->sym->attr.untyped)
19198 : : {
19199 : 2 : gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
19200 : : el->sym->name, &el->sym->declared_at);
19201 : 2 : el->sym->attr.untyped = 1;
19202 : : }
19203 : : }
19204 : :
19205 : 170522 : if (sym->ts.type == BT_CHARACTER
19206 : 6511 : && sym->ts.u.cl->length
19207 : 1716 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
19208 : 1711 : gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
19209 : : }
19210 : :
19211 : :
19212 : : /* 12.3.2.1.1 Defined operators. */
19213 : :
19214 : : static bool
19215 : 371 : check_uop_procedure (gfc_symbol *sym, locus where)
19216 : : {
19217 : 371 : gfc_formal_arglist *formal;
19218 : :
19219 : 371 : if (!sym->attr.function)
19220 : : {
19221 : 3 : gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
19222 : : sym->name, &where);
19223 : 3 : return false;
19224 : : }
19225 : :
19226 : 368 : if (sym->ts.type == BT_CHARACTER
19227 : 15 : && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
19228 : 2 : && !(sym->result && ((sym->result->ts.u.cl
19229 : 2 : && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
19230 : : {
19231 : 2 : gfc_error ("User operator procedure %qs at %L cannot be assumed "
19232 : : "character length", sym->name, &where);
19233 : 2 : return false;
19234 : : }
19235 : :
19236 : 366 : formal = gfc_sym_get_dummy_args (sym);
19237 : 366 : if (!formal || !formal->sym)
19238 : : {
19239 : 1 : gfc_error ("User operator procedure %qs at %L must have at least "
19240 : : "one argument", sym->name, &where);
19241 : 1 : return false;
19242 : : }
19243 : :
19244 : 365 : if (formal->sym->attr.intent != INTENT_IN)
19245 : : {
19246 : 0 : gfc_error ("First argument of operator interface at %L must be "
19247 : : "INTENT(IN)", &where);
19248 : 0 : return false;
19249 : : }
19250 : :
19251 : 365 : if (formal->sym->attr.optional)
19252 : : {
19253 : 0 : gfc_error ("First argument of operator interface at %L cannot be "
19254 : : "optional", &where);
19255 : 0 : return false;
19256 : : }
19257 : :
19258 : 365 : formal = formal->next;
19259 : 365 : if (!formal || !formal->sym)
19260 : : return true;
19261 : :
19262 : 232 : if (formal->sym->attr.intent != INTENT_IN)
19263 : : {
19264 : 0 : gfc_error ("Second argument of operator interface at %L must be "
19265 : : "INTENT(IN)", &where);
19266 : 0 : return false;
19267 : : }
19268 : :
19269 : 232 : if (formal->sym->attr.optional)
19270 : : {
19271 : 1 : gfc_error ("Second argument of operator interface at %L cannot be "
19272 : : "optional", &where);
19273 : 1 : return false;
19274 : : }
19275 : :
19276 : 231 : if (formal->next)
19277 : : {
19278 : 2 : gfc_error ("Operator interface at %L must have, at most, two "
19279 : : "arguments", &where);
19280 : 2 : return false;
19281 : : }
19282 : :
19283 : : return true;
19284 : : }
19285 : :
19286 : : static void
19287 : 323242 : gfc_resolve_uops (gfc_symtree *symtree)
19288 : : {
19289 : 323242 : gfc_interface *itr;
19290 : :
19291 : 323242 : if (symtree == NULL)
19292 : : return;
19293 : :
19294 : 333 : gfc_resolve_uops (symtree->left);
19295 : 333 : gfc_resolve_uops (symtree->right);
19296 : :
19297 : 662 : for (itr = symtree->n.uop->op; itr; itr = itr->next)
19298 : 329 : check_uop_procedure (itr->sym, itr->sym->declared_at);
19299 : : }
19300 : :
19301 : :
19302 : : /* Examine all of the expressions associated with a program unit,
19303 : : assign types to all intermediate expressions, make sure that all
19304 : : assignments are to compatible types and figure out which names
19305 : : refer to which functions or subroutines. It doesn't check code
19306 : : block, which is handled by gfc_resolve_code. */
19307 : :
19308 : : static void
19309 : 324891 : resolve_types (gfc_namespace *ns)
19310 : : {
19311 : 324891 : gfc_namespace *n;
19312 : 324891 : gfc_charlen *cl;
19313 : 324891 : gfc_data *d;
19314 : 324891 : gfc_equiv *eq;
19315 : 324891 : gfc_namespace* old_ns = gfc_current_ns;
19316 : 324891 : bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
19317 : :
19318 : 324891 : if (ns->types_resolved)
19319 : : return;
19320 : :
19321 : : /* Check that all IMPLICIT types are ok. */
19322 : 322577 : if (!ns->seen_implicit_none)
19323 : : {
19324 : : unsigned letter;
19325 : 8110909 : for (letter = 0; letter != GFC_LETTERS; ++letter)
19326 : 7810505 : if (ns->set_flag[letter]
19327 : 7810505 : && !resolve_typespec_used (&ns->default_type[letter],
19328 : : &ns->implicit_loc[letter], NULL))
19329 : : return;
19330 : : }
19331 : :
19332 : 322576 : gfc_current_ns = ns;
19333 : :
19334 : 322576 : resolve_entries (ns);
19335 : :
19336 : 322576 : resolve_common_vars (&ns->blank_common, false);
19337 : 322576 : resolve_common_blocks (ns->common_root);
19338 : :
19339 : 322576 : resolve_contained_functions (ns);
19340 : :
19341 : 322576 : if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
19342 : 322528 : && ns->proc_name->attr.if_source == IFSRC_IFBODY)
19343 : 177966 : gfc_resolve_formal_arglist (ns->proc_name);
19344 : :
19345 : 322576 : gfc_traverse_ns (ns, resolve_bind_c_derived_types);
19346 : :
19347 : 413298 : for (cl = ns->cl_list; cl; cl = cl->next)
19348 : 90722 : resolve_charlen (cl);
19349 : :
19350 : 322576 : gfc_traverse_ns (ns, resolve_symbol);
19351 : :
19352 : 322576 : resolve_fntype (ns);
19353 : :
19354 : 367275 : for (n = ns->contained; n; n = n->sibling)
19355 : : {
19356 : : /* Exclude final wrappers with the test for the artificial attribute. */
19357 : 44699 : if (gfc_pure (ns->proc_name)
19358 : 5 : && !gfc_pure (n->proc_name)
19359 : 44699 : && !n->proc_name->attr.artificial)
19360 : 0 : gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
19361 : : "also be PURE", n->proc_name->name,
19362 : : &n->proc_name->declared_at);
19363 : :
19364 : 44699 : resolve_types (n);
19365 : : }
19366 : :
19367 : 322576 : forall_flag = 0;
19368 : 322576 : gfc_do_concurrent_flag = 0;
19369 : 322576 : gfc_check_interfaces (ns);
19370 : :
19371 : 322576 : gfc_traverse_ns (ns, resolve_values);
19372 : :
19373 : 322576 : if (ns->save_all || (!flag_automatic && !recursive))
19374 : 345 : gfc_save_all (ns);
19375 : :
19376 : 322576 : iter_stack = NULL;
19377 : 325178 : for (d = ns->data; d; d = d->next)
19378 : 2602 : resolve_data (d);
19379 : :
19380 : 322576 : iter_stack = NULL;
19381 : 322576 : gfc_traverse_ns (ns, gfc_formalize_init_value);
19382 : :
19383 : 322576 : gfc_traverse_ns (ns, gfc_verify_binding_labels);
19384 : :
19385 : 324156 : for (eq = ns->equiv; eq; eq = eq->next)
19386 : 1580 : resolve_equivalence (eq);
19387 : :
19388 : : /* Warn about unused labels. */
19389 : 322576 : if (warn_unused_label)
19390 : 4387 : warn_unused_fortran_label (ns->st_labels);
19391 : :
19392 : 322576 : gfc_resolve_uops (ns->uop_root);
19393 : :
19394 : 322576 : gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
19395 : :
19396 : 322576 : gfc_resolve_omp_declare (ns);
19397 : :
19398 : 322576 : gfc_resolve_omp_udrs (ns->omp_udr_root);
19399 : :
19400 : 322576 : ns->types_resolved = 1;
19401 : :
19402 : 322576 : gfc_current_ns = old_ns;
19403 : : }
19404 : :
19405 : :
19406 : : /* Call gfc_resolve_code recursively. */
19407 : :
19408 : : static void
19409 : 324946 : resolve_codes (gfc_namespace *ns)
19410 : : {
19411 : 324946 : gfc_namespace *n;
19412 : 324946 : bitmap_obstack old_obstack;
19413 : :
19414 : 324946 : if (ns->resolved == 1)
19415 : 12475 : return;
19416 : :
19417 : 357225 : for (n = ns->contained; n; n = n->sibling)
19418 : 44754 : resolve_codes (n);
19419 : :
19420 : 312471 : gfc_current_ns = ns;
19421 : :
19422 : : /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
19423 : 312471 : if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
19424 : 301176 : cs_base = NULL;
19425 : :
19426 : : /* Set to an out of range value. */
19427 : 312471 : current_entry_id = -1;
19428 : :
19429 : 312471 : old_obstack = labels_obstack;
19430 : 312471 : bitmap_obstack_initialize (&labels_obstack);
19431 : :
19432 : 312471 : gfc_resolve_oacc_declare (ns);
19433 : 312471 : gfc_resolve_oacc_routines (ns);
19434 : 312471 : gfc_resolve_omp_local_vars (ns);
19435 : 312471 : if (ns->omp_allocate)
19436 : 55 : gfc_resolve_omp_allocate (ns, ns->omp_allocate);
19437 : 312471 : gfc_resolve_code (ns->code, ns);
19438 : :
19439 : 312470 : bitmap_obstack_release (&labels_obstack);
19440 : 312470 : labels_obstack = old_obstack;
19441 : : }
19442 : :
19443 : :
19444 : : /* This function is called after a complete program unit has been compiled.
19445 : : Its purpose is to examine all of the expressions associated with a program
19446 : : unit, assign types to all intermediate expressions, make sure that all
19447 : : assignments are to compatible types and figure out which names refer to
19448 : : which functions or subroutines. */
19449 : :
19450 : : void
19451 : 284571 : gfc_resolve (gfc_namespace *ns)
19452 : : {
19453 : 284571 : gfc_namespace *old_ns;
19454 : 284571 : code_stack *old_cs_base;
19455 : 284571 : struct gfc_omp_saved_state old_omp_state;
19456 : :
19457 : 284571 : if (ns->resolved)
19458 : 4379 : return;
19459 : :
19460 : 280192 : ns->resolved = -1;
19461 : 280192 : old_ns = gfc_current_ns;
19462 : 280192 : old_cs_base = cs_base;
19463 : :
19464 : : /* As gfc_resolve can be called during resolution of an OpenMP construct
19465 : : body, we should clear any state associated to it, so that say NS's
19466 : : DO loops are not interpreted as OpenMP loops. */
19467 : 280192 : if (!ns->construct_entities)
19468 : 268897 : gfc_omp_save_and_clear_state (&old_omp_state);
19469 : :
19470 : 280192 : resolve_types (ns);
19471 : 280192 : component_assignment_level = 0;
19472 : 280192 : resolve_codes (ns);
19473 : :
19474 : 280191 : if (ns->omp_assumes)
19475 : 13 : gfc_resolve_omp_assumptions (ns->omp_assumes);
19476 : :
19477 : 280191 : gfc_current_ns = old_ns;
19478 : 280191 : cs_base = old_cs_base;
19479 : 280191 : ns->resolved = 1;
19480 : :
19481 : 280191 : gfc_run_passes (ns);
19482 : :
19483 : 280191 : if (!ns->construct_entities)
19484 : 268896 : gfc_omp_restore_state (&old_omp_state);
19485 : : }
|
