1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2016 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 /* Nonzero if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77 static int formal_arg_flag = 0;
78
79 /* True if we are resolving a specification expression. */
80 static bool specification_expr = false;
81
82 /* The id of the last entry seen. */
83 static int current_entry_id;
84
85 /* We use bitmaps to determine if a branch target is valid. */
86 static bitmap_obstack labels_obstack;
87
88 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89 static bool inquiry_argument = false;
90
91
92 int
gfc_is_formal_arg(void)93 gfc_is_formal_arg (void)
94 {
95 return formal_arg_flag;
96 }
97
98 /* Is the symbol host associated? */
99 static bool
is_sym_host_assoc(gfc_symbol * sym,gfc_namespace * ns)100 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
101 {
102 for (ns = ns->parent; ns; ns = ns->parent)
103 {
104 if (sym->ns == ns)
105 return true;
106 }
107
108 return false;
109 }
110
111 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
114
115 static bool
resolve_typespec_used(gfc_typespec * ts,locus * where,const char * name)116 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
117 {
118 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
119 {
120 if (where)
121 {
122 if (name)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name, where, ts->u.derived->name);
125 else
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts->u.derived->name, where);
128 }
129
130 return false;
131 }
132
133 return true;
134 }
135
136
137 static bool
check_proc_interface(gfc_symbol * ifc,locus * where)138 check_proc_interface (gfc_symbol *ifc, locus *where)
139 {
140 /* Several checks for F08:C1216. */
141 if (ifc->attr.procedure)
142 {
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc->name, where);
145 return false;
146 }
147 if (ifc->generic)
148 {
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface *gen = ifc->generic;
152 while (gen && strcmp (gen->sym->name, ifc->name) != 0)
153 gen = gen->next;
154 if (!gen)
155 {
156 gfc_error ("Interface %qs at %L may not be generic",
157 ifc->name, where);
158 return false;
159 }
160 }
161 if (ifc->attr.proc == PROC_ST_FUNCTION)
162 {
163 gfc_error ("Interface %qs at %L may not be a statement function",
164 ifc->name, where);
165 return false;
166 }
167 if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
168 || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
169 ifc->attr.intrinsic = 1;
170 if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
171 {
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc->name, where);
174 return false;
175 }
176 if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
177 {
178 gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
179 return false;
180 }
181 return true;
182 }
183
184
185 static void resolve_symbol (gfc_symbol *sym);
186
187
188 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
189
190 static bool
resolve_procedure_interface(gfc_symbol * sym)191 resolve_procedure_interface (gfc_symbol *sym)
192 {
193 gfc_symbol *ifc = sym->ts.interface;
194
195 if (!ifc)
196 return true;
197
198 if (ifc == sym)
199 {
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym->name, &sym->declared_at);
202 return false;
203 }
204 if (!check_proc_interface (ifc, &sym->declared_at))
205 return false;
206
207 if (ifc->attr.if_source || ifc->attr.intrinsic)
208 {
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc);
211 if (ifc->attr.intrinsic)
212 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
213
214 if (ifc->result)
215 {
216 sym->ts = ifc->result->ts;
217 sym->result = sym;
218 }
219 else
220 sym->ts = ifc->ts;
221 sym->ts.interface = ifc;
222 sym->attr.function = ifc->attr.function;
223 sym->attr.subroutine = ifc->attr.subroutine;
224
225 sym->attr.allocatable = ifc->attr.allocatable;
226 sym->attr.pointer = ifc->attr.pointer;
227 sym->attr.pure = ifc->attr.pure;
228 sym->attr.elemental = ifc->attr.elemental;
229 sym->attr.dimension = ifc->attr.dimension;
230 sym->attr.contiguous = ifc->attr.contiguous;
231 sym->attr.recursive = ifc->attr.recursive;
232 sym->attr.always_explicit = ifc->attr.always_explicit;
233 sym->attr.ext_attr |= ifc->attr.ext_attr;
234 sym->attr.is_bind_c = ifc->attr.is_bind_c;
235 sym->attr.class_ok = ifc->attr.class_ok;
236 /* Copy array spec. */
237 sym->as = gfc_copy_array_spec (ifc->as);
238 /* Copy char length. */
239 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
240 {
241 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
242 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
243 && !gfc_resolve_expr (sym->ts.u.cl->length))
244 return false;
245 }
246 }
247
248 return true;
249 }
250
251
252 /* Resolve types of formal argument lists. These have to be done early so that
253 the formal argument lists of module procedures can be copied to the
254 containing module before the individual procedures are resolved
255 individually. We also resolve argument lists of procedures in interface
256 blocks because they are self-contained scoping units.
257
258 Since a dummy argument cannot be a non-dummy procedure, the only
259 resort left for untyped names are the IMPLICIT types. */
260
261 static void
resolve_formal_arglist(gfc_symbol * proc)262 resolve_formal_arglist (gfc_symbol *proc)
263 {
264 gfc_formal_arglist *f;
265 gfc_symbol *sym;
266 bool saved_specification_expr;
267 int i;
268
269 if (proc->result != NULL)
270 sym = proc->result;
271 else
272 sym = proc;
273
274 if (gfc_elemental (proc)
275 || sym->attr.pointer || sym->attr.allocatable
276 || (sym->as && sym->as->rank != 0))
277 {
278 proc->attr.always_explicit = 1;
279 sym->attr.always_explicit = 1;
280 }
281
282 formal_arg_flag = 1;
283
284 for (f = proc->formal; f; f = f->next)
285 {
286 gfc_array_spec *as;
287
288 sym = f->sym;
289
290 if (sym == NULL)
291 {
292 /* Alternate return placeholder. */
293 if (gfc_elemental (proc))
294 gfc_error ("Alternate return specifier in elemental subroutine "
295 "%qs at %L is not allowed", proc->name,
296 &proc->declared_at);
297 if (proc->attr.function)
298 gfc_error ("Alternate return specifier in function "
299 "%qs at %L is not allowed", proc->name,
300 &proc->declared_at);
301 continue;
302 }
303 else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
304 && !resolve_procedure_interface (sym))
305 return;
306
307 if (strcmp (proc->name, sym->name) == 0)
308 {
309 gfc_error ("Self-referential argument "
310 "%qs at %L is not allowed", sym->name,
311 &proc->declared_at);
312 return;
313 }
314
315 if (sym->attr.if_source != IFSRC_UNKNOWN)
316 resolve_formal_arglist (sym);
317
318 if (sym->attr.subroutine || sym->attr.external)
319 {
320 if (sym->attr.flavor == FL_UNKNOWN)
321 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
322 }
323 else
324 {
325 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
326 && (!sym->attr.function || sym->result == sym))
327 gfc_set_default_type (sym, 1, sym->ns);
328 }
329
330 as = sym->ts.type == BT_CLASS && sym->attr.class_ok
331 ? CLASS_DATA (sym)->as : sym->as;
332
333 saved_specification_expr = specification_expr;
334 specification_expr = true;
335 gfc_resolve_array_spec (as, 0);
336 specification_expr = saved_specification_expr;
337
338 /* We can't tell if an array with dimension (:) is assumed or deferred
339 shape until we know if it has the pointer or allocatable attributes.
340 */
341 if (as && as->rank > 0 && as->type == AS_DEFERRED
342 && ((sym->ts.type != BT_CLASS
343 && !(sym->attr.pointer || sym->attr.allocatable))
344 || (sym->ts.type == BT_CLASS
345 && !(CLASS_DATA (sym)->attr.class_pointer
346 || CLASS_DATA (sym)->attr.allocatable)))
347 && sym->attr.flavor != FL_PROCEDURE)
348 {
349 as->type = AS_ASSUMED_SHAPE;
350 for (i = 0; i < as->rank; i++)
351 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
352 }
353
354 if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
355 || (as && as->type == AS_ASSUMED_RANK)
356 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
357 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
358 && (CLASS_DATA (sym)->attr.class_pointer
359 || CLASS_DATA (sym)->attr.allocatable
360 || CLASS_DATA (sym)->attr.target))
361 || sym->attr.optional)
362 {
363 proc->attr.always_explicit = 1;
364 if (proc->result)
365 proc->result->attr.always_explicit = 1;
366 }
367
368 /* If the flavor is unknown at this point, it has to be a variable.
369 A procedure specification would have already set the type. */
370
371 if (sym->attr.flavor == FL_UNKNOWN)
372 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
373
374 if (gfc_pure (proc))
375 {
376 if (sym->attr.flavor == FL_PROCEDURE)
377 {
378 /* F08:C1279. */
379 if (!gfc_pure (sym))
380 {
381 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
382 "also be PURE", sym->name, &sym->declared_at);
383 continue;
384 }
385 }
386 else if (!sym->attr.pointer)
387 {
388 if (proc->attr.function && sym->attr.intent != INTENT_IN)
389 {
390 if (sym->attr.value)
391 gfc_notify_std (GFC_STD_F2008, "Argument %qs"
392 " of pure function %qs at %L with VALUE "
393 "attribute but without INTENT(IN)",
394 sym->name, proc->name, &sym->declared_at);
395 else
396 gfc_error ("Argument %qs of pure function %qs at %L must "
397 "be INTENT(IN) or VALUE", sym->name, proc->name,
398 &sym->declared_at);
399 }
400
401 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
402 {
403 if (sym->attr.value)
404 gfc_notify_std (GFC_STD_F2008, "Argument %qs"
405 " of pure subroutine %qs at %L with VALUE "
406 "attribute but without INTENT", sym->name,
407 proc->name, &sym->declared_at);
408 else
409 gfc_error ("Argument %qs of pure subroutine %qs at %L "
410 "must have its INTENT specified or have the "
411 "VALUE attribute", sym->name, proc->name,
412 &sym->declared_at);
413 }
414 }
415
416 /* F08:C1278a. */
417 if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
418 {
419 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
420 " may not be polymorphic", sym->name, proc->name,
421 &sym->declared_at);
422 continue;
423 }
424 }
425
426 if (proc->attr.implicit_pure)
427 {
428 if (sym->attr.flavor == FL_PROCEDURE)
429 {
430 if (!gfc_pure (sym))
431 proc->attr.implicit_pure = 0;
432 }
433 else if (!sym->attr.pointer)
434 {
435 if (proc->attr.function && sym->attr.intent != INTENT_IN
436 && !sym->value)
437 proc->attr.implicit_pure = 0;
438
439 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
440 && !sym->value)
441 proc->attr.implicit_pure = 0;
442 }
443 }
444
445 if (gfc_elemental (proc))
446 {
447 /* F08:C1289. */
448 if (sym->attr.codimension
449 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
450 && CLASS_DATA (sym)->attr.codimension))
451 {
452 gfc_error ("Coarray dummy argument %qs at %L to elemental "
453 "procedure", sym->name, &sym->declared_at);
454 continue;
455 }
456
457 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
458 && CLASS_DATA (sym)->as))
459 {
460 gfc_error ("Argument %qs of elemental procedure at %L must "
461 "be scalar", sym->name, &sym->declared_at);
462 continue;
463 }
464
465 if (sym->attr.allocatable
466 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
467 && CLASS_DATA (sym)->attr.allocatable))
468 {
469 gfc_error ("Argument %qs of elemental procedure at %L cannot "
470 "have the ALLOCATABLE attribute", sym->name,
471 &sym->declared_at);
472 continue;
473 }
474
475 if (sym->attr.pointer
476 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
477 && CLASS_DATA (sym)->attr.class_pointer))
478 {
479 gfc_error ("Argument %qs of elemental procedure at %L cannot "
480 "have the POINTER attribute", sym->name,
481 &sym->declared_at);
482 continue;
483 }
484
485 if (sym->attr.flavor == FL_PROCEDURE)
486 {
487 gfc_error ("Dummy procedure %qs not allowed in elemental "
488 "procedure %qs at %L", sym->name, proc->name,
489 &sym->declared_at);
490 continue;
491 }
492
493 /* Fortran 2008 Corrigendum 1, C1290a. */
494 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
495 {
496 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
497 "have its INTENT specified or have the VALUE "
498 "attribute", sym->name, proc->name,
499 &sym->declared_at);
500 continue;
501 }
502 }
503
504 /* Each dummy shall be specified to be scalar. */
505 if (proc->attr.proc == PROC_ST_FUNCTION)
506 {
507 if (sym->as != NULL)
508 {
509 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
510 shall be specified, explicitly or implicitly, to be scalar. */
511 gfc_error ("Argument '%s' of statement function '%s' at %L "
512 "must be scalar", sym->name, proc->name,
513 &proc->declared_at);
514 continue;
515 }
516
517 if (sym->ts.type == BT_CHARACTER)
518 {
519 gfc_charlen *cl = sym->ts.u.cl;
520 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
521 {
522 gfc_error ("Character-valued argument %qs of statement "
523 "function at %L must have constant length",
524 sym->name, &sym->declared_at);
525 continue;
526 }
527 }
528 }
529 }
530 formal_arg_flag = 0;
531 }
532
533
534 /* Work function called when searching for symbols that have argument lists
535 associated with them. */
536
537 static void
find_arglists(gfc_symbol * sym)538 find_arglists (gfc_symbol *sym)
539 {
540 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
541 || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
542 return;
543
544 resolve_formal_arglist (sym);
545 }
546
547
548 /* Given a namespace, resolve all formal argument lists within the namespace.
549 */
550
551 static void
resolve_formal_arglists(gfc_namespace * ns)552 resolve_formal_arglists (gfc_namespace *ns)
553 {
554 if (ns == NULL)
555 return;
556
557 gfc_traverse_ns (ns, find_arglists);
558 }
559
560
561 static void
resolve_contained_fntype(gfc_symbol * sym,gfc_namespace * ns)562 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
563 {
564 bool t;
565
566 /* If this namespace is not a function or an entry master function,
567 ignore it. */
568 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
569 || sym->attr.entry_master)
570 return;
571
572 /* Try to find out of what the return type is. */
573 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
574 {
575 t = gfc_set_default_type (sym->result, 0, ns);
576
577 if (!t && !sym->result->attr.untyped)
578 {
579 if (sym->result == sym)
580 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
581 sym->name, &sym->declared_at);
582 else if (!sym->result->attr.proc_pointer)
583 gfc_error ("Result %qs of contained function %qs at %L has "
584 "no IMPLICIT type", sym->result->name, sym->name,
585 &sym->result->declared_at);
586 sym->result->attr.untyped = 1;
587 }
588 }
589
590 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
591 type, lists the only ways a character length value of * can be used:
592 dummy arguments of procedures, named constants, and function results
593 in external functions. Internal function results and results of module
594 procedures are not on this list, ergo, not permitted. */
595
596 if (sym->result->ts.type == BT_CHARACTER)
597 {
598 gfc_charlen *cl = sym->result->ts.u.cl;
599 if ((!cl || !cl->length) && !sym->result->ts.deferred)
600 {
601 /* See if this is a module-procedure and adapt error message
602 accordingly. */
603 bool module_proc;
604 gcc_assert (ns->parent && ns->parent->proc_name);
605 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
606
607 gfc_error ("Character-valued %s %qs at %L must not be"
608 " assumed length",
609 module_proc ? _("module procedure")
610 : _("internal function"),
611 sym->name, &sym->declared_at);
612 }
613 }
614 }
615
616
617 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
618 introduce duplicates. */
619
620 static void
merge_argument_lists(gfc_symbol * proc,gfc_formal_arglist * new_args)621 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
622 {
623 gfc_formal_arglist *f, *new_arglist;
624 gfc_symbol *new_sym;
625
626 for (; new_args != NULL; new_args = new_args->next)
627 {
628 new_sym = new_args->sym;
629 /* See if this arg is already in the formal argument list. */
630 for (f = proc->formal; f; f = f->next)
631 {
632 if (new_sym == f->sym)
633 break;
634 }
635
636 if (f)
637 continue;
638
639 /* Add a new argument. Argument order is not important. */
640 new_arglist = gfc_get_formal_arglist ();
641 new_arglist->sym = new_sym;
642 new_arglist->next = proc->formal;
643 proc->formal = new_arglist;
644 }
645 }
646
647
648 /* Flag the arguments that are not present in all entries. */
649
650 static void
check_argument_lists(gfc_symbol * proc,gfc_formal_arglist * new_args)651 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
652 {
653 gfc_formal_arglist *f, *head;
654 head = new_args;
655
656 for (f = proc->formal; f; f = f->next)
657 {
658 if (f->sym == NULL)
659 continue;
660
661 for (new_args = head; new_args; new_args = new_args->next)
662 {
663 if (new_args->sym == f->sym)
664 break;
665 }
666
667 if (new_args)
668 continue;
669
670 f->sym->attr.not_always_present = 1;
671 }
672 }
673
674
675 /* Resolve alternate entry points. If a symbol has multiple entry points we
676 create a new master symbol for the main routine, and turn the existing
677 symbol into an entry point. */
678
679 static void
resolve_entries(gfc_namespace * ns)680 resolve_entries (gfc_namespace *ns)
681 {
682 gfc_namespace *old_ns;
683 gfc_code *c;
684 gfc_symbol *proc;
685 gfc_entry_list *el;
686 char name[GFC_MAX_SYMBOL_LEN + 1];
687 static int master_count = 0;
688
689 if (ns->proc_name == NULL)
690 return;
691
692 /* No need to do anything if this procedure doesn't have alternate entry
693 points. */
694 if (!ns->entries)
695 return;
696
697 /* We may already have resolved alternate entry points. */
698 if (ns->proc_name->attr.entry_master)
699 return;
700
701 /* If this isn't a procedure something has gone horribly wrong. */
702 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
703
704 /* Remember the current namespace. */
705 old_ns = gfc_current_ns;
706
707 gfc_current_ns = ns;
708
709 /* Add the main entry point to the list of entry points. */
710 el = gfc_get_entry_list ();
711 el->sym = ns->proc_name;
712 el->id = 0;
713 el->next = ns->entries;
714 ns->entries = el;
715 ns->proc_name->attr.entry = 1;
716
717 /* If it is a module function, it needs to be in the right namespace
718 so that gfc_get_fake_result_decl can gather up the results. The
719 need for this arose in get_proc_name, where these beasts were
720 left in their own namespace, to keep prior references linked to
721 the entry declaration.*/
722 if (ns->proc_name->attr.function
723 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
724 el->sym->ns = ns;
725
726 /* Do the same for entries where the master is not a module
727 procedure. These are retained in the module namespace because
728 of the module procedure declaration. */
729 for (el = el->next; el; el = el->next)
730 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
731 && el->sym->attr.mod_proc)
732 el->sym->ns = ns;
733 el = ns->entries;
734
735 /* Add an entry statement for it. */
736 c = gfc_get_code (EXEC_ENTRY);
737 c->ext.entry = el;
738 c->next = ns->code;
739 ns->code = c;
740
741 /* Create a new symbol for the master function. */
742 /* Give the internal function a unique name (within this file).
743 Also include the function name so the user has some hope of figuring
744 out what is going on. */
745 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
746 master_count++, ns->proc_name->name);
747 gfc_get_ha_symbol (name, &proc);
748 gcc_assert (proc != NULL);
749
750 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
751 if (ns->proc_name->attr.subroutine)
752 gfc_add_subroutine (&proc->attr, proc->name, NULL);
753 else
754 {
755 gfc_symbol *sym;
756 gfc_typespec *ts, *fts;
757 gfc_array_spec *as, *fas;
758 gfc_add_function (&proc->attr, proc->name, NULL);
759 proc->result = proc;
760 fas = ns->entries->sym->as;
761 fas = fas ? fas : ns->entries->sym->result->as;
762 fts = &ns->entries->sym->result->ts;
763 if (fts->type == BT_UNKNOWN)
764 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
765 for (el = ns->entries->next; el; el = el->next)
766 {
767 ts = &el->sym->result->ts;
768 as = el->sym->as;
769 as = as ? as : el->sym->result->as;
770 if (ts->type == BT_UNKNOWN)
771 ts = gfc_get_default_type (el->sym->result->name, NULL);
772
773 if (! gfc_compare_types (ts, fts)
774 || (el->sym->result->attr.dimension
775 != ns->entries->sym->result->attr.dimension)
776 || (el->sym->result->attr.pointer
777 != ns->entries->sym->result->attr.pointer))
778 break;
779 else if (as && fas && ns->entries->sym->result != el->sym->result
780 && gfc_compare_array_spec (as, fas) == 0)
781 gfc_error ("Function %s at %L has entries with mismatched "
782 "array specifications", ns->entries->sym->name,
783 &ns->entries->sym->declared_at);
784 /* The characteristics need to match and thus both need to have
785 the same string length, i.e. both len=*, or both len=4.
786 Having both len=<variable> is also possible, but difficult to
787 check at compile time. */
788 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
789 && (((ts->u.cl->length && !fts->u.cl->length)
790 ||(!ts->u.cl->length && fts->u.cl->length))
791 || (ts->u.cl->length
792 && ts->u.cl->length->expr_type
793 != fts->u.cl->length->expr_type)
794 || (ts->u.cl->length
795 && ts->u.cl->length->expr_type == EXPR_CONSTANT
796 && mpz_cmp (ts->u.cl->length->value.integer,
797 fts->u.cl->length->value.integer) != 0)))
798 gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
799 "entries returning variables of different "
800 "string lengths", ns->entries->sym->name,
801 &ns->entries->sym->declared_at);
802 }
803
804 if (el == NULL)
805 {
806 sym = ns->entries->sym->result;
807 /* All result types the same. */
808 proc->ts = *fts;
809 if (sym->attr.dimension)
810 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
811 if (sym->attr.pointer)
812 gfc_add_pointer (&proc->attr, NULL);
813 }
814 else
815 {
816 /* Otherwise the result will be passed through a union by
817 reference. */
818 proc->attr.mixed_entry_master = 1;
819 for (el = ns->entries; el; el = el->next)
820 {
821 sym = el->sym->result;
822 if (sym->attr.dimension)
823 {
824 if (el == ns->entries)
825 gfc_error ("FUNCTION result %s can't be an array in "
826 "FUNCTION %s at %L", sym->name,
827 ns->entries->sym->name, &sym->declared_at);
828 else
829 gfc_error ("ENTRY result %s can't be an array in "
830 "FUNCTION %s at %L", sym->name,
831 ns->entries->sym->name, &sym->declared_at);
832 }
833 else if (sym->attr.pointer)
834 {
835 if (el == ns->entries)
836 gfc_error ("FUNCTION result %s can't be a POINTER in "
837 "FUNCTION %s at %L", sym->name,
838 ns->entries->sym->name, &sym->declared_at);
839 else
840 gfc_error ("ENTRY result %s can't be a POINTER in "
841 "FUNCTION %s at %L", sym->name,
842 ns->entries->sym->name, &sym->declared_at);
843 }
844 else
845 {
846 ts = &sym->ts;
847 if (ts->type == BT_UNKNOWN)
848 ts = gfc_get_default_type (sym->name, NULL);
849 switch (ts->type)
850 {
851 case BT_INTEGER:
852 if (ts->kind == gfc_default_integer_kind)
853 sym = NULL;
854 break;
855 case BT_REAL:
856 if (ts->kind == gfc_default_real_kind
857 || ts->kind == gfc_default_double_kind)
858 sym = NULL;
859 break;
860 case BT_COMPLEX:
861 if (ts->kind == gfc_default_complex_kind)
862 sym = NULL;
863 break;
864 case BT_LOGICAL:
865 if (ts->kind == gfc_default_logical_kind)
866 sym = NULL;
867 break;
868 case BT_UNKNOWN:
869 /* We will issue error elsewhere. */
870 sym = NULL;
871 break;
872 default:
873 break;
874 }
875 if (sym)
876 {
877 if (el == ns->entries)
878 gfc_error ("FUNCTION result %s can't be of type %s "
879 "in FUNCTION %s at %L", sym->name,
880 gfc_typename (ts), ns->entries->sym->name,
881 &sym->declared_at);
882 else
883 gfc_error ("ENTRY result %s can't be of type %s "
884 "in FUNCTION %s at %L", sym->name,
885 gfc_typename (ts), ns->entries->sym->name,
886 &sym->declared_at);
887 }
888 }
889 }
890 }
891 }
892 proc->attr.access = ACCESS_PRIVATE;
893 proc->attr.entry_master = 1;
894
895 /* Merge all the entry point arguments. */
896 for (el = ns->entries; el; el = el->next)
897 merge_argument_lists (proc, el->sym->formal);
898
899 /* Check the master formal arguments for any that are not
900 present in all entry points. */
901 for (el = ns->entries; el; el = el->next)
902 check_argument_lists (proc, el->sym->formal);
903
904 /* Use the master function for the function body. */
905 ns->proc_name = proc;
906
907 /* Finalize the new symbols. */
908 gfc_commit_symbols ();
909
910 /* Restore the original namespace. */
911 gfc_current_ns = old_ns;
912 }
913
914
915 /* Resolve common variables. */
916 static void
resolve_common_vars(gfc_common_head * common_block,bool named_common)917 resolve_common_vars (gfc_common_head *common_block, bool named_common)
918 {
919 gfc_symbol *csym = common_block->head;
920
921 for (; csym; csym = csym->common_next)
922 {
923 /* gfc_add_in_common may have been called before, but the reported errors
924 have been ignored to continue parsing.
925 We do the checks again here. */
926 if (!csym->attr.use_assoc)
927 gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
928
929 if (csym->value || csym->attr.data)
930 {
931 if (!csym->ns->is_block_data)
932 gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
933 "but only in BLOCK DATA initialization is "
934 "allowed", csym->name, &csym->declared_at);
935 else if (!named_common)
936 gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
937 "in a blank COMMON but initialization is only "
938 "allowed in named common blocks", csym->name,
939 &csym->declared_at);
940 }
941
942 if (UNLIMITED_POLY (csym))
943 gfc_error_now ("%qs in cannot appear in COMMON at %L "
944 "[F2008:C5100]", csym->name, &csym->declared_at);
945
946 if (csym->ts.type != BT_DERIVED)
947 continue;
948
949 if (!(csym->ts.u.derived->attr.sequence
950 || csym->ts.u.derived->attr.is_bind_c))
951 gfc_error_now ("Derived type variable %qs in COMMON at %L "
952 "has neither the SEQUENCE nor the BIND(C) "
953 "attribute", csym->name, &csym->declared_at);
954 if (csym->ts.u.derived->attr.alloc_comp)
955 gfc_error_now ("Derived type variable %qs in COMMON at %L "
956 "has an ultimate component that is "
957 "allocatable", csym->name, &csym->declared_at);
958 if (gfc_has_default_initializer (csym->ts.u.derived))
959 gfc_error_now ("Derived type variable %qs in COMMON at %L "
960 "may not have default initializer", csym->name,
961 &csym->declared_at);
962
963 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
964 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
965 }
966 }
967
968 /* Resolve common blocks. */
969 static void
resolve_common_blocks(gfc_symtree * common_root)970 resolve_common_blocks (gfc_symtree *common_root)
971 {
972 gfc_symbol *sym;
973 gfc_gsymbol * gsym;
974
975 if (common_root == NULL)
976 return;
977
978 if (common_root->left)
979 resolve_common_blocks (common_root->left);
980 if (common_root->right)
981 resolve_common_blocks (common_root->right);
982
983 resolve_common_vars (common_root->n.common, true);
984
985 /* The common name is a global name - in Fortran 2003 also if it has a
986 C binding name, since Fortran 2008 only the C binding name is a global
987 identifier. */
988 if (!common_root->n.common->binding_label
989 || gfc_notification_std (GFC_STD_F2008))
990 {
991 gsym = gfc_find_gsymbol (gfc_gsym_root,
992 common_root->n.common->name);
993
994 if (gsym && gfc_notification_std (GFC_STD_F2008)
995 && gsym->type == GSYM_COMMON
996 && ((common_root->n.common->binding_label
997 && (!gsym->binding_label
998 || strcmp (common_root->n.common->binding_label,
999 gsym->binding_label) != 0))
1000 || (!common_root->n.common->binding_label
1001 && gsym->binding_label)))
1002 {
1003 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1004 "identifier and must thus have the same binding name "
1005 "as the same-named COMMON block at %L: %s vs %s",
1006 common_root->n.common->name, &common_root->n.common->where,
1007 &gsym->where,
1008 common_root->n.common->binding_label
1009 ? common_root->n.common->binding_label : "(blank)",
1010 gsym->binding_label ? gsym->binding_label : "(blank)");
1011 return;
1012 }
1013
1014 if (gsym && gsym->type != GSYM_COMMON
1015 && !common_root->n.common->binding_label)
1016 {
1017 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1018 "as entity at %L",
1019 common_root->n.common->name, &common_root->n.common->where,
1020 &gsym->where);
1021 return;
1022 }
1023 if (gsym && gsym->type != GSYM_COMMON)
1024 {
1025 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1026 "%L sharing the identifier with global non-COMMON-block "
1027 "entity at %L", common_root->n.common->name,
1028 &common_root->n.common->where, &gsym->where);
1029 return;
1030 }
1031 if (!gsym)
1032 {
1033 gsym = gfc_get_gsymbol (common_root->n.common->name);
1034 gsym->type = GSYM_COMMON;
1035 gsym->where = common_root->n.common->where;
1036 gsym->defined = 1;
1037 }
1038 gsym->used = 1;
1039 }
1040
1041 if (common_root->n.common->binding_label)
1042 {
1043 gsym = gfc_find_gsymbol (gfc_gsym_root,
1044 common_root->n.common->binding_label);
1045 if (gsym && gsym->type != GSYM_COMMON)
1046 {
1047 gfc_error ("COMMON block at %L with binding label %s uses the same "
1048 "global identifier as entity at %L",
1049 &common_root->n.common->where,
1050 common_root->n.common->binding_label, &gsym->where);
1051 return;
1052 }
1053 if (!gsym)
1054 {
1055 gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
1056 gsym->type = GSYM_COMMON;
1057 gsym->where = common_root->n.common->where;
1058 gsym->defined = 1;
1059 }
1060 gsym->used = 1;
1061 }
1062
1063 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1064 if (sym == NULL)
1065 return;
1066
1067 if (sym->attr.flavor == FL_PARAMETER)
1068 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1069 sym->name, &common_root->n.common->where, &sym->declared_at);
1070
1071 if (sym->attr.external)
1072 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1073 sym->name, &common_root->n.common->where);
1074
1075 if (sym->attr.intrinsic)
1076 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1077 sym->name, &common_root->n.common->where);
1078 else if (sym->attr.result
1079 || gfc_is_function_return_value (sym, gfc_current_ns))
1080 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1081 "that is also a function result", sym->name,
1082 &common_root->n.common->where);
1083 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1084 && sym->attr.proc != PROC_ST_FUNCTION)
1085 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
1086 "that is also a global procedure", sym->name,
1087 &common_root->n.common->where);
1088 }
1089
1090
1091 /* Resolve contained function types. Because contained functions can call one
1092 another, they have to be worked out before any of the contained procedures
1093 can be resolved.
1094
1095 The good news is that if a function doesn't already have a type, the only
1096 way it can get one is through an IMPLICIT type or a RESULT variable, because
1097 by definition contained functions are contained namespace they're contained
1098 in, not in a sibling or parent namespace. */
1099
1100 static void
resolve_contained_functions(gfc_namespace * ns)1101 resolve_contained_functions (gfc_namespace *ns)
1102 {
1103 gfc_namespace *child;
1104 gfc_entry_list *el;
1105
1106 resolve_formal_arglists (ns);
1107
1108 for (child = ns->contained; child; child = child->sibling)
1109 {
1110 /* Resolve alternate entry points first. */
1111 resolve_entries (child);
1112
1113 /* Then check function return types. */
1114 resolve_contained_fntype (child->proc_name, child);
1115 for (el = child->entries; el; el = el->next)
1116 resolve_contained_fntype (el->sym, child);
1117 }
1118 }
1119
1120
1121 static bool resolve_fl_derived0 (gfc_symbol *sym);
1122 static bool resolve_fl_struct (gfc_symbol *sym);
1123
1124
1125 /* Resolve all of the elements of a structure constructor and make sure that
1126 the types are correct. The 'init' flag indicates that the given
1127 constructor is an initializer. */
1128
1129 static bool
resolve_structure_cons(gfc_expr * expr,int init)1130 resolve_structure_cons (gfc_expr *expr, int init)
1131 {
1132 gfc_constructor *cons;
1133 gfc_component *comp;
1134 bool t;
1135 symbol_attribute a;
1136
1137 t = true;
1138
1139 if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1140 {
1141 if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1142 resolve_fl_derived0 (expr->ts.u.derived);
1143 else
1144 resolve_fl_struct (expr->ts.u.derived);
1145 }
1146
1147 cons = gfc_constructor_first (expr->value.constructor);
1148
1149 /* A constructor may have references if it is the result of substituting a
1150 parameter variable. In this case we just pull out the component we
1151 want. */
1152 if (expr->ref)
1153 comp = expr->ref->u.c.sym->components;
1154 else
1155 comp = expr->ts.u.derived->components;
1156
1157 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1158 {
1159 int rank;
1160
1161 if (!cons->expr)
1162 continue;
1163
1164 if (!gfc_resolve_expr (cons->expr))
1165 {
1166 t = false;
1167 continue;
1168 }
1169
1170 rank = comp->as ? comp->as->rank : 0;
1171 if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->as)
1172 rank = CLASS_DATA (comp)->as->rank;
1173
1174 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1175 && (comp->attr.allocatable || cons->expr->rank))
1176 {
1177 gfc_error ("The rank of the element in the structure "
1178 "constructor at %L does not match that of the "
1179 "component (%d/%d)", &cons->expr->where,
1180 cons->expr->rank, rank);
1181 t = false;
1182 }
1183
1184 /* If we don't have the right type, try to convert it. */
1185
1186 if (!comp->attr.proc_pointer &&
1187 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1188 {
1189 if (strcmp (comp->name, "_extends") == 0)
1190 {
1191 /* Can afford to be brutal with the _extends initializer.
1192 The derived type can get lost because it is PRIVATE
1193 but it is not usage constrained by the standard. */
1194 cons->expr->ts = comp->ts;
1195 }
1196 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1197 {
1198 gfc_error ("The element in the structure constructor at %L, "
1199 "for pointer component %qs, is %s but should be %s",
1200 &cons->expr->where, comp->name,
1201 gfc_basic_typename (cons->expr->ts.type),
1202 gfc_basic_typename (comp->ts.type));
1203 t = false;
1204 }
1205 else
1206 {
1207 bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1208 if (t)
1209 t = t2;
1210 }
1211 }
1212
1213 /* For strings, the length of the constructor should be the same as
1214 the one of the structure, ensure this if the lengths are known at
1215 compile time and when we are dealing with PARAMETER or structure
1216 constructors. */
1217 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1218 && comp->ts.u.cl->length
1219 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1220 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1221 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1222 && cons->expr->rank != 0
1223 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1224 comp->ts.u.cl->length->value.integer) != 0)
1225 {
1226 if (cons->expr->expr_type == EXPR_VARIABLE
1227 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1228 {
1229 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1230 to make use of the gfc_resolve_character_array_constructor
1231 machinery. The expression is later simplified away to
1232 an array of string literals. */
1233 gfc_expr *para = cons->expr;
1234 cons->expr = gfc_get_expr ();
1235 cons->expr->ts = para->ts;
1236 cons->expr->where = para->where;
1237 cons->expr->expr_type = EXPR_ARRAY;
1238 cons->expr->rank = para->rank;
1239 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1240 gfc_constructor_append_expr (&cons->expr->value.constructor,
1241 para, &cons->expr->where);
1242 }
1243 if (cons->expr->expr_type == EXPR_ARRAY)
1244 {
1245 gfc_constructor *p;
1246 p = gfc_constructor_first (cons->expr->value.constructor);
1247 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1248 {
1249 gfc_charlen *cl, *cl2;
1250
1251 cl2 = NULL;
1252 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1253 {
1254 if (cl == cons->expr->ts.u.cl)
1255 break;
1256 cl2 = cl;
1257 }
1258
1259 gcc_assert (cl);
1260
1261 if (cl2)
1262 cl2->next = cl->next;
1263
1264 gfc_free_expr (cl->length);
1265 free (cl);
1266 }
1267
1268 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1269 cons->expr->ts.u.cl->length_from_typespec = true;
1270 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1271 gfc_resolve_character_array_constructor (cons->expr);
1272 }
1273 }
1274
1275 if (cons->expr->expr_type == EXPR_NULL
1276 && !(comp->attr.pointer || comp->attr.allocatable
1277 || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1278 || (comp->ts.type == BT_CLASS
1279 && (CLASS_DATA (comp)->attr.class_pointer
1280 || CLASS_DATA (comp)->attr.allocatable))))
1281 {
1282 t = false;
1283 gfc_error ("The NULL in the structure constructor at %L is "
1284 "being applied to component %qs, which is neither "
1285 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1286 comp->name);
1287 }
1288
1289 if (comp->attr.proc_pointer && comp->ts.interface)
1290 {
1291 /* Check procedure pointer interface. */
1292 gfc_symbol *s2 = NULL;
1293 gfc_component *c2;
1294 const char *name;
1295 char err[200];
1296
1297 c2 = gfc_get_proc_ptr_comp (cons->expr);
1298 if (c2)
1299 {
1300 s2 = c2->ts.interface;
1301 name = c2->name;
1302 }
1303 else if (cons->expr->expr_type == EXPR_FUNCTION)
1304 {
1305 s2 = cons->expr->symtree->n.sym->result;
1306 name = cons->expr->symtree->n.sym->result->name;
1307 }
1308 else if (cons->expr->expr_type != EXPR_NULL)
1309 {
1310 s2 = cons->expr->symtree->n.sym;
1311 name = cons->expr->symtree->n.sym->name;
1312 }
1313
1314 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1315 err, sizeof (err), NULL, NULL))
1316 {
1317 gfc_error ("Interface mismatch for procedure-pointer component "
1318 "%qs in structure constructor at %L: %s",
1319 comp->name, &cons->expr->where, err);
1320 return false;
1321 }
1322 }
1323
1324 if (!comp->attr.pointer || comp->attr.proc_pointer
1325 || cons->expr->expr_type == EXPR_NULL)
1326 continue;
1327
1328 a = gfc_expr_attr (cons->expr);
1329
1330 if (!a.pointer && !a.target)
1331 {
1332 t = false;
1333 gfc_error ("The element in the structure constructor at %L, "
1334 "for pointer component %qs should be a POINTER or "
1335 "a TARGET", &cons->expr->where, comp->name);
1336 }
1337
1338 if (init)
1339 {
1340 /* F08:C461. Additional checks for pointer initialization. */
1341 if (a.allocatable)
1342 {
1343 t = false;
1344 gfc_error ("Pointer initialization target at %L "
1345 "must not be ALLOCATABLE ", &cons->expr->where);
1346 }
1347 if (!a.save)
1348 {
1349 t = false;
1350 gfc_error ("Pointer initialization target at %L "
1351 "must have the SAVE attribute", &cons->expr->where);
1352 }
1353 }
1354
1355 /* F2003, C1272 (3). */
1356 bool impure = cons->expr->expr_type == EXPR_VARIABLE
1357 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1358 || gfc_is_coindexed (cons->expr));
1359 if (impure && gfc_pure (NULL))
1360 {
1361 t = false;
1362 gfc_error ("Invalid expression in the structure constructor for "
1363 "pointer component %qs at %L in PURE procedure",
1364 comp->name, &cons->expr->where);
1365 }
1366
1367 if (impure)
1368 gfc_unset_implicit_pure (NULL);
1369 }
1370
1371 return t;
1372 }
1373
1374
1375 /****************** Expression name resolution ******************/
1376
1377 /* Returns 0 if a symbol was not declared with a type or
1378 attribute declaration statement, nonzero otherwise. */
1379
1380 static int
was_declared(gfc_symbol * sym)1381 was_declared (gfc_symbol *sym)
1382 {
1383 symbol_attribute a;
1384
1385 a = sym->attr;
1386
1387 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1388 return 1;
1389
1390 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1391 || a.optional || a.pointer || a.save || a.target || a.volatile_
1392 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1393 || a.asynchronous || a.codimension)
1394 return 1;
1395
1396 return 0;
1397 }
1398
1399
1400 /* Determine if a symbol is generic or not. */
1401
1402 static int
generic_sym(gfc_symbol * sym)1403 generic_sym (gfc_symbol *sym)
1404 {
1405 gfc_symbol *s;
1406
1407 if (sym->attr.generic ||
1408 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1409 return 1;
1410
1411 if (was_declared (sym) || sym->ns->parent == NULL)
1412 return 0;
1413
1414 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1415
1416 if (s != NULL)
1417 {
1418 if (s == sym)
1419 return 0;
1420 else
1421 return generic_sym (s);
1422 }
1423
1424 return 0;
1425 }
1426
1427
1428 /* Determine if a symbol is specific or not. */
1429
1430 static int
specific_sym(gfc_symbol * sym)1431 specific_sym (gfc_symbol *sym)
1432 {
1433 gfc_symbol *s;
1434
1435 if (sym->attr.if_source == IFSRC_IFBODY
1436 || sym->attr.proc == PROC_MODULE
1437 || sym->attr.proc == PROC_INTERNAL
1438 || sym->attr.proc == PROC_ST_FUNCTION
1439 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1440 || sym->attr.external)
1441 return 1;
1442
1443 if (was_declared (sym) || sym->ns->parent == NULL)
1444 return 0;
1445
1446 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1447
1448 return (s == NULL) ? 0 : specific_sym (s);
1449 }
1450
1451
1452 /* Figure out if the procedure is specific, generic or unknown. */
1453
1454 enum proc_type
1455 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1456
1457 static proc_type
procedure_kind(gfc_symbol * sym)1458 procedure_kind (gfc_symbol *sym)
1459 {
1460 if (generic_sym (sym))
1461 return PTYPE_GENERIC;
1462
1463 if (specific_sym (sym))
1464 return PTYPE_SPECIFIC;
1465
1466 return PTYPE_UNKNOWN;
1467 }
1468
1469 /* Check references to assumed size arrays. The flag need_full_assumed_size
1470 is nonzero when matching actual arguments. */
1471
1472 static int need_full_assumed_size = 0;
1473
1474 static bool
check_assumed_size_reference(gfc_symbol * sym,gfc_expr * e)1475 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1476 {
1477 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1478 return false;
1479
1480 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1481 What should it be? */
1482 if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1483 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1484 && (e->ref->u.ar.type == AR_FULL))
1485 {
1486 gfc_error ("The upper bound in the last dimension must "
1487 "appear in the reference to the assumed size "
1488 "array %qs at %L", sym->name, &e->where);
1489 return true;
1490 }
1491 return false;
1492 }
1493
1494
1495 /* Look for bad assumed size array references in argument expressions
1496 of elemental and array valued intrinsic procedures. Since this is
1497 called from procedure resolution functions, it only recurses at
1498 operators. */
1499
1500 static bool
resolve_assumed_size_actual(gfc_expr * e)1501 resolve_assumed_size_actual (gfc_expr *e)
1502 {
1503 if (e == NULL)
1504 return false;
1505
1506 switch (e->expr_type)
1507 {
1508 case EXPR_VARIABLE:
1509 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1510 return true;
1511 break;
1512
1513 case EXPR_OP:
1514 if (resolve_assumed_size_actual (e->value.op.op1)
1515 || resolve_assumed_size_actual (e->value.op.op2))
1516 return true;
1517 break;
1518
1519 default:
1520 break;
1521 }
1522 return false;
1523 }
1524
1525
1526 /* Check a generic procedure, passed as an actual argument, to see if
1527 there is a matching specific name. If none, it is an error, and if
1528 more than one, the reference is ambiguous. */
1529 static int
count_specific_procs(gfc_expr * e)1530 count_specific_procs (gfc_expr *e)
1531 {
1532 int n;
1533 gfc_interface *p;
1534 gfc_symbol *sym;
1535
1536 n = 0;
1537 sym = e->symtree->n.sym;
1538
1539 for (p = sym->generic; p; p = p->next)
1540 if (strcmp (sym->name, p->sym->name) == 0)
1541 {
1542 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1543 sym->name);
1544 n++;
1545 }
1546
1547 if (n > 1)
1548 gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1549 &e->where);
1550
1551 if (n == 0)
1552 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1553 "argument at %L", sym->name, &e->where);
1554
1555 return n;
1556 }
1557
1558
1559 /* See if a call to sym could possibly be a not allowed RECURSION because of
1560 a missing RECURSIVE declaration. This means that either sym is the current
1561 context itself, or sym is the parent of a contained procedure calling its
1562 non-RECURSIVE containing procedure.
1563 This also works if sym is an ENTRY. */
1564
1565 static bool
is_illegal_recursion(gfc_symbol * sym,gfc_namespace * context)1566 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1567 {
1568 gfc_symbol* proc_sym;
1569 gfc_symbol* context_proc;
1570 gfc_namespace* real_context;
1571
1572 if (sym->attr.flavor == FL_PROGRAM
1573 || gfc_fl_struct (sym->attr.flavor))
1574 return false;
1575
1576 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1577
1578 /* If we've got an ENTRY, find real procedure. */
1579 if (sym->attr.entry && sym->ns->entries)
1580 proc_sym = sym->ns->entries->sym;
1581 else
1582 proc_sym = sym;
1583
1584 /* If sym is RECURSIVE, all is well of course. */
1585 if (proc_sym->attr.recursive || flag_recursive)
1586 return false;
1587
1588 /* Find the context procedure's "real" symbol if it has entries.
1589 We look for a procedure symbol, so recurse on the parents if we don't
1590 find one (like in case of a BLOCK construct). */
1591 for (real_context = context; ; real_context = real_context->parent)
1592 {
1593 /* We should find something, eventually! */
1594 gcc_assert (real_context);
1595
1596 context_proc = (real_context->entries ? real_context->entries->sym
1597 : real_context->proc_name);
1598
1599 /* In some special cases, there may not be a proc_name, like for this
1600 invalid code:
1601 real(bad_kind()) function foo () ...
1602 when checking the call to bad_kind ().
1603 In these cases, we simply return here and assume that the
1604 call is ok. */
1605 if (!context_proc)
1606 return false;
1607
1608 if (context_proc->attr.flavor != FL_LABEL)
1609 break;
1610 }
1611
1612 /* A call from sym's body to itself is recursion, of course. */
1613 if (context_proc == proc_sym)
1614 return true;
1615
1616 /* The same is true if context is a contained procedure and sym the
1617 containing one. */
1618 if (context_proc->attr.contained)
1619 {
1620 gfc_symbol* parent_proc;
1621
1622 gcc_assert (context->parent);
1623 parent_proc = (context->parent->entries ? context->parent->entries->sym
1624 : context->parent->proc_name);
1625
1626 if (parent_proc == proc_sym)
1627 return true;
1628 }
1629
1630 return false;
1631 }
1632
1633
1634 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1635 its typespec and formal argument list. */
1636
1637 bool
gfc_resolve_intrinsic(gfc_symbol * sym,locus * loc)1638 gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1639 {
1640 gfc_intrinsic_sym* isym = NULL;
1641 const char* symstd;
1642
1643 if (sym->formal)
1644 return true;
1645
1646 /* Already resolved. */
1647 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1648 return true;
1649
1650 /* We already know this one is an intrinsic, so we don't call
1651 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1652 gfc_find_subroutine directly to check whether it is a function or
1653 subroutine. */
1654
1655 if (sym->intmod_sym_id && sym->attr.subroutine)
1656 {
1657 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1658 isym = gfc_intrinsic_subroutine_by_id (id);
1659 }
1660 else if (sym->intmod_sym_id)
1661 {
1662 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1663 isym = gfc_intrinsic_function_by_id (id);
1664 }
1665 else if (!sym->attr.subroutine)
1666 isym = gfc_find_function (sym->name);
1667
1668 if (isym && !sym->attr.subroutine)
1669 {
1670 if (sym->ts.type != BT_UNKNOWN && warn_surprising
1671 && !sym->attr.implicit_type)
1672 gfc_warning (OPT_Wsurprising,
1673 "Type specified for intrinsic function %qs at %L is"
1674 " ignored", sym->name, &sym->declared_at);
1675
1676 if (!sym->attr.function &&
1677 !gfc_add_function(&sym->attr, sym->name, loc))
1678 return false;
1679
1680 sym->ts = isym->ts;
1681 }
1682 else if (isym || (isym = gfc_find_subroutine (sym->name)))
1683 {
1684 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1685 {
1686 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1687 " specifier", sym->name, &sym->declared_at);
1688 return false;
1689 }
1690
1691 if (!sym->attr.subroutine &&
1692 !gfc_add_subroutine(&sym->attr, sym->name, loc))
1693 return false;
1694 }
1695 else
1696 {
1697 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1698 &sym->declared_at);
1699 return false;
1700 }
1701
1702 gfc_copy_formal_args_intr (sym, isym, NULL);
1703
1704 sym->attr.pure = isym->pure;
1705 sym->attr.elemental = isym->elemental;
1706
1707 /* Check it is actually available in the standard settings. */
1708 if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1709 {
1710 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1711 "available in the current standard settings but %s. Use "
1712 "an appropriate %<-std=*%> option or enable "
1713 "%<-fall-intrinsics%> in order to use it.",
1714 sym->name, &sym->declared_at, symstd);
1715 return false;
1716 }
1717
1718 return true;
1719 }
1720
1721
1722 /* Resolve a procedure expression, like passing it to a called procedure or as
1723 RHS for a procedure pointer assignment. */
1724
1725 static bool
resolve_procedure_expression(gfc_expr * expr)1726 resolve_procedure_expression (gfc_expr* expr)
1727 {
1728 gfc_symbol* sym;
1729
1730 if (expr->expr_type != EXPR_VARIABLE)
1731 return true;
1732 gcc_assert (expr->symtree);
1733
1734 sym = expr->symtree->n.sym;
1735
1736 if (sym->attr.intrinsic)
1737 gfc_resolve_intrinsic (sym, &expr->where);
1738
1739 if (sym->attr.flavor != FL_PROCEDURE
1740 || (sym->attr.function && sym->result == sym))
1741 return true;
1742
1743 /* A non-RECURSIVE procedure that is used as procedure expression within its
1744 own body is in danger of being called recursively. */
1745 if (is_illegal_recursion (sym, gfc_current_ns))
1746 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1747 " itself recursively. Declare it RECURSIVE or use"
1748 " %<-frecursive%>", sym->name, &expr->where);
1749
1750 return true;
1751 }
1752
1753
1754 /* Resolve an actual argument list. Most of the time, this is just
1755 resolving the expressions in the list.
1756 The exception is that we sometimes have to decide whether arguments
1757 that look like procedure arguments are really simple variable
1758 references. */
1759
1760 static bool
resolve_actual_arglist(gfc_actual_arglist * arg,procedure_type ptype,bool no_formal_args)1761 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1762 bool no_formal_args)
1763 {
1764 gfc_symbol *sym;
1765 gfc_symtree *parent_st;
1766 gfc_expr *e;
1767 gfc_component *comp;
1768 int save_need_full_assumed_size;
1769 bool return_value = false;
1770 bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
1771
1772 actual_arg = true;
1773 first_actual_arg = true;
1774
1775 for (; arg; arg = arg->next)
1776 {
1777 e = arg->expr;
1778 if (e == NULL)
1779 {
1780 /* Check the label is a valid branching target. */
1781 if (arg->label)
1782 {
1783 if (arg->label->defined == ST_LABEL_UNKNOWN)
1784 {
1785 gfc_error ("Label %d referenced at %L is never defined",
1786 arg->label->value, &arg->label->where);
1787 goto cleanup;
1788 }
1789 }
1790 first_actual_arg = false;
1791 continue;
1792 }
1793
1794 if (e->expr_type == EXPR_VARIABLE
1795 && e->symtree->n.sym->attr.generic
1796 && no_formal_args
1797 && count_specific_procs (e) != 1)
1798 goto cleanup;
1799
1800 if (e->ts.type != BT_PROCEDURE)
1801 {
1802 save_need_full_assumed_size = need_full_assumed_size;
1803 if (e->expr_type != EXPR_VARIABLE)
1804 need_full_assumed_size = 0;
1805 if (!gfc_resolve_expr (e))
1806 goto cleanup;
1807 need_full_assumed_size = save_need_full_assumed_size;
1808 goto argument_list;
1809 }
1810
1811 /* See if the expression node should really be a variable reference. */
1812
1813 sym = e->symtree->n.sym;
1814
1815 if (sym->attr.flavor == FL_PROCEDURE
1816 || sym->attr.intrinsic
1817 || sym->attr.external)
1818 {
1819 int actual_ok;
1820
1821 /* If a procedure is not already determined to be something else
1822 check if it is intrinsic. */
1823 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1824 sym->attr.intrinsic = 1;
1825
1826 if (sym->attr.proc == PROC_ST_FUNCTION)
1827 {
1828 gfc_error ("Statement function %qs at %L is not allowed as an "
1829 "actual argument", sym->name, &e->where);
1830 }
1831
1832 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1833 sym->attr.subroutine);
1834 if (sym->attr.intrinsic && actual_ok == 0)
1835 {
1836 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1837 "actual argument", sym->name, &e->where);
1838 }
1839
1840 if (sym->attr.contained && !sym->attr.use_assoc
1841 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1842 {
1843 if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
1844 " used as actual argument at %L",
1845 sym->name, &e->where))
1846 goto cleanup;
1847 }
1848
1849 if (sym->attr.elemental && !sym->attr.intrinsic)
1850 {
1851 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1852 "allowed as an actual argument at %L", sym->name,
1853 &e->where);
1854 }
1855
1856 /* Check if a generic interface has a specific procedure
1857 with the same name before emitting an error. */
1858 if (sym->attr.generic && count_specific_procs (e) != 1)
1859 goto cleanup;
1860
1861 /* Just in case a specific was found for the expression. */
1862 sym = e->symtree->n.sym;
1863
1864 /* If the symbol is the function that names the current (or
1865 parent) scope, then we really have a variable reference. */
1866
1867 if (gfc_is_function_return_value (sym, sym->ns))
1868 goto got_variable;
1869
1870 /* If all else fails, see if we have a specific intrinsic. */
1871 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1872 {
1873 gfc_intrinsic_sym *isym;
1874
1875 isym = gfc_find_function (sym->name);
1876 if (isym == NULL || !isym->specific)
1877 {
1878 gfc_error ("Unable to find a specific INTRINSIC procedure "
1879 "for the reference %qs at %L", sym->name,
1880 &e->where);
1881 goto cleanup;
1882 }
1883 sym->ts = isym->ts;
1884 sym->attr.intrinsic = 1;
1885 sym->attr.function = 1;
1886 }
1887
1888 if (!gfc_resolve_expr (e))
1889 goto cleanup;
1890 goto argument_list;
1891 }
1892
1893 /* See if the name is a module procedure in a parent unit. */
1894
1895 if (was_declared (sym) || sym->ns->parent == NULL)
1896 goto got_variable;
1897
1898 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1899 {
1900 gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
1901 goto cleanup;
1902 }
1903
1904 if (parent_st == NULL)
1905 goto got_variable;
1906
1907 sym = parent_st->n.sym;
1908 e->symtree = parent_st; /* Point to the right thing. */
1909
1910 if (sym->attr.flavor == FL_PROCEDURE
1911 || sym->attr.intrinsic
1912 || sym->attr.external)
1913 {
1914 if (!gfc_resolve_expr (e))
1915 goto cleanup;
1916 goto argument_list;
1917 }
1918
1919 got_variable:
1920 e->expr_type = EXPR_VARIABLE;
1921 e->ts = sym->ts;
1922 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
1923 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1924 && CLASS_DATA (sym)->as))
1925 {
1926 e->rank = sym->ts.type == BT_CLASS
1927 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
1928 e->ref = gfc_get_ref ();
1929 e->ref->type = REF_ARRAY;
1930 e->ref->u.ar.type = AR_FULL;
1931 e->ref->u.ar.as = sym->ts.type == BT_CLASS
1932 ? CLASS_DATA (sym)->as : sym->as;
1933 }
1934
1935 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1936 primary.c (match_actual_arg). If above code determines that it
1937 is a variable instead, it needs to be resolved as it was not
1938 done at the beginning of this function. */
1939 save_need_full_assumed_size = need_full_assumed_size;
1940 if (e->expr_type != EXPR_VARIABLE)
1941 need_full_assumed_size = 0;
1942 if (!gfc_resolve_expr (e))
1943 goto cleanup;
1944 need_full_assumed_size = save_need_full_assumed_size;
1945
1946 argument_list:
1947 /* Check argument list functions %VAL, %LOC and %REF. There is
1948 nothing to do for %REF. */
1949 if (arg->name && arg->name[0] == '%')
1950 {
1951 if (strncmp ("%VAL", arg->name, 4) == 0)
1952 {
1953 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1954 {
1955 gfc_error ("By-value argument at %L is not of numeric "
1956 "type", &e->where);
1957 goto cleanup;
1958 }
1959
1960 if (e->rank)
1961 {
1962 gfc_error ("By-value argument at %L cannot be an array or "
1963 "an array section", &e->where);
1964 goto cleanup;
1965 }
1966
1967 /* Intrinsics are still PROC_UNKNOWN here. However,
1968 since same file external procedures are not resolvable
1969 in gfortran, it is a good deal easier to leave them to
1970 intrinsic.c. */
1971 if (ptype != PROC_UNKNOWN
1972 && ptype != PROC_DUMMY
1973 && ptype != PROC_EXTERNAL
1974 && ptype != PROC_MODULE)
1975 {
1976 gfc_error ("By-value argument at %L is not allowed "
1977 "in this context", &e->where);
1978 goto cleanup;
1979 }
1980 }
1981
1982 /* Statement functions have already been excluded above. */
1983 else if (strncmp ("%LOC", arg->name, 4) == 0
1984 && e->ts.type == BT_PROCEDURE)
1985 {
1986 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1987 {
1988 gfc_error ("Passing internal procedure at %L by location "
1989 "not allowed", &e->where);
1990 goto cleanup;
1991 }
1992 }
1993 }
1994
1995 comp = gfc_get_proc_ptr_comp(e);
1996 if (e->expr_type == EXPR_VARIABLE
1997 && comp && comp->attr.elemental)
1998 {
1999 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2000 "allowed as an actual argument at %L", comp->name,
2001 &e->where);
2002 }
2003
2004 /* Fortran 2008, C1237. */
2005 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2006 && gfc_has_ultimate_pointer (e))
2007 {
2008 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2009 "component", &e->where);
2010 goto cleanup;
2011 }
2012
2013 first_actual_arg = false;
2014 }
2015
2016 return_value = true;
2017
2018 cleanup:
2019 actual_arg = actual_arg_sav;
2020 first_actual_arg = first_actual_arg_sav;
2021
2022 return return_value;
2023 }
2024
2025
2026 /* Do the checks of the actual argument list that are specific to elemental
2027 procedures. If called with c == NULL, we have a function, otherwise if
2028 expr == NULL, we have a subroutine. */
2029
2030 static bool
resolve_elemental_actual(gfc_expr * expr,gfc_code * c)2031 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2032 {
2033 gfc_actual_arglist *arg0;
2034 gfc_actual_arglist *arg;
2035 gfc_symbol *esym = NULL;
2036 gfc_intrinsic_sym *isym = NULL;
2037 gfc_expr *e = NULL;
2038 gfc_intrinsic_arg *iformal = NULL;
2039 gfc_formal_arglist *eformal = NULL;
2040 bool formal_optional = false;
2041 bool set_by_optional = false;
2042 int i;
2043 int rank = 0;
2044
2045 /* Is this an elemental procedure? */
2046 if (expr && expr->value.function.actual != NULL)
2047 {
2048 if (expr->value.function.esym != NULL
2049 && expr->value.function.esym->attr.elemental)
2050 {
2051 arg0 = expr->value.function.actual;
2052 esym = expr->value.function.esym;
2053 }
2054 else if (expr->value.function.isym != NULL
2055 && expr->value.function.isym->elemental)
2056 {
2057 arg0 = expr->value.function.actual;
2058 isym = expr->value.function.isym;
2059 }
2060 else
2061 return true;
2062 }
2063 else if (c && c->ext.actual != NULL)
2064 {
2065 arg0 = c->ext.actual;
2066
2067 if (c->resolved_sym)
2068 esym = c->resolved_sym;
2069 else
2070 esym = c->symtree->n.sym;
2071 gcc_assert (esym);
2072
2073 if (!esym->attr.elemental)
2074 return true;
2075 }
2076 else
2077 return true;
2078
2079 /* The rank of an elemental is the rank of its array argument(s). */
2080 for (arg = arg0; arg; arg = arg->next)
2081 {
2082 if (arg->expr != NULL && arg->expr->rank != 0)
2083 {
2084 rank = arg->expr->rank;
2085 if (arg->expr->expr_type == EXPR_VARIABLE
2086 && arg->expr->symtree->n.sym->attr.optional)
2087 set_by_optional = true;
2088
2089 /* Function specific; set the result rank and shape. */
2090 if (expr)
2091 {
2092 expr->rank = rank;
2093 if (!expr->shape && arg->expr->shape)
2094 {
2095 expr->shape = gfc_get_shape (rank);
2096 for (i = 0; i < rank; i++)
2097 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2098 }
2099 }
2100 break;
2101 }
2102 }
2103
2104 /* If it is an array, it shall not be supplied as an actual argument
2105 to an elemental procedure unless an array of the same rank is supplied
2106 as an actual argument corresponding to a nonoptional dummy argument of
2107 that elemental procedure(12.4.1.5). */
2108 formal_optional = false;
2109 if (isym)
2110 iformal = isym->formal;
2111 else
2112 eformal = esym->formal;
2113
2114 for (arg = arg0; arg; arg = arg->next)
2115 {
2116 if (eformal)
2117 {
2118 if (eformal->sym && eformal->sym->attr.optional)
2119 formal_optional = true;
2120 eformal = eformal->next;
2121 }
2122 else if (isym && iformal)
2123 {
2124 if (iformal->optional)
2125 formal_optional = true;
2126 iformal = iformal->next;
2127 }
2128 else if (isym)
2129 formal_optional = true;
2130
2131 if (pedantic && arg->expr != NULL
2132 && arg->expr->expr_type == EXPR_VARIABLE
2133 && arg->expr->symtree->n.sym->attr.optional
2134 && formal_optional
2135 && arg->expr->rank
2136 && (set_by_optional || arg->expr->rank != rank)
2137 && !(isym && isym->id == GFC_ISYM_CONVERSION))
2138 {
2139 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2140 "MISSING, it cannot be the actual argument of an "
2141 "ELEMENTAL procedure unless there is a non-optional "
2142 "argument with the same rank (12.4.1.5)",
2143 arg->expr->symtree->n.sym->name, &arg->expr->where);
2144 }
2145 }
2146
2147 for (arg = arg0; arg; arg = arg->next)
2148 {
2149 if (arg->expr == NULL || arg->expr->rank == 0)
2150 continue;
2151
2152 /* Being elemental, the last upper bound of an assumed size array
2153 argument must be present. */
2154 if (resolve_assumed_size_actual (arg->expr))
2155 return false;
2156
2157 /* Elemental procedure's array actual arguments must conform. */
2158 if (e != NULL)
2159 {
2160 if (!gfc_check_conformance (arg->expr, e, "elemental procedure"))
2161 return false;
2162 }
2163 else
2164 e = arg->expr;
2165 }
2166
2167 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2168 is an array, the intent inout/out variable needs to be also an array. */
2169 if (rank > 0 && esym && expr == NULL)
2170 for (eformal = esym->formal, arg = arg0; arg && eformal;
2171 arg = arg->next, eformal = eformal->next)
2172 if ((eformal->sym->attr.intent == INTENT_OUT
2173 || eformal->sym->attr.intent == INTENT_INOUT)
2174 && arg->expr && arg->expr->rank == 0)
2175 {
2176 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2177 "ELEMENTAL subroutine %qs is a scalar, but another "
2178 "actual argument is an array", &arg->expr->where,
2179 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2180 : "INOUT", eformal->sym->name, esym->name);
2181 return false;
2182 }
2183 return true;
2184 }
2185
2186
2187 /* This function does the checking of references to global procedures
2188 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2189 77 and 95 standards. It checks for a gsymbol for the name, making
2190 one if it does not already exist. If it already exists, then the
2191 reference being resolved must correspond to the type of gsymbol.
2192 Otherwise, the new symbol is equipped with the attributes of the
2193 reference. The corresponding code that is called in creating
2194 global entities is parse.c.
2195
2196 In addition, for all but -std=legacy, the gsymbols are used to
2197 check the interfaces of external procedures from the same file.
2198 The namespace of the gsymbol is resolved and then, once this is
2199 done the interface is checked. */
2200
2201
2202 static bool
not_in_recursive(gfc_symbol * sym,gfc_namespace * gsym_ns)2203 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2204 {
2205 if (!gsym_ns->proc_name->attr.recursive)
2206 return true;
2207
2208 if (sym->ns == gsym_ns)
2209 return false;
2210
2211 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2212 return false;
2213
2214 return true;
2215 }
2216
2217 static bool
not_entry_self_reference(gfc_symbol * sym,gfc_namespace * gsym_ns)2218 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2219 {
2220 if (gsym_ns->entries)
2221 {
2222 gfc_entry_list *entry = gsym_ns->entries;
2223
2224 for (; entry; entry = entry->next)
2225 {
2226 if (strcmp (sym->name, entry->sym->name) == 0)
2227 {
2228 if (strcmp (gsym_ns->proc_name->name,
2229 sym->ns->proc_name->name) == 0)
2230 return false;
2231
2232 if (sym->ns->parent
2233 && strcmp (gsym_ns->proc_name->name,
2234 sym->ns->parent->proc_name->name) == 0)
2235 return false;
2236 }
2237 }
2238 }
2239 return true;
2240 }
2241
2242
2243 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2244
2245 bool
gfc_explicit_interface_required(gfc_symbol * sym,char * errmsg,int err_len)2246 gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2247 {
2248 gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2249
2250 for ( ; arg; arg = arg->next)
2251 {
2252 if (!arg->sym)
2253 continue;
2254
2255 if (arg->sym->attr.allocatable) /* (2a) */
2256 {
2257 strncpy (errmsg, _("allocatable argument"), err_len);
2258 return true;
2259 }
2260 else if (arg->sym->attr.asynchronous)
2261 {
2262 strncpy (errmsg, _("asynchronous argument"), err_len);
2263 return true;
2264 }
2265 else if (arg->sym->attr.optional)
2266 {
2267 strncpy (errmsg, _("optional argument"), err_len);
2268 return true;
2269 }
2270 else if (arg->sym->attr.pointer)
2271 {
2272 strncpy (errmsg, _("pointer argument"), err_len);
2273 return true;
2274 }
2275 else if (arg->sym->attr.target)
2276 {
2277 strncpy (errmsg, _("target argument"), err_len);
2278 return true;
2279 }
2280 else if (arg->sym->attr.value)
2281 {
2282 strncpy (errmsg, _("value argument"), err_len);
2283 return true;
2284 }
2285 else if (arg->sym->attr.volatile_)
2286 {
2287 strncpy (errmsg, _("volatile argument"), err_len);
2288 return true;
2289 }
2290 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2291 {
2292 strncpy (errmsg, _("assumed-shape argument"), err_len);
2293 return true;
2294 }
2295 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2296 {
2297 strncpy (errmsg, _("assumed-rank argument"), err_len);
2298 return true;
2299 }
2300 else if (arg->sym->attr.codimension) /* (2c) */
2301 {
2302 strncpy (errmsg, _("coarray argument"), err_len);
2303 return true;
2304 }
2305 else if (false) /* (2d) TODO: parametrized derived type */
2306 {
2307 strncpy (errmsg, _("parametrized derived type argument"), err_len);
2308 return true;
2309 }
2310 else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2311 {
2312 strncpy (errmsg, _("polymorphic argument"), err_len);
2313 return true;
2314 }
2315 else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2316 {
2317 strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2318 return true;
2319 }
2320 else if (arg->sym->ts.type == BT_ASSUMED)
2321 {
2322 /* As assumed-type is unlimited polymorphic (cf. above).
2323 See also TS 29113, Note 6.1. */
2324 strncpy (errmsg, _("assumed-type argument"), err_len);
2325 return true;
2326 }
2327 }
2328
2329 if (sym->attr.function)
2330 {
2331 gfc_symbol *res = sym->result ? sym->result : sym;
2332
2333 if (res->attr.dimension) /* (3a) */
2334 {
2335 strncpy (errmsg, _("array result"), err_len);
2336 return true;
2337 }
2338 else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2339 {
2340 strncpy (errmsg, _("pointer or allocatable result"), err_len);
2341 return true;
2342 }
2343 else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2344 && res->ts.u.cl->length
2345 && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2346 {
2347 strncpy (errmsg, _("result with non-constant character length"), err_len);
2348 return true;
2349 }
2350 }
2351
2352 if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2353 {
2354 strncpy (errmsg, _("elemental procedure"), err_len);
2355 return true;
2356 }
2357 else if (sym->attr.is_bind_c) /* (5) */
2358 {
2359 strncpy (errmsg, _("bind(c) procedure"), err_len);
2360 return true;
2361 }
2362
2363 return false;
2364 }
2365
2366
2367 static void
resolve_global_procedure(gfc_symbol * sym,locus * where,gfc_actual_arglist ** actual,int sub)2368 resolve_global_procedure (gfc_symbol *sym, locus *where,
2369 gfc_actual_arglist **actual, int sub)
2370 {
2371 gfc_gsymbol * gsym;
2372 gfc_namespace *ns;
2373 enum gfc_symbol_type type;
2374 char reason[200];
2375
2376 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2377
2378 gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
2379
2380 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2381 gfc_global_used (gsym, where);
2382
2383 if ((sym->attr.if_source == IFSRC_UNKNOWN
2384 || sym->attr.if_source == IFSRC_IFBODY)
2385 && gsym->type != GSYM_UNKNOWN
2386 && !gsym->binding_label
2387 && gsym->ns
2388 && gsym->ns->resolved != -1
2389 && gsym->ns->proc_name
2390 && not_in_recursive (sym, gsym->ns)
2391 && not_entry_self_reference (sym, gsym->ns))
2392 {
2393 gfc_symbol *def_sym;
2394
2395 /* Resolve the gsymbol namespace if needed. */
2396 if (!gsym->ns->resolved)
2397 {
2398 gfc_dt_list *old_dt_list;
2399
2400 /* Stash away derived types so that the backend_decls do not
2401 get mixed up. */
2402 old_dt_list = gfc_derived_types;
2403 gfc_derived_types = NULL;
2404
2405 gfc_resolve (gsym->ns);
2406
2407 /* Store the new derived types with the global namespace. */
2408 if (gfc_derived_types)
2409 gsym->ns->derived_types = gfc_derived_types;
2410
2411 /* Restore the derived types of this namespace. */
2412 gfc_derived_types = old_dt_list;
2413 }
2414
2415 /* Make sure that translation for the gsymbol occurs before
2416 the procedure currently being resolved. */
2417 ns = gfc_global_ns_list;
2418 for (; ns && ns != gsym->ns; ns = ns->sibling)
2419 {
2420 if (ns->sibling == gsym->ns)
2421 {
2422 ns->sibling = gsym->ns->sibling;
2423 gsym->ns->sibling = gfc_global_ns_list;
2424 gfc_global_ns_list = gsym->ns;
2425 break;
2426 }
2427 }
2428
2429 def_sym = gsym->ns->proc_name;
2430
2431 /* This can happen if a binding name has been specified. */
2432 if (gsym->binding_label && gsym->sym_name != def_sym->name)
2433 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2434
2435 if (def_sym->attr.entry_master)
2436 {
2437 gfc_entry_list *entry;
2438 for (entry = gsym->ns->entries; entry; entry = entry->next)
2439 if (strcmp (entry->sym->name, sym->name) == 0)
2440 {
2441 def_sym = entry->sym;
2442 break;
2443 }
2444 }
2445
2446 if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2447 {
2448 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2449 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2450 gfc_typename (&def_sym->ts));
2451 goto done;
2452 }
2453
2454 if (sym->attr.if_source == IFSRC_UNKNOWN
2455 && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2456 {
2457 gfc_error ("Explicit interface required for %qs at %L: %s",
2458 sym->name, &sym->declared_at, reason);
2459 goto done;
2460 }
2461
2462 if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU))
2463 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2464 gfc_errors_to_warnings (true);
2465
2466 if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2467 reason, sizeof(reason), NULL, NULL))
2468 {
2469 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2470 sym->name, &sym->declared_at, reason);
2471 goto done;
2472 }
2473
2474 if (!pedantic
2475 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2476 && !(gfc_option.warn_std & GFC_STD_GNU)))
2477 gfc_errors_to_warnings (true);
2478
2479 if (sym->attr.if_source != IFSRC_IFBODY)
2480 gfc_procedure_use (def_sym, actual, where);
2481 }
2482
2483 done:
2484 gfc_errors_to_warnings (false);
2485
2486 if (gsym->type == GSYM_UNKNOWN)
2487 {
2488 gsym->type = type;
2489 gsym->where = *where;
2490 }
2491
2492 gsym->used = 1;
2493 }
2494
2495
2496 /************* Function resolution *************/
2497
2498 /* Resolve a function call known to be generic.
2499 Section 14.1.2.4.1. */
2500
2501 static match
resolve_generic_f0(gfc_expr * expr,gfc_symbol * sym)2502 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2503 {
2504 gfc_symbol *s;
2505
2506 if (sym->attr.generic)
2507 {
2508 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2509 if (s != NULL)
2510 {
2511 expr->value.function.name = s->name;
2512 expr->value.function.esym = s;
2513
2514 if (s->ts.type != BT_UNKNOWN)
2515 expr->ts = s->ts;
2516 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2517 expr->ts = s->result->ts;
2518
2519 if (s->as != NULL)
2520 expr->rank = s->as->rank;
2521 else if (s->result != NULL && s->result->as != NULL)
2522 expr->rank = s->result->as->rank;
2523
2524 gfc_set_sym_referenced (expr->value.function.esym);
2525
2526 return MATCH_YES;
2527 }
2528
2529 /* TODO: Need to search for elemental references in generic
2530 interface. */
2531 }
2532
2533 if (sym->attr.intrinsic)
2534 return gfc_intrinsic_func_interface (expr, 0);
2535
2536 return MATCH_NO;
2537 }
2538
2539
2540 static bool
resolve_generic_f(gfc_expr * expr)2541 resolve_generic_f (gfc_expr *expr)
2542 {
2543 gfc_symbol *sym;
2544 match m;
2545 gfc_interface *intr = NULL;
2546
2547 sym = expr->symtree->n.sym;
2548
2549 for (;;)
2550 {
2551 m = resolve_generic_f0 (expr, sym);
2552 if (m == MATCH_YES)
2553 return true;
2554 else if (m == MATCH_ERROR)
2555 return false;
2556
2557 generic:
2558 if (!intr)
2559 for (intr = sym->generic; intr; intr = intr->next)
2560 if (gfc_fl_struct (intr->sym->attr.flavor))
2561 break;
2562
2563 if (sym->ns->parent == NULL)
2564 break;
2565 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2566
2567 if (sym == NULL)
2568 break;
2569 if (!generic_sym (sym))
2570 goto generic;
2571 }
2572
2573 /* Last ditch attempt. See if the reference is to an intrinsic
2574 that possesses a matching interface. 14.1.2.4 */
2575 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2576 {
2577 if (gfc_init_expr_flag)
2578 gfc_error ("Function %qs in initialization expression at %L "
2579 "must be an intrinsic function",
2580 expr->symtree->n.sym->name, &expr->where);
2581 else
2582 gfc_error ("There is no specific function for the generic %qs "
2583 "at %L", expr->symtree->n.sym->name, &expr->where);
2584 return false;
2585 }
2586
2587 if (intr)
2588 {
2589 if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
2590 NULL, false))
2591 return false;
2592 return resolve_structure_cons (expr, 0);
2593 }
2594
2595 m = gfc_intrinsic_func_interface (expr, 0);
2596 if (m == MATCH_YES)
2597 return true;
2598
2599 if (m == MATCH_NO)
2600 gfc_error ("Generic function %qs at %L is not consistent with a "
2601 "specific intrinsic interface", expr->symtree->n.sym->name,
2602 &expr->where);
2603
2604 return false;
2605 }
2606
2607
2608 /* Resolve a function call known to be specific. */
2609
2610 static match
resolve_specific_f0(gfc_symbol * sym,gfc_expr * expr)2611 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2612 {
2613 match m;
2614
2615 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2616 {
2617 if (sym->attr.dummy)
2618 {
2619 sym->attr.proc = PROC_DUMMY;
2620 goto found;
2621 }
2622
2623 sym->attr.proc = PROC_EXTERNAL;
2624 goto found;
2625 }
2626
2627 if (sym->attr.proc == PROC_MODULE
2628 || sym->attr.proc == PROC_ST_FUNCTION
2629 || sym->attr.proc == PROC_INTERNAL)
2630 goto found;
2631
2632 if (sym->attr.intrinsic)
2633 {
2634 m = gfc_intrinsic_func_interface (expr, 1);
2635 if (m == MATCH_YES)
2636 return MATCH_YES;
2637 if (m == MATCH_NO)
2638 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2639 "with an intrinsic", sym->name, &expr->where);
2640
2641 return MATCH_ERROR;
2642 }
2643
2644 return MATCH_NO;
2645
2646 found:
2647 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2648
2649 if (sym->result)
2650 expr->ts = sym->result->ts;
2651 else
2652 expr->ts = sym->ts;
2653 expr->value.function.name = sym->name;
2654 expr->value.function.esym = sym;
2655 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2656 error(s). */
2657 if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2658 return MATCH_ERROR;
2659 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2660 expr->rank = CLASS_DATA (sym)->as->rank;
2661 else if (sym->as != NULL)
2662 expr->rank = sym->as->rank;
2663
2664 return MATCH_YES;
2665 }
2666
2667
2668 static bool
resolve_specific_f(gfc_expr * expr)2669 resolve_specific_f (gfc_expr *expr)
2670 {
2671 gfc_symbol *sym;
2672 match m;
2673
2674 sym = expr->symtree->n.sym;
2675
2676 for (;;)
2677 {
2678 m = resolve_specific_f0 (sym, expr);
2679 if (m == MATCH_YES)
2680 return true;
2681 if (m == MATCH_ERROR)
2682 return false;
2683
2684 if (sym->ns->parent == NULL)
2685 break;
2686
2687 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2688
2689 if (sym == NULL)
2690 break;
2691 }
2692
2693 gfc_error ("Unable to resolve the specific function %qs at %L",
2694 expr->symtree->n.sym->name, &expr->where);
2695
2696 return true;
2697 }
2698
2699
2700 /* Resolve a procedure call not known to be generic nor specific. */
2701
2702 static bool
resolve_unknown_f(gfc_expr * expr)2703 resolve_unknown_f (gfc_expr *expr)
2704 {
2705 gfc_symbol *sym;
2706 gfc_typespec *ts;
2707
2708 sym = expr->symtree->n.sym;
2709
2710 if (sym->attr.dummy)
2711 {
2712 sym->attr.proc = PROC_DUMMY;
2713 expr->value.function.name = sym->name;
2714 goto set_type;
2715 }
2716
2717 /* See if we have an intrinsic function reference. */
2718
2719 if (gfc_is_intrinsic (sym, 0, expr->where))
2720 {
2721 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2722 return true;
2723 return false;
2724 }
2725
2726 /* The reference is to an external name. */
2727
2728 sym->attr.proc = PROC_EXTERNAL;
2729 expr->value.function.name = sym->name;
2730 expr->value.function.esym = expr->symtree->n.sym;
2731
2732 if (sym->as != NULL)
2733 expr->rank = sym->as->rank;
2734
2735 /* Type of the expression is either the type of the symbol or the
2736 default type of the symbol. */
2737
2738 set_type:
2739 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2740
2741 if (sym->ts.type != BT_UNKNOWN)
2742 expr->ts = sym->ts;
2743 else
2744 {
2745 ts = gfc_get_default_type (sym->name, sym->ns);
2746
2747 if (ts->type == BT_UNKNOWN)
2748 {
2749 gfc_error ("Function %qs at %L has no IMPLICIT type",
2750 sym->name, &expr->where);
2751 return false;
2752 }
2753 else
2754 expr->ts = *ts;
2755 }
2756
2757 return true;
2758 }
2759
2760
2761 /* Return true, if the symbol is an external procedure. */
2762 static bool
is_external_proc(gfc_symbol * sym)2763 is_external_proc (gfc_symbol *sym)
2764 {
2765 if (!sym->attr.dummy && !sym->attr.contained
2766 && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
2767 && sym->attr.proc != PROC_ST_FUNCTION
2768 && !sym->attr.proc_pointer
2769 && !sym->attr.use_assoc
2770 && sym->name)
2771 return true;
2772
2773 return false;
2774 }
2775
2776
2777 /* Figure out if a function reference is pure or not. Also set the name
2778 of the function for a potential error message. Return nonzero if the
2779 function is PURE, zero if not. */
2780 static int
2781 pure_stmt_function (gfc_expr *, gfc_symbol *);
2782
2783 static int
pure_function(gfc_expr * e,const char ** name)2784 pure_function (gfc_expr *e, const char **name)
2785 {
2786 int pure;
2787 gfc_component *comp;
2788
2789 *name = NULL;
2790
2791 if (e->symtree != NULL
2792 && e->symtree->n.sym != NULL
2793 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2794 return pure_stmt_function (e, e->symtree->n.sym);
2795
2796 comp = gfc_get_proc_ptr_comp (e);
2797 if (comp)
2798 {
2799 pure = gfc_pure (comp->ts.interface);
2800 *name = comp->name;
2801 }
2802 else if (e->value.function.esym)
2803 {
2804 pure = gfc_pure (e->value.function.esym);
2805 *name = e->value.function.esym->name;
2806 }
2807 else if (e->value.function.isym)
2808 {
2809 pure = e->value.function.isym->pure
2810 || e->value.function.isym->elemental;
2811 *name = e->value.function.isym->name;
2812 }
2813 else
2814 {
2815 /* Implicit functions are not pure. */
2816 pure = 0;
2817 *name = e->value.function.name;
2818 }
2819
2820 return pure;
2821 }
2822
2823
2824 static bool
impure_stmt_fcn(gfc_expr * e,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)2825 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2826 int *f ATTRIBUTE_UNUSED)
2827 {
2828 const char *name;
2829
2830 /* Don't bother recursing into other statement functions
2831 since they will be checked individually for purity. */
2832 if (e->expr_type != EXPR_FUNCTION
2833 || !e->symtree
2834 || e->symtree->n.sym == sym
2835 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2836 return false;
2837
2838 return pure_function (e, &name) ? false : true;
2839 }
2840
2841
2842 static int
pure_stmt_function(gfc_expr * e,gfc_symbol * sym)2843 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2844 {
2845 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2846 }
2847
2848
2849 /* Check if an impure function is allowed in the current context. */
2850
check_pure_function(gfc_expr * e)2851 static bool check_pure_function (gfc_expr *e)
2852 {
2853 const char *name = NULL;
2854 if (!pure_function (e, &name) && name)
2855 {
2856 if (forall_flag)
2857 {
2858 gfc_error ("Reference to impure function %qs at %L inside a "
2859 "FORALL %s", name, &e->where,
2860 forall_flag == 2 ? "mask" : "block");
2861 return false;
2862 }
2863 else if (gfc_do_concurrent_flag)
2864 {
2865 gfc_error ("Reference to impure function %qs at %L inside a "
2866 "DO CONCURRENT %s", name, &e->where,
2867 gfc_do_concurrent_flag == 2 ? "mask" : "block");
2868 return false;
2869 }
2870 else if (gfc_pure (NULL))
2871 {
2872 gfc_error ("Reference to impure function %qs at %L "
2873 "within a PURE procedure", name, &e->where);
2874 return false;
2875 }
2876 gfc_unset_implicit_pure (NULL);
2877 }
2878 return true;
2879 }
2880
2881
2882 /* Update current procedure's array_outer_dependency flag, considering
2883 a call to procedure SYM. */
2884
2885 static void
update_current_proc_array_outer_dependency(gfc_symbol * sym)2886 update_current_proc_array_outer_dependency (gfc_symbol *sym)
2887 {
2888 /* Check to see if this is a sibling function that has not yet
2889 been resolved. */
2890 gfc_namespace *sibling = gfc_current_ns->sibling;
2891 for (; sibling; sibling = sibling->sibling)
2892 {
2893 if (sibling->proc_name == sym)
2894 {
2895 gfc_resolve (sibling);
2896 break;
2897 }
2898 }
2899
2900 /* If SYM has references to outer arrays, so has the procedure calling
2901 SYM. If SYM is a procedure pointer, we can assume the worst. */
2902 if (sym->attr.array_outer_dependency
2903 || sym->attr.proc_pointer)
2904 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
2905 }
2906
2907
2908 /* Resolve a function call, which means resolving the arguments, then figuring
2909 out which entity the name refers to. */
2910
2911 static bool
resolve_function(gfc_expr * expr)2912 resolve_function (gfc_expr *expr)
2913 {
2914 gfc_actual_arglist *arg;
2915 gfc_symbol *sym;
2916 bool t;
2917 int temp;
2918 procedure_type p = PROC_INTRINSIC;
2919 bool no_formal_args;
2920
2921 sym = NULL;
2922 if (expr->symtree)
2923 sym = expr->symtree->n.sym;
2924
2925 /* If this is a procedure pointer component, it has already been resolved. */
2926 if (gfc_is_proc_ptr_comp (expr))
2927 return true;
2928
2929 if (sym && sym->attr.intrinsic
2930 && !gfc_resolve_intrinsic (sym, &expr->where))
2931 return false;
2932
2933 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
2934 {
2935 gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
2936 return false;
2937 }
2938
2939 /* If this ia a deferred TBP with an abstract interface (which may
2940 of course be referenced), expr->value.function.esym will be set. */
2941 if (sym && sym->attr.abstract && !expr->value.function.esym)
2942 {
2943 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2944 sym->name, &expr->where);
2945 return false;
2946 }
2947
2948 /* Switch off assumed size checking and do this again for certain kinds
2949 of procedure, once the procedure itself is resolved. */
2950 need_full_assumed_size++;
2951
2952 if (expr->symtree && expr->symtree->n.sym)
2953 p = expr->symtree->n.sym->attr.proc;
2954
2955 if (expr->value.function.isym && expr->value.function.isym->inquiry)
2956 inquiry_argument = true;
2957 no_formal_args = sym && is_external_proc (sym)
2958 && gfc_sym_get_dummy_args (sym) == NULL;
2959
2960 if (!resolve_actual_arglist (expr->value.function.actual,
2961 p, no_formal_args))
2962 {
2963 inquiry_argument = false;
2964 return false;
2965 }
2966
2967 inquiry_argument = false;
2968
2969 /* Resume assumed_size checking. */
2970 need_full_assumed_size--;
2971
2972 /* If the procedure is external, check for usage. */
2973 if (sym && is_external_proc (sym))
2974 resolve_global_procedure (sym, &expr->where,
2975 &expr->value.function.actual, 0);
2976
2977 if (sym && sym->ts.type == BT_CHARACTER
2978 && sym->ts.u.cl
2979 && sym->ts.u.cl->length == NULL
2980 && !sym->attr.dummy
2981 && !sym->ts.deferred
2982 && expr->value.function.esym == NULL
2983 && !sym->attr.contained)
2984 {
2985 /* Internal procedures are taken care of in resolve_contained_fntype. */
2986 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2987 "be used at %L since it is not a dummy argument",
2988 sym->name, &expr->where);
2989 return false;
2990 }
2991
2992 /* See if function is already resolved. */
2993
2994 if (expr->value.function.name != NULL
2995 || expr->value.function.isym != NULL)
2996 {
2997 if (expr->ts.type == BT_UNKNOWN)
2998 expr->ts = sym->ts;
2999 t = true;
3000 }
3001 else
3002 {
3003 /* Apply the rules of section 14.1.2. */
3004
3005 switch (procedure_kind (sym))
3006 {
3007 case PTYPE_GENERIC:
3008 t = resolve_generic_f (expr);
3009 break;
3010
3011 case PTYPE_SPECIFIC:
3012 t = resolve_specific_f (expr);
3013 break;
3014
3015 case PTYPE_UNKNOWN:
3016 t = resolve_unknown_f (expr);
3017 break;
3018
3019 default:
3020 gfc_internal_error ("resolve_function(): bad function type");
3021 }
3022 }
3023
3024 /* If the expression is still a function (it might have simplified),
3025 then we check to see if we are calling an elemental function. */
3026
3027 if (expr->expr_type != EXPR_FUNCTION)
3028 return t;
3029
3030 temp = need_full_assumed_size;
3031 need_full_assumed_size = 0;
3032
3033 if (!resolve_elemental_actual (expr, NULL))
3034 return false;
3035
3036 if (omp_workshare_flag
3037 && expr->value.function.esym
3038 && ! gfc_elemental (expr->value.function.esym))
3039 {
3040 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3041 "in WORKSHARE construct", expr->value.function.esym->name,
3042 &expr->where);
3043 t = false;
3044 }
3045
3046 #define GENERIC_ID expr->value.function.isym->id
3047 else if (expr->value.function.actual != NULL
3048 && expr->value.function.isym != NULL
3049 && GENERIC_ID != GFC_ISYM_LBOUND
3050 && GENERIC_ID != GFC_ISYM_LCOBOUND
3051 && GENERIC_ID != GFC_ISYM_UCOBOUND
3052 && GENERIC_ID != GFC_ISYM_LEN
3053 && GENERIC_ID != GFC_ISYM_LOC
3054 && GENERIC_ID != GFC_ISYM_C_LOC
3055 && GENERIC_ID != GFC_ISYM_PRESENT)
3056 {
3057 /* Array intrinsics must also have the last upper bound of an
3058 assumed size array argument. UBOUND and SIZE have to be
3059 excluded from the check if the second argument is anything
3060 than a constant. */
3061
3062 for (arg = expr->value.function.actual; arg; arg = arg->next)
3063 {
3064 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3065 && arg == expr->value.function.actual
3066 && arg->next != NULL && arg->next->expr)
3067 {
3068 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3069 break;
3070
3071 if (arg->next->name && strncmp (arg->next->name, "kind", 4) == 0)
3072 break;
3073
3074 if ((int)mpz_get_si (arg->next->expr->value.integer)
3075 < arg->expr->rank)
3076 break;
3077 }
3078
3079 if (arg->expr != NULL
3080 && arg->expr->rank > 0
3081 && resolve_assumed_size_actual (arg->expr))
3082 return false;
3083 }
3084 }
3085 #undef GENERIC_ID
3086
3087 need_full_assumed_size = temp;
3088
3089 if (!check_pure_function(expr))
3090 t = false;
3091
3092 /* Functions without the RECURSIVE attribution are not allowed to
3093 * call themselves. */
3094 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3095 {
3096 gfc_symbol *esym;
3097 esym = expr->value.function.esym;
3098
3099 if (is_illegal_recursion (esym, gfc_current_ns))
3100 {
3101 if (esym->attr.entry && esym->ns->entries)
3102 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3103 " function %qs is not RECURSIVE",
3104 esym->name, &expr->where, esym->ns->entries->sym->name);
3105 else
3106 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3107 " is not RECURSIVE", esym->name, &expr->where);
3108
3109 t = false;
3110 }
3111 }
3112
3113 /* Character lengths of use associated functions may contains references to
3114 symbols not referenced from the current program unit otherwise. Make sure
3115 those symbols are marked as referenced. */
3116
3117 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3118 && expr->value.function.esym->attr.use_assoc)
3119 {
3120 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3121 }
3122
3123 /* Make sure that the expression has a typespec that works. */
3124 if (expr->ts.type == BT_UNKNOWN)
3125 {
3126 if (expr->symtree->n.sym->result
3127 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3128 && !expr->symtree->n.sym->result->attr.proc_pointer)
3129 expr->ts = expr->symtree->n.sym->result->ts;
3130 }
3131
3132 if (!expr->ref && !expr->value.function.isym)
3133 {
3134 if (expr->value.function.esym)
3135 update_current_proc_array_outer_dependency (expr->value.function.esym);
3136 else
3137 update_current_proc_array_outer_dependency (sym);
3138 }
3139 else if (expr->ref)
3140 /* typebound procedure: Assume the worst. */
3141 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3142
3143 return t;
3144 }
3145
3146
3147 /************* Subroutine resolution *************/
3148
3149 static bool
pure_subroutine(gfc_symbol * sym,const char * name,locus * loc)3150 pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3151 {
3152 if (gfc_pure (sym))
3153 return true;
3154
3155 if (forall_flag)
3156 {
3157 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3158 name, loc);
3159 return false;
3160 }
3161 else if (gfc_do_concurrent_flag)
3162 {
3163 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3164 "PURE", name, loc);
3165 return false;
3166 }
3167 else if (gfc_pure (NULL))
3168 {
3169 gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3170 return false;
3171 }
3172
3173 gfc_unset_implicit_pure (NULL);
3174 return true;
3175 }
3176
3177
3178 static match
resolve_generic_s0(gfc_code * c,gfc_symbol * sym)3179 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3180 {
3181 gfc_symbol *s;
3182
3183 if (sym->attr.generic)
3184 {
3185 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3186 if (s != NULL)
3187 {
3188 c->resolved_sym = s;
3189 if (!pure_subroutine (s, s->name, &c->loc))
3190 return MATCH_ERROR;
3191 return MATCH_YES;
3192 }
3193
3194 /* TODO: Need to search for elemental references in generic interface. */
3195 }
3196
3197 if (sym->attr.intrinsic)
3198 return gfc_intrinsic_sub_interface (c, 0);
3199
3200 return MATCH_NO;
3201 }
3202
3203
3204 static bool
resolve_generic_s(gfc_code * c)3205 resolve_generic_s (gfc_code *c)
3206 {
3207 gfc_symbol *sym;
3208 match m;
3209
3210 sym = c->symtree->n.sym;
3211
3212 for (;;)
3213 {
3214 m = resolve_generic_s0 (c, sym);
3215 if (m == MATCH_YES)
3216 return true;
3217 else if (m == MATCH_ERROR)
3218 return false;
3219
3220 generic:
3221 if (sym->ns->parent == NULL)
3222 break;
3223 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3224
3225 if (sym == NULL)
3226 break;
3227 if (!generic_sym (sym))
3228 goto generic;
3229 }
3230
3231 /* Last ditch attempt. See if the reference is to an intrinsic
3232 that possesses a matching interface. 14.1.2.4 */
3233 sym = c->symtree->n.sym;
3234
3235 if (!gfc_is_intrinsic (sym, 1, c->loc))
3236 {
3237 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3238 sym->name, &c->loc);
3239 return false;
3240 }
3241
3242 m = gfc_intrinsic_sub_interface (c, 0);
3243 if (m == MATCH_YES)
3244 return true;
3245 if (m == MATCH_NO)
3246 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3247 "intrinsic subroutine interface", sym->name, &c->loc);
3248
3249 return false;
3250 }
3251
3252
3253 /* Resolve a subroutine call known to be specific. */
3254
3255 static match
resolve_specific_s0(gfc_code * c,gfc_symbol * sym)3256 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3257 {
3258 match m;
3259
3260 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3261 {
3262 if (sym->attr.dummy)
3263 {
3264 sym->attr.proc = PROC_DUMMY;
3265 goto found;
3266 }
3267
3268 sym->attr.proc = PROC_EXTERNAL;
3269 goto found;
3270 }
3271
3272 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3273 goto found;
3274
3275 if (sym->attr.intrinsic)
3276 {
3277 m = gfc_intrinsic_sub_interface (c, 1);
3278 if (m == MATCH_YES)
3279 return MATCH_YES;
3280 if (m == MATCH_NO)
3281 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3282 "with an intrinsic", sym->name, &c->loc);
3283
3284 return MATCH_ERROR;
3285 }
3286
3287 return MATCH_NO;
3288
3289 found:
3290 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3291
3292 c->resolved_sym = sym;
3293 if (!pure_subroutine (sym, sym->name, &c->loc))
3294 return MATCH_ERROR;
3295
3296 return MATCH_YES;
3297 }
3298
3299
3300 static bool
resolve_specific_s(gfc_code * c)3301 resolve_specific_s (gfc_code *c)
3302 {
3303 gfc_symbol *sym;
3304 match m;
3305
3306 sym = c->symtree->n.sym;
3307
3308 for (;;)
3309 {
3310 m = resolve_specific_s0 (c, sym);
3311 if (m == MATCH_YES)
3312 return true;
3313 if (m == MATCH_ERROR)
3314 return false;
3315
3316 if (sym->ns->parent == NULL)
3317 break;
3318
3319 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3320
3321 if (sym == NULL)
3322 break;
3323 }
3324
3325 sym = c->symtree->n.sym;
3326 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3327 sym->name, &c->loc);
3328
3329 return false;
3330 }
3331
3332
3333 /* Resolve a subroutine call not known to be generic nor specific. */
3334
3335 static bool
resolve_unknown_s(gfc_code * c)3336 resolve_unknown_s (gfc_code *c)
3337 {
3338 gfc_symbol *sym;
3339
3340 sym = c->symtree->n.sym;
3341
3342 if (sym->attr.dummy)
3343 {
3344 sym->attr.proc = PROC_DUMMY;
3345 goto found;
3346 }
3347
3348 /* See if we have an intrinsic function reference. */
3349
3350 if (gfc_is_intrinsic (sym, 1, c->loc))
3351 {
3352 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3353 return true;
3354 return false;
3355 }
3356
3357 /* The reference is to an external name. */
3358
3359 found:
3360 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3361
3362 c->resolved_sym = sym;
3363
3364 return pure_subroutine (sym, sym->name, &c->loc);
3365 }
3366
3367
3368 /* Resolve a subroutine call. Although it was tempting to use the same code
3369 for functions, subroutines and functions are stored differently and this
3370 makes things awkward. */
3371
3372 static bool
resolve_call(gfc_code * c)3373 resolve_call (gfc_code *c)
3374 {
3375 bool t;
3376 procedure_type ptype = PROC_INTRINSIC;
3377 gfc_symbol *csym, *sym;
3378 bool no_formal_args;
3379
3380 csym = c->symtree ? c->symtree->n.sym : NULL;
3381
3382 if (csym && csym->ts.type != BT_UNKNOWN)
3383 {
3384 gfc_error ("%qs at %L has a type, which is not consistent with "
3385 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3386 return false;
3387 }
3388
3389 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3390 {
3391 gfc_symtree *st;
3392 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3393 sym = st ? st->n.sym : NULL;
3394 if (sym && csym != sym
3395 && sym->ns == gfc_current_ns
3396 && sym->attr.flavor == FL_PROCEDURE
3397 && sym->attr.contained)
3398 {
3399 sym->refs++;
3400 if (csym->attr.generic)
3401 c->symtree->n.sym = sym;
3402 else
3403 c->symtree = st;
3404 csym = c->symtree->n.sym;
3405 }
3406 }
3407
3408 /* If this ia a deferred TBP, c->expr1 will be set. */
3409 if (!c->expr1 && csym)
3410 {
3411 if (csym->attr.abstract)
3412 {
3413 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3414 csym->name, &c->loc);
3415 return false;
3416 }
3417
3418 /* Subroutines without the RECURSIVE attribution are not allowed to
3419 call themselves. */
3420 if (is_illegal_recursion (csym, gfc_current_ns))
3421 {
3422 if (csym->attr.entry && csym->ns->entries)
3423 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3424 "as subroutine %qs is not RECURSIVE",
3425 csym->name, &c->loc, csym->ns->entries->sym->name);
3426 else
3427 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3428 "as it is not RECURSIVE", csym->name, &c->loc);
3429
3430 t = false;
3431 }
3432 }
3433
3434 /* Switch off assumed size checking and do this again for certain kinds
3435 of procedure, once the procedure itself is resolved. */
3436 need_full_assumed_size++;
3437
3438 if (csym)
3439 ptype = csym->attr.proc;
3440
3441 no_formal_args = csym && is_external_proc (csym)
3442 && gfc_sym_get_dummy_args (csym) == NULL;
3443 if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
3444 return false;
3445
3446 /* Resume assumed_size checking. */
3447 need_full_assumed_size--;
3448
3449 /* If external, check for usage. */
3450 if (csym && is_external_proc (csym))
3451 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3452
3453 t = true;
3454 if (c->resolved_sym == NULL)
3455 {
3456 c->resolved_isym = NULL;
3457 switch (procedure_kind (csym))
3458 {
3459 case PTYPE_GENERIC:
3460 t = resolve_generic_s (c);
3461 break;
3462
3463 case PTYPE_SPECIFIC:
3464 t = resolve_specific_s (c);
3465 break;
3466
3467 case PTYPE_UNKNOWN:
3468 t = resolve_unknown_s (c);
3469 break;
3470
3471 default:
3472 gfc_internal_error ("resolve_subroutine(): bad function type");
3473 }
3474 }
3475
3476 /* Some checks of elemental subroutine actual arguments. */
3477 if (!resolve_elemental_actual (NULL, c))
3478 return false;
3479
3480 if (!c->expr1)
3481 update_current_proc_array_outer_dependency (csym);
3482 else
3483 /* Typebound procedure: Assume the worst. */
3484 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3485
3486 return t;
3487 }
3488
3489
3490 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3491 op1->shape and op2->shape are non-NULL return true if their shapes
3492 match. If both op1->shape and op2->shape are non-NULL return false
3493 if their shapes do not match. If either op1->shape or op2->shape is
3494 NULL, return true. */
3495
3496 static bool
compare_shapes(gfc_expr * op1,gfc_expr * op2)3497 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3498 {
3499 bool t;
3500 int i;
3501
3502 t = true;
3503
3504 if (op1->shape != NULL && op2->shape != NULL)
3505 {
3506 for (i = 0; i < op1->rank; i++)
3507 {
3508 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3509 {
3510 gfc_error ("Shapes for operands at %L and %L are not conformable",
3511 &op1->where, &op2->where);
3512 t = false;
3513 break;
3514 }
3515 }
3516 }
3517
3518 return t;
3519 }
3520
3521
3522 /* Resolve an operator expression node. This can involve replacing the
3523 operation with a user defined function call. */
3524
3525 static bool
resolve_operator(gfc_expr * e)3526 resolve_operator (gfc_expr *e)
3527 {
3528 gfc_expr *op1, *op2;
3529 char msg[200];
3530 bool dual_locus_error;
3531 bool t;
3532
3533 /* Resolve all subnodes-- give them types. */
3534
3535 switch (e->value.op.op)
3536 {
3537 default:
3538 if (!gfc_resolve_expr (e->value.op.op2))
3539 return false;
3540
3541 /* Fall through... */
3542
3543 case INTRINSIC_NOT:
3544 case INTRINSIC_UPLUS:
3545 case INTRINSIC_UMINUS:
3546 case INTRINSIC_PARENTHESES:
3547 if (!gfc_resolve_expr (e->value.op.op1))
3548 return false;
3549 break;
3550 }
3551
3552 /* Typecheck the new node. */
3553
3554 op1 = e->value.op.op1;
3555 op2 = e->value.op.op2;
3556 dual_locus_error = false;
3557
3558 if ((op1 && op1->expr_type == EXPR_NULL)
3559 || (op2 && op2->expr_type == EXPR_NULL))
3560 {
3561 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3562 goto bad_op;
3563 }
3564
3565 switch (e->value.op.op)
3566 {
3567 case INTRINSIC_UPLUS:
3568 case INTRINSIC_UMINUS:
3569 if (op1->ts.type == BT_INTEGER
3570 || op1->ts.type == BT_REAL
3571 || op1->ts.type == BT_COMPLEX)
3572 {
3573 e->ts = op1->ts;
3574 break;
3575 }
3576
3577 sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
3578 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3579 goto bad_op;
3580
3581 case INTRINSIC_PLUS:
3582 case INTRINSIC_MINUS:
3583 case INTRINSIC_TIMES:
3584 case INTRINSIC_DIVIDE:
3585 case INTRINSIC_POWER:
3586 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3587 {
3588 gfc_type_convert_binary (e, 1);
3589 break;
3590 }
3591
3592 sprintf (msg,
3593 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
3594 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3595 gfc_typename (&op2->ts));
3596 goto bad_op;
3597
3598 case INTRINSIC_CONCAT:
3599 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3600 && op1->ts.kind == op2->ts.kind)
3601 {
3602 e->ts.type = BT_CHARACTER;
3603 e->ts.kind = op1->ts.kind;
3604 break;
3605 }
3606
3607 sprintf (msg,
3608 _("Operands of string concatenation operator at %%L are %s/%s"),
3609 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3610 goto bad_op;
3611
3612 case INTRINSIC_AND:
3613 case INTRINSIC_OR:
3614 case INTRINSIC_EQV:
3615 case INTRINSIC_NEQV:
3616 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3617 {
3618 e->ts.type = BT_LOGICAL;
3619 e->ts.kind = gfc_kind_max (op1, op2);
3620 if (op1->ts.kind < e->ts.kind)
3621 gfc_convert_type (op1, &e->ts, 2);
3622 else if (op2->ts.kind < e->ts.kind)
3623 gfc_convert_type (op2, &e->ts, 2);
3624 break;
3625 }
3626
3627 sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
3628 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3629 gfc_typename (&op2->ts));
3630
3631 goto bad_op;
3632
3633 case INTRINSIC_NOT:
3634 if (op1->ts.type == BT_LOGICAL)
3635 {
3636 e->ts.type = BT_LOGICAL;
3637 e->ts.kind = op1->ts.kind;
3638 break;
3639 }
3640
3641 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
3642 gfc_typename (&op1->ts));
3643 goto bad_op;
3644
3645 case INTRINSIC_GT:
3646 case INTRINSIC_GT_OS:
3647 case INTRINSIC_GE:
3648 case INTRINSIC_GE_OS:
3649 case INTRINSIC_LT:
3650 case INTRINSIC_LT_OS:
3651 case INTRINSIC_LE:
3652 case INTRINSIC_LE_OS:
3653 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
3654 {
3655 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
3656 goto bad_op;
3657 }
3658
3659 /* Fall through... */
3660
3661 case INTRINSIC_EQ:
3662 case INTRINSIC_EQ_OS:
3663 case INTRINSIC_NE:
3664 case INTRINSIC_NE_OS:
3665 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3666 && op1->ts.kind == op2->ts.kind)
3667 {
3668 e->ts.type = BT_LOGICAL;
3669 e->ts.kind = gfc_default_logical_kind;
3670 break;
3671 }
3672
3673 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3674 {
3675 gfc_type_convert_binary (e, 1);
3676
3677 e->ts.type = BT_LOGICAL;
3678 e->ts.kind = gfc_default_logical_kind;
3679
3680 if (warn_compare_reals)
3681 {
3682 gfc_intrinsic_op op = e->value.op.op;
3683
3684 /* Type conversion has made sure that the types of op1 and op2
3685 agree, so it is only necessary to check the first one. */
3686 if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
3687 && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
3688 || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
3689 {
3690 const char *msg;
3691
3692 if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
3693 msg = "Equality comparison for %s at %L";
3694 else
3695 msg = "Inequality comparison for %s at %L";
3696
3697 gfc_warning (0, msg, gfc_typename (&op1->ts), &op1->where);
3698 }
3699 }
3700
3701 break;
3702 }
3703
3704 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3705 sprintf (msg,
3706 _("Logicals at %%L must be compared with %s instead of %s"),
3707 (e->value.op.op == INTRINSIC_EQ
3708 || e->value.op.op == INTRINSIC_EQ_OS)
3709 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
3710 else
3711 sprintf (msg,
3712 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
3713 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3714 gfc_typename (&op2->ts));
3715
3716 goto bad_op;
3717
3718 case INTRINSIC_USER:
3719 if (e->value.op.uop->op == NULL)
3720 sprintf (msg, _("Unknown operator %%<%s%%> at %%L"),
3721 e->value.op.uop->name);
3722 else if (op2 == NULL)
3723 sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
3724 e->value.op.uop->name, gfc_typename (&op1->ts));
3725 else
3726 {
3727 sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
3728 e->value.op.uop->name, gfc_typename (&op1->ts),
3729 gfc_typename (&op2->ts));
3730 e->value.op.uop->op->sym->attr.referenced = 1;
3731 }
3732
3733 goto bad_op;
3734
3735 case INTRINSIC_PARENTHESES:
3736 e->ts = op1->ts;
3737 if (e->ts.type == BT_CHARACTER)
3738 e->ts.u.cl = op1->ts.u.cl;
3739 break;
3740
3741 default:
3742 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3743 }
3744
3745 /* Deal with arrayness of an operand through an operator. */
3746
3747 t = true;
3748
3749 switch (e->value.op.op)
3750 {
3751 case INTRINSIC_PLUS:
3752 case INTRINSIC_MINUS:
3753 case INTRINSIC_TIMES:
3754 case INTRINSIC_DIVIDE:
3755 case INTRINSIC_POWER:
3756 case INTRINSIC_CONCAT:
3757 case INTRINSIC_AND:
3758 case INTRINSIC_OR:
3759 case INTRINSIC_EQV:
3760 case INTRINSIC_NEQV:
3761 case INTRINSIC_EQ:
3762 case INTRINSIC_EQ_OS:
3763 case INTRINSIC_NE:
3764 case INTRINSIC_NE_OS:
3765 case INTRINSIC_GT:
3766 case INTRINSIC_GT_OS:
3767 case INTRINSIC_GE:
3768 case INTRINSIC_GE_OS:
3769 case INTRINSIC_LT:
3770 case INTRINSIC_LT_OS:
3771 case INTRINSIC_LE:
3772 case INTRINSIC_LE_OS:
3773
3774 if (op1->rank == 0 && op2->rank == 0)
3775 e->rank = 0;
3776
3777 if (op1->rank == 0 && op2->rank != 0)
3778 {
3779 e->rank = op2->rank;
3780
3781 if (e->shape == NULL)
3782 e->shape = gfc_copy_shape (op2->shape, op2->rank);
3783 }
3784
3785 if (op1->rank != 0 && op2->rank == 0)
3786 {
3787 e->rank = op1->rank;
3788
3789 if (e->shape == NULL)
3790 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3791 }
3792
3793 if (op1->rank != 0 && op2->rank != 0)
3794 {
3795 if (op1->rank == op2->rank)
3796 {
3797 e->rank = op1->rank;
3798 if (e->shape == NULL)
3799 {
3800 t = compare_shapes (op1, op2);
3801 if (!t)
3802 e->shape = NULL;
3803 else
3804 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3805 }
3806 }
3807 else
3808 {
3809 /* Allow higher level expressions to work. */
3810 e->rank = 0;
3811
3812 /* Try user-defined operators, and otherwise throw an error. */
3813 dual_locus_error = true;
3814 sprintf (msg,
3815 _("Inconsistent ranks for operator at %%L and %%L"));
3816 goto bad_op;
3817 }
3818 }
3819
3820 break;
3821
3822 case INTRINSIC_PARENTHESES:
3823 case INTRINSIC_NOT:
3824 case INTRINSIC_UPLUS:
3825 case INTRINSIC_UMINUS:
3826 /* Simply copy arrayness attribute */
3827 e->rank = op1->rank;
3828
3829 if (e->shape == NULL)
3830 e->shape = gfc_copy_shape (op1->shape, op1->rank);
3831
3832 break;
3833
3834 default:
3835 break;
3836 }
3837
3838 /* Attempt to simplify the expression. */
3839 if (t)
3840 {
3841 t = gfc_simplify_expr (e, 0);
3842 /* Some calls do not succeed in simplification and return false
3843 even though there is no error; e.g. variable references to
3844 PARAMETER arrays. */
3845 if (!gfc_is_constant_expr (e))
3846 t = true;
3847 }
3848 return t;
3849
3850 bad_op:
3851
3852 {
3853 match m = gfc_extend_expr (e);
3854 if (m == MATCH_YES)
3855 return true;
3856 if (m == MATCH_ERROR)
3857 return false;
3858 }
3859
3860 if (dual_locus_error)
3861 gfc_error (msg, &op1->where, &op2->where);
3862 else
3863 gfc_error (msg, &e->where);
3864
3865 return false;
3866 }
3867
3868
3869 /************** Array resolution subroutines **************/
3870
3871 enum compare_result
3872 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
3873
3874 /* Compare two integer expressions. */
3875
3876 static compare_result
compare_bound(gfc_expr * a,gfc_expr * b)3877 compare_bound (gfc_expr *a, gfc_expr *b)
3878 {
3879 int i;
3880
3881 if (a == NULL || a->expr_type != EXPR_CONSTANT
3882 || b == NULL || b->expr_type != EXPR_CONSTANT)
3883 return CMP_UNKNOWN;
3884
3885 /* If either of the types isn't INTEGER, we must have
3886 raised an error earlier. */
3887
3888 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
3889 return CMP_UNKNOWN;
3890
3891 i = mpz_cmp (a->value.integer, b->value.integer);
3892
3893 if (i < 0)
3894 return CMP_LT;
3895 if (i > 0)
3896 return CMP_GT;
3897 return CMP_EQ;
3898 }
3899
3900
3901 /* Compare an integer expression with an integer. */
3902
3903 static compare_result
compare_bound_int(gfc_expr * a,int b)3904 compare_bound_int (gfc_expr *a, int b)
3905 {
3906 int i;
3907
3908 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3909 return CMP_UNKNOWN;
3910
3911 if (a->ts.type != BT_INTEGER)
3912 gfc_internal_error ("compare_bound_int(): Bad expression");
3913
3914 i = mpz_cmp_si (a->value.integer, b);
3915
3916 if (i < 0)
3917 return CMP_LT;
3918 if (i > 0)
3919 return CMP_GT;
3920 return CMP_EQ;
3921 }
3922
3923
3924 /* Compare an integer expression with a mpz_t. */
3925
3926 static compare_result
compare_bound_mpz_t(gfc_expr * a,mpz_t b)3927 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
3928 {
3929 int i;
3930
3931 if (a == NULL || a->expr_type != EXPR_CONSTANT)
3932 return CMP_UNKNOWN;
3933
3934 if (a->ts.type != BT_INTEGER)
3935 gfc_internal_error ("compare_bound_int(): Bad expression");
3936
3937 i = mpz_cmp (a->value.integer, b);
3938
3939 if (i < 0)
3940 return CMP_LT;
3941 if (i > 0)
3942 return CMP_GT;
3943 return CMP_EQ;
3944 }
3945
3946
3947 /* Compute the last value of a sequence given by a triplet.
3948 Return 0 if it wasn't able to compute the last value, or if the
3949 sequence if empty, and 1 otherwise. */
3950
3951 static int
compute_last_value_for_triplet(gfc_expr * start,gfc_expr * end,gfc_expr * stride,mpz_t last)3952 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
3953 gfc_expr *stride, mpz_t last)
3954 {
3955 mpz_t rem;
3956
3957 if (start == NULL || start->expr_type != EXPR_CONSTANT
3958 || end == NULL || end->expr_type != EXPR_CONSTANT
3959 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
3960 return 0;
3961
3962 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
3963 || (stride != NULL && stride->ts.type != BT_INTEGER))
3964 return 0;
3965
3966 if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
3967 {
3968 if (compare_bound (start, end) == CMP_GT)
3969 return 0;
3970 mpz_set (last, end->value.integer);
3971 return 1;
3972 }
3973
3974 if (compare_bound_int (stride, 0) == CMP_GT)
3975 {
3976 /* Stride is positive */
3977 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
3978 return 0;
3979 }
3980 else
3981 {
3982 /* Stride is negative */
3983 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
3984 return 0;
3985 }
3986
3987 mpz_init (rem);
3988 mpz_sub (rem, end->value.integer, start->value.integer);
3989 mpz_tdiv_r (rem, rem, stride->value.integer);
3990 mpz_sub (last, end->value.integer, rem);
3991 mpz_clear (rem);
3992
3993 return 1;
3994 }
3995
3996
3997 /* Compare a single dimension of an array reference to the array
3998 specification. */
3999
4000 static bool
check_dimension(int i,gfc_array_ref * ar,gfc_array_spec * as)4001 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4002 {
4003 mpz_t last_value;
4004
4005 if (ar->dimen_type[i] == DIMEN_STAR)
4006 {
4007 gcc_assert (ar->stride[i] == NULL);
4008 /* This implies [*] as [*:] and [*:3] are not possible. */
4009 if (ar->start[i] == NULL)
4010 {
4011 gcc_assert (ar->end[i] == NULL);
4012 return true;
4013 }
4014 }
4015
4016 /* Given start, end and stride values, calculate the minimum and
4017 maximum referenced indexes. */
4018
4019 switch (ar->dimen_type[i])
4020 {
4021 case DIMEN_VECTOR:
4022 case DIMEN_THIS_IMAGE:
4023 break;
4024
4025 case DIMEN_STAR:
4026 case DIMEN_ELEMENT:
4027 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4028 {
4029 if (i < as->rank)
4030 gfc_warning (0, "Array reference at %L is out of bounds "
4031 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4032 mpz_get_si (ar->start[i]->value.integer),
4033 mpz_get_si (as->lower[i]->value.integer), i+1);
4034 else
4035 gfc_warning (0, "Array reference at %L is out of bounds "
4036 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4037 mpz_get_si (ar->start[i]->value.integer),
4038 mpz_get_si (as->lower[i]->value.integer),
4039 i + 1 - as->rank);
4040 return true;
4041 }
4042 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4043 {
4044 if (i < as->rank)
4045 gfc_warning (0, "Array reference at %L is out of bounds "
4046 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4047 mpz_get_si (ar->start[i]->value.integer),
4048 mpz_get_si (as->upper[i]->value.integer), i+1);
4049 else
4050 gfc_warning (0, "Array reference at %L is out of bounds "
4051 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4052 mpz_get_si (ar->start[i]->value.integer),
4053 mpz_get_si (as->upper[i]->value.integer),
4054 i + 1 - as->rank);
4055 return true;
4056 }
4057
4058 break;
4059
4060 case DIMEN_RANGE:
4061 {
4062 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4063 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4064
4065 compare_result comp_start_end = compare_bound (AR_START, AR_END);
4066
4067 /* Check for zero stride, which is not allowed. */
4068 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4069 {
4070 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4071 return false;
4072 }
4073
4074 /* if start == len || (stride > 0 && start < len)
4075 || (stride < 0 && start > len),
4076 then the array section contains at least one element. In this
4077 case, there is an out-of-bounds access if
4078 (start < lower || start > upper). */
4079 if (compare_bound (AR_START, AR_END) == CMP_EQ
4080 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4081 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4082 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4083 && comp_start_end == CMP_GT))
4084 {
4085 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4086 {
4087 gfc_warning (0, "Lower array reference at %L is out of bounds "
4088 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4089 mpz_get_si (AR_START->value.integer),
4090 mpz_get_si (as->lower[i]->value.integer), i+1);
4091 return true;
4092 }
4093 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4094 {
4095 gfc_warning (0, "Lower array reference at %L is out of bounds "
4096 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4097 mpz_get_si (AR_START->value.integer),
4098 mpz_get_si (as->upper[i]->value.integer), i+1);
4099 return true;
4100 }
4101 }
4102
4103 /* If we can compute the highest index of the array section,
4104 then it also has to be between lower and upper. */
4105 mpz_init (last_value);
4106 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4107 last_value))
4108 {
4109 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4110 {
4111 gfc_warning (0, "Upper array reference at %L is out of bounds "
4112 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4113 mpz_get_si (last_value),
4114 mpz_get_si (as->lower[i]->value.integer), i+1);
4115 mpz_clear (last_value);
4116 return true;
4117 }
4118 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4119 {
4120 gfc_warning (0, "Upper array reference at %L is out of bounds "
4121 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4122 mpz_get_si (last_value),
4123 mpz_get_si (as->upper[i]->value.integer), i+1);
4124 mpz_clear (last_value);
4125 return true;
4126 }
4127 }
4128 mpz_clear (last_value);
4129
4130 #undef AR_START
4131 #undef AR_END
4132 }
4133 break;
4134
4135 default:
4136 gfc_internal_error ("check_dimension(): Bad array reference");
4137 }
4138
4139 return true;
4140 }
4141
4142
4143 /* Compare an array reference with an array specification. */
4144
4145 static bool
compare_spec_to_ref(gfc_array_ref * ar)4146 compare_spec_to_ref (gfc_array_ref *ar)
4147 {
4148 gfc_array_spec *as;
4149 int i;
4150
4151 as = ar->as;
4152 i = as->rank - 1;
4153 /* TODO: Full array sections are only allowed as actual parameters. */
4154 if (as->type == AS_ASSUMED_SIZE
4155 && (/*ar->type == AR_FULL
4156 ||*/ (ar->type == AR_SECTION
4157 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4158 {
4159 gfc_error ("Rightmost upper bound of assumed size array section "
4160 "not specified at %L", &ar->where);
4161 return false;
4162 }
4163
4164 if (ar->type == AR_FULL)
4165 return true;
4166
4167 if (as->rank != ar->dimen)
4168 {
4169 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4170 &ar->where, ar->dimen, as->rank);
4171 return false;
4172 }
4173
4174 /* ar->codimen == 0 is a local array. */
4175 if (as->corank != ar->codimen && ar->codimen != 0)
4176 {
4177 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4178 &ar->where, ar->codimen, as->corank);
4179 return false;
4180 }
4181
4182 for (i = 0; i < as->rank; i++)
4183 if (!check_dimension (i, ar, as))
4184 return false;
4185
4186 /* Local access has no coarray spec. */
4187 if (ar->codimen != 0)
4188 for (i = as->rank; i < as->rank + as->corank; i++)
4189 {
4190 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4191 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4192 {
4193 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4194 i + 1 - as->rank, &ar->where);
4195 return false;
4196 }
4197 if (!check_dimension (i, ar, as))
4198 return false;
4199 }
4200
4201 return true;
4202 }
4203
4204
4205 /* Resolve one part of an array index. */
4206
4207 static bool
gfc_resolve_index_1(gfc_expr * index,int check_scalar,int force_index_integer_kind)4208 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4209 int force_index_integer_kind)
4210 {
4211 gfc_typespec ts;
4212
4213 if (index == NULL)
4214 return true;
4215
4216 if (!gfc_resolve_expr (index))
4217 return false;
4218
4219 if (check_scalar && index->rank != 0)
4220 {
4221 gfc_error ("Array index at %L must be scalar", &index->where);
4222 return false;
4223 }
4224
4225 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4226 {
4227 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4228 &index->where, gfc_basic_typename (index->ts.type));
4229 return false;
4230 }
4231
4232 if (index->ts.type == BT_REAL)
4233 if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
4234 &index->where))
4235 return false;
4236
4237 if ((index->ts.kind != gfc_index_integer_kind
4238 && force_index_integer_kind)
4239 || index->ts.type != BT_INTEGER)
4240 {
4241 gfc_clear_ts (&ts);
4242 ts.type = BT_INTEGER;
4243 ts.kind = gfc_index_integer_kind;
4244
4245 gfc_convert_type_warn (index, &ts, 2, 0);
4246 }
4247
4248 return true;
4249 }
4250
4251 /* Resolve one part of an array index. */
4252
4253 bool
gfc_resolve_index(gfc_expr * index,int check_scalar)4254 gfc_resolve_index (gfc_expr *index, int check_scalar)
4255 {
4256 return gfc_resolve_index_1 (index, check_scalar, 1);
4257 }
4258
4259 /* Resolve a dim argument to an intrinsic function. */
4260
4261 bool
gfc_resolve_dim_arg(gfc_expr * dim)4262 gfc_resolve_dim_arg (gfc_expr *dim)
4263 {
4264 if (dim == NULL)
4265 return true;
4266
4267 if (!gfc_resolve_expr (dim))
4268 return false;
4269
4270 if (dim->rank != 0)
4271 {
4272 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4273 return false;
4274
4275 }
4276
4277 if (dim->ts.type != BT_INTEGER)
4278 {
4279 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4280 return false;
4281 }
4282
4283 if (dim->ts.kind != gfc_index_integer_kind)
4284 {
4285 gfc_typespec ts;
4286
4287 gfc_clear_ts (&ts);
4288 ts.type = BT_INTEGER;
4289 ts.kind = gfc_index_integer_kind;
4290
4291 gfc_convert_type_warn (dim, &ts, 2, 0);
4292 }
4293
4294 return true;
4295 }
4296
4297 /* Given an expression that contains array references, update those array
4298 references to point to the right array specifications. While this is
4299 filled in during matching, this information is difficult to save and load
4300 in a module, so we take care of it here.
4301
4302 The idea here is that the original array reference comes from the
4303 base symbol. We traverse the list of reference structures, setting
4304 the stored reference to references. Component references can
4305 provide an additional array specification. */
4306
4307 static void
find_array_spec(gfc_expr * e)4308 find_array_spec (gfc_expr *e)
4309 {
4310 gfc_array_spec *as;
4311 gfc_component *c;
4312 gfc_ref *ref;
4313
4314 if (e->symtree->n.sym->ts.type == BT_CLASS)
4315 as = CLASS_DATA (e->symtree->n.sym)->as;
4316 else
4317 as = e->symtree->n.sym->as;
4318
4319 for (ref = e->ref; ref; ref = ref->next)
4320 switch (ref->type)
4321 {
4322 case REF_ARRAY:
4323 if (as == NULL)
4324 gfc_internal_error ("find_array_spec(): Missing spec");
4325
4326 ref->u.ar.as = as;
4327 as = NULL;
4328 break;
4329
4330 case REF_COMPONENT:
4331 c = ref->u.c.component;
4332 if (c->attr.dimension)
4333 {
4334 if (as != NULL)
4335 gfc_internal_error ("find_array_spec(): unused as(1)");
4336 as = c->as;
4337 }
4338
4339 break;
4340
4341 case REF_SUBSTRING:
4342 break;
4343 }
4344
4345 if (as != NULL)
4346 gfc_internal_error ("find_array_spec(): unused as(2)");
4347 }
4348
4349
4350 /* Resolve an array reference. */
4351
4352 static bool
resolve_array_ref(gfc_array_ref * ar)4353 resolve_array_ref (gfc_array_ref *ar)
4354 {
4355 int i, check_scalar;
4356 gfc_expr *e;
4357
4358 for (i = 0; i < ar->dimen + ar->codimen; i++)
4359 {
4360 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4361
4362 /* Do not force gfc_index_integer_kind for the start. We can
4363 do fine with any integer kind. This avoids temporary arrays
4364 created for indexing with a vector. */
4365 if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
4366 return false;
4367 if (!gfc_resolve_index (ar->end[i], check_scalar))
4368 return false;
4369 if (!gfc_resolve_index (ar->stride[i], check_scalar))
4370 return false;
4371
4372 e = ar->start[i];
4373
4374 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4375 switch (e->rank)
4376 {
4377 case 0:
4378 ar->dimen_type[i] = DIMEN_ELEMENT;
4379 break;
4380
4381 case 1:
4382 ar->dimen_type[i] = DIMEN_VECTOR;
4383 if (e->expr_type == EXPR_VARIABLE
4384 && e->symtree->n.sym->ts.type == BT_DERIVED)
4385 ar->start[i] = gfc_get_parentheses (e);
4386 break;
4387
4388 default:
4389 gfc_error ("Array index at %L is an array of rank %d",
4390 &ar->c_where[i], e->rank);
4391 return false;
4392 }
4393
4394 /* Fill in the upper bound, which may be lower than the
4395 specified one for something like a(2:10:5), which is
4396 identical to a(2:7:5). Only relevant for strides not equal
4397 to one. Don't try a division by zero. */
4398 if (ar->dimen_type[i] == DIMEN_RANGE
4399 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4400 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4401 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4402 {
4403 mpz_t size, end;
4404
4405 if (gfc_ref_dimen_size (ar, i, &size, &end))
4406 {
4407 if (ar->end[i] == NULL)
4408 {
4409 ar->end[i] =
4410 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4411 &ar->where);
4412 mpz_set (ar->end[i]->value.integer, end);
4413 }
4414 else if (ar->end[i]->ts.type == BT_INTEGER
4415 && ar->end[i]->expr_type == EXPR_CONSTANT)
4416 {
4417 mpz_set (ar->end[i]->value.integer, end);
4418 }
4419 else
4420 gcc_unreachable ();
4421
4422 mpz_clear (size);
4423 mpz_clear (end);
4424 }
4425 }
4426 }
4427
4428 if (ar->type == AR_FULL)
4429 {
4430 if (ar->as->rank == 0)
4431 ar->type = AR_ELEMENT;
4432
4433 /* Make sure array is the same as array(:,:), this way
4434 we don't need to special case all the time. */
4435 ar->dimen = ar->as->rank;
4436 for (i = 0; i < ar->dimen; i++)
4437 {
4438 ar->dimen_type[i] = DIMEN_RANGE;
4439
4440 gcc_assert (ar->start[i] == NULL);
4441 gcc_assert (ar->end[i] == NULL);
4442 gcc_assert (ar->stride[i] == NULL);
4443 }
4444 }
4445
4446 /* If the reference type is unknown, figure out what kind it is. */
4447
4448 if (ar->type == AR_UNKNOWN)
4449 {
4450 ar->type = AR_ELEMENT;
4451 for (i = 0; i < ar->dimen; i++)
4452 if (ar->dimen_type[i] == DIMEN_RANGE
4453 || ar->dimen_type[i] == DIMEN_VECTOR)
4454 {
4455 ar->type = AR_SECTION;
4456 break;
4457 }
4458 }
4459
4460 if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
4461 return false;
4462
4463 if (ar->as->corank && ar->codimen == 0)
4464 {
4465 int n;
4466 ar->codimen = ar->as->corank;
4467 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4468 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4469 }
4470
4471 return true;
4472 }
4473
4474
4475 static bool
resolve_substring(gfc_ref * ref)4476 resolve_substring (gfc_ref *ref)
4477 {
4478 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4479
4480 if (ref->u.ss.start != NULL)
4481 {
4482 if (!gfc_resolve_expr (ref->u.ss.start))
4483 return false;
4484
4485 if (ref->u.ss.start->ts.type != BT_INTEGER)
4486 {
4487 gfc_error ("Substring start index at %L must be of type INTEGER",
4488 &ref->u.ss.start->where);
4489 return false;
4490 }
4491
4492 if (ref->u.ss.start->rank != 0)
4493 {
4494 gfc_error ("Substring start index at %L must be scalar",
4495 &ref->u.ss.start->where);
4496 return false;
4497 }
4498
4499 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4500 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4501 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4502 {
4503 gfc_error ("Substring start index at %L is less than one",
4504 &ref->u.ss.start->where);
4505 return false;
4506 }
4507 }
4508
4509 if (ref->u.ss.end != NULL)
4510 {
4511 if (!gfc_resolve_expr (ref->u.ss.end))
4512 return false;
4513
4514 if (ref->u.ss.end->ts.type != BT_INTEGER)
4515 {
4516 gfc_error ("Substring end index at %L must be of type INTEGER",
4517 &ref->u.ss.end->where);
4518 return false;
4519 }
4520
4521 if (ref->u.ss.end->rank != 0)
4522 {
4523 gfc_error ("Substring end index at %L must be scalar",
4524 &ref->u.ss.end->where);
4525 return false;
4526 }
4527
4528 if (ref->u.ss.length != NULL
4529 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4530 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4531 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4532 {
4533 gfc_error ("Substring end index at %L exceeds the string length",
4534 &ref->u.ss.start->where);
4535 return false;
4536 }
4537
4538 if (compare_bound_mpz_t (ref->u.ss.end,
4539 gfc_integer_kinds[k].huge) == CMP_GT
4540 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4541 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4542 {
4543 gfc_error ("Substring end index at %L is too large",
4544 &ref->u.ss.end->where);
4545 return false;
4546 }
4547 }
4548
4549 return true;
4550 }
4551
4552
4553 /* This function supplies missing substring charlens. */
4554
4555 void
gfc_resolve_substring_charlen(gfc_expr * e)4556 gfc_resolve_substring_charlen (gfc_expr *e)
4557 {
4558 gfc_ref *char_ref;
4559 gfc_expr *start, *end;
4560 gfc_typespec *ts = NULL;
4561
4562 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4563 {
4564 if (char_ref->type == REF_SUBSTRING)
4565 break;
4566 if (char_ref->type == REF_COMPONENT)
4567 ts = &char_ref->u.c.component->ts;
4568 }
4569
4570 if (!char_ref)
4571 return;
4572
4573 gcc_assert (char_ref->next == NULL);
4574
4575 if (e->ts.u.cl)
4576 {
4577 if (e->ts.u.cl->length)
4578 gfc_free_expr (e->ts.u.cl->length);
4579 else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
4580 return;
4581 }
4582
4583 e->ts.type = BT_CHARACTER;
4584 e->ts.kind = gfc_default_character_kind;
4585
4586 if (!e->ts.u.cl)
4587 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4588
4589 if (char_ref->u.ss.start)
4590 start = gfc_copy_expr (char_ref->u.ss.start);
4591 else
4592 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4593
4594 if (char_ref->u.ss.end)
4595 end = gfc_copy_expr (char_ref->u.ss.end);
4596 else if (e->expr_type == EXPR_VARIABLE)
4597 {
4598 if (!ts)
4599 ts = &e->symtree->n.sym->ts;
4600 end = gfc_copy_expr (ts->u.cl->length);
4601 }
4602 else
4603 end = NULL;
4604
4605 if (!start || !end)
4606 {
4607 gfc_free_expr (start);
4608 gfc_free_expr (end);
4609 return;
4610 }
4611
4612 /* Length = (end - start + 1). */
4613 e->ts.u.cl->length = gfc_subtract (end, start);
4614 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4615 gfc_get_int_expr (gfc_default_integer_kind,
4616 NULL, 1));
4617
4618 /* F2008, 6.4.1: Both the starting point and the ending point shall
4619 be within the range 1, 2, ..., n unless the starting point exceeds
4620 the ending point, in which case the substring has length zero. */
4621
4622 if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
4623 mpz_set_si (e->ts.u.cl->length->value.integer, 0);
4624
4625 e->ts.u.cl->length->ts.type = BT_INTEGER;
4626 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4627
4628 /* Make sure that the length is simplified. */
4629 gfc_simplify_expr (e->ts.u.cl->length, 1);
4630 gfc_resolve_expr (e->ts.u.cl->length);
4631 }
4632
4633
4634 /* Resolve subtype references. */
4635
4636 static bool
resolve_ref(gfc_expr * expr)4637 resolve_ref (gfc_expr *expr)
4638 {
4639 int current_part_dimension, n_components, seen_part_dimension;
4640 gfc_ref *ref;
4641
4642 for (ref = expr->ref; ref; ref = ref->next)
4643 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
4644 {
4645 find_array_spec (expr);
4646 break;
4647 }
4648
4649 for (ref = expr->ref; ref; ref = ref->next)
4650 switch (ref->type)
4651 {
4652 case REF_ARRAY:
4653 if (!resolve_array_ref (&ref->u.ar))
4654 return false;
4655 break;
4656
4657 case REF_COMPONENT:
4658 break;
4659
4660 case REF_SUBSTRING:
4661 if (!resolve_substring (ref))
4662 return false;
4663 break;
4664 }
4665
4666 /* Check constraints on part references. */
4667
4668 current_part_dimension = 0;
4669 seen_part_dimension = 0;
4670 n_components = 0;
4671
4672 for (ref = expr->ref; ref; ref = ref->next)
4673 {
4674 switch (ref->type)
4675 {
4676 case REF_ARRAY:
4677 switch (ref->u.ar.type)
4678 {
4679 case AR_FULL:
4680 /* Coarray scalar. */
4681 if (ref->u.ar.as->rank == 0)
4682 {
4683 current_part_dimension = 0;
4684 break;
4685 }
4686 /* Fall through. */
4687 case AR_SECTION:
4688 current_part_dimension = 1;
4689 break;
4690
4691 case AR_ELEMENT:
4692 current_part_dimension = 0;
4693 break;
4694
4695 case AR_UNKNOWN:
4696 gfc_internal_error ("resolve_ref(): Bad array reference");
4697 }
4698
4699 break;
4700
4701 case REF_COMPONENT:
4702 if (current_part_dimension || seen_part_dimension)
4703 {
4704 /* F03:C614. */
4705 if (ref->u.c.component->attr.pointer
4706 || ref->u.c.component->attr.proc_pointer
4707 || (ref->u.c.component->ts.type == BT_CLASS
4708 && CLASS_DATA (ref->u.c.component)->attr.pointer))
4709 {
4710 gfc_error ("Component to the right of a part reference "
4711 "with nonzero rank must not have the POINTER "
4712 "attribute at %L", &expr->where);
4713 return false;
4714 }
4715 else if (ref->u.c.component->attr.allocatable
4716 || (ref->u.c.component->ts.type == BT_CLASS
4717 && CLASS_DATA (ref->u.c.component)->attr.allocatable))
4718
4719 {
4720 gfc_error ("Component to the right of a part reference "
4721 "with nonzero rank must not have the ALLOCATABLE "
4722 "attribute at %L", &expr->where);
4723 return false;
4724 }
4725 }
4726
4727 n_components++;
4728 break;
4729
4730 case REF_SUBSTRING:
4731 break;
4732 }
4733
4734 if (((ref->type == REF_COMPONENT && n_components > 1)
4735 || ref->next == NULL)
4736 && current_part_dimension
4737 && seen_part_dimension)
4738 {
4739 gfc_error ("Two or more part references with nonzero rank must "
4740 "not be specified at %L", &expr->where);
4741 return false;
4742 }
4743
4744 if (ref->type == REF_COMPONENT)
4745 {
4746 if (current_part_dimension)
4747 seen_part_dimension = 1;
4748
4749 /* reset to make sure */
4750 current_part_dimension = 0;
4751 }
4752 }
4753
4754 return true;
4755 }
4756
4757
4758 /* Given an expression, determine its shape. This is easier than it sounds.
4759 Leaves the shape array NULL if it is not possible to determine the shape. */
4760
4761 static void
expression_shape(gfc_expr * e)4762 expression_shape (gfc_expr *e)
4763 {
4764 mpz_t array[GFC_MAX_DIMENSIONS];
4765 int i;
4766
4767 if (e->rank <= 0 || e->shape != NULL)
4768 return;
4769
4770 for (i = 0; i < e->rank; i++)
4771 if (!gfc_array_dimen_size (e, i, &array[i]))
4772 goto fail;
4773
4774 e->shape = gfc_get_shape (e->rank);
4775
4776 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
4777
4778 return;
4779
4780 fail:
4781 for (i--; i >= 0; i--)
4782 mpz_clear (array[i]);
4783 }
4784
4785
4786 /* Given a variable expression node, compute the rank of the expression by
4787 examining the base symbol and any reference structures it may have. */
4788
4789 void
expression_rank(gfc_expr * e)4790 expression_rank (gfc_expr *e)
4791 {
4792 gfc_ref *ref;
4793 int i, rank;
4794
4795 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4796 could lead to serious confusion... */
4797 gcc_assert (e->expr_type != EXPR_COMPCALL);
4798
4799 if (e->ref == NULL)
4800 {
4801 if (e->expr_type == EXPR_ARRAY)
4802 goto done;
4803 /* Constructors can have a rank different from one via RESHAPE(). */
4804
4805 if (e->symtree == NULL)
4806 {
4807 e->rank = 0;
4808 goto done;
4809 }
4810
4811 e->rank = (e->symtree->n.sym->as == NULL)
4812 ? 0 : e->symtree->n.sym->as->rank;
4813 goto done;
4814 }
4815
4816 rank = 0;
4817
4818 for (ref = e->ref; ref; ref = ref->next)
4819 {
4820 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
4821 && ref->u.c.component->attr.function && !ref->next)
4822 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
4823
4824 if (ref->type != REF_ARRAY)
4825 continue;
4826
4827 if (ref->u.ar.type == AR_FULL)
4828 {
4829 rank = ref->u.ar.as->rank;
4830 break;
4831 }
4832
4833 if (ref->u.ar.type == AR_SECTION)
4834 {
4835 /* Figure out the rank of the section. */
4836 if (rank != 0)
4837 gfc_internal_error ("expression_rank(): Two array specs");
4838
4839 for (i = 0; i < ref->u.ar.dimen; i++)
4840 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
4841 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
4842 rank++;
4843
4844 break;
4845 }
4846 }
4847
4848 e->rank = rank;
4849
4850 done:
4851 expression_shape (e);
4852 }
4853
4854
4855 static void
add_caf_get_intrinsic(gfc_expr * e)4856 add_caf_get_intrinsic (gfc_expr *e)
4857 {
4858 gfc_expr *wrapper, *tmp_expr;
4859 gfc_ref *ref;
4860 int n;
4861
4862 for (ref = e->ref; ref; ref = ref->next)
4863 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4864 break;
4865 if (ref == NULL)
4866 return;
4867
4868 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
4869 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
4870 return;
4871
4872 tmp_expr = XCNEW (gfc_expr);
4873 *tmp_expr = *e;
4874 wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
4875 "caf_get", tmp_expr->where, 1, tmp_expr);
4876 wrapper->ts = e->ts;
4877 wrapper->rank = e->rank;
4878 if (e->rank)
4879 wrapper->shape = gfc_copy_shape (e->shape, e->rank);
4880 *e = *wrapper;
4881 free (wrapper);
4882 }
4883
4884
4885 static void
remove_caf_get_intrinsic(gfc_expr * e)4886 remove_caf_get_intrinsic (gfc_expr *e)
4887 {
4888 gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
4889 && e->value.function.isym->id == GFC_ISYM_CAF_GET);
4890 gfc_expr *e2 = e->value.function.actual->expr;
4891 e->value.function.actual->expr = NULL;
4892 gfc_free_actual_arglist (e->value.function.actual);
4893 gfc_free_shape (&e->shape, e->rank);
4894 *e = *e2;
4895 free (e2);
4896 }
4897
4898
4899 /* Resolve a variable expression. */
4900
4901 static bool
resolve_variable(gfc_expr * e)4902 resolve_variable (gfc_expr *e)
4903 {
4904 gfc_symbol *sym;
4905 bool t;
4906
4907 t = true;
4908
4909 if (e->symtree == NULL)
4910 return false;
4911 sym = e->symtree->n.sym;
4912
4913 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4914 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4915 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
4916 {
4917 if (!actual_arg || inquiry_argument)
4918 {
4919 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4920 "be used as actual argument", sym->name, &e->where);
4921 return false;
4922 }
4923 }
4924 /* TS 29113, 407b. */
4925 else if (e->ts.type == BT_ASSUMED)
4926 {
4927 if (!actual_arg)
4928 {
4929 gfc_error ("Assumed-type variable %s at %L may only be used "
4930 "as actual argument", sym->name, &e->where);
4931 return false;
4932 }
4933 else if (inquiry_argument && !first_actual_arg)
4934 {
4935 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4936 for all inquiry functions in resolve_function; the reason is
4937 that the function-name resolution happens too late in that
4938 function. */
4939 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4940 "an inquiry function shall be the first argument",
4941 sym->name, &e->where);
4942 return false;
4943 }
4944 }
4945 /* TS 29113, C535b. */
4946 else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
4947 && CLASS_DATA (sym)->as
4948 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
4949 || (sym->ts.type != BT_CLASS && sym->as
4950 && sym->as->type == AS_ASSUMED_RANK))
4951 {
4952 if (!actual_arg)
4953 {
4954 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4955 "actual argument", sym->name, &e->where);
4956 return false;
4957 }
4958 else if (inquiry_argument && !first_actual_arg)
4959 {
4960 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4961 for all inquiry functions in resolve_function; the reason is
4962 that the function-name resolution happens too late in that
4963 function. */
4964 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4965 "to an inquiry function shall be the first argument",
4966 sym->name, &e->where);
4967 return false;
4968 }
4969 }
4970
4971 if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
4972 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
4973 && e->ref->next == NULL))
4974 {
4975 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4976 "a subobject reference", sym->name, &e->ref->u.ar.where);
4977 return false;
4978 }
4979 /* TS 29113, 407b. */
4980 else if (e->ts.type == BT_ASSUMED && e->ref
4981 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
4982 && e->ref->next == NULL))
4983 {
4984 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4985 "reference", sym->name, &e->ref->u.ar.where);
4986 return false;
4987 }
4988
4989 /* TS 29113, C535b. */
4990 if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
4991 && CLASS_DATA (sym)->as
4992 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
4993 || (sym->ts.type != BT_CLASS && sym->as
4994 && sym->as->type == AS_ASSUMED_RANK))
4995 && e->ref
4996 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
4997 && e->ref->next == NULL))
4998 {
4999 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5000 "reference", sym->name, &e->ref->u.ar.where);
5001 return false;
5002 }
5003
5004 /* For variables that are used in an associate (target => object) where
5005 the object's basetype is array valued while the target is scalar,
5006 the ts' type of the component refs is still array valued, which
5007 can't be translated that way. */
5008 if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
5009 && sym->assoc->target->ts.type == BT_CLASS
5010 && CLASS_DATA (sym->assoc->target)->as)
5011 {
5012 gfc_ref *ref = e->ref;
5013 while (ref)
5014 {
5015 switch (ref->type)
5016 {
5017 case REF_COMPONENT:
5018 ref->u.c.sym = sym->ts.u.derived;
5019 /* Stop the loop. */
5020 ref = NULL;
5021 break;
5022 default:
5023 ref = ref->next;
5024 break;
5025 }
5026 }
5027 }
5028
5029 /* If this is an associate-name, it may be parsed with an array reference
5030 in error even though the target is scalar. Fail directly in this case.
5031 TODO Understand why class scalar expressions must be excluded. */
5032 if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5033 {
5034 if (sym->ts.type == BT_CLASS)
5035 gfc_fix_class_refs (e);
5036 if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5037 return false;
5038 }
5039
5040 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5041 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5042
5043 /* On the other hand, the parser may not have known this is an array;
5044 in this case, we have to add a FULL reference. */
5045 if (sym->assoc && sym->attr.dimension && !e->ref)
5046 {
5047 e->ref = gfc_get_ref ();
5048 e->ref->type = REF_ARRAY;
5049 e->ref->u.ar.type = AR_FULL;
5050 e->ref->u.ar.dimen = 0;
5051 }
5052
5053 /* Like above, but for class types, where the checking whether an array
5054 ref is present is more complicated. Furthermore make sure not to add
5055 the full array ref to _vptr or _len refs. */
5056 if (sym->assoc && sym->ts.type == BT_CLASS
5057 && CLASS_DATA (sym)->attr.dimension
5058 && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
5059 {
5060 gfc_ref *ref, *newref;
5061
5062 newref = gfc_get_ref ();
5063 newref->type = REF_ARRAY;
5064 newref->u.ar.type = AR_FULL;
5065 newref->u.ar.dimen = 0;
5066 /* Because this is an associate var and the first ref either is a ref to
5067 the _data component or not, no traversal of the ref chain is
5068 needed. The array ref needs to be inserted after the _data ref,
5069 or when that is not present, which may happend for polymorphic
5070 types, then at the first position. */
5071 ref = e->ref;
5072 if (!ref)
5073 e->ref = newref;
5074 else if (ref->type == REF_COMPONENT
5075 && strcmp ("_data", ref->u.c.component->name) == 0)
5076 {
5077 if (!ref->next || ref->next->type != REF_ARRAY)
5078 {
5079 newref->next = ref->next;
5080 ref->next = newref;
5081 }
5082 else
5083 /* Array ref present already. */
5084 gfc_free_ref_list (newref);
5085 }
5086 else if (ref->type == REF_ARRAY)
5087 /* Array ref present already. */
5088 gfc_free_ref_list (newref);
5089 else
5090 {
5091 newref->next = ref;
5092 e->ref = newref;
5093 }
5094 }
5095
5096 if (e->ref && !resolve_ref (e))
5097 return false;
5098
5099 if (sym->attr.flavor == FL_PROCEDURE
5100 && (!sym->attr.function
5101 || (sym->attr.function && sym->result
5102 && sym->result->attr.proc_pointer
5103 && !sym->result->attr.function)))
5104 {
5105 e->ts.type = BT_PROCEDURE;
5106 goto resolve_procedure;
5107 }
5108
5109 if (sym->ts.type != BT_UNKNOWN)
5110 gfc_variable_attr (e, &e->ts);
5111 else if (sym->attr.flavor == FL_PROCEDURE
5112 && sym->attr.function && sym->result
5113 && sym->result->ts.type != BT_UNKNOWN
5114 && sym->result->attr.proc_pointer)
5115 e->ts = sym->result->ts;
5116 else
5117 {
5118 /* Must be a simple variable reference. */
5119 if (!gfc_set_default_type (sym, 1, sym->ns))
5120 return false;
5121 e->ts = sym->ts;
5122 }
5123
5124 if (check_assumed_size_reference (sym, e))
5125 return false;
5126
5127 /* Deal with forward references to entries during gfc_resolve_code, to
5128 satisfy, at least partially, 12.5.2.5. */
5129 if (gfc_current_ns->entries
5130 && current_entry_id == sym->entry_id
5131 && cs_base
5132 && cs_base->current
5133 && cs_base->current->op != EXEC_ENTRY)
5134 {
5135 gfc_entry_list *entry;
5136 gfc_formal_arglist *formal;
5137 int n;
5138 bool seen, saved_specification_expr;
5139
5140 /* If the symbol is a dummy... */
5141 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5142 {
5143 entry = gfc_current_ns->entries;
5144 seen = false;
5145
5146 /* ...test if the symbol is a parameter of previous entries. */
5147 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5148 for (formal = entry->sym->formal; formal; formal = formal->next)
5149 {
5150 if (formal->sym && sym->name == formal->sym->name)
5151 {
5152 seen = true;
5153 break;
5154 }
5155 }
5156
5157 /* If it has not been seen as a dummy, this is an error. */
5158 if (!seen)
5159 {
5160 if (specification_expr)
5161 gfc_error ("Variable %qs, used in a specification expression"
5162 ", is referenced at %L before the ENTRY statement "
5163 "in which it is a parameter",
5164 sym->name, &cs_base->current->loc);
5165 else
5166 gfc_error ("Variable %qs is used at %L before the ENTRY "
5167 "statement in which it is a parameter",
5168 sym->name, &cs_base->current->loc);
5169 t = false;
5170 }
5171 }
5172
5173 /* Now do the same check on the specification expressions. */
5174 saved_specification_expr = specification_expr;
5175 specification_expr = true;
5176 if (sym->ts.type == BT_CHARACTER
5177 && !gfc_resolve_expr (sym->ts.u.cl->length))
5178 t = false;
5179
5180 if (sym->as)
5181 for (n = 0; n < sym->as->rank; n++)
5182 {
5183 if (!gfc_resolve_expr (sym->as->lower[n]))
5184 t = false;
5185 if (!gfc_resolve_expr (sym->as->upper[n]))
5186 t = false;
5187 }
5188 specification_expr = saved_specification_expr;
5189
5190 if (t)
5191 /* Update the symbol's entry level. */
5192 sym->entry_id = current_entry_id + 1;
5193 }
5194
5195 /* If a symbol has been host_associated mark it. This is used latter,
5196 to identify if aliasing is possible via host association. */
5197 if (sym->attr.flavor == FL_VARIABLE
5198 && gfc_current_ns->parent
5199 && (gfc_current_ns->parent == sym->ns
5200 || (gfc_current_ns->parent->parent
5201 && gfc_current_ns->parent->parent == sym->ns)))
5202 sym->attr.host_assoc = 1;
5203
5204 if (gfc_current_ns->proc_name
5205 && sym->attr.dimension
5206 && (sym->ns != gfc_current_ns
5207 || sym->attr.use_assoc
5208 || sym->attr.in_common))
5209 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
5210
5211 resolve_procedure:
5212 if (t && !resolve_procedure_expression (e))
5213 t = false;
5214
5215 /* F2008, C617 and C1229. */
5216 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5217 && gfc_is_coindexed (e))
5218 {
5219 gfc_ref *ref, *ref2 = NULL;
5220
5221 for (ref = e->ref; ref; ref = ref->next)
5222 {
5223 if (ref->type == REF_COMPONENT)
5224 ref2 = ref;
5225 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5226 break;
5227 }
5228
5229 for ( ; ref; ref = ref->next)
5230 if (ref->type == REF_COMPONENT)
5231 break;
5232
5233 /* Expression itself is not coindexed object. */
5234 if (ref && e->ts.type == BT_CLASS)
5235 {
5236 gfc_error ("Polymorphic subobject of coindexed object at %L",
5237 &e->where);
5238 t = false;
5239 }
5240
5241 /* Expression itself is coindexed object. */
5242 if (ref == NULL)
5243 {
5244 gfc_component *c;
5245 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5246 for ( ; c; c = c->next)
5247 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5248 {
5249 gfc_error ("Coindexed object with polymorphic allocatable "
5250 "subcomponent at %L", &e->where);
5251 t = false;
5252 break;
5253 }
5254 }
5255 }
5256
5257 if (t)
5258 expression_rank (e);
5259
5260 if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
5261 add_caf_get_intrinsic (e);
5262
5263 return t;
5264 }
5265
5266
5267 /* Checks to see that the correct symbol has been host associated.
5268 The only situation where this arises is that in which a twice
5269 contained function is parsed after the host association is made.
5270 Therefore, on detecting this, change the symbol in the expression
5271 and convert the array reference into an actual arglist if the old
5272 symbol is a variable. */
5273 static bool
check_host_association(gfc_expr * e)5274 check_host_association (gfc_expr *e)
5275 {
5276 gfc_symbol *sym, *old_sym;
5277 gfc_symtree *st;
5278 int n;
5279 gfc_ref *ref;
5280 gfc_actual_arglist *arg, *tail = NULL;
5281 bool retval = e->expr_type == EXPR_FUNCTION;
5282
5283 /* If the expression is the result of substitution in
5284 interface.c(gfc_extend_expr) because there is no way in
5285 which the host association can be wrong. */
5286 if (e->symtree == NULL
5287 || e->symtree->n.sym == NULL
5288 || e->user_operator)
5289 return retval;
5290
5291 old_sym = e->symtree->n.sym;
5292
5293 if (gfc_current_ns->parent
5294 && old_sym->ns != gfc_current_ns)
5295 {
5296 /* Use the 'USE' name so that renamed module symbols are
5297 correctly handled. */
5298 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5299
5300 if (sym && old_sym != sym
5301 && sym->ts.type == old_sym->ts.type
5302 && sym->attr.flavor == FL_PROCEDURE
5303 && sym->attr.contained)
5304 {
5305 /* Clear the shape, since it might not be valid. */
5306 gfc_free_shape (&e->shape, e->rank);
5307
5308 /* Give the expression the right symtree! */
5309 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5310 gcc_assert (st != NULL);
5311
5312 if (old_sym->attr.flavor == FL_PROCEDURE
5313 || e->expr_type == EXPR_FUNCTION)
5314 {
5315 /* Original was function so point to the new symbol, since
5316 the actual argument list is already attached to the
5317 expression. */
5318 e->value.function.esym = NULL;
5319 e->symtree = st;
5320 }
5321 else
5322 {
5323 /* Original was variable so convert array references into
5324 an actual arglist. This does not need any checking now
5325 since resolve_function will take care of it. */
5326 e->value.function.actual = NULL;
5327 e->expr_type = EXPR_FUNCTION;
5328 e->symtree = st;
5329
5330 /* Ambiguity will not arise if the array reference is not
5331 the last reference. */
5332 for (ref = e->ref; ref; ref = ref->next)
5333 if (ref->type == REF_ARRAY && ref->next == NULL)
5334 break;
5335
5336 gcc_assert (ref->type == REF_ARRAY);
5337
5338 /* Grab the start expressions from the array ref and
5339 copy them into actual arguments. */
5340 for (n = 0; n < ref->u.ar.dimen; n++)
5341 {
5342 arg = gfc_get_actual_arglist ();
5343 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5344 if (e->value.function.actual == NULL)
5345 tail = e->value.function.actual = arg;
5346 else
5347 {
5348 tail->next = arg;
5349 tail = arg;
5350 }
5351 }
5352
5353 /* Dump the reference list and set the rank. */
5354 gfc_free_ref_list (e->ref);
5355 e->ref = NULL;
5356 e->rank = sym->as ? sym->as->rank : 0;
5357 }
5358
5359 gfc_resolve_expr (e);
5360 sym->refs++;
5361 }
5362 }
5363 /* This might have changed! */
5364 return e->expr_type == EXPR_FUNCTION;
5365 }
5366
5367
5368 static void
gfc_resolve_character_operator(gfc_expr * e)5369 gfc_resolve_character_operator (gfc_expr *e)
5370 {
5371 gfc_expr *op1 = e->value.op.op1;
5372 gfc_expr *op2 = e->value.op.op2;
5373 gfc_expr *e1 = NULL;
5374 gfc_expr *e2 = NULL;
5375
5376 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5377
5378 if (op1->ts.u.cl && op1->ts.u.cl->length)
5379 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5380 else if (op1->expr_type == EXPR_CONSTANT)
5381 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5382 op1->value.character.length);
5383
5384 if (op2->ts.u.cl && op2->ts.u.cl->length)
5385 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5386 else if (op2->expr_type == EXPR_CONSTANT)
5387 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5388 op2->value.character.length);
5389
5390 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5391
5392 if (!e1 || !e2)
5393 {
5394 gfc_free_expr (e1);
5395 gfc_free_expr (e2);
5396
5397 return;
5398 }
5399
5400 e->ts.u.cl->length = gfc_add (e1, e2);
5401 e->ts.u.cl->length->ts.type = BT_INTEGER;
5402 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5403 gfc_simplify_expr (e->ts.u.cl->length, 0);
5404 gfc_resolve_expr (e->ts.u.cl->length);
5405
5406 return;
5407 }
5408
5409
5410 /* Ensure that an character expression has a charlen and, if possible, a
5411 length expression. */
5412
5413 static void
fixup_charlen(gfc_expr * e)5414 fixup_charlen (gfc_expr *e)
5415 {
5416 /* The cases fall through so that changes in expression type and the need
5417 for multiple fixes are picked up. In all circumstances, a charlen should
5418 be available for the middle end to hang a backend_decl on. */
5419 switch (e->expr_type)
5420 {
5421 case EXPR_OP:
5422 gfc_resolve_character_operator (e);
5423
5424 case EXPR_ARRAY:
5425 if (e->expr_type == EXPR_ARRAY)
5426 gfc_resolve_character_array_constructor (e);
5427
5428 case EXPR_SUBSTRING:
5429 if (!e->ts.u.cl && e->ref)
5430 gfc_resolve_substring_charlen (e);
5431
5432 default:
5433 if (!e->ts.u.cl)
5434 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5435
5436 break;
5437 }
5438 }
5439
5440
5441 /* Update an actual argument to include the passed-object for type-bound
5442 procedures at the right position. */
5443
5444 static gfc_actual_arglist*
update_arglist_pass(gfc_actual_arglist * lst,gfc_expr * po,unsigned argpos,const char * name)5445 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5446 const char *name)
5447 {
5448 gcc_assert (argpos > 0);
5449
5450 if (argpos == 1)
5451 {
5452 gfc_actual_arglist* result;
5453
5454 result = gfc_get_actual_arglist ();
5455 result->expr = po;
5456 result->next = lst;
5457 if (name)
5458 result->name = name;
5459
5460 return result;
5461 }
5462
5463 if (lst)
5464 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5465 else
5466 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5467 return lst;
5468 }
5469
5470
5471 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5472
5473 static gfc_expr*
extract_compcall_passed_object(gfc_expr * e)5474 extract_compcall_passed_object (gfc_expr* e)
5475 {
5476 gfc_expr* po;
5477
5478 gcc_assert (e->expr_type == EXPR_COMPCALL);
5479
5480 if (e->value.compcall.base_object)
5481 po = gfc_copy_expr (e->value.compcall.base_object);
5482 else
5483 {
5484 po = gfc_get_expr ();
5485 po->expr_type = EXPR_VARIABLE;
5486 po->symtree = e->symtree;
5487 po->ref = gfc_copy_ref (e->ref);
5488 po->where = e->where;
5489 }
5490
5491 if (!gfc_resolve_expr (po))
5492 return NULL;
5493
5494 return po;
5495 }
5496
5497
5498 /* Update the arglist of an EXPR_COMPCALL expression to include the
5499 passed-object. */
5500
5501 static bool
update_compcall_arglist(gfc_expr * e)5502 update_compcall_arglist (gfc_expr* e)
5503 {
5504 gfc_expr* po;
5505 gfc_typebound_proc* tbp;
5506
5507 tbp = e->value.compcall.tbp;
5508
5509 if (tbp->error)
5510 return false;
5511
5512 po = extract_compcall_passed_object (e);
5513 if (!po)
5514 return false;
5515
5516 if (tbp->nopass || e->value.compcall.ignore_pass)
5517 {
5518 gfc_free_expr (po);
5519 return true;
5520 }
5521
5522 gcc_assert (tbp->pass_arg_num > 0);
5523 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5524 tbp->pass_arg_num,
5525 tbp->pass_arg);
5526
5527 return true;
5528 }
5529
5530
5531 /* Extract the passed object from a PPC call (a copy of it). */
5532
5533 static gfc_expr*
extract_ppc_passed_object(gfc_expr * e)5534 extract_ppc_passed_object (gfc_expr *e)
5535 {
5536 gfc_expr *po;
5537 gfc_ref **ref;
5538
5539 po = gfc_get_expr ();
5540 po->expr_type = EXPR_VARIABLE;
5541 po->symtree = e->symtree;
5542 po->ref = gfc_copy_ref (e->ref);
5543 po->where = e->where;
5544
5545 /* Remove PPC reference. */
5546 ref = &po->ref;
5547 while ((*ref)->next)
5548 ref = &(*ref)->next;
5549 gfc_free_ref_list (*ref);
5550 *ref = NULL;
5551
5552 if (!gfc_resolve_expr (po))
5553 return NULL;
5554
5555 return po;
5556 }
5557
5558
5559 /* Update the actual arglist of a procedure pointer component to include the
5560 passed-object. */
5561
5562 static bool
update_ppc_arglist(gfc_expr * e)5563 update_ppc_arglist (gfc_expr* e)
5564 {
5565 gfc_expr* po;
5566 gfc_component *ppc;
5567 gfc_typebound_proc* tb;
5568
5569 ppc = gfc_get_proc_ptr_comp (e);
5570 if (!ppc)
5571 return false;
5572
5573 tb = ppc->tb;
5574
5575 if (tb->error)
5576 return false;
5577 else if (tb->nopass)
5578 return true;
5579
5580 po = extract_ppc_passed_object (e);
5581 if (!po)
5582 return false;
5583
5584 /* F08:R739. */
5585 if (po->rank != 0)
5586 {
5587 gfc_error ("Passed-object at %L must be scalar", &e->where);
5588 return false;
5589 }
5590
5591 /* F08:C611. */
5592 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5593 {
5594 gfc_error ("Base object for procedure-pointer component call at %L is of"
5595 " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
5596 return false;
5597 }
5598
5599 gcc_assert (tb->pass_arg_num > 0);
5600 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5601 tb->pass_arg_num,
5602 tb->pass_arg);
5603
5604 return true;
5605 }
5606
5607
5608 /* Check that the object a TBP is called on is valid, i.e. it must not be
5609 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5610
5611 static bool
check_typebound_baseobject(gfc_expr * e)5612 check_typebound_baseobject (gfc_expr* e)
5613 {
5614 gfc_expr* base;
5615 bool return_value = false;
5616
5617 base = extract_compcall_passed_object (e);
5618 if (!base)
5619 return false;
5620
5621 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5622
5623 if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
5624 return false;
5625
5626 /* F08:C611. */
5627 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5628 {
5629 gfc_error ("Base object for type-bound procedure call at %L is of"
5630 " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
5631 goto cleanup;
5632 }
5633
5634 /* F08:C1230. If the procedure called is NOPASS,
5635 the base object must be scalar. */
5636 if (e->value.compcall.tbp->nopass && base->rank != 0)
5637 {
5638 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5639 " be scalar", &e->where);
5640 goto cleanup;
5641 }
5642
5643 return_value = true;
5644
5645 cleanup:
5646 gfc_free_expr (base);
5647 return return_value;
5648 }
5649
5650
5651 /* Resolve a call to a type-bound procedure, either function or subroutine,
5652 statically from the data in an EXPR_COMPCALL expression. The adapted
5653 arglist and the target-procedure symtree are returned. */
5654
5655 static bool
resolve_typebound_static(gfc_expr * e,gfc_symtree ** target,gfc_actual_arglist ** actual)5656 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5657 gfc_actual_arglist** actual)
5658 {
5659 gcc_assert (e->expr_type == EXPR_COMPCALL);
5660 gcc_assert (!e->value.compcall.tbp->is_generic);
5661
5662 /* Update the actual arglist for PASS. */
5663 if (!update_compcall_arglist (e))
5664 return false;
5665
5666 *actual = e->value.compcall.actual;
5667 *target = e->value.compcall.tbp->u.specific;
5668
5669 gfc_free_ref_list (e->ref);
5670 e->ref = NULL;
5671 e->value.compcall.actual = NULL;
5672
5673 /* If we find a deferred typebound procedure, check for derived types
5674 that an overriding typebound procedure has not been missed. */
5675 if (e->value.compcall.name
5676 && !e->value.compcall.tbp->non_overridable
5677 && e->value.compcall.base_object
5678 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5679 {
5680 gfc_symtree *st;
5681 gfc_symbol *derived;
5682
5683 /* Use the derived type of the base_object. */
5684 derived = e->value.compcall.base_object->ts.u.derived;
5685 st = NULL;
5686
5687 /* If necessary, go through the inheritance chain. */
5688 while (!st && derived)
5689 {
5690 /* Look for the typebound procedure 'name'. */
5691 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5692 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5693 e->value.compcall.name);
5694 if (!st)
5695 derived = gfc_get_derived_super_type (derived);
5696 }
5697
5698 /* Now find the specific name in the derived type namespace. */
5699 if (st && st->n.tb && st->n.tb->u.specific)
5700 gfc_find_sym_tree (st->n.tb->u.specific->name,
5701 derived->ns, 1, &st);
5702 if (st)
5703 *target = st;
5704 }
5705 return true;
5706 }
5707
5708
5709 /* Get the ultimate declared type from an expression. In addition,
5710 return the last class/derived type reference and the copy of the
5711 reference list. If check_types is set true, derived types are
5712 identified as well as class references. */
5713 static gfc_symbol*
get_declared_from_expr(gfc_ref ** class_ref,gfc_ref ** new_ref,gfc_expr * e,bool check_types)5714 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5715 gfc_expr *e, bool check_types)
5716 {
5717 gfc_symbol *declared;
5718 gfc_ref *ref;
5719
5720 declared = NULL;
5721 if (class_ref)
5722 *class_ref = NULL;
5723 if (new_ref)
5724 *new_ref = gfc_copy_ref (e->ref);
5725
5726 for (ref = e->ref; ref; ref = ref->next)
5727 {
5728 if (ref->type != REF_COMPONENT)
5729 continue;
5730
5731 if ((ref->u.c.component->ts.type == BT_CLASS
5732 || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
5733 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5734 {
5735 declared = ref->u.c.component->ts.u.derived;
5736 if (class_ref)
5737 *class_ref = ref;
5738 }
5739 }
5740
5741 if (declared == NULL)
5742 declared = e->symtree->n.sym->ts.u.derived;
5743
5744 return declared;
5745 }
5746
5747
5748 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5749 which of the specific bindings (if any) matches the arglist and transform
5750 the expression into a call of that binding. */
5751
5752 static bool
resolve_typebound_generic_call(gfc_expr * e,const char ** name)5753 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5754 {
5755 gfc_typebound_proc* genproc;
5756 const char* genname;
5757 gfc_symtree *st;
5758 gfc_symbol *derived;
5759
5760 gcc_assert (e->expr_type == EXPR_COMPCALL);
5761 genname = e->value.compcall.name;
5762 genproc = e->value.compcall.tbp;
5763
5764 if (!genproc->is_generic)
5765 return true;
5766
5767 /* Try the bindings on this type and in the inheritance hierarchy. */
5768 for (; genproc; genproc = genproc->overridden)
5769 {
5770 gfc_tbp_generic* g;
5771
5772 gcc_assert (genproc->is_generic);
5773 for (g = genproc->u.generic; g; g = g->next)
5774 {
5775 gfc_symbol* target;
5776 gfc_actual_arglist* args;
5777 bool matches;
5778
5779 gcc_assert (g->specific);
5780
5781 if (g->specific->error)
5782 continue;
5783
5784 target = g->specific->u.specific->n.sym;
5785
5786 /* Get the right arglist by handling PASS/NOPASS. */
5787 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5788 if (!g->specific->nopass)
5789 {
5790 gfc_expr* po;
5791 po = extract_compcall_passed_object (e);
5792 if (!po)
5793 {
5794 gfc_free_actual_arglist (args);
5795 return false;
5796 }
5797
5798 gcc_assert (g->specific->pass_arg_num > 0);
5799 gcc_assert (!g->specific->error);
5800 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
5801 g->specific->pass_arg);
5802 }
5803 resolve_actual_arglist (args, target->attr.proc,
5804 is_external_proc (target)
5805 && gfc_sym_get_dummy_args (target) == NULL);
5806
5807 /* Check if this arglist matches the formal. */
5808 matches = gfc_arglist_matches_symbol (&args, target);
5809
5810 /* Clean up and break out of the loop if we've found it. */
5811 gfc_free_actual_arglist (args);
5812 if (matches)
5813 {
5814 e->value.compcall.tbp = g->specific;
5815 genname = g->specific_st->name;
5816 /* Pass along the name for CLASS methods, where the vtab
5817 procedure pointer component has to be referenced. */
5818 if (name)
5819 *name = genname;
5820 goto success;
5821 }
5822 }
5823 }
5824
5825 /* Nothing matching found! */
5826 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5827 " %qs at %L", genname, &e->where);
5828 return false;
5829
5830 success:
5831 /* Make sure that we have the right specific instance for the name. */
5832 derived = get_declared_from_expr (NULL, NULL, e, true);
5833
5834 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
5835 if (st)
5836 e->value.compcall.tbp = st->n.tb;
5837
5838 return true;
5839 }
5840
5841
5842 /* Resolve a call to a type-bound subroutine. */
5843
5844 static bool
resolve_typebound_call(gfc_code * c,const char ** name,bool * overridable)5845 resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
5846 {
5847 gfc_actual_arglist* newactual;
5848 gfc_symtree* target;
5849
5850 /* Check that's really a SUBROUTINE. */
5851 if (!c->expr1->value.compcall.tbp->subroutine)
5852 {
5853 gfc_error ("%qs at %L should be a SUBROUTINE",
5854 c->expr1->value.compcall.name, &c->loc);
5855 return false;
5856 }
5857
5858 if (!check_typebound_baseobject (c->expr1))
5859 return false;
5860
5861 /* Pass along the name for CLASS methods, where the vtab
5862 procedure pointer component has to be referenced. */
5863 if (name)
5864 *name = c->expr1->value.compcall.name;
5865
5866 if (!resolve_typebound_generic_call (c->expr1, name))
5867 return false;
5868
5869 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5870 if (overridable)
5871 *overridable = !c->expr1->value.compcall.tbp->non_overridable;
5872
5873 /* Transform into an ordinary EXEC_CALL for now. */
5874
5875 if (!resolve_typebound_static (c->expr1, &target, &newactual))
5876 return false;
5877
5878 c->ext.actual = newactual;
5879 c->symtree = target;
5880 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
5881
5882 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
5883
5884 gfc_free_expr (c->expr1);
5885 c->expr1 = gfc_get_expr ();
5886 c->expr1->expr_type = EXPR_FUNCTION;
5887 c->expr1->symtree = target;
5888 c->expr1->where = c->loc;
5889
5890 return resolve_call (c);
5891 }
5892
5893
5894 /* Resolve a component-call expression. */
5895 static bool
resolve_compcall(gfc_expr * e,const char ** name)5896 resolve_compcall (gfc_expr* e, const char **name)
5897 {
5898 gfc_actual_arglist* newactual;
5899 gfc_symtree* target;
5900
5901 /* Check that's really a FUNCTION. */
5902 if (!e->value.compcall.tbp->function)
5903 {
5904 gfc_error ("%qs at %L should be a FUNCTION",
5905 e->value.compcall.name, &e->where);
5906 return false;
5907 }
5908
5909 /* These must not be assign-calls! */
5910 gcc_assert (!e->value.compcall.assign);
5911
5912 if (!check_typebound_baseobject (e))
5913 return false;
5914
5915 /* Pass along the name for CLASS methods, where the vtab
5916 procedure pointer component has to be referenced. */
5917 if (name)
5918 *name = e->value.compcall.name;
5919
5920 if (!resolve_typebound_generic_call (e, name))
5921 return false;
5922 gcc_assert (!e->value.compcall.tbp->is_generic);
5923
5924 /* Take the rank from the function's symbol. */
5925 if (e->value.compcall.tbp->u.specific->n.sym->as)
5926 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
5927
5928 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5929 arglist to the TBP's binding target. */
5930
5931 if (!resolve_typebound_static (e, &target, &newactual))
5932 return false;
5933
5934 e->value.function.actual = newactual;
5935 e->value.function.name = NULL;
5936 e->value.function.esym = target->n.sym;
5937 e->value.function.isym = NULL;
5938 e->symtree = target;
5939 e->ts = target->n.sym->ts;
5940 e->expr_type = EXPR_FUNCTION;
5941
5942 /* Resolution is not necessary if this is a class subroutine; this
5943 function only has to identify the specific proc. Resolution of
5944 the call will be done next in resolve_typebound_call. */
5945 return gfc_resolve_expr (e);
5946 }
5947
5948
5949 static bool resolve_fl_derived (gfc_symbol *sym);
5950
5951
5952 /* Resolve a typebound function, or 'method'. First separate all
5953 the non-CLASS references by calling resolve_compcall directly. */
5954
5955 static bool
resolve_typebound_function(gfc_expr * e)5956 resolve_typebound_function (gfc_expr* e)
5957 {
5958 gfc_symbol *declared;
5959 gfc_component *c;
5960 gfc_ref *new_ref;
5961 gfc_ref *class_ref;
5962 gfc_symtree *st;
5963 const char *name;
5964 gfc_typespec ts;
5965 gfc_expr *expr;
5966 bool overridable;
5967
5968 st = e->symtree;
5969
5970 /* Deal with typebound operators for CLASS objects. */
5971 expr = e->value.compcall.base_object;
5972 overridable = !e->value.compcall.tbp->non_overridable;
5973 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
5974 {
5975 /* If the base_object is not a variable, the corresponding actual
5976 argument expression must be stored in e->base_expression so
5977 that the corresponding tree temporary can be used as the base
5978 object in gfc_conv_procedure_call. */
5979 if (expr->expr_type != EXPR_VARIABLE)
5980 {
5981 gfc_actual_arglist *args;
5982
5983 for (args= e->value.function.actual; args; args = args->next)
5984 {
5985 if (expr == args->expr)
5986 expr = args->expr;
5987 }
5988 }
5989
5990 /* Since the typebound operators are generic, we have to ensure
5991 that any delays in resolution are corrected and that the vtab
5992 is present. */
5993 ts = expr->ts;
5994 declared = ts.u.derived;
5995 c = gfc_find_component (declared, "_vptr", true, true, NULL);
5996 if (c->ts.u.derived == NULL)
5997 c->ts.u.derived = gfc_find_derived_vtab (declared);
5998
5999 if (!resolve_compcall (e, &name))
6000 return false;
6001
6002 /* Use the generic name if it is there. */
6003 name = name ? name : e->value.function.esym->name;
6004 e->symtree = expr->symtree;
6005 e->ref = gfc_copy_ref (expr->ref);
6006 get_declared_from_expr (&class_ref, NULL, e, false);
6007
6008 /* Trim away the extraneous references that emerge from nested
6009 use of interface.c (extend_expr). */
6010 if (class_ref && class_ref->next)
6011 {
6012 gfc_free_ref_list (class_ref->next);
6013 class_ref->next = NULL;
6014 }
6015 else if (e->ref && !class_ref)
6016 {
6017 gfc_free_ref_list (e->ref);
6018 e->ref = NULL;
6019 }
6020
6021 gfc_add_vptr_component (e);
6022 gfc_add_component_ref (e, name);
6023 e->value.function.esym = NULL;
6024 if (expr->expr_type != EXPR_VARIABLE)
6025 e->base_expr = expr;
6026 return true;
6027 }
6028
6029 if (st == NULL)
6030 return resolve_compcall (e, NULL);
6031
6032 if (!resolve_ref (e))
6033 return false;
6034
6035 /* Get the CLASS declared type. */
6036 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
6037
6038 if (!resolve_fl_derived (declared))
6039 return false;
6040
6041 /* Weed out cases of the ultimate component being a derived type. */
6042 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
6043 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6044 {
6045 gfc_free_ref_list (new_ref);
6046 return resolve_compcall (e, NULL);
6047 }
6048
6049 c = gfc_find_component (declared, "_data", true, true, NULL);
6050 declared = c->ts.u.derived;
6051
6052 /* Treat the call as if it is a typebound procedure, in order to roll
6053 out the correct name for the specific function. */
6054 if (!resolve_compcall (e, &name))
6055 {
6056 gfc_free_ref_list (new_ref);
6057 return false;
6058 }
6059 ts = e->ts;
6060
6061 if (overridable)
6062 {
6063 /* Convert the expression to a procedure pointer component call. */
6064 e->value.function.esym = NULL;
6065 e->symtree = st;
6066
6067 if (new_ref)
6068 e->ref = new_ref;
6069
6070 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6071 gfc_add_vptr_component (e);
6072 gfc_add_component_ref (e, name);
6073
6074 /* Recover the typespec for the expression. This is really only
6075 necessary for generic procedures, where the additional call
6076 to gfc_add_component_ref seems to throw the collection of the
6077 correct typespec. */
6078 e->ts = ts;
6079 }
6080 else if (new_ref)
6081 gfc_free_ref_list (new_ref);
6082
6083 return true;
6084 }
6085
6086 /* Resolve a typebound subroutine, or 'method'. First separate all
6087 the non-CLASS references by calling resolve_typebound_call
6088 directly. */
6089
6090 static bool
resolve_typebound_subroutine(gfc_code * code)6091 resolve_typebound_subroutine (gfc_code *code)
6092 {
6093 gfc_symbol *declared;
6094 gfc_component *c;
6095 gfc_ref *new_ref;
6096 gfc_ref *class_ref;
6097 gfc_symtree *st;
6098 const char *name;
6099 gfc_typespec ts;
6100 gfc_expr *expr;
6101 bool overridable;
6102
6103 st = code->expr1->symtree;
6104
6105 /* Deal with typebound operators for CLASS objects. */
6106 expr = code->expr1->value.compcall.base_object;
6107 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6108 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6109 {
6110 /* If the base_object is not a variable, the corresponding actual
6111 argument expression must be stored in e->base_expression so
6112 that the corresponding tree temporary can be used as the base
6113 object in gfc_conv_procedure_call. */
6114 if (expr->expr_type != EXPR_VARIABLE)
6115 {
6116 gfc_actual_arglist *args;
6117
6118 args= code->expr1->value.function.actual;
6119 for (; args; args = args->next)
6120 if (expr == args->expr)
6121 expr = args->expr;
6122 }
6123
6124 /* Since the typebound operators are generic, we have to ensure
6125 that any delays in resolution are corrected and that the vtab
6126 is present. */
6127 declared = expr->ts.u.derived;
6128 c = gfc_find_component (declared, "_vptr", true, true, NULL);
6129 if (c->ts.u.derived == NULL)
6130 c->ts.u.derived = gfc_find_derived_vtab (declared);
6131
6132 if (!resolve_typebound_call (code, &name, NULL))
6133 return false;
6134
6135 /* Use the generic name if it is there. */
6136 name = name ? name : code->expr1->value.function.esym->name;
6137 code->expr1->symtree = expr->symtree;
6138 code->expr1->ref = gfc_copy_ref (expr->ref);
6139
6140 /* Trim away the extraneous references that emerge from nested
6141 use of interface.c (extend_expr). */
6142 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6143 if (class_ref && class_ref->next)
6144 {
6145 gfc_free_ref_list (class_ref->next);
6146 class_ref->next = NULL;
6147 }
6148 else if (code->expr1->ref && !class_ref)
6149 {
6150 gfc_free_ref_list (code->expr1->ref);
6151 code->expr1->ref = NULL;
6152 }
6153
6154 /* Now use the procedure in the vtable. */
6155 gfc_add_vptr_component (code->expr1);
6156 gfc_add_component_ref (code->expr1, name);
6157 code->expr1->value.function.esym = NULL;
6158 if (expr->expr_type != EXPR_VARIABLE)
6159 code->expr1->base_expr = expr;
6160 return true;
6161 }
6162
6163 if (st == NULL)
6164 return resolve_typebound_call (code, NULL, NULL);
6165
6166 if (!resolve_ref (code->expr1))
6167 return false;
6168
6169 /* Get the CLASS declared type. */
6170 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6171
6172 /* Weed out cases of the ultimate component being a derived type. */
6173 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
6174 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6175 {
6176 gfc_free_ref_list (new_ref);
6177 return resolve_typebound_call (code, NULL, NULL);
6178 }
6179
6180 if (!resolve_typebound_call (code, &name, &overridable))
6181 {
6182 gfc_free_ref_list (new_ref);
6183 return false;
6184 }
6185 ts = code->expr1->ts;
6186
6187 if (overridable)
6188 {
6189 /* Convert the expression to a procedure pointer component call. */
6190 code->expr1->value.function.esym = NULL;
6191 code->expr1->symtree = st;
6192
6193 if (new_ref)
6194 code->expr1->ref = new_ref;
6195
6196 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6197 gfc_add_vptr_component (code->expr1);
6198 gfc_add_component_ref (code->expr1, name);
6199
6200 /* Recover the typespec for the expression. This is really only
6201 necessary for generic procedures, where the additional call
6202 to gfc_add_component_ref seems to throw the collection of the
6203 correct typespec. */
6204 code->expr1->ts = ts;
6205 }
6206 else if (new_ref)
6207 gfc_free_ref_list (new_ref);
6208
6209 return true;
6210 }
6211
6212
6213 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6214
6215 static bool
resolve_ppc_call(gfc_code * c)6216 resolve_ppc_call (gfc_code* c)
6217 {
6218 gfc_component *comp;
6219
6220 comp = gfc_get_proc_ptr_comp (c->expr1);
6221 gcc_assert (comp != NULL);
6222
6223 c->resolved_sym = c->expr1->symtree->n.sym;
6224 c->expr1->expr_type = EXPR_VARIABLE;
6225
6226 if (!comp->attr.subroutine)
6227 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6228
6229 if (!resolve_ref (c->expr1))
6230 return false;
6231
6232 if (!update_ppc_arglist (c->expr1))
6233 return false;
6234
6235 c->ext.actual = c->expr1->value.compcall.actual;
6236
6237 if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6238 !(comp->ts.interface
6239 && comp->ts.interface->formal)))
6240 return false;
6241
6242 if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
6243 return false;
6244
6245 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6246
6247 return true;
6248 }
6249
6250
6251 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6252
6253 static bool
resolve_expr_ppc(gfc_expr * e)6254 resolve_expr_ppc (gfc_expr* e)
6255 {
6256 gfc_component *comp;
6257
6258 comp = gfc_get_proc_ptr_comp (e);
6259 gcc_assert (comp != NULL);
6260
6261 /* Convert to EXPR_FUNCTION. */
6262 e->expr_type = EXPR_FUNCTION;
6263 e->value.function.isym = NULL;
6264 e->value.function.actual = e->value.compcall.actual;
6265 e->ts = comp->ts;
6266 if (comp->as != NULL)
6267 e->rank = comp->as->rank;
6268
6269 if (!comp->attr.function)
6270 gfc_add_function (&comp->attr, comp->name, &e->where);
6271
6272 if (!resolve_ref (e))
6273 return false;
6274
6275 if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6276 !(comp->ts.interface
6277 && comp->ts.interface->formal)))
6278 return false;
6279
6280 if (!update_ppc_arglist (e))
6281 return false;
6282
6283 if (!check_pure_function(e))
6284 return false;
6285
6286 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6287
6288 return true;
6289 }
6290
6291
6292 static bool
gfc_is_expandable_expr(gfc_expr * e)6293 gfc_is_expandable_expr (gfc_expr *e)
6294 {
6295 gfc_constructor *con;
6296
6297 if (e->expr_type == EXPR_ARRAY)
6298 {
6299 /* Traverse the constructor looking for variables that are flavor
6300 parameter. Parameters must be expanded since they are fully used at
6301 compile time. */
6302 con = gfc_constructor_first (e->value.constructor);
6303 for (; con; con = gfc_constructor_next (con))
6304 {
6305 if (con->expr->expr_type == EXPR_VARIABLE
6306 && con->expr->symtree
6307 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6308 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6309 return true;
6310 if (con->expr->expr_type == EXPR_ARRAY
6311 && gfc_is_expandable_expr (con->expr))
6312 return true;
6313 }
6314 }
6315
6316 return false;
6317 }
6318
6319
6320 /* Sometimes variables in specification expressions of the result
6321 of module procedures in submodules wind up not being the 'real'
6322 dummy. Find this, if possible, in the namespace of the first
6323 formal argument. */
6324
6325 static void
fixup_unique_dummy(gfc_expr * e)6326 fixup_unique_dummy (gfc_expr *e)
6327 {
6328 gfc_symtree *st = NULL;
6329 gfc_symbol *s = NULL;
6330
6331 if (e->symtree->n.sym->ns->proc_name
6332 && e->symtree->n.sym->ns->proc_name->formal)
6333 s = e->symtree->n.sym->ns->proc_name->formal->sym;
6334
6335 if (s != NULL)
6336 st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
6337
6338 if (st != NULL
6339 && st->n.sym != NULL
6340 && st->n.sym->attr.dummy)
6341 e->symtree = st;
6342 }
6343
6344 /* Resolve an expression. That is, make sure that types of operands agree
6345 with their operators, intrinsic operators are converted to function calls
6346 for overloaded types and unresolved function references are resolved. */
6347
6348 bool
gfc_resolve_expr(gfc_expr * e)6349 gfc_resolve_expr (gfc_expr *e)
6350 {
6351 bool t;
6352 bool inquiry_save, actual_arg_save, first_actual_arg_save;
6353
6354 if (e == NULL)
6355 return true;
6356
6357 /* inquiry_argument only applies to variables. */
6358 inquiry_save = inquiry_argument;
6359 actual_arg_save = actual_arg;
6360 first_actual_arg_save = first_actual_arg;
6361
6362 if (e->expr_type != EXPR_VARIABLE)
6363 {
6364 inquiry_argument = false;
6365 actual_arg = false;
6366 first_actual_arg = false;
6367 }
6368 else if (e->symtree != NULL
6369 && *e->symtree->name == '@'
6370 && e->symtree->n.sym->attr.dummy)
6371 {
6372 /* Deal with submodule specification expressions that are not
6373 found to be referenced in module.c(read_cleanup). */
6374 fixup_unique_dummy (e);
6375 }
6376
6377 switch (e->expr_type)
6378 {
6379 case EXPR_OP:
6380 t = resolve_operator (e);
6381 break;
6382
6383 case EXPR_FUNCTION:
6384 case EXPR_VARIABLE:
6385
6386 if (check_host_association (e))
6387 t = resolve_function (e);
6388 else
6389 t = resolve_variable (e);
6390
6391 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6392 && e->ref->type != REF_SUBSTRING)
6393 gfc_resolve_substring_charlen (e);
6394
6395 break;
6396
6397 case EXPR_COMPCALL:
6398 t = resolve_typebound_function (e);
6399 break;
6400
6401 case EXPR_SUBSTRING:
6402 t = resolve_ref (e);
6403 break;
6404
6405 case EXPR_CONSTANT:
6406 case EXPR_NULL:
6407 t = true;
6408 break;
6409
6410 case EXPR_PPC:
6411 t = resolve_expr_ppc (e);
6412 break;
6413
6414 case EXPR_ARRAY:
6415 t = false;
6416 if (!resolve_ref (e))
6417 break;
6418
6419 t = gfc_resolve_array_constructor (e);
6420 /* Also try to expand a constructor. */
6421 if (t)
6422 {
6423 expression_rank (e);
6424 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6425 gfc_expand_constructor (e, false);
6426 }
6427
6428 /* This provides the opportunity for the length of constructors with
6429 character valued function elements to propagate the string length
6430 to the expression. */
6431 if (t && e->ts.type == BT_CHARACTER)
6432 {
6433 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6434 here rather then add a duplicate test for it above. */
6435 gfc_expand_constructor (e, false);
6436 t = gfc_resolve_character_array_constructor (e);
6437 }
6438
6439 break;
6440
6441 case EXPR_STRUCTURE:
6442 t = resolve_ref (e);
6443 if (!t)
6444 break;
6445
6446 t = resolve_structure_cons (e, 0);
6447 if (!t)
6448 break;
6449
6450 t = gfc_simplify_expr (e, 0);
6451 break;
6452
6453 default:
6454 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6455 }
6456
6457 if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
6458 fixup_charlen (e);
6459
6460 inquiry_argument = inquiry_save;
6461 actual_arg = actual_arg_save;
6462 first_actual_arg = first_actual_arg_save;
6463
6464 return t;
6465 }
6466
6467
6468 /* Resolve an expression from an iterator. They must be scalar and have
6469 INTEGER or (optionally) REAL type. */
6470
6471 static bool
gfc_resolve_iterator_expr(gfc_expr * expr,bool real_ok,const char * name_msgid)6472 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6473 const char *name_msgid)
6474 {
6475 if (!gfc_resolve_expr (expr))
6476 return false;
6477
6478 if (expr->rank != 0)
6479 {
6480 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6481 return false;
6482 }
6483
6484 if (expr->ts.type != BT_INTEGER)
6485 {
6486 if (expr->ts.type == BT_REAL)
6487 {
6488 if (real_ok)
6489 return gfc_notify_std (GFC_STD_F95_DEL,
6490 "%s at %L must be integer",
6491 _(name_msgid), &expr->where);
6492 else
6493 {
6494 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6495 &expr->where);
6496 return false;
6497 }
6498 }
6499 else
6500 {
6501 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6502 return false;
6503 }
6504 }
6505 return true;
6506 }
6507
6508
6509 /* Resolve the expressions in an iterator structure. If REAL_OK is
6510 false allow only INTEGER type iterators, otherwise allow REAL types.
6511 Set own_scope to true for ac-implied-do and data-implied-do as those
6512 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6513
6514 bool
gfc_resolve_iterator(gfc_iterator * iter,bool real_ok,bool own_scope)6515 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
6516 {
6517 if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
6518 return false;
6519
6520 if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
6521 _("iterator variable")))
6522 return false;
6523
6524 if (!gfc_resolve_iterator_expr (iter->start, real_ok,
6525 "Start expression in DO loop"))
6526 return false;
6527
6528 if (!gfc_resolve_iterator_expr (iter->end, real_ok,
6529 "End expression in DO loop"))
6530 return false;
6531
6532 if (!gfc_resolve_iterator_expr (iter->step, real_ok,
6533 "Step expression in DO loop"))
6534 return false;
6535
6536 if (iter->step->expr_type == EXPR_CONSTANT)
6537 {
6538 if ((iter->step->ts.type == BT_INTEGER
6539 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6540 || (iter->step->ts.type == BT_REAL
6541 && mpfr_sgn (iter->step->value.real) == 0))
6542 {
6543 gfc_error ("Step expression in DO loop at %L cannot be zero",
6544 &iter->step->where);
6545 return false;
6546 }
6547 }
6548
6549 /* Convert start, end, and step to the same type as var. */
6550 if (iter->start->ts.kind != iter->var->ts.kind
6551 || iter->start->ts.type != iter->var->ts.type)
6552 gfc_convert_type (iter->start, &iter->var->ts, 1);
6553
6554 if (iter->end->ts.kind != iter->var->ts.kind
6555 || iter->end->ts.type != iter->var->ts.type)
6556 gfc_convert_type (iter->end, &iter->var->ts, 1);
6557
6558 if (iter->step->ts.kind != iter->var->ts.kind
6559 || iter->step->ts.type != iter->var->ts.type)
6560 gfc_convert_type (iter->step, &iter->var->ts, 1);
6561
6562 if (iter->start->expr_type == EXPR_CONSTANT
6563 && iter->end->expr_type == EXPR_CONSTANT
6564 && iter->step->expr_type == EXPR_CONSTANT)
6565 {
6566 int sgn, cmp;
6567 if (iter->start->ts.type == BT_INTEGER)
6568 {
6569 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6570 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6571 }
6572 else
6573 {
6574 sgn = mpfr_sgn (iter->step->value.real);
6575 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6576 }
6577 if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
6578 gfc_warning (OPT_Wzerotrip,
6579 "DO loop at %L will be executed zero times",
6580 &iter->step->where);
6581 }
6582
6583 return true;
6584 }
6585
6586
6587 /* Traversal function for find_forall_index. f == 2 signals that
6588 that variable itself is not to be checked - only the references. */
6589
6590 static bool
forall_index(gfc_expr * expr,gfc_symbol * sym,int * f)6591 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6592 {
6593 if (expr->expr_type != EXPR_VARIABLE)
6594 return false;
6595
6596 /* A scalar assignment */
6597 if (!expr->ref || *f == 1)
6598 {
6599 if (expr->symtree->n.sym == sym)
6600 return true;
6601 else
6602 return false;
6603 }
6604
6605 if (*f == 2)
6606 *f = 1;
6607 return false;
6608 }
6609
6610
6611 /* Check whether the FORALL index appears in the expression or not.
6612 Returns true if SYM is found in EXPR. */
6613
6614 bool
find_forall_index(gfc_expr * expr,gfc_symbol * sym,int f)6615 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6616 {
6617 if (gfc_traverse_expr (expr, sym, forall_index, f))
6618 return true;
6619 else
6620 return false;
6621 }
6622
6623
6624 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6625 to be a scalar INTEGER variable. The subscripts and stride are scalar
6626 INTEGERs, and if stride is a constant it must be nonzero.
6627 Furthermore "A subscript or stride in a forall-triplet-spec shall
6628 not contain a reference to any index-name in the
6629 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6630
6631 static void
resolve_forall_iterators(gfc_forall_iterator * it)6632 resolve_forall_iterators (gfc_forall_iterator *it)
6633 {
6634 gfc_forall_iterator *iter, *iter2;
6635
6636 for (iter = it; iter; iter = iter->next)
6637 {
6638 if (gfc_resolve_expr (iter->var)
6639 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6640 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6641 &iter->var->where);
6642
6643 if (gfc_resolve_expr (iter->start)
6644 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6645 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6646 &iter->start->where);
6647 if (iter->var->ts.kind != iter->start->ts.kind)
6648 gfc_convert_type (iter->start, &iter->var->ts, 1);
6649
6650 if (gfc_resolve_expr (iter->end)
6651 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6652 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6653 &iter->end->where);
6654 if (iter->var->ts.kind != iter->end->ts.kind)
6655 gfc_convert_type (iter->end, &iter->var->ts, 1);
6656
6657 if (gfc_resolve_expr (iter->stride))
6658 {
6659 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6660 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6661 &iter->stride->where, "INTEGER");
6662
6663 if (iter->stride->expr_type == EXPR_CONSTANT
6664 && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
6665 gfc_error ("FORALL stride expression at %L cannot be zero",
6666 &iter->stride->where);
6667 }
6668 if (iter->var->ts.kind != iter->stride->ts.kind)
6669 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6670 }
6671
6672 for (iter = it; iter; iter = iter->next)
6673 for (iter2 = iter; iter2; iter2 = iter2->next)
6674 {
6675 if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
6676 || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
6677 || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
6678 gfc_error ("FORALL index %qs may not appear in triplet "
6679 "specification at %L", iter->var->symtree->name,
6680 &iter2->start->where);
6681 }
6682 }
6683
6684
6685 /* Given a pointer to a symbol that is a derived type, see if it's
6686 inaccessible, i.e. if it's defined in another module and the components are
6687 PRIVATE. The search is recursive if necessary. Returns zero if no
6688 inaccessible components are found, nonzero otherwise. */
6689
6690 static int
derived_inaccessible(gfc_symbol * sym)6691 derived_inaccessible (gfc_symbol *sym)
6692 {
6693 gfc_component *c;
6694
6695 if (sym->attr.use_assoc && sym->attr.private_comp)
6696 return 1;
6697
6698 for (c = sym->components; c; c = c->next)
6699 {
6700 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6701 return 1;
6702 }
6703
6704 return 0;
6705 }
6706
6707
6708 /* Resolve the argument of a deallocate expression. The expression must be
6709 a pointer or a full array. */
6710
6711 static bool
resolve_deallocate_expr(gfc_expr * e)6712 resolve_deallocate_expr (gfc_expr *e)
6713 {
6714 symbol_attribute attr;
6715 int allocatable, pointer;
6716 gfc_ref *ref;
6717 gfc_symbol *sym;
6718 gfc_component *c;
6719 bool unlimited;
6720
6721 if (!gfc_resolve_expr (e))
6722 return false;
6723
6724 if (e->expr_type != EXPR_VARIABLE)
6725 goto bad;
6726
6727 sym = e->symtree->n.sym;
6728 unlimited = UNLIMITED_POLY(sym);
6729
6730 if (sym->ts.type == BT_CLASS)
6731 {
6732 allocatable = CLASS_DATA (sym)->attr.allocatable;
6733 pointer = CLASS_DATA (sym)->attr.class_pointer;
6734 }
6735 else
6736 {
6737 allocatable = sym->attr.allocatable;
6738 pointer = sym->attr.pointer;
6739 }
6740 for (ref = e->ref; ref; ref = ref->next)
6741 {
6742 switch (ref->type)
6743 {
6744 case REF_ARRAY:
6745 if (ref->u.ar.type != AR_FULL
6746 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6747 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6748 allocatable = 0;
6749 break;
6750
6751 case REF_COMPONENT:
6752 c = ref->u.c.component;
6753 if (c->ts.type == BT_CLASS)
6754 {
6755 allocatable = CLASS_DATA (c)->attr.allocatable;
6756 pointer = CLASS_DATA (c)->attr.class_pointer;
6757 }
6758 else
6759 {
6760 allocatable = c->attr.allocatable;
6761 pointer = c->attr.pointer;
6762 }
6763 break;
6764
6765 case REF_SUBSTRING:
6766 allocatable = 0;
6767 break;
6768 }
6769 }
6770
6771 attr = gfc_expr_attr (e);
6772
6773 if (allocatable == 0 && attr.pointer == 0 && !unlimited)
6774 {
6775 bad:
6776 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6777 &e->where);
6778 return false;
6779 }
6780
6781 /* F2008, C644. */
6782 if (gfc_is_coindexed (e))
6783 {
6784 gfc_error ("Coindexed allocatable object at %L", &e->where);
6785 return false;
6786 }
6787
6788 if (pointer
6789 && !gfc_check_vardef_context (e, true, true, false,
6790 _("DEALLOCATE object")))
6791 return false;
6792 if (!gfc_check_vardef_context (e, false, true, false,
6793 _("DEALLOCATE object")))
6794 return false;
6795
6796 return true;
6797 }
6798
6799
6800 /* Returns true if the expression e contains a reference to the symbol sym. */
6801 static bool
sym_in_expr(gfc_expr * e,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)6802 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6803 {
6804 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6805 return true;
6806
6807 return false;
6808 }
6809
6810 bool
gfc_find_sym_in_expr(gfc_symbol * sym,gfc_expr * e)6811 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6812 {
6813 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6814 }
6815
6816
6817 /* Given the expression node e for an allocatable/pointer of derived type to be
6818 allocated, get the expression node to be initialized afterwards (needed for
6819 derived types with default initializers, and derived types with allocatable
6820 components that need nullification.) */
6821
6822 gfc_expr *
gfc_expr_to_initialize(gfc_expr * e)6823 gfc_expr_to_initialize (gfc_expr *e)
6824 {
6825 gfc_expr *result;
6826 gfc_ref *ref;
6827 int i;
6828
6829 result = gfc_copy_expr (e);
6830
6831 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6832 for (ref = result->ref; ref; ref = ref->next)
6833 if (ref->type == REF_ARRAY && ref->next == NULL)
6834 {
6835 ref->u.ar.type = AR_FULL;
6836
6837 for (i = 0; i < ref->u.ar.dimen; i++)
6838 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
6839
6840 break;
6841 }
6842
6843 gfc_free_shape (&result->shape, result->rank);
6844
6845 /* Recalculate rank, shape, etc. */
6846 gfc_resolve_expr (result);
6847 return result;
6848 }
6849
6850
6851 /* If the last ref of an expression is an array ref, return a copy of the
6852 expression with that one removed. Otherwise, a copy of the original
6853 expression. This is used for allocate-expressions and pointer assignment
6854 LHS, where there may be an array specification that needs to be stripped
6855 off when using gfc_check_vardef_context. */
6856
6857 static gfc_expr*
remove_last_array_ref(gfc_expr * e)6858 remove_last_array_ref (gfc_expr* e)
6859 {
6860 gfc_expr* e2;
6861 gfc_ref** r;
6862
6863 e2 = gfc_copy_expr (e);
6864 for (r = &e2->ref; *r; r = &(*r)->next)
6865 if ((*r)->type == REF_ARRAY && !(*r)->next)
6866 {
6867 gfc_free_ref_list (*r);
6868 *r = NULL;
6869 break;
6870 }
6871
6872 return e2;
6873 }
6874
6875
6876 /* Used in resolve_allocate_expr to check that a allocation-object and
6877 a source-expr are conformable. This does not catch all possible
6878 cases; in particular a runtime checking is needed. */
6879
6880 static bool
conformable_arrays(gfc_expr * e1,gfc_expr * e2)6881 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
6882 {
6883 gfc_ref *tail;
6884 for (tail = e2->ref; tail && tail->next; tail = tail->next);
6885
6886 /* First compare rank. */
6887 if ((tail && e1->rank != tail->u.ar.as->rank)
6888 || (!tail && e1->rank != e2->rank))
6889 {
6890 gfc_error ("Source-expr at %L must be scalar or have the "
6891 "same rank as the allocate-object at %L",
6892 &e1->where, &e2->where);
6893 return false;
6894 }
6895
6896 if (e1->shape)
6897 {
6898 int i;
6899 mpz_t s;
6900
6901 mpz_init (s);
6902
6903 for (i = 0; i < e1->rank; i++)
6904 {
6905 if (tail->u.ar.start[i] == NULL)
6906 break;
6907
6908 if (tail->u.ar.end[i])
6909 {
6910 mpz_set (s, tail->u.ar.end[i]->value.integer);
6911 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
6912 mpz_add_ui (s, s, 1);
6913 }
6914 else
6915 {
6916 mpz_set (s, tail->u.ar.start[i]->value.integer);
6917 }
6918
6919 if (mpz_cmp (e1->shape[i], s) != 0)
6920 {
6921 gfc_error ("Source-expr at %L and allocate-object at %L must "
6922 "have the same shape", &e1->where, &e2->where);
6923 mpz_clear (s);
6924 return false;
6925 }
6926 }
6927
6928 mpz_clear (s);
6929 }
6930
6931 return true;
6932 }
6933
6934
6935 /* Resolve the expression in an ALLOCATE statement, doing the additional
6936 checks to see whether the expression is OK or not. The expression must
6937 have a trailing array reference that gives the size of the array. */
6938
6939 static bool
resolve_allocate_expr(gfc_expr * e,gfc_code * code,bool * array_alloc_wo_spec)6940 resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
6941 {
6942 int i, pointer, allocatable, dimension, is_abstract;
6943 int codimension;
6944 bool coindexed;
6945 bool unlimited;
6946 symbol_attribute attr;
6947 gfc_ref *ref, *ref2;
6948 gfc_expr *e2;
6949 gfc_array_ref *ar;
6950 gfc_symbol *sym = NULL;
6951 gfc_alloc *a;
6952 gfc_component *c;
6953 bool t;
6954
6955 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6956 checking of coarrays. */
6957 for (ref = e->ref; ref; ref = ref->next)
6958 if (ref->next == NULL)
6959 break;
6960
6961 if (ref && ref->type == REF_ARRAY)
6962 ref->u.ar.in_allocate = true;
6963
6964 if (!gfc_resolve_expr (e))
6965 goto failure;
6966
6967 /* Make sure the expression is allocatable or a pointer. If it is
6968 pointer, the next-to-last reference must be a pointer. */
6969
6970 ref2 = NULL;
6971 if (e->symtree)
6972 sym = e->symtree->n.sym;
6973
6974 /* Check whether ultimate component is abstract and CLASS. */
6975 is_abstract = 0;
6976
6977 /* Is the allocate-object unlimited polymorphic? */
6978 unlimited = UNLIMITED_POLY(e);
6979
6980 if (e->expr_type != EXPR_VARIABLE)
6981 {
6982 allocatable = 0;
6983 attr = gfc_expr_attr (e);
6984 pointer = attr.pointer;
6985 dimension = attr.dimension;
6986 codimension = attr.codimension;
6987 }
6988 else
6989 {
6990 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
6991 {
6992 allocatable = CLASS_DATA (sym)->attr.allocatable;
6993 pointer = CLASS_DATA (sym)->attr.class_pointer;
6994 dimension = CLASS_DATA (sym)->attr.dimension;
6995 codimension = CLASS_DATA (sym)->attr.codimension;
6996 is_abstract = CLASS_DATA (sym)->attr.abstract;
6997 }
6998 else
6999 {
7000 allocatable = sym->attr.allocatable;
7001 pointer = sym->attr.pointer;
7002 dimension = sym->attr.dimension;
7003 codimension = sym->attr.codimension;
7004 }
7005
7006 coindexed = false;
7007
7008 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
7009 {
7010 switch (ref->type)
7011 {
7012 case REF_ARRAY:
7013 if (ref->u.ar.codimen > 0)
7014 {
7015 int n;
7016 for (n = ref->u.ar.dimen;
7017 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
7018 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
7019 {
7020 coindexed = true;
7021 break;
7022 }
7023 }
7024
7025 if (ref->next != NULL)
7026 pointer = 0;
7027 break;
7028
7029 case REF_COMPONENT:
7030 /* F2008, C644. */
7031 if (coindexed)
7032 {
7033 gfc_error ("Coindexed allocatable object at %L",
7034 &e->where);
7035 goto failure;
7036 }
7037
7038 c = ref->u.c.component;
7039 if (c->ts.type == BT_CLASS)
7040 {
7041 allocatable = CLASS_DATA (c)->attr.allocatable;
7042 pointer = CLASS_DATA (c)->attr.class_pointer;
7043 dimension = CLASS_DATA (c)->attr.dimension;
7044 codimension = CLASS_DATA (c)->attr.codimension;
7045 is_abstract = CLASS_DATA (c)->attr.abstract;
7046 }
7047 else
7048 {
7049 allocatable = c->attr.allocatable;
7050 pointer = c->attr.pointer;
7051 dimension = c->attr.dimension;
7052 codimension = c->attr.codimension;
7053 is_abstract = c->attr.abstract;
7054 }
7055 break;
7056
7057 case REF_SUBSTRING:
7058 allocatable = 0;
7059 pointer = 0;
7060 break;
7061 }
7062 }
7063 }
7064
7065 /* Check for F08:C628. */
7066 if (allocatable == 0 && pointer == 0 && !unlimited)
7067 {
7068 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7069 &e->where);
7070 goto failure;
7071 }
7072
7073 /* Some checks for the SOURCE tag. */
7074 if (code->expr3)
7075 {
7076 /* Check F03:C631. */
7077 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
7078 {
7079 gfc_error ("Type of entity at %L is type incompatible with "
7080 "source-expr at %L", &e->where, &code->expr3->where);
7081 goto failure;
7082 }
7083
7084 /* Check F03:C632 and restriction following Note 6.18. */
7085 if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
7086 goto failure;
7087
7088 /* Check F03:C633. */
7089 if (code->expr3->ts.kind != e->ts.kind && !unlimited)
7090 {
7091 gfc_error ("The allocate-object at %L and the source-expr at %L "
7092 "shall have the same kind type parameter",
7093 &e->where, &code->expr3->where);
7094 goto failure;
7095 }
7096
7097 /* Check F2008, C642. */
7098 if (code->expr3->ts.type == BT_DERIVED
7099 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
7100 || (code->expr3->ts.u.derived->from_intmod
7101 == INTMOD_ISO_FORTRAN_ENV
7102 && code->expr3->ts.u.derived->intmod_sym_id
7103 == ISOFORTRAN_LOCK_TYPE)))
7104 {
7105 gfc_error ("The source-expr at %L shall neither be of type "
7106 "LOCK_TYPE nor have a LOCK_TYPE component if "
7107 "allocate-object at %L is a coarray",
7108 &code->expr3->where, &e->where);
7109 goto failure;
7110 }
7111
7112 /* Check TS18508, C702/C703. */
7113 if (code->expr3->ts.type == BT_DERIVED
7114 && ((codimension && gfc_expr_attr (code->expr3).event_comp)
7115 || (code->expr3->ts.u.derived->from_intmod
7116 == INTMOD_ISO_FORTRAN_ENV
7117 && code->expr3->ts.u.derived->intmod_sym_id
7118 == ISOFORTRAN_EVENT_TYPE)))
7119 {
7120 gfc_error ("The source-expr at %L shall neither be of type "
7121 "EVENT_TYPE nor have a EVENT_TYPE component if "
7122 "allocate-object at %L is a coarray",
7123 &code->expr3->where, &e->where);
7124 goto failure;
7125 }
7126 }
7127
7128 /* Check F08:C629. */
7129 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7130 && !code->expr3)
7131 {
7132 gcc_assert (e->ts.type == BT_CLASS);
7133 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7134 "type-spec or source-expr", sym->name, &e->where);
7135 goto failure;
7136 }
7137
7138 /* Check F08:C632. */
7139 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
7140 && !UNLIMITED_POLY (e))
7141 {
7142 int cmp;
7143
7144 if (!e->ts.u.cl->length)
7145 goto failure;
7146
7147 cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7148 code->ext.alloc.ts.u.cl->length);
7149 if (cmp == 1 || cmp == -1 || cmp == -3)
7150 {
7151 gfc_error ("Allocating %s at %L with type-spec requires the same "
7152 "character-length parameter as in the declaration",
7153 sym->name, &e->where);
7154 goto failure;
7155 }
7156 }
7157
7158 /* In the variable definition context checks, gfc_expr_attr is used
7159 on the expression. This is fooled by the array specification
7160 present in e, thus we have to eliminate that one temporarily. */
7161 e2 = remove_last_array_ref (e);
7162 t = true;
7163 if (t && pointer)
7164 t = gfc_check_vardef_context (e2, true, true, false,
7165 _("ALLOCATE object"));
7166 if (t)
7167 t = gfc_check_vardef_context (e2, false, true, false,
7168 _("ALLOCATE object"));
7169 gfc_free_expr (e2);
7170 if (!t)
7171 goto failure;
7172
7173 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7174 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7175 {
7176 /* For class arrays, the initialization with SOURCE is done
7177 using _copy and trans_call. It is convenient to exploit that
7178 when the allocated type is different from the declared type but
7179 no SOURCE exists by setting expr3. */
7180 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7181 }
7182 else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
7183 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7184 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7185 {
7186 /* We have to zero initialize the integer variable. */
7187 code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
7188 }
7189 else if (!code->expr3)
7190 {
7191 /* Set up default initializer if needed. */
7192 gfc_typespec ts;
7193 gfc_expr *init_e;
7194
7195 if (gfc_bt_struct (code->ext.alloc.ts.type))
7196 ts = code->ext.alloc.ts;
7197 else
7198 ts = e->ts;
7199
7200 if (ts.type == BT_CLASS)
7201 ts = ts.u.derived->components->ts;
7202
7203 if (gfc_bt_struct (ts.type) && (init_e = gfc_default_initializer (&ts)))
7204 {
7205 gfc_code *init_st = gfc_get_code (EXEC_INIT_ASSIGN);
7206 init_st->loc = code->loc;
7207 init_st->expr1 = gfc_expr_to_initialize (e);
7208 init_st->expr2 = init_e;
7209 init_st->next = code->next;
7210 code->next = init_st;
7211 }
7212 }
7213 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7214 {
7215 /* Default initialization via MOLD (non-polymorphic). */
7216 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7217 if (rhs != NULL)
7218 {
7219 gfc_resolve_expr (rhs);
7220 gfc_free_expr (code->expr3);
7221 code->expr3 = rhs;
7222 }
7223 }
7224
7225 if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
7226 {
7227 /* Make sure the vtab symbol is present when
7228 the module variables are generated. */
7229 gfc_typespec ts = e->ts;
7230 if (code->expr3)
7231 ts = code->expr3->ts;
7232 else if (code->ext.alloc.ts.type == BT_DERIVED)
7233 ts = code->ext.alloc.ts;
7234
7235 gfc_find_derived_vtab (ts.u.derived);
7236
7237 if (dimension)
7238 e = gfc_expr_to_initialize (e);
7239 }
7240 else if (unlimited && !UNLIMITED_POLY (code->expr3))
7241 {
7242 /* Again, make sure the vtab symbol is present when
7243 the module variables are generated. */
7244 gfc_typespec *ts = NULL;
7245 if (code->expr3)
7246 ts = &code->expr3->ts;
7247 else
7248 ts = &code->ext.alloc.ts;
7249
7250 gcc_assert (ts);
7251
7252 gfc_find_vtab (ts);
7253
7254 if (dimension)
7255 e = gfc_expr_to_initialize (e);
7256 }
7257
7258 if (dimension == 0 && codimension == 0)
7259 goto success;
7260
7261 /* Make sure the last reference node is an array specification. */
7262
7263 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7264 || (dimension && ref2->u.ar.dimen == 0))
7265 {
7266 /* F08:C633. */
7267 if (code->expr3)
7268 {
7269 if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
7270 "in ALLOCATE statement at %L", &e->where))
7271 goto failure;
7272 if (code->expr3->rank != 0)
7273 *array_alloc_wo_spec = true;
7274 else
7275 {
7276 gfc_error ("Array specification or array-valued SOURCE= "
7277 "expression required in ALLOCATE statement at %L",
7278 &e->where);
7279 goto failure;
7280 }
7281 }
7282 else
7283 {
7284 gfc_error ("Array specification required in ALLOCATE statement "
7285 "at %L", &e->where);
7286 goto failure;
7287 }
7288 }
7289
7290 /* Make sure that the array section reference makes sense in the
7291 context of an ALLOCATE specification. */
7292
7293 ar = &ref2->u.ar;
7294
7295 if (codimension)
7296 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7297 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7298 {
7299 gfc_error ("Coarray specification required in ALLOCATE statement "
7300 "at %L", &e->where);
7301 goto failure;
7302 }
7303
7304 for (i = 0; i < ar->dimen; i++)
7305 {
7306 if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
7307 goto check_symbols;
7308
7309 switch (ar->dimen_type[i])
7310 {
7311 case DIMEN_ELEMENT:
7312 break;
7313
7314 case DIMEN_RANGE:
7315 if (ar->start[i] != NULL
7316 && ar->end[i] != NULL
7317 && ar->stride[i] == NULL)
7318 break;
7319
7320 /* Fall Through... */
7321
7322 case DIMEN_UNKNOWN:
7323 case DIMEN_VECTOR:
7324 case DIMEN_STAR:
7325 case DIMEN_THIS_IMAGE:
7326 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7327 &e->where);
7328 goto failure;
7329 }
7330
7331 check_symbols:
7332 for (a = code->ext.alloc.list; a; a = a->next)
7333 {
7334 sym = a->expr->symtree->n.sym;
7335
7336 /* TODO - check derived type components. */
7337 if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
7338 continue;
7339
7340 if ((ar->start[i] != NULL
7341 && gfc_find_sym_in_expr (sym, ar->start[i]))
7342 || (ar->end[i] != NULL
7343 && gfc_find_sym_in_expr (sym, ar->end[i])))
7344 {
7345 gfc_error ("%qs must not appear in the array specification at "
7346 "%L in the same ALLOCATE statement where it is "
7347 "itself allocated", sym->name, &ar->where);
7348 goto failure;
7349 }
7350 }
7351 }
7352
7353 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7354 {
7355 if (ar->dimen_type[i] == DIMEN_ELEMENT
7356 || ar->dimen_type[i] == DIMEN_RANGE)
7357 {
7358 if (i == (ar->dimen + ar->codimen - 1))
7359 {
7360 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7361 "statement at %L", &e->where);
7362 goto failure;
7363 }
7364 continue;
7365 }
7366
7367 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7368 && ar->stride[i] == NULL)
7369 break;
7370
7371 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7372 &e->where);
7373 goto failure;
7374 }
7375
7376 success:
7377 return true;
7378
7379 failure:
7380 return false;
7381 }
7382
7383
7384 static void
resolve_allocate_deallocate(gfc_code * code,const char * fcn)7385 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7386 {
7387 gfc_expr *stat, *errmsg, *pe, *qe;
7388 gfc_alloc *a, *p, *q;
7389
7390 stat = code->expr1;
7391 errmsg = code->expr2;
7392
7393 /* Check the stat variable. */
7394 if (stat)
7395 {
7396 gfc_check_vardef_context (stat, false, false, false,
7397 _("STAT variable"));
7398
7399 if ((stat->ts.type != BT_INTEGER
7400 && !(stat->ref && (stat->ref->type == REF_ARRAY
7401 || stat->ref->type == REF_COMPONENT)))
7402 || stat->rank > 0)
7403 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7404 "variable", &stat->where);
7405
7406 for (p = code->ext.alloc.list; p; p = p->next)
7407 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7408 {
7409 gfc_ref *ref1, *ref2;
7410 bool found = true;
7411
7412 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7413 ref1 = ref1->next, ref2 = ref2->next)
7414 {
7415 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7416 continue;
7417 if (ref1->u.c.component->name != ref2->u.c.component->name)
7418 {
7419 found = false;
7420 break;
7421 }
7422 }
7423
7424 if (found)
7425 {
7426 gfc_error ("Stat-variable at %L shall not be %sd within "
7427 "the same %s statement", &stat->where, fcn, fcn);
7428 break;
7429 }
7430 }
7431 }
7432
7433 /* Check the errmsg variable. */
7434 if (errmsg)
7435 {
7436 if (!stat)
7437 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7438 &errmsg->where);
7439
7440 gfc_check_vardef_context (errmsg, false, false, false,
7441 _("ERRMSG variable"));
7442
7443 if ((errmsg->ts.type != BT_CHARACTER
7444 && !(errmsg->ref
7445 && (errmsg->ref->type == REF_ARRAY
7446 || errmsg->ref->type == REF_COMPONENT)))
7447 || errmsg->rank > 0 )
7448 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7449 "variable", &errmsg->where);
7450
7451 for (p = code->ext.alloc.list; p; p = p->next)
7452 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7453 {
7454 gfc_ref *ref1, *ref2;
7455 bool found = true;
7456
7457 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7458 ref1 = ref1->next, ref2 = ref2->next)
7459 {
7460 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7461 continue;
7462 if (ref1->u.c.component->name != ref2->u.c.component->name)
7463 {
7464 found = false;
7465 break;
7466 }
7467 }
7468
7469 if (found)
7470 {
7471 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7472 "the same %s statement", &errmsg->where, fcn, fcn);
7473 break;
7474 }
7475 }
7476 }
7477
7478 /* Check that an allocate-object appears only once in the statement. */
7479
7480 for (p = code->ext.alloc.list; p; p = p->next)
7481 {
7482 pe = p->expr;
7483 for (q = p->next; q; q = q->next)
7484 {
7485 qe = q->expr;
7486 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7487 {
7488 /* This is a potential collision. */
7489 gfc_ref *pr = pe->ref;
7490 gfc_ref *qr = qe->ref;
7491
7492 /* Follow the references until
7493 a) They start to differ, in which case there is no error;
7494 you can deallocate a%b and a%c in a single statement
7495 b) Both of them stop, which is an error
7496 c) One of them stops, which is also an error. */
7497 while (1)
7498 {
7499 if (pr == NULL && qr == NULL)
7500 {
7501 gfc_error ("Allocate-object at %L also appears at %L",
7502 &pe->where, &qe->where);
7503 break;
7504 }
7505 else if (pr != NULL && qr == NULL)
7506 {
7507 gfc_error ("Allocate-object at %L is subobject of"
7508 " object at %L", &pe->where, &qe->where);
7509 break;
7510 }
7511 else if (pr == NULL && qr != NULL)
7512 {
7513 gfc_error ("Allocate-object at %L is subobject of"
7514 " object at %L", &qe->where, &pe->where);
7515 break;
7516 }
7517 /* Here, pr != NULL && qr != NULL */
7518 gcc_assert(pr->type == qr->type);
7519 if (pr->type == REF_ARRAY)
7520 {
7521 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7522 which are legal. */
7523 gcc_assert (qr->type == REF_ARRAY);
7524
7525 if (pr->next && qr->next)
7526 {
7527 int i;
7528 gfc_array_ref *par = &(pr->u.ar);
7529 gfc_array_ref *qar = &(qr->u.ar);
7530
7531 for (i=0; i<par->dimen; i++)
7532 {
7533 if ((par->start[i] != NULL
7534 || qar->start[i] != NULL)
7535 && gfc_dep_compare_expr (par->start[i],
7536 qar->start[i]) != 0)
7537 goto break_label;
7538 }
7539 }
7540 }
7541 else
7542 {
7543 if (pr->u.c.component->name != qr->u.c.component->name)
7544 break;
7545 }
7546
7547 pr = pr->next;
7548 qr = qr->next;
7549 }
7550 break_label:
7551 ;
7552 }
7553 }
7554 }
7555
7556 if (strcmp (fcn, "ALLOCATE") == 0)
7557 {
7558 bool arr_alloc_wo_spec = false;
7559 for (a = code->ext.alloc.list; a; a = a->next)
7560 resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
7561
7562 if (arr_alloc_wo_spec && code->expr3)
7563 {
7564 /* Mark the allocate to have to take the array specification
7565 from the expr3. */
7566 code->ext.alloc.arr_spec_from_expr3 = 1;
7567 }
7568 }
7569 else
7570 {
7571 for (a = code->ext.alloc.list; a; a = a->next)
7572 resolve_deallocate_expr (a->expr);
7573 }
7574 }
7575
7576
7577 /************ SELECT CASE resolution subroutines ************/
7578
7579 /* Callback function for our mergesort variant. Determines interval
7580 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7581 op1 > op2. Assumes we're not dealing with the default case.
7582 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7583 There are nine situations to check. */
7584
7585 static int
compare_cases(const gfc_case * op1,const gfc_case * op2)7586 compare_cases (const gfc_case *op1, const gfc_case *op2)
7587 {
7588 int retval;
7589
7590 if (op1->low == NULL) /* op1 = (:L) */
7591 {
7592 /* op2 = (:N), so overlap. */
7593 retval = 0;
7594 /* op2 = (M:) or (M:N), L < M */
7595 if (op2->low != NULL
7596 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7597 retval = -1;
7598 }
7599 else if (op1->high == NULL) /* op1 = (K:) */
7600 {
7601 /* op2 = (M:), so overlap. */
7602 retval = 0;
7603 /* op2 = (:N) or (M:N), K > N */
7604 if (op2->high != NULL
7605 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7606 retval = 1;
7607 }
7608 else /* op1 = (K:L) */
7609 {
7610 if (op2->low == NULL) /* op2 = (:N), K > N */
7611 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7612 ? 1 : 0;
7613 else if (op2->high == NULL) /* op2 = (M:), L < M */
7614 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7615 ? -1 : 0;
7616 else /* op2 = (M:N) */
7617 {
7618 retval = 0;
7619 /* L < M */
7620 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7621 retval = -1;
7622 /* K > N */
7623 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7624 retval = 1;
7625 }
7626 }
7627
7628 return retval;
7629 }
7630
7631
7632 /* Merge-sort a double linked case list, detecting overlap in the
7633 process. LIST is the head of the double linked case list before it
7634 is sorted. Returns the head of the sorted list if we don't see any
7635 overlap, or NULL otherwise. */
7636
7637 static gfc_case *
check_case_overlap(gfc_case * list)7638 check_case_overlap (gfc_case *list)
7639 {
7640 gfc_case *p, *q, *e, *tail;
7641 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7642
7643 /* If the passed list was empty, return immediately. */
7644 if (!list)
7645 return NULL;
7646
7647 overlap_seen = 0;
7648 insize = 1;
7649
7650 /* Loop unconditionally. The only exit from this loop is a return
7651 statement, when we've finished sorting the case list. */
7652 for (;;)
7653 {
7654 p = list;
7655 list = NULL;
7656 tail = NULL;
7657
7658 /* Count the number of merges we do in this pass. */
7659 nmerges = 0;
7660
7661 /* Loop while there exists a merge to be done. */
7662 while (p)
7663 {
7664 int i;
7665
7666 /* Count this merge. */
7667 nmerges++;
7668
7669 /* Cut the list in two pieces by stepping INSIZE places
7670 forward in the list, starting from P. */
7671 psize = 0;
7672 q = p;
7673 for (i = 0; i < insize; i++)
7674 {
7675 psize++;
7676 q = q->right;
7677 if (!q)
7678 break;
7679 }
7680 qsize = insize;
7681
7682 /* Now we have two lists. Merge them! */
7683 while (psize > 0 || (qsize > 0 && q != NULL))
7684 {
7685 /* See from which the next case to merge comes from. */
7686 if (psize == 0)
7687 {
7688 /* P is empty so the next case must come from Q. */
7689 e = q;
7690 q = q->right;
7691 qsize--;
7692 }
7693 else if (qsize == 0 || q == NULL)
7694 {
7695 /* Q is empty. */
7696 e = p;
7697 p = p->right;
7698 psize--;
7699 }
7700 else
7701 {
7702 cmp = compare_cases (p, q);
7703 if (cmp < 0)
7704 {
7705 /* The whole case range for P is less than the
7706 one for Q. */
7707 e = p;
7708 p = p->right;
7709 psize--;
7710 }
7711 else if (cmp > 0)
7712 {
7713 /* The whole case range for Q is greater than
7714 the case range for P. */
7715 e = q;
7716 q = q->right;
7717 qsize--;
7718 }
7719 else
7720 {
7721 /* The cases overlap, or they are the same
7722 element in the list. Either way, we must
7723 issue an error and get the next case from P. */
7724 /* FIXME: Sort P and Q by line number. */
7725 gfc_error ("CASE label at %L overlaps with CASE "
7726 "label at %L", &p->where, &q->where);
7727 overlap_seen = 1;
7728 e = p;
7729 p = p->right;
7730 psize--;
7731 }
7732 }
7733
7734 /* Add the next element to the merged list. */
7735 if (tail)
7736 tail->right = e;
7737 else
7738 list = e;
7739 e->left = tail;
7740 tail = e;
7741 }
7742
7743 /* P has now stepped INSIZE places along, and so has Q. So
7744 they're the same. */
7745 p = q;
7746 }
7747 tail->right = NULL;
7748
7749 /* If we have done only one merge or none at all, we've
7750 finished sorting the cases. */
7751 if (nmerges <= 1)
7752 {
7753 if (!overlap_seen)
7754 return list;
7755 else
7756 return NULL;
7757 }
7758
7759 /* Otherwise repeat, merging lists twice the size. */
7760 insize *= 2;
7761 }
7762 }
7763
7764
7765 /* Check to see if an expression is suitable for use in a CASE statement.
7766 Makes sure that all case expressions are scalar constants of the same
7767 type. Return false if anything is wrong. */
7768
7769 static bool
validate_case_label_expr(gfc_expr * e,gfc_expr * case_expr)7770 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7771 {
7772 if (e == NULL) return true;
7773
7774 if (e->ts.type != case_expr->ts.type)
7775 {
7776 gfc_error ("Expression in CASE statement at %L must be of type %s",
7777 &e->where, gfc_basic_typename (case_expr->ts.type));
7778 return false;
7779 }
7780
7781 /* C805 (R808) For a given case-construct, each case-value shall be of
7782 the same type as case-expr. For character type, length differences
7783 are allowed, but the kind type parameters shall be the same. */
7784
7785 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7786 {
7787 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7788 &e->where, case_expr->ts.kind);
7789 return false;
7790 }
7791
7792 /* Convert the case value kind to that of case expression kind,
7793 if needed */
7794
7795 if (e->ts.kind != case_expr->ts.kind)
7796 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7797
7798 if (e->rank != 0)
7799 {
7800 gfc_error ("Expression in CASE statement at %L must be scalar",
7801 &e->where);
7802 return false;
7803 }
7804
7805 return true;
7806 }
7807
7808
7809 /* Given a completely parsed select statement, we:
7810
7811 - Validate all expressions and code within the SELECT.
7812 - Make sure that the selection expression is not of the wrong type.
7813 - Make sure that no case ranges overlap.
7814 - Eliminate unreachable cases and unreachable code resulting from
7815 removing case labels.
7816
7817 The standard does allow unreachable cases, e.g. CASE (5:3). But
7818 they are a hassle for code generation, and to prevent that, we just
7819 cut them out here. This is not necessary for overlapping cases
7820 because they are illegal and we never even try to generate code.
7821
7822 We have the additional caveat that a SELECT construct could have
7823 been a computed GOTO in the source code. Fortunately we can fairly
7824 easily work around that here: The case_expr for a "real" SELECT CASE
7825 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7826 we have to do is make sure that the case_expr is a scalar integer
7827 expression. */
7828
7829 static void
resolve_select(gfc_code * code,bool select_type)7830 resolve_select (gfc_code *code, bool select_type)
7831 {
7832 gfc_code *body;
7833 gfc_expr *case_expr;
7834 gfc_case *cp, *default_case, *tail, *head;
7835 int seen_unreachable;
7836 int seen_logical;
7837 int ncases;
7838 bt type;
7839 bool t;
7840
7841 if (code->expr1 == NULL)
7842 {
7843 /* This was actually a computed GOTO statement. */
7844 case_expr = code->expr2;
7845 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7846 gfc_error ("Selection expression in computed GOTO statement "
7847 "at %L must be a scalar integer expression",
7848 &case_expr->where);
7849
7850 /* Further checking is not necessary because this SELECT was built
7851 by the compiler, so it should always be OK. Just move the
7852 case_expr from expr2 to expr so that we can handle computed
7853 GOTOs as normal SELECTs from here on. */
7854 code->expr1 = code->expr2;
7855 code->expr2 = NULL;
7856 return;
7857 }
7858
7859 case_expr = code->expr1;
7860 type = case_expr->ts.type;
7861
7862 /* F08:C830. */
7863 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7864 {
7865 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7866 &case_expr->where, gfc_typename (&case_expr->ts));
7867
7868 /* Punt. Going on here just produce more garbage error messages. */
7869 return;
7870 }
7871
7872 /* F08:R842. */
7873 if (!select_type && case_expr->rank != 0)
7874 {
7875 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7876 "expression", &case_expr->where);
7877
7878 /* Punt. */
7879 return;
7880 }
7881
7882 /* Raise a warning if an INTEGER case value exceeds the range of
7883 the case-expr. Later, all expressions will be promoted to the
7884 largest kind of all case-labels. */
7885
7886 if (type == BT_INTEGER)
7887 for (body = code->block; body; body = body->block)
7888 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7889 {
7890 if (cp->low
7891 && gfc_check_integer_range (cp->low->value.integer,
7892 case_expr->ts.kind) != ARITH_OK)
7893 gfc_warning (0, "Expression in CASE statement at %L is "
7894 "not in the range of %s", &cp->low->where,
7895 gfc_typename (&case_expr->ts));
7896
7897 if (cp->high
7898 && cp->low != cp->high
7899 && gfc_check_integer_range (cp->high->value.integer,
7900 case_expr->ts.kind) != ARITH_OK)
7901 gfc_warning (0, "Expression in CASE statement at %L is "
7902 "not in the range of %s", &cp->high->where,
7903 gfc_typename (&case_expr->ts));
7904 }
7905
7906 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7907 of the SELECT CASE expression and its CASE values. Walk the lists
7908 of case values, and if we find a mismatch, promote case_expr to
7909 the appropriate kind. */
7910
7911 if (type == BT_LOGICAL || type == BT_INTEGER)
7912 {
7913 for (body = code->block; body; body = body->block)
7914 {
7915 /* Walk the case label list. */
7916 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7917 {
7918 /* Intercept the DEFAULT case. It does not have a kind. */
7919 if (cp->low == NULL && cp->high == NULL)
7920 continue;
7921
7922 /* Unreachable case ranges are discarded, so ignore. */
7923 if (cp->low != NULL && cp->high != NULL
7924 && cp->low != cp->high
7925 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
7926 continue;
7927
7928 if (cp->low != NULL
7929 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
7930 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
7931
7932 if (cp->high != NULL
7933 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
7934 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
7935 }
7936 }
7937 }
7938
7939 /* Assume there is no DEFAULT case. */
7940 default_case = NULL;
7941 head = tail = NULL;
7942 ncases = 0;
7943 seen_logical = 0;
7944
7945 for (body = code->block; body; body = body->block)
7946 {
7947 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7948 t = true;
7949 seen_unreachable = 0;
7950
7951 /* Walk the case label list, making sure that all case labels
7952 are legal. */
7953 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7954 {
7955 /* Count the number of cases in the whole construct. */
7956 ncases++;
7957
7958 /* Intercept the DEFAULT case. */
7959 if (cp->low == NULL && cp->high == NULL)
7960 {
7961 if (default_case != NULL)
7962 {
7963 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7964 "by a second DEFAULT CASE at %L",
7965 &default_case->where, &cp->where);
7966 t = false;
7967 break;
7968 }
7969 else
7970 {
7971 default_case = cp;
7972 continue;
7973 }
7974 }
7975
7976 /* Deal with single value cases and case ranges. Errors are
7977 issued from the validation function. */
7978 if (!validate_case_label_expr (cp->low, case_expr)
7979 || !validate_case_label_expr (cp->high, case_expr))
7980 {
7981 t = false;
7982 break;
7983 }
7984
7985 if (type == BT_LOGICAL
7986 && ((cp->low == NULL || cp->high == NULL)
7987 || cp->low != cp->high))
7988 {
7989 gfc_error ("Logical range in CASE statement at %L is not "
7990 "allowed", &cp->low->where);
7991 t = false;
7992 break;
7993 }
7994
7995 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
7996 {
7997 int value;
7998 value = cp->low->value.logical == 0 ? 2 : 1;
7999 if (value & seen_logical)
8000 {
8001 gfc_error ("Constant logical value in CASE statement "
8002 "is repeated at %L",
8003 &cp->low->where);
8004 t = false;
8005 break;
8006 }
8007 seen_logical |= value;
8008 }
8009
8010 if (cp->low != NULL && cp->high != NULL
8011 && cp->low != cp->high
8012 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8013 {
8014 if (warn_surprising)
8015 gfc_warning (OPT_Wsurprising,
8016 "Range specification at %L can never be matched",
8017 &cp->where);
8018
8019 cp->unreachable = 1;
8020 seen_unreachable = 1;
8021 }
8022 else
8023 {
8024 /* If the case range can be matched, it can also overlap with
8025 other cases. To make sure it does not, we put it in a
8026 double linked list here. We sort that with a merge sort
8027 later on to detect any overlapping cases. */
8028 if (!head)
8029 {
8030 head = tail = cp;
8031 head->right = head->left = NULL;
8032 }
8033 else
8034 {
8035 tail->right = cp;
8036 tail->right->left = tail;
8037 tail = tail->right;
8038 tail->right = NULL;
8039 }
8040 }
8041 }
8042
8043 /* It there was a failure in the previous case label, give up
8044 for this case label list. Continue with the next block. */
8045 if (!t)
8046 continue;
8047
8048 /* See if any case labels that are unreachable have been seen.
8049 If so, we eliminate them. This is a bit of a kludge because
8050 the case lists for a single case statement (label) is a
8051 single forward linked lists. */
8052 if (seen_unreachable)
8053 {
8054 /* Advance until the first case in the list is reachable. */
8055 while (body->ext.block.case_list != NULL
8056 && body->ext.block.case_list->unreachable)
8057 {
8058 gfc_case *n = body->ext.block.case_list;
8059 body->ext.block.case_list = body->ext.block.case_list->next;
8060 n->next = NULL;
8061 gfc_free_case_list (n);
8062 }
8063
8064 /* Strip all other unreachable cases. */
8065 if (body->ext.block.case_list)
8066 {
8067 for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
8068 {
8069 if (cp->next->unreachable)
8070 {
8071 gfc_case *n = cp->next;
8072 cp->next = cp->next->next;
8073 n->next = NULL;
8074 gfc_free_case_list (n);
8075 }
8076 }
8077 }
8078 }
8079 }
8080
8081 /* See if there were overlapping cases. If the check returns NULL,
8082 there was overlap. In that case we don't do anything. If head
8083 is non-NULL, we prepend the DEFAULT case. The sorted list can
8084 then used during code generation for SELECT CASE constructs with
8085 a case expression of a CHARACTER type. */
8086 if (head)
8087 {
8088 head = check_case_overlap (head);
8089
8090 /* Prepend the default_case if it is there. */
8091 if (head != NULL && default_case)
8092 {
8093 default_case->left = NULL;
8094 default_case->right = head;
8095 head->left = default_case;
8096 }
8097 }
8098
8099 /* Eliminate dead blocks that may be the result if we've seen
8100 unreachable case labels for a block. */
8101 for (body = code; body && body->block; body = body->block)
8102 {
8103 if (body->block->ext.block.case_list == NULL)
8104 {
8105 /* Cut the unreachable block from the code chain. */
8106 gfc_code *c = body->block;
8107 body->block = c->block;
8108
8109 /* Kill the dead block, but not the blocks below it. */
8110 c->block = NULL;
8111 gfc_free_statements (c);
8112 }
8113 }
8114
8115 /* More than two cases is legal but insane for logical selects.
8116 Issue a warning for it. */
8117 if (warn_surprising && type == BT_LOGICAL && ncases > 2)
8118 gfc_warning (OPT_Wsurprising,
8119 "Logical SELECT CASE block at %L has more that two cases",
8120 &code->loc);
8121 }
8122
8123
8124 /* Check if a derived type is extensible. */
8125
8126 bool
gfc_type_is_extensible(gfc_symbol * sym)8127 gfc_type_is_extensible (gfc_symbol *sym)
8128 {
8129 return !(sym->attr.is_bind_c || sym->attr.sequence
8130 || (sym->attr.is_class
8131 && sym->components->ts.u.derived->attr.unlimited_polymorphic));
8132 }
8133
8134
8135 static void
8136 resolve_types (gfc_namespace *ns);
8137
8138 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8139 correct as well as possibly the array-spec. */
8140
8141 static void
resolve_assoc_var(gfc_symbol * sym,bool resolve_target)8142 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
8143 {
8144 gfc_expr* target;
8145
8146 gcc_assert (sym->assoc);
8147 gcc_assert (sym->attr.flavor == FL_VARIABLE);
8148
8149 /* If this is for SELECT TYPE, the target may not yet be set. In that
8150 case, return. Resolution will be called later manually again when
8151 this is done. */
8152 target = sym->assoc->target;
8153 if (!target)
8154 return;
8155 gcc_assert (!sym->assoc->dangling);
8156
8157 if (resolve_target && !gfc_resolve_expr (target))
8158 return;
8159
8160 /* For variable targets, we get some attributes from the target. */
8161 if (target->expr_type == EXPR_VARIABLE)
8162 {
8163 gfc_symbol* tsym;
8164
8165 gcc_assert (target->symtree);
8166 tsym = target->symtree->n.sym;
8167
8168 sym->attr.asynchronous = tsym->attr.asynchronous;
8169 sym->attr.volatile_ = tsym->attr.volatile_;
8170
8171 sym->attr.target = tsym->attr.target
8172 || gfc_expr_attr (target).pointer;
8173 if (is_subref_array (target))
8174 sym->attr.subref_array_pointer = 1;
8175 }
8176
8177 /* Get type if this was not already set. Note that it can be
8178 some other type than the target in case this is a SELECT TYPE
8179 selector! So we must not update when the type is already there. */
8180 if (sym->ts.type == BT_UNKNOWN)
8181 sym->ts = target->ts;
8182 gcc_assert (sym->ts.type != BT_UNKNOWN);
8183
8184 /* See if this is a valid association-to-variable. */
8185 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
8186 && !gfc_has_vector_subscript (target));
8187
8188 /* Finally resolve if this is an array or not. */
8189 if (sym->attr.dimension && target->rank == 0)
8190 {
8191 /* primary.c makes the assumption that a reference to an associate
8192 name followed by a left parenthesis is an array reference. */
8193 if (sym->ts.type != BT_CHARACTER)
8194 gfc_error ("Associate-name %qs at %L is used as array",
8195 sym->name, &sym->declared_at);
8196 sym->attr.dimension = 0;
8197 return;
8198 }
8199
8200
8201 /* We cannot deal with class selectors that need temporaries. */
8202 if (target->ts.type == BT_CLASS
8203 && gfc_ref_needs_temporary_p (target->ref))
8204 {
8205 gfc_error ("CLASS selector at %L needs a temporary which is not "
8206 "yet implemented", &target->where);
8207 return;
8208 }
8209
8210 if (target->ts.type == BT_CLASS)
8211 gfc_fix_class_refs (target);
8212
8213 if (target->rank != 0)
8214 {
8215 gfc_array_spec *as;
8216 /* The rank may be incorrectly guessed at parsing, therefore make sure
8217 it is corrected now. */
8218 if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed))
8219 {
8220 if (!sym->as)
8221 sym->as = gfc_get_array_spec ();
8222 as = sym->as;
8223 as->rank = target->rank;
8224 as->type = AS_DEFERRED;
8225 as->corank = gfc_get_corank (target);
8226 sym->attr.dimension = 1;
8227 if (as->corank != 0)
8228 sym->attr.codimension = 1;
8229 }
8230 }
8231 else
8232 {
8233 /* target's rank is 0, but the type of the sym is still array valued,
8234 which has to be corrected. */
8235 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
8236 {
8237 gfc_array_spec *as;
8238 symbol_attribute attr;
8239 /* The associated variable's type is still the array type
8240 correct this now. */
8241 gfc_typespec *ts = &target->ts;
8242 gfc_ref *ref;
8243 gfc_component *c;
8244 for (ref = target->ref; ref != NULL; ref = ref->next)
8245 {
8246 switch (ref->type)
8247 {
8248 case REF_COMPONENT:
8249 ts = &ref->u.c.component->ts;
8250 break;
8251 case REF_ARRAY:
8252 if (ts->type == BT_CLASS)
8253 ts = &ts->u.derived->components->ts;
8254 break;
8255 default:
8256 break;
8257 }
8258 }
8259 /* Create a scalar instance of the current class type. Because the
8260 rank of a class array goes into its name, the type has to be
8261 rebuild. The alternative of (re-)setting just the attributes
8262 and as in the current type, destroys the type also in other
8263 places. */
8264 as = NULL;
8265 sym->ts = *ts;
8266 sym->ts.type = BT_CLASS;
8267 attr = CLASS_DATA (sym)->attr;
8268 attr.class_ok = 0;
8269 attr.associate_var = 1;
8270 attr.dimension = attr.codimension = 0;
8271 attr.class_pointer = 1;
8272 if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
8273 gcc_unreachable ();
8274 /* Make sure the _vptr is set. */
8275 c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
8276 if (c->ts.u.derived == NULL)
8277 c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
8278 CLASS_DATA (sym)->attr.pointer = 1;
8279 CLASS_DATA (sym)->attr.class_pointer = 1;
8280 gfc_set_sym_referenced (sym->ts.u.derived);
8281 gfc_commit_symbol (sym->ts.u.derived);
8282 /* _vptr now has the _vtab in it, change it to the _vtype. */
8283 if (c->ts.u.derived->attr.vtab)
8284 c->ts.u.derived = c->ts.u.derived->ts.u.derived;
8285 c->ts.u.derived->ns->types_resolved = 0;
8286 resolve_types (c->ts.u.derived->ns);
8287 }
8288 }
8289
8290 /* Mark this as an associate variable. */
8291 sym->attr.associate_var = 1;
8292
8293 /* Fix up the type-spec for CHARACTER types. */
8294 if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
8295 {
8296 if (!sym->ts.u.cl)
8297 sym->ts.u.cl = target->ts.u.cl;
8298
8299 if (!sym->ts.u.cl->length)
8300 sym->ts.u.cl->length
8301 = gfc_get_int_expr (gfc_default_integer_kind,
8302 NULL, target->value.character.length);
8303 }
8304
8305 /* If the target is a good class object, so is the associate variable. */
8306 if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
8307 sym->attr.class_ok = 1;
8308 }
8309
8310
8311 /* Resolve a SELECT TYPE statement. */
8312
8313 static void
resolve_select_type(gfc_code * code,gfc_namespace * old_ns)8314 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
8315 {
8316 gfc_symbol *selector_type;
8317 gfc_code *body, *new_st, *if_st, *tail;
8318 gfc_code *class_is = NULL, *default_case = NULL;
8319 gfc_case *c;
8320 gfc_symtree *st;
8321 char name[GFC_MAX_SYMBOL_LEN];
8322 gfc_namespace *ns;
8323 int error = 0;
8324 int charlen = 0;
8325
8326 ns = code->ext.block.ns;
8327 gfc_resolve (ns);
8328
8329 /* Check for F03:C813. */
8330 if (code->expr1->ts.type != BT_CLASS
8331 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8332 {
8333 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8334 "at %L", &code->loc);
8335 return;
8336 }
8337
8338 if (!code->expr1->symtree->n.sym->attr.class_ok)
8339 return;
8340
8341 if (code->expr2)
8342 {
8343 if (code->expr1->symtree->n.sym->attr.untyped)
8344 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8345 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8346
8347 if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
8348 CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
8349
8350 /* F2008: C803 The selector expression must not be coindexed. */
8351 if (gfc_is_coindexed (code->expr2))
8352 {
8353 gfc_error ("Selector at %L must not be coindexed",
8354 &code->expr2->where);
8355 return;
8356 }
8357
8358 }
8359 else
8360 {
8361 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8362
8363 if (gfc_is_coindexed (code->expr1))
8364 {
8365 gfc_error ("Selector at %L must not be coindexed",
8366 &code->expr1->where);
8367 return;
8368 }
8369 }
8370
8371 /* Loop over TYPE IS / CLASS IS cases. */
8372 for (body = code->block; body; body = body->block)
8373 {
8374 c = body->ext.block.case_list;
8375
8376 /* Check F03:C815. */
8377 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8378 && !selector_type->attr.unlimited_polymorphic
8379 && !gfc_type_is_extensible (c->ts.u.derived))
8380 {
8381 gfc_error ("Derived type %qs at %L must be extensible",
8382 c->ts.u.derived->name, &c->where);
8383 error++;
8384 continue;
8385 }
8386
8387 /* Check F03:C816. */
8388 if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
8389 && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
8390 || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
8391 {
8392 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8393 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8394 c->ts.u.derived->name, &c->where, selector_type->name);
8395 else
8396 gfc_error ("Unexpected intrinsic type %qs at %L",
8397 gfc_basic_typename (c->ts.type), &c->where);
8398 error++;
8399 continue;
8400 }
8401
8402 /* Check F03:C814. */
8403 if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL)
8404 {
8405 gfc_error ("The type-spec at %L shall specify that each length "
8406 "type parameter is assumed", &c->where);
8407 error++;
8408 continue;
8409 }
8410
8411 /* Intercept the DEFAULT case. */
8412 if (c->ts.type == BT_UNKNOWN)
8413 {
8414 /* Check F03:C818. */
8415 if (default_case)
8416 {
8417 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8418 "by a second DEFAULT CASE at %L",
8419 &default_case->ext.block.case_list->where, &c->where);
8420 error++;
8421 continue;
8422 }
8423
8424 default_case = body;
8425 }
8426 }
8427
8428 if (error > 0)
8429 return;
8430
8431 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8432 target if present. If there are any EXIT statements referring to the
8433 SELECT TYPE construct, this is no problem because the gfc_code
8434 reference stays the same and EXIT is equally possible from the BLOCK
8435 it is changed to. */
8436 code->op = EXEC_BLOCK;
8437 if (code->expr2)
8438 {
8439 gfc_association_list* assoc;
8440
8441 assoc = gfc_get_association_list ();
8442 assoc->st = code->expr1->symtree;
8443 assoc->target = gfc_copy_expr (code->expr2);
8444 assoc->target->where = code->expr2->where;
8445 /* assoc->variable will be set by resolve_assoc_var. */
8446
8447 code->ext.block.assoc = assoc;
8448 code->expr1->symtree->n.sym->assoc = assoc;
8449
8450 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8451 }
8452 else
8453 code->ext.block.assoc = NULL;
8454
8455 /* Add EXEC_SELECT to switch on type. */
8456 new_st = gfc_get_code (code->op);
8457 new_st->expr1 = code->expr1;
8458 new_st->expr2 = code->expr2;
8459 new_st->block = code->block;
8460 code->expr1 = code->expr2 = NULL;
8461 code->block = NULL;
8462 if (!ns->code)
8463 ns->code = new_st;
8464 else
8465 ns->code->next = new_st;
8466 code = new_st;
8467 code->op = EXEC_SELECT;
8468
8469 gfc_add_vptr_component (code->expr1);
8470 gfc_add_hash_component (code->expr1);
8471
8472 /* Loop over TYPE IS / CLASS IS cases. */
8473 for (body = code->block; body; body = body->block)
8474 {
8475 c = body->ext.block.case_list;
8476
8477 if (c->ts.type == BT_DERIVED)
8478 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8479 c->ts.u.derived->hash_value);
8480 else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
8481 {
8482 gfc_symbol *ivtab;
8483 gfc_expr *e;
8484
8485 ivtab = gfc_find_vtab (&c->ts);
8486 gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
8487 e = CLASS_DATA (ivtab)->initializer;
8488 c->low = c->high = gfc_copy_expr (e);
8489 }
8490
8491 else if (c->ts.type == BT_UNKNOWN)
8492 continue;
8493
8494 /* Associate temporary to selector. This should only be done
8495 when this case is actually true, so build a new ASSOCIATE
8496 that does precisely this here (instead of using the
8497 'global' one). */
8498
8499 if (c->ts.type == BT_CLASS)
8500 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8501 else if (c->ts.type == BT_DERIVED)
8502 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8503 else if (c->ts.type == BT_CHARACTER)
8504 {
8505 if (c->ts.u.cl && c->ts.u.cl->length
8506 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8507 charlen = mpz_get_si (c->ts.u.cl->length->value.integer);
8508 sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type),
8509 charlen, c->ts.kind);
8510 }
8511 else
8512 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
8513 c->ts.kind);
8514
8515 st = gfc_find_symtree (ns->sym_root, name);
8516 gcc_assert (st->n.sym->assoc);
8517 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8518 st->n.sym->assoc->target->where = code->expr1->where;
8519 if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
8520 gfc_add_data_component (st->n.sym->assoc->target);
8521
8522 new_st = gfc_get_code (EXEC_BLOCK);
8523 new_st->ext.block.ns = gfc_build_block_ns (ns);
8524 new_st->ext.block.ns->code = body->next;
8525 body->next = new_st;
8526
8527 /* Chain in the new list only if it is marked as dangling. Otherwise
8528 there is a CASE label overlap and this is already used. Just ignore,
8529 the error is diagnosed elsewhere. */
8530 if (st->n.sym->assoc->dangling)
8531 {
8532 new_st->ext.block.assoc = st->n.sym->assoc;
8533 st->n.sym->assoc->dangling = 0;
8534 }
8535
8536 resolve_assoc_var (st->n.sym, false);
8537 }
8538
8539 /* Take out CLASS IS cases for separate treatment. */
8540 body = code;
8541 while (body && body->block)
8542 {
8543 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8544 {
8545 /* Add to class_is list. */
8546 if (class_is == NULL)
8547 {
8548 class_is = body->block;
8549 tail = class_is;
8550 }
8551 else
8552 {
8553 for (tail = class_is; tail->block; tail = tail->block) ;
8554 tail->block = body->block;
8555 tail = tail->block;
8556 }
8557 /* Remove from EXEC_SELECT list. */
8558 body->block = body->block->block;
8559 tail->block = NULL;
8560 }
8561 else
8562 body = body->block;
8563 }
8564
8565 if (class_is)
8566 {
8567 gfc_symbol *vtab;
8568
8569 if (!default_case)
8570 {
8571 /* Add a default case to hold the CLASS IS cases. */
8572 for (tail = code; tail->block; tail = tail->block) ;
8573 tail->block = gfc_get_code (EXEC_SELECT_TYPE);
8574 tail = tail->block;
8575 tail->ext.block.case_list = gfc_get_case ();
8576 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8577 tail->next = NULL;
8578 default_case = tail;
8579 }
8580
8581 /* More than one CLASS IS block? */
8582 if (class_is->block)
8583 {
8584 gfc_code **c1,*c2;
8585 bool swapped;
8586 /* Sort CLASS IS blocks by extension level. */
8587 do
8588 {
8589 swapped = false;
8590 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8591 {
8592 c2 = (*c1)->block;
8593 /* F03:C817 (check for doubles). */
8594 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8595 == c2->ext.block.case_list->ts.u.derived->hash_value)
8596 {
8597 gfc_error ("Double CLASS IS block in SELECT TYPE "
8598 "statement at %L",
8599 &c2->ext.block.case_list->where);
8600 return;
8601 }
8602 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8603 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8604 {
8605 /* Swap. */
8606 (*c1)->block = c2->block;
8607 c2->block = *c1;
8608 *c1 = c2;
8609 swapped = true;
8610 }
8611 }
8612 }
8613 while (swapped);
8614 }
8615
8616 /* Generate IF chain. */
8617 if_st = gfc_get_code (EXEC_IF);
8618 new_st = if_st;
8619 for (body = class_is; body; body = body->block)
8620 {
8621 new_st->block = gfc_get_code (EXEC_IF);
8622 new_st = new_st->block;
8623 /* Set up IF condition: Call _gfortran_is_extension_of. */
8624 new_st->expr1 = gfc_get_expr ();
8625 new_st->expr1->expr_type = EXPR_FUNCTION;
8626 new_st->expr1->ts.type = BT_LOGICAL;
8627 new_st->expr1->ts.kind = 4;
8628 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8629 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8630 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8631 /* Set up arguments. */
8632 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8633 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8634 new_st->expr1->value.function.actual->expr->where = code->loc;
8635 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8636 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8637 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8638 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8639 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8640 new_st->next = body->next;
8641 }
8642 if (default_case->next)
8643 {
8644 new_st->block = gfc_get_code (EXEC_IF);
8645 new_st = new_st->block;
8646 new_st->next = default_case->next;
8647 }
8648
8649 /* Replace CLASS DEFAULT code by the IF chain. */
8650 default_case->next = if_st;
8651 }
8652
8653 /* Resolve the internal code. This can not be done earlier because
8654 it requires that the sym->assoc of selectors is set already. */
8655 gfc_current_ns = ns;
8656 gfc_resolve_blocks (code->block, gfc_current_ns);
8657 gfc_current_ns = old_ns;
8658
8659 resolve_select (code, true);
8660 }
8661
8662
8663 /* Resolve a transfer statement. This is making sure that:
8664 -- a derived type being transferred has only non-pointer components
8665 -- a derived type being transferred doesn't have private components, unless
8666 it's being transferred from the module where the type was defined
8667 -- we're not trying to transfer a whole assumed size array. */
8668
8669 static void
resolve_transfer(gfc_code * code)8670 resolve_transfer (gfc_code *code)
8671 {
8672 gfc_typespec *ts;
8673 gfc_symbol *sym;
8674 gfc_ref *ref;
8675 gfc_expr *exp;
8676
8677 exp = code->expr1;
8678
8679 while (exp != NULL && exp->expr_type == EXPR_OP
8680 && exp->value.op.op == INTRINSIC_PARENTHESES)
8681 exp = exp->value.op.op1;
8682
8683 if (exp && exp->expr_type == EXPR_NULL
8684 && code->ext.dt)
8685 {
8686 gfc_error ("Invalid context for NULL () intrinsic at %L",
8687 &exp->where);
8688 return;
8689 }
8690
8691 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8692 && exp->expr_type != EXPR_FUNCTION
8693 && exp->expr_type != EXPR_STRUCTURE))
8694 return;
8695
8696 /* If we are reading, the variable will be changed. Note that
8697 code->ext.dt may be NULL if the TRANSFER is related to
8698 an INQUIRE statement -- but in this case, we are not reading, either. */
8699 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8700 && !gfc_check_vardef_context (exp, false, false, false,
8701 _("item in READ")))
8702 return;
8703
8704 ts = exp->expr_type == EXPR_STRUCTURE ? &exp->ts : &exp->symtree->n.sym->ts;
8705
8706 /* Go to actual component transferred. */
8707 for (ref = exp->ref; ref; ref = ref->next)
8708 if (ref->type == REF_COMPONENT)
8709 ts = &ref->u.c.component->ts;
8710
8711 if (ts->type == BT_CLASS)
8712 {
8713 /* FIXME: Test for defined input/output. */
8714 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8715 "it is processed by a defined input/output procedure",
8716 &code->loc);
8717 return;
8718 }
8719
8720 if (ts->type == BT_DERIVED)
8721 {
8722 /* Check that transferred derived type doesn't contain POINTER
8723 components. */
8724 if (ts->u.derived->attr.pointer_comp)
8725 {
8726 gfc_error ("Data transfer element at %L cannot have POINTER "
8727 "components unless it is processed by a defined "
8728 "input/output procedure", &code->loc);
8729 return;
8730 }
8731
8732 /* F08:C935. */
8733 if (ts->u.derived->attr.proc_pointer_comp)
8734 {
8735 gfc_error ("Data transfer element at %L cannot have "
8736 "procedure pointer components", &code->loc);
8737 return;
8738 }
8739
8740 if (ts->u.derived->attr.alloc_comp)
8741 {
8742 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8743 "components unless it is processed by a defined "
8744 "input/output procedure", &code->loc);
8745 return;
8746 }
8747
8748 /* C_PTR and C_FUNPTR have private components which means they can not
8749 be printed. However, if -std=gnu and not -pedantic, allow
8750 the component to be printed to help debugging. */
8751 if (ts->u.derived->ts.f90_type == BT_VOID)
8752 {
8753 if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L "
8754 "cannot have PRIVATE components", &code->loc))
8755 return;
8756 }
8757 else if (derived_inaccessible (ts->u.derived))
8758 {
8759 gfc_error ("Data transfer element at %L cannot have "
8760 "PRIVATE components",&code->loc);
8761 return;
8762 }
8763 }
8764
8765 if (exp->expr_type == EXPR_STRUCTURE)
8766 return;
8767
8768 sym = exp->symtree->n.sym;
8769
8770 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8771 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8772 {
8773 gfc_error ("Data transfer element at %L cannot be a full reference to "
8774 "an assumed-size array", &code->loc);
8775 return;
8776 }
8777 }
8778
8779
8780 /*********** Toplevel code resolution subroutines ***********/
8781
8782 /* Find the set of labels that are reachable from this block. We also
8783 record the last statement in each block. */
8784
8785 static void
find_reachable_labels(gfc_code * block)8786 find_reachable_labels (gfc_code *block)
8787 {
8788 gfc_code *c;
8789
8790 if (!block)
8791 return;
8792
8793 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8794
8795 /* Collect labels in this block. We don't keep those corresponding
8796 to END {IF|SELECT}, these are checked in resolve_branch by going
8797 up through the code_stack. */
8798 for (c = block; c; c = c->next)
8799 {
8800 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8801 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8802 }
8803
8804 /* Merge with labels from parent block. */
8805 if (cs_base->prev)
8806 {
8807 gcc_assert (cs_base->prev->reachable_labels);
8808 bitmap_ior_into (cs_base->reachable_labels,
8809 cs_base->prev->reachable_labels);
8810 }
8811 }
8812
8813
8814 static void
resolve_lock_unlock_event(gfc_code * code)8815 resolve_lock_unlock_event (gfc_code *code)
8816 {
8817 if (code->expr1->expr_type == EXPR_FUNCTION
8818 && code->expr1->value.function.isym
8819 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
8820 remove_caf_get_intrinsic (code->expr1);
8821
8822 if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
8823 && (code->expr1->ts.type != BT_DERIVED
8824 || code->expr1->expr_type != EXPR_VARIABLE
8825 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8826 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8827 || code->expr1->rank != 0
8828 || (!gfc_is_coarray (code->expr1) &&
8829 !gfc_is_coindexed (code->expr1))))
8830 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8831 &code->expr1->where);
8832 else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
8833 && (code->expr1->ts.type != BT_DERIVED
8834 || code->expr1->expr_type != EXPR_VARIABLE
8835 || code->expr1->ts.u.derived->from_intmod
8836 != INTMOD_ISO_FORTRAN_ENV
8837 || code->expr1->ts.u.derived->intmod_sym_id
8838 != ISOFORTRAN_EVENT_TYPE
8839 || code->expr1->rank != 0))
8840 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
8841 &code->expr1->where);
8842 else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
8843 && !gfc_is_coindexed (code->expr1))
8844 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
8845 &code->expr1->where);
8846 else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
8847 gfc_error ("Event variable argument at %L must be a coarray but not "
8848 "coindexed", &code->expr1->where);
8849
8850 /* Check STAT. */
8851 if (code->expr2
8852 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8853 || code->expr2->expr_type != EXPR_VARIABLE))
8854 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8855 &code->expr2->where);
8856
8857 if (code->expr2
8858 && !gfc_check_vardef_context (code->expr2, false, false, false,
8859 _("STAT variable")))
8860 return;
8861
8862 /* Check ERRMSG. */
8863 if (code->expr3
8864 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8865 || code->expr3->expr_type != EXPR_VARIABLE))
8866 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8867 &code->expr3->where);
8868
8869 if (code->expr3
8870 && !gfc_check_vardef_context (code->expr3, false, false, false,
8871 _("ERRMSG variable")))
8872 return;
8873
8874 /* Check for LOCK the ACQUIRED_LOCK. */
8875 if (code->op != EXEC_EVENT_WAIT && code->expr4
8876 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8877 || code->expr4->expr_type != EXPR_VARIABLE))
8878 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8879 "variable", &code->expr4->where);
8880
8881 if (code->op != EXEC_EVENT_WAIT && code->expr4
8882 && !gfc_check_vardef_context (code->expr4, false, false, false,
8883 _("ACQUIRED_LOCK variable")))
8884 return;
8885
8886 /* Check for EVENT WAIT the UNTIL_COUNT. */
8887 if (code->op == EXEC_EVENT_WAIT && code->expr4)
8888 {
8889 if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
8890 || code->expr4->rank != 0)
8891 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
8892 "expression", &code->expr4->where);
8893 }
8894 }
8895
8896
8897 static void
resolve_critical(gfc_code * code)8898 resolve_critical (gfc_code *code)
8899 {
8900 gfc_symtree *symtree;
8901 gfc_symbol *lock_type;
8902 char name[GFC_MAX_SYMBOL_LEN];
8903 static int serial = 0;
8904
8905 if (flag_coarray != GFC_FCOARRAY_LIB)
8906 return;
8907
8908 symtree = gfc_find_symtree (gfc_current_ns->sym_root,
8909 GFC_PREFIX ("lock_type"));
8910 if (symtree)
8911 lock_type = symtree->n.sym;
8912 else
8913 {
8914 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
8915 false) != 0)
8916 gcc_unreachable ();
8917 lock_type = symtree->n.sym;
8918 lock_type->attr.flavor = FL_DERIVED;
8919 lock_type->attr.zero_comp = 1;
8920 lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
8921 lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
8922 }
8923
8924 sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
8925 if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
8926 gcc_unreachable ();
8927
8928 code->resolved_sym = symtree->n.sym;
8929 symtree->n.sym->attr.flavor = FL_VARIABLE;
8930 symtree->n.sym->attr.referenced = 1;
8931 symtree->n.sym->attr.artificial = 1;
8932 symtree->n.sym->attr.codimension = 1;
8933 symtree->n.sym->ts.type = BT_DERIVED;
8934 symtree->n.sym->ts.u.derived = lock_type;
8935 symtree->n.sym->as = gfc_get_array_spec ();
8936 symtree->n.sym->as->corank = 1;
8937 symtree->n.sym->as->type = AS_EXPLICIT;
8938 symtree->n.sym->as->cotype = AS_EXPLICIT;
8939 symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
8940 NULL, 1);
8941 gfc_commit_symbols();
8942 }
8943
8944
8945 static void
resolve_sync(gfc_code * code)8946 resolve_sync (gfc_code *code)
8947 {
8948 /* Check imageset. The * case matches expr1 == NULL. */
8949 if (code->expr1)
8950 {
8951 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8952 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8953 "INTEGER expression", &code->expr1->where);
8954 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8955 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8956 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8957 &code->expr1->where);
8958 else if (code->expr1->expr_type == EXPR_ARRAY
8959 && gfc_simplify_expr (code->expr1, 0))
8960 {
8961 gfc_constructor *cons;
8962 cons = gfc_constructor_first (code->expr1->value.constructor);
8963 for (; cons; cons = gfc_constructor_next (cons))
8964 if (cons->expr->expr_type == EXPR_CONSTANT
8965 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8966 gfc_error ("Imageset argument at %L must between 1 and "
8967 "num_images()", &cons->expr->where);
8968 }
8969 }
8970
8971 /* Check STAT. */
8972 if (code->expr2
8973 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8974 || code->expr2->expr_type != EXPR_VARIABLE))
8975 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8976 &code->expr2->where);
8977
8978 /* Check ERRMSG. */
8979 if (code->expr3
8980 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8981 || code->expr3->expr_type != EXPR_VARIABLE))
8982 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8983 &code->expr3->where);
8984 }
8985
8986
8987 /* Given a branch to a label, see if the branch is conforming.
8988 The code node describes where the branch is located. */
8989
8990 static void
resolve_branch(gfc_st_label * label,gfc_code * code)8991 resolve_branch (gfc_st_label *label, gfc_code *code)
8992 {
8993 code_stack *stack;
8994
8995 if (label == NULL)
8996 return;
8997
8998 /* Step one: is this a valid branching target? */
8999
9000 if (label->defined == ST_LABEL_UNKNOWN)
9001 {
9002 gfc_error ("Label %d referenced at %L is never defined", label->value,
9003 &code->loc);
9004 return;
9005 }
9006
9007 if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
9008 {
9009 gfc_error ("Statement at %L is not a valid branch target statement "
9010 "for the branch statement at %L", &label->where, &code->loc);
9011 return;
9012 }
9013
9014 /* Step two: make sure this branch is not a branch to itself ;-) */
9015
9016 if (code->here == label)
9017 {
9018 gfc_warning (0,
9019 "Branch at %L may result in an infinite loop", &code->loc);
9020 return;
9021 }
9022
9023 /* Step three: See if the label is in the same block as the
9024 branching statement. The hard work has been done by setting up
9025 the bitmap reachable_labels. */
9026
9027 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
9028 {
9029 /* Check now whether there is a CRITICAL construct; if so, check
9030 whether the label is still visible outside of the CRITICAL block,
9031 which is invalid. */
9032 for (stack = cs_base; stack; stack = stack->prev)
9033 {
9034 if (stack->current->op == EXEC_CRITICAL
9035 && bitmap_bit_p (stack->reachable_labels, label->value))
9036 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
9037 "label at %L", &code->loc, &label->where);
9038 else if (stack->current->op == EXEC_DO_CONCURRENT
9039 && bitmap_bit_p (stack->reachable_labels, label->value))
9040 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
9041 "for label at %L", &code->loc, &label->where);
9042 }
9043
9044 return;
9045 }
9046
9047 /* Step four: If we haven't found the label in the bitmap, it may
9048 still be the label of the END of the enclosing block, in which
9049 case we find it by going up the code_stack. */
9050
9051 for (stack = cs_base; stack; stack = stack->prev)
9052 {
9053 if (stack->current->next && stack->current->next->here == label)
9054 break;
9055 if (stack->current->op == EXEC_CRITICAL)
9056 {
9057 /* Note: A label at END CRITICAL does not leave the CRITICAL
9058 construct as END CRITICAL is still part of it. */
9059 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
9060 " at %L", &code->loc, &label->where);
9061 return;
9062 }
9063 else if (stack->current->op == EXEC_DO_CONCURRENT)
9064 {
9065 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
9066 "label at %L", &code->loc, &label->where);
9067 return;
9068 }
9069 }
9070
9071 if (stack)
9072 {
9073 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
9074 return;
9075 }
9076
9077 /* The label is not in an enclosing block, so illegal. This was
9078 allowed in Fortran 66, so we allow it as extension. No
9079 further checks are necessary in this case. */
9080 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
9081 "as the GOTO statement at %L", &label->where,
9082 &code->loc);
9083 return;
9084 }
9085
9086
9087 /* Check whether EXPR1 has the same shape as EXPR2. */
9088
9089 static bool
resolve_where_shape(gfc_expr * expr1,gfc_expr * expr2)9090 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
9091 {
9092 mpz_t shape[GFC_MAX_DIMENSIONS];
9093 mpz_t shape2[GFC_MAX_DIMENSIONS];
9094 bool result = false;
9095 int i;
9096
9097 /* Compare the rank. */
9098 if (expr1->rank != expr2->rank)
9099 return result;
9100
9101 /* Compare the size of each dimension. */
9102 for (i=0; i<expr1->rank; i++)
9103 {
9104 if (!gfc_array_dimen_size (expr1, i, &shape[i]))
9105 goto ignore;
9106
9107 if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
9108 goto ignore;
9109
9110 if (mpz_cmp (shape[i], shape2[i]))
9111 goto over;
9112 }
9113
9114 /* When either of the two expression is an assumed size array, we
9115 ignore the comparison of dimension sizes. */
9116 ignore:
9117 result = true;
9118
9119 over:
9120 gfc_clear_shape (shape, i);
9121 gfc_clear_shape (shape2, i);
9122 return result;
9123 }
9124
9125
9126 /* Check whether a WHERE assignment target or a WHERE mask expression
9127 has the same shape as the outmost WHERE mask expression. */
9128
9129 static void
resolve_where(gfc_code * code,gfc_expr * mask)9130 resolve_where (gfc_code *code, gfc_expr *mask)
9131 {
9132 gfc_code *cblock;
9133 gfc_code *cnext;
9134 gfc_expr *e = NULL;
9135
9136 cblock = code->block;
9137
9138 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9139 In case of nested WHERE, only the outmost one is stored. */
9140 if (mask == NULL) /* outmost WHERE */
9141 e = cblock->expr1;
9142 else /* inner WHERE */
9143 e = mask;
9144
9145 while (cblock)
9146 {
9147 if (cblock->expr1)
9148 {
9149 /* Check if the mask-expr has a consistent shape with the
9150 outmost WHERE mask-expr. */
9151 if (!resolve_where_shape (cblock->expr1, e))
9152 gfc_error ("WHERE mask at %L has inconsistent shape",
9153 &cblock->expr1->where);
9154 }
9155
9156 /* the assignment statement of a WHERE statement, or the first
9157 statement in where-body-construct of a WHERE construct */
9158 cnext = cblock->next;
9159 while (cnext)
9160 {
9161 switch (cnext->op)
9162 {
9163 /* WHERE assignment statement */
9164 case EXEC_ASSIGN:
9165
9166 /* Check shape consistent for WHERE assignment target. */
9167 if (e && !resolve_where_shape (cnext->expr1, e))
9168 gfc_error ("WHERE assignment target at %L has "
9169 "inconsistent shape", &cnext->expr1->where);
9170 break;
9171
9172
9173 case EXEC_ASSIGN_CALL:
9174 resolve_call (cnext);
9175 if (!cnext->resolved_sym->attr.elemental)
9176 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9177 &cnext->ext.actual->expr->where);
9178 break;
9179
9180 /* WHERE or WHERE construct is part of a where-body-construct */
9181 case EXEC_WHERE:
9182 resolve_where (cnext, e);
9183 break;
9184
9185 default:
9186 gfc_error ("Unsupported statement inside WHERE at %L",
9187 &cnext->loc);
9188 }
9189 /* the next statement within the same where-body-construct */
9190 cnext = cnext->next;
9191 }
9192 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9193 cblock = cblock->block;
9194 }
9195 }
9196
9197
9198 /* Resolve assignment in FORALL construct.
9199 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9200 FORALL index variables. */
9201
9202 static void
gfc_resolve_assign_in_forall(gfc_code * code,int nvar,gfc_expr ** var_expr)9203 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
9204 {
9205 int n;
9206
9207 for (n = 0; n < nvar; n++)
9208 {
9209 gfc_symbol *forall_index;
9210
9211 forall_index = var_expr[n]->symtree->n.sym;
9212
9213 /* Check whether the assignment target is one of the FORALL index
9214 variable. */
9215 if ((code->expr1->expr_type == EXPR_VARIABLE)
9216 && (code->expr1->symtree->n.sym == forall_index))
9217 gfc_error ("Assignment to a FORALL index variable at %L",
9218 &code->expr1->where);
9219 else
9220 {
9221 /* If one of the FORALL index variables doesn't appear in the
9222 assignment variable, then there could be a many-to-one
9223 assignment. Emit a warning rather than an error because the
9224 mask could be resolving this problem. */
9225 if (!find_forall_index (code->expr1, forall_index, 0))
9226 gfc_warning (0, "The FORALL with index %qs is not used on the "
9227 "left side of the assignment at %L and so might "
9228 "cause multiple assignment to this object",
9229 var_expr[n]->symtree->name, &code->expr1->where);
9230 }
9231 }
9232 }
9233
9234
9235 /* Resolve WHERE statement in FORALL construct. */
9236
9237 static void
gfc_resolve_where_code_in_forall(gfc_code * code,int nvar,gfc_expr ** var_expr)9238 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
9239 gfc_expr **var_expr)
9240 {
9241 gfc_code *cblock;
9242 gfc_code *cnext;
9243
9244 cblock = code->block;
9245 while (cblock)
9246 {
9247 /* the assignment statement of a WHERE statement, or the first
9248 statement in where-body-construct of a WHERE construct */
9249 cnext = cblock->next;
9250 while (cnext)
9251 {
9252 switch (cnext->op)
9253 {
9254 /* WHERE assignment statement */
9255 case EXEC_ASSIGN:
9256 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
9257 break;
9258
9259 /* WHERE operator assignment statement */
9260 case EXEC_ASSIGN_CALL:
9261 resolve_call (cnext);
9262 if (!cnext->resolved_sym->attr.elemental)
9263 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9264 &cnext->ext.actual->expr->where);
9265 break;
9266
9267 /* WHERE or WHERE construct is part of a where-body-construct */
9268 case EXEC_WHERE:
9269 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
9270 break;
9271
9272 default:
9273 gfc_error ("Unsupported statement inside WHERE at %L",
9274 &cnext->loc);
9275 }
9276 /* the next statement within the same where-body-construct */
9277 cnext = cnext->next;
9278 }
9279 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9280 cblock = cblock->block;
9281 }
9282 }
9283
9284
9285 /* Traverse the FORALL body to check whether the following errors exist:
9286 1. For assignment, check if a many-to-one assignment happens.
9287 2. For WHERE statement, check the WHERE body to see if there is any
9288 many-to-one assignment. */
9289
9290 static void
gfc_resolve_forall_body(gfc_code * code,int nvar,gfc_expr ** var_expr)9291 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
9292 {
9293 gfc_code *c;
9294
9295 c = code->block->next;
9296 while (c)
9297 {
9298 switch (c->op)
9299 {
9300 case EXEC_ASSIGN:
9301 case EXEC_POINTER_ASSIGN:
9302 gfc_resolve_assign_in_forall (c, nvar, var_expr);
9303 break;
9304
9305 case EXEC_ASSIGN_CALL:
9306 resolve_call (c);
9307 break;
9308
9309 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9310 there is no need to handle it here. */
9311 case EXEC_FORALL:
9312 break;
9313 case EXEC_WHERE:
9314 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
9315 break;
9316 default:
9317 break;
9318 }
9319 /* The next statement in the FORALL body. */
9320 c = c->next;
9321 }
9322 }
9323
9324
9325 /* Counts the number of iterators needed inside a forall construct, including
9326 nested forall constructs. This is used to allocate the needed memory
9327 in gfc_resolve_forall. */
9328
9329 static int
gfc_count_forall_iterators(gfc_code * code)9330 gfc_count_forall_iterators (gfc_code *code)
9331 {
9332 int max_iters, sub_iters, current_iters;
9333 gfc_forall_iterator *fa;
9334
9335 gcc_assert(code->op == EXEC_FORALL);
9336 max_iters = 0;
9337 current_iters = 0;
9338
9339 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
9340 current_iters ++;
9341
9342 code = code->block->next;
9343
9344 while (code)
9345 {
9346 if (code->op == EXEC_FORALL)
9347 {
9348 sub_iters = gfc_count_forall_iterators (code);
9349 if (sub_iters > max_iters)
9350 max_iters = sub_iters;
9351 }
9352 code = code->next;
9353 }
9354
9355 return current_iters + max_iters;
9356 }
9357
9358
9359 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9360 gfc_resolve_forall_body to resolve the FORALL body. */
9361
9362 static void
gfc_resolve_forall(gfc_code * code,gfc_namespace * ns,int forall_save)9363 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
9364 {
9365 static gfc_expr **var_expr;
9366 static int total_var = 0;
9367 static int nvar = 0;
9368 int i, old_nvar, tmp;
9369 gfc_forall_iterator *fa;
9370
9371 old_nvar = nvar;
9372
9373 /* Start to resolve a FORALL construct */
9374 if (forall_save == 0)
9375 {
9376 /* Count the total number of FORALL indices in the nested FORALL
9377 construct in order to allocate the VAR_EXPR with proper size. */
9378 total_var = gfc_count_forall_iterators (code);
9379
9380 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9381 var_expr = XCNEWVEC (gfc_expr *, total_var);
9382 }
9383
9384 /* The information about FORALL iterator, including FORALL indices start, end
9385 and stride. An outer FORALL indice cannot appear in start, end or stride. */
9386 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
9387 {
9388 /* Fortran 20008: C738 (R753). */
9389 if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
9390 {
9391 gfc_error ("FORALL index-name at %L must be a scalar variable "
9392 "of type integer", &fa->var->where);
9393 continue;
9394 }
9395
9396 /* Check if any outer FORALL index name is the same as the current
9397 one. */
9398 for (i = 0; i < nvar; i++)
9399 {
9400 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
9401 gfc_error ("An outer FORALL construct already has an index "
9402 "with this name %L", &fa->var->where);
9403 }
9404
9405 /* Record the current FORALL index. */
9406 var_expr[nvar] = gfc_copy_expr (fa->var);
9407
9408 nvar++;
9409
9410 /* No memory leak. */
9411 gcc_assert (nvar <= total_var);
9412 }
9413
9414 /* Resolve the FORALL body. */
9415 gfc_resolve_forall_body (code, nvar, var_expr);
9416
9417 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9418 gfc_resolve_blocks (code->block, ns);
9419
9420 tmp = nvar;
9421 nvar = old_nvar;
9422 /* Free only the VAR_EXPRs allocated in this frame. */
9423 for (i = nvar; i < tmp; i++)
9424 gfc_free_expr (var_expr[i]);
9425
9426 if (nvar == 0)
9427 {
9428 /* We are in the outermost FORALL construct. */
9429 gcc_assert (forall_save == 0);
9430
9431 /* VAR_EXPR is not needed any more. */
9432 free (var_expr);
9433 total_var = 0;
9434 }
9435 }
9436
9437
9438 /* Resolve a BLOCK construct statement. */
9439
9440 static void
resolve_block_construct(gfc_code * code)9441 resolve_block_construct (gfc_code* code)
9442 {
9443 /* Resolve the BLOCK's namespace. */
9444 gfc_resolve (code->ext.block.ns);
9445
9446 /* For an ASSOCIATE block, the associations (and their targets) are already
9447 resolved during resolve_symbol. */
9448 }
9449
9450
9451 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9452 DO code nodes. */
9453
9454 void
gfc_resolve_blocks(gfc_code * b,gfc_namespace * ns)9455 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
9456 {
9457 bool t;
9458
9459 for (; b; b = b->block)
9460 {
9461 t = gfc_resolve_expr (b->expr1);
9462 if (!gfc_resolve_expr (b->expr2))
9463 t = false;
9464
9465 switch (b->op)
9466 {
9467 case EXEC_IF:
9468 if (t && b->expr1 != NULL
9469 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
9470 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9471 &b->expr1->where);
9472 break;
9473
9474 case EXEC_WHERE:
9475 if (t
9476 && b->expr1 != NULL
9477 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9478 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9479 &b->expr1->where);
9480 break;
9481
9482 case EXEC_GOTO:
9483 resolve_branch (b->label1, b);
9484 break;
9485
9486 case EXEC_BLOCK:
9487 resolve_block_construct (b);
9488 break;
9489
9490 case EXEC_SELECT:
9491 case EXEC_SELECT_TYPE:
9492 case EXEC_FORALL:
9493 case EXEC_DO:
9494 case EXEC_DO_WHILE:
9495 case EXEC_DO_CONCURRENT:
9496 case EXEC_CRITICAL:
9497 case EXEC_READ:
9498 case EXEC_WRITE:
9499 case EXEC_IOLENGTH:
9500 case EXEC_WAIT:
9501 break;
9502
9503 case EXEC_OMP_ATOMIC:
9504 case EXEC_OACC_ATOMIC:
9505 {
9506 gfc_omp_atomic_op aop
9507 = (gfc_omp_atomic_op) (b->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
9508
9509 /* Verify this before calling gfc_resolve_code, which might
9510 change it. */
9511 gcc_assert (b->next && b->next->op == EXEC_ASSIGN);
9512 gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE)
9513 && b->next->next == NULL)
9514 || ((aop == GFC_OMP_ATOMIC_CAPTURE)
9515 && b->next->next != NULL
9516 && b->next->next->op == EXEC_ASSIGN
9517 && b->next->next->next == NULL));
9518 }
9519 break;
9520
9521 case EXEC_OACC_PARALLEL_LOOP:
9522 case EXEC_OACC_PARALLEL:
9523 case EXEC_OACC_KERNELS_LOOP:
9524 case EXEC_OACC_KERNELS:
9525 case EXEC_OACC_DATA:
9526 case EXEC_OACC_HOST_DATA:
9527 case EXEC_OACC_LOOP:
9528 case EXEC_OACC_UPDATE:
9529 case EXEC_OACC_WAIT:
9530 case EXEC_OACC_CACHE:
9531 case EXEC_OACC_ENTER_DATA:
9532 case EXEC_OACC_EXIT_DATA:
9533 case EXEC_OACC_ROUTINE:
9534 case EXEC_OMP_CRITICAL:
9535 case EXEC_OMP_DISTRIBUTE:
9536 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9537 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9538 case EXEC_OMP_DISTRIBUTE_SIMD:
9539 case EXEC_OMP_DO:
9540 case EXEC_OMP_DO_SIMD:
9541 case EXEC_OMP_MASTER:
9542 case EXEC_OMP_ORDERED:
9543 case EXEC_OMP_PARALLEL:
9544 case EXEC_OMP_PARALLEL_DO:
9545 case EXEC_OMP_PARALLEL_DO_SIMD:
9546 case EXEC_OMP_PARALLEL_SECTIONS:
9547 case EXEC_OMP_PARALLEL_WORKSHARE:
9548 case EXEC_OMP_SECTIONS:
9549 case EXEC_OMP_SIMD:
9550 case EXEC_OMP_SINGLE:
9551 case EXEC_OMP_TARGET:
9552 case EXEC_OMP_TARGET_DATA:
9553 case EXEC_OMP_TARGET_TEAMS:
9554 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9555 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9556 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9557 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9558 case EXEC_OMP_TARGET_UPDATE:
9559 case EXEC_OMP_TASK:
9560 case EXEC_OMP_TASKGROUP:
9561 case EXEC_OMP_TASKWAIT:
9562 case EXEC_OMP_TASKYIELD:
9563 case EXEC_OMP_TEAMS:
9564 case EXEC_OMP_TEAMS_DISTRIBUTE:
9565 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9566 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9567 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9568 case EXEC_OMP_WORKSHARE:
9569 break;
9570
9571 default:
9572 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9573 }
9574
9575 gfc_resolve_code (b->next, ns);
9576 }
9577 }
9578
9579
9580 /* Does everything to resolve an ordinary assignment. Returns true
9581 if this is an interface assignment. */
9582 static bool
resolve_ordinary_assign(gfc_code * code,gfc_namespace * ns)9583 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9584 {
9585 bool rval = false;
9586 gfc_expr *lhs;
9587 gfc_expr *rhs;
9588 int llen = 0;
9589 int rlen = 0;
9590 int n;
9591 gfc_ref *ref;
9592 symbol_attribute attr;
9593
9594 if (gfc_extend_assign (code, ns))
9595 {
9596 gfc_expr** rhsptr;
9597
9598 if (code->op == EXEC_ASSIGN_CALL)
9599 {
9600 lhs = code->ext.actual->expr;
9601 rhsptr = &code->ext.actual->next->expr;
9602 }
9603 else
9604 {
9605 gfc_actual_arglist* args;
9606 gfc_typebound_proc* tbp;
9607
9608 gcc_assert (code->op == EXEC_COMPCALL);
9609
9610 args = code->expr1->value.compcall.actual;
9611 lhs = args->expr;
9612 rhsptr = &args->next->expr;
9613
9614 tbp = code->expr1->value.compcall.tbp;
9615 gcc_assert (!tbp->is_generic);
9616 }
9617
9618 /* Make a temporary rhs when there is a default initializer
9619 and rhs is the same symbol as the lhs. */
9620 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9621 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9622 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9623 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9624 *rhsptr = gfc_get_parentheses (*rhsptr);
9625
9626 return true;
9627 }
9628
9629 lhs = code->expr1;
9630 rhs = code->expr2;
9631
9632 if (rhs->is_boz
9633 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
9634 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9635 &code->loc))
9636 return false;
9637
9638 /* Handle the case of a BOZ literal on the RHS. */
9639 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9640 {
9641 int rc;
9642 if (warn_surprising)
9643 gfc_warning (OPT_Wsurprising,
9644 "BOZ literal at %L is bitwise transferred "
9645 "non-integer symbol %qs", &code->loc,
9646 lhs->symtree->n.sym->name);
9647
9648 if (!gfc_convert_boz (rhs, &lhs->ts))
9649 return false;
9650 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9651 {
9652 if (rc == ARITH_UNDERFLOW)
9653 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9654 ". This check can be disabled with the option "
9655 "%<-fno-range-check%>", &rhs->where);
9656 else if (rc == ARITH_OVERFLOW)
9657 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9658 ". This check can be disabled with the option "
9659 "%<-fno-range-check%>", &rhs->where);
9660 else if (rc == ARITH_NAN)
9661 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9662 ". This check can be disabled with the option "
9663 "%<-fno-range-check%>", &rhs->where);
9664 return false;
9665 }
9666 }
9667
9668 if (lhs->ts.type == BT_CHARACTER
9669 && warn_character_truncation)
9670 {
9671 if (lhs->ts.u.cl != NULL
9672 && lhs->ts.u.cl->length != NULL
9673 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9674 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9675
9676 if (rhs->expr_type == EXPR_CONSTANT)
9677 rlen = rhs->value.character.length;
9678
9679 else if (rhs->ts.u.cl != NULL
9680 && rhs->ts.u.cl->length != NULL
9681 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9682 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9683
9684 if (rlen && llen && rlen > llen)
9685 gfc_warning_now (OPT_Wcharacter_truncation,
9686 "CHARACTER expression will be truncated "
9687 "in assignment (%d/%d) at %L",
9688 llen, rlen, &code->loc);
9689 }
9690
9691 /* Ensure that a vector index expression for the lvalue is evaluated
9692 to a temporary if the lvalue symbol is referenced in it. */
9693 if (lhs->rank)
9694 {
9695 for (ref = lhs->ref; ref; ref= ref->next)
9696 if (ref->type == REF_ARRAY)
9697 {
9698 for (n = 0; n < ref->u.ar.dimen; n++)
9699 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9700 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9701 ref->u.ar.start[n]))
9702 ref->u.ar.start[n]
9703 = gfc_get_parentheses (ref->u.ar.start[n]);
9704 }
9705 }
9706
9707 if (gfc_pure (NULL))
9708 {
9709 if (lhs->ts.type == BT_DERIVED
9710 && lhs->expr_type == EXPR_VARIABLE
9711 && lhs->ts.u.derived->attr.pointer_comp
9712 && rhs->expr_type == EXPR_VARIABLE
9713 && (gfc_impure_variable (rhs->symtree->n.sym)
9714 || gfc_is_coindexed (rhs)))
9715 {
9716 /* F2008, C1283. */
9717 if (gfc_is_coindexed (rhs))
9718 gfc_error ("Coindexed expression at %L is assigned to "
9719 "a derived type variable with a POINTER "
9720 "component in a PURE procedure",
9721 &rhs->where);
9722 else
9723 gfc_error ("The impure variable at %L is assigned to "
9724 "a derived type variable with a POINTER "
9725 "component in a PURE procedure (12.6)",
9726 &rhs->where);
9727 return rval;
9728 }
9729
9730 /* Fortran 2008, C1283. */
9731 if (gfc_is_coindexed (lhs))
9732 {
9733 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9734 "procedure", &rhs->where);
9735 return rval;
9736 }
9737 }
9738
9739 if (gfc_implicit_pure (NULL))
9740 {
9741 if (lhs->expr_type == EXPR_VARIABLE
9742 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9743 && lhs->symtree->n.sym->ns != gfc_current_ns)
9744 gfc_unset_implicit_pure (NULL);
9745
9746 if (lhs->ts.type == BT_DERIVED
9747 && lhs->expr_type == EXPR_VARIABLE
9748 && lhs->ts.u.derived->attr.pointer_comp
9749 && rhs->expr_type == EXPR_VARIABLE
9750 && (gfc_impure_variable (rhs->symtree->n.sym)
9751 || gfc_is_coindexed (rhs)))
9752 gfc_unset_implicit_pure (NULL);
9753
9754 /* Fortran 2008, C1283. */
9755 if (gfc_is_coindexed (lhs))
9756 gfc_unset_implicit_pure (NULL);
9757 }
9758
9759 /* F2008, 7.2.1.2. */
9760 attr = gfc_expr_attr (lhs);
9761 if (lhs->ts.type == BT_CLASS && attr.allocatable)
9762 {
9763 if (attr.codimension)
9764 {
9765 gfc_error ("Assignment to polymorphic coarray at %L is not "
9766 "permitted", &lhs->where);
9767 return false;
9768 }
9769 if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
9770 "polymorphic variable at %L", &lhs->where))
9771 return false;
9772 if (!flag_realloc_lhs)
9773 {
9774 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9775 "requires %<-frealloc-lhs%>", &lhs->where);
9776 return false;
9777 }
9778 /* See PR 43366. */
9779 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9780 "is not yet supported", &lhs->where);
9781 return false;
9782 }
9783 else if (lhs->ts.type == BT_CLASS)
9784 {
9785 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9786 "assignment at %L - check that there is a matching specific "
9787 "subroutine for '=' operator", &lhs->where);
9788 return false;
9789 }
9790
9791 bool lhs_coindexed = gfc_is_coindexed (lhs);
9792
9793 /* F2008, Section 7.2.1.2. */
9794 if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
9795 {
9796 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9797 "component in assignment at %L", &lhs->where);
9798 return false;
9799 }
9800
9801 gfc_check_assign (lhs, rhs, 1);
9802
9803 /* Assign the 'data' of a class object to a derived type. */
9804 if (lhs->ts.type == BT_DERIVED
9805 && rhs->ts.type == BT_CLASS
9806 && rhs->expr_type != EXPR_ARRAY)
9807 gfc_add_data_component (rhs);
9808
9809 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9810 Additionally, insert this code when the RHS is a CAF as we then use the
9811 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9812 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9813 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9814 path. */
9815 if (flag_coarray == GFC_FCOARRAY_LIB
9816 && (lhs_coindexed
9817 || (code->expr2->expr_type == EXPR_FUNCTION
9818 && code->expr2->value.function.isym
9819 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
9820 && (code->expr1->rank == 0 || code->expr2->rank != 0)
9821 && !gfc_expr_attr (rhs).allocatable
9822 && !gfc_has_vector_subscript (rhs))))
9823 {
9824 if (code->expr2->expr_type == EXPR_FUNCTION
9825 && code->expr2->value.function.isym
9826 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
9827 remove_caf_get_intrinsic (code->expr2);
9828 code->op = EXEC_CALL;
9829 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
9830 code->resolved_sym = code->symtree->n.sym;
9831 code->resolved_sym->attr.flavor = FL_PROCEDURE;
9832 code->resolved_sym->attr.intrinsic = 1;
9833 code->resolved_sym->attr.subroutine = 1;
9834 code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
9835 gfc_commit_symbol (code->resolved_sym);
9836 code->ext.actual = gfc_get_actual_arglist ();
9837 code->ext.actual->expr = lhs;
9838 code->ext.actual->next = gfc_get_actual_arglist ();
9839 code->ext.actual->next->expr = rhs;
9840 code->expr1 = NULL;
9841 code->expr2 = NULL;
9842 }
9843
9844 return false;
9845 }
9846
9847
9848 /* Add a component reference onto an expression. */
9849
9850 static void
add_comp_ref(gfc_expr * e,gfc_component * c)9851 add_comp_ref (gfc_expr *e, gfc_component *c)
9852 {
9853 gfc_ref **ref;
9854 ref = &(e->ref);
9855 while (*ref)
9856 ref = &((*ref)->next);
9857 *ref = gfc_get_ref ();
9858 (*ref)->type = REF_COMPONENT;
9859 (*ref)->u.c.sym = e->ts.u.derived;
9860 (*ref)->u.c.component = c;
9861 e->ts = c->ts;
9862
9863 /* Add a full array ref, as necessary. */
9864 if (c->as)
9865 {
9866 gfc_add_full_array_ref (e, c->as);
9867 e->rank = c->as->rank;
9868 }
9869 }
9870
9871
9872 /* Build an assignment. Keep the argument 'op' for future use, so that
9873 pointer assignments can be made. */
9874
9875 static gfc_code *
build_assignment(gfc_exec_op op,gfc_expr * expr1,gfc_expr * expr2,gfc_component * comp1,gfc_component * comp2,locus loc)9876 build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
9877 gfc_component *comp1, gfc_component *comp2, locus loc)
9878 {
9879 gfc_code *this_code;
9880
9881 this_code = gfc_get_code (op);
9882 this_code->next = NULL;
9883 this_code->expr1 = gfc_copy_expr (expr1);
9884 this_code->expr2 = gfc_copy_expr (expr2);
9885 this_code->loc = loc;
9886 if (comp1 && comp2)
9887 {
9888 add_comp_ref (this_code->expr1, comp1);
9889 add_comp_ref (this_code->expr2, comp2);
9890 }
9891
9892 return this_code;
9893 }
9894
9895
9896 /* Makes a temporary variable expression based on the characteristics of
9897 a given variable expression. */
9898
9899 static gfc_expr*
get_temp_from_expr(gfc_expr * e,gfc_namespace * ns)9900 get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
9901 {
9902 static int serial = 0;
9903 char name[GFC_MAX_SYMBOL_LEN];
9904 gfc_symtree *tmp;
9905 gfc_array_spec *as;
9906 gfc_array_ref *aref;
9907 gfc_ref *ref;
9908
9909 sprintf (name, GFC_PREFIX("DA%d"), serial++);
9910 gfc_get_sym_tree (name, ns, &tmp, false);
9911 gfc_add_type (tmp->n.sym, &e->ts, NULL);
9912
9913 as = NULL;
9914 ref = NULL;
9915 aref = NULL;
9916
9917 /* Obtain the arrayspec for the temporary. */
9918 if (e->rank && e->expr_type != EXPR_ARRAY
9919 && e->expr_type != EXPR_FUNCTION
9920 && e->expr_type != EXPR_OP)
9921 {
9922 aref = gfc_find_array_ref (e);
9923 if (e->expr_type == EXPR_VARIABLE
9924 && e->symtree->n.sym->as == aref->as)
9925 as = aref->as;
9926 else
9927 {
9928 for (ref = e->ref; ref; ref = ref->next)
9929 if (ref->type == REF_COMPONENT
9930 && ref->u.c.component->as == aref->as)
9931 {
9932 as = aref->as;
9933 break;
9934 }
9935 }
9936 }
9937
9938 /* Add the attributes and the arrayspec to the temporary. */
9939 tmp->n.sym->attr = gfc_expr_attr (e);
9940 tmp->n.sym->attr.function = 0;
9941 tmp->n.sym->attr.result = 0;
9942 tmp->n.sym->attr.flavor = FL_VARIABLE;
9943 tmp->n.sym->attr.dummy = 0;
9944 tmp->n.sym->attr.intent = INTENT_UNKNOWN;
9945
9946 if (as)
9947 {
9948 tmp->n.sym->as = gfc_copy_array_spec (as);
9949 if (!ref)
9950 ref = e->ref;
9951 if (as->type == AS_DEFERRED)
9952 tmp->n.sym->attr.allocatable = 1;
9953 }
9954 else if (e->rank && (e->expr_type == EXPR_ARRAY
9955 || e->expr_type == EXPR_FUNCTION
9956 || e->expr_type == EXPR_OP))
9957 {
9958 tmp->n.sym->as = gfc_get_array_spec ();
9959 tmp->n.sym->as->type = AS_DEFERRED;
9960 tmp->n.sym->as->rank = e->rank;
9961 tmp->n.sym->attr.allocatable = 1;
9962 tmp->n.sym->attr.dimension = 1;
9963 }
9964 else
9965 tmp->n.sym->attr.dimension = 0;
9966
9967 gfc_set_sym_referenced (tmp->n.sym);
9968 gfc_commit_symbol (tmp->n.sym);
9969 e = gfc_lval_expr_from_sym (tmp->n.sym);
9970
9971 /* Should the lhs be a section, use its array ref for the
9972 temporary expression. */
9973 if (aref && aref->type != AR_FULL)
9974 {
9975 gfc_free_ref_list (e->ref);
9976 e->ref = gfc_copy_ref (ref);
9977 }
9978 return e;
9979 }
9980
9981
9982 /* Add one line of code to the code chain, making sure that 'head' and
9983 'tail' are appropriately updated. */
9984
9985 static void
add_code_to_chain(gfc_code ** this_code,gfc_code ** head,gfc_code ** tail)9986 add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
9987 {
9988 gcc_assert (this_code);
9989 if (*head == NULL)
9990 *head = *tail = *this_code;
9991 else
9992 *tail = gfc_append_code (*tail, *this_code);
9993 *this_code = NULL;
9994 }
9995
9996
9997 /* Counts the potential number of part array references that would
9998 result from resolution of typebound defined assignments. */
9999
10000 static int
nonscalar_typebound_assign(gfc_symbol * derived,int depth)10001 nonscalar_typebound_assign (gfc_symbol *derived, int depth)
10002 {
10003 gfc_component *c;
10004 int c_depth = 0, t_depth;
10005
10006 for (c= derived->components; c; c = c->next)
10007 {
10008 if ((!gfc_bt_struct (c->ts.type)
10009 || c->attr.pointer
10010 || c->attr.allocatable
10011 || c->attr.proc_pointer_comp
10012 || c->attr.class_pointer
10013 || c->attr.proc_pointer)
10014 && !c->attr.defined_assign_comp)
10015 continue;
10016
10017 if (c->as && c_depth == 0)
10018 c_depth = 1;
10019
10020 if (c->ts.u.derived->attr.defined_assign_comp)
10021 t_depth = nonscalar_typebound_assign (c->ts.u.derived,
10022 c->as ? 1 : 0);
10023 else
10024 t_depth = 0;
10025
10026 c_depth = t_depth > c_depth ? t_depth : c_depth;
10027 }
10028 return depth + c_depth;
10029 }
10030
10031
10032 /* Implement 7.2.1.3 of the F08 standard:
10033 "An intrinsic assignment where the variable is of derived type is
10034 performed as if each component of the variable were assigned from the
10035 corresponding component of expr using pointer assignment (7.2.2) for
10036 each pointer component, defined assignment for each nonpointer
10037 nonallocatable component of a type that has a type-bound defined
10038 assignment consistent with the component, intrinsic assignment for
10039 each other nonpointer nonallocatable component, ..."
10040
10041 The pointer assignments are taken care of by the intrinsic
10042 assignment of the structure itself. This function recursively adds
10043 defined assignments where required. The recursion is accomplished
10044 by calling gfc_resolve_code.
10045
10046 When the lhs in a defined assignment has intent INOUT, we need a
10047 temporary for the lhs. In pseudo-code:
10048
10049 ! Only call function lhs once.
10050 if (lhs is not a constant or an variable)
10051 temp_x = expr2
10052 expr2 => temp_x
10053 ! Do the intrinsic assignment
10054 expr1 = expr2
10055 ! Now do the defined assignments
10056 do over components with typebound defined assignment [%cmp]
10057 #if one component's assignment procedure is INOUT
10058 t1 = expr1
10059 #if expr2 non-variable
10060 temp_x = expr2
10061 expr2 => temp_x
10062 # endif
10063 expr1 = expr2
10064 # for each cmp
10065 t1%cmp {defined=} expr2%cmp
10066 expr1%cmp = t1%cmp
10067 #else
10068 expr1 = expr2
10069
10070 # for each cmp
10071 expr1%cmp {defined=} expr2%cmp
10072 #endif
10073 */
10074
10075 /* The temporary assignments have to be put on top of the additional
10076 code to avoid the result being changed by the intrinsic assignment.
10077 */
10078 static int component_assignment_level = 0;
10079 static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
10080
10081 static void
generate_component_assignments(gfc_code ** code,gfc_namespace * ns)10082 generate_component_assignments (gfc_code **code, gfc_namespace *ns)
10083 {
10084 gfc_component *comp1, *comp2;
10085 gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
10086 gfc_expr *t1;
10087 int error_count, depth;
10088
10089 gfc_get_errors (NULL, &error_count);
10090
10091 /* Filter out continuing processing after an error. */
10092 if (error_count
10093 || (*code)->expr1->ts.type != BT_DERIVED
10094 || (*code)->expr2->ts.type != BT_DERIVED)
10095 return;
10096
10097 /* TODO: Handle more than one part array reference in assignments. */
10098 depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
10099 (*code)->expr1->rank ? 1 : 0);
10100 if (depth > 1)
10101 {
10102 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
10103 "done because multiple part array references would "
10104 "occur in intermediate expressions.", &(*code)->loc);
10105 return;
10106 }
10107
10108 component_assignment_level++;
10109
10110 /* Create a temporary so that functions get called only once. */
10111 if ((*code)->expr2->expr_type != EXPR_VARIABLE
10112 && (*code)->expr2->expr_type != EXPR_CONSTANT)
10113 {
10114 gfc_expr *tmp_expr;
10115
10116 /* Assign the rhs to the temporary. */
10117 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
10118 this_code = build_assignment (EXEC_ASSIGN,
10119 tmp_expr, (*code)->expr2,
10120 NULL, NULL, (*code)->loc);
10121 /* Add the code and substitute the rhs expression. */
10122 add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
10123 gfc_free_expr ((*code)->expr2);
10124 (*code)->expr2 = tmp_expr;
10125 }
10126
10127 /* Do the intrinsic assignment. This is not needed if the lhs is one
10128 of the temporaries generated here, since the intrinsic assignment
10129 to the final result already does this. */
10130 if ((*code)->expr1->symtree->n.sym->name[2] != '@')
10131 {
10132 this_code = build_assignment (EXEC_ASSIGN,
10133 (*code)->expr1, (*code)->expr2,
10134 NULL, NULL, (*code)->loc);
10135 add_code_to_chain (&this_code, &head, &tail);
10136 }
10137
10138 comp1 = (*code)->expr1->ts.u.derived->components;
10139 comp2 = (*code)->expr2->ts.u.derived->components;
10140
10141 t1 = NULL;
10142 for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
10143 {
10144 bool inout = false;
10145
10146 /* The intrinsic assignment does the right thing for pointers
10147 of all kinds and allocatable components. */
10148 if (!gfc_bt_struct (comp1->ts.type)
10149 || comp1->attr.pointer
10150 || comp1->attr.allocatable
10151 || comp1->attr.proc_pointer_comp
10152 || comp1->attr.class_pointer
10153 || comp1->attr.proc_pointer)
10154 continue;
10155
10156 /* Make an assigment for this component. */
10157 this_code = build_assignment (EXEC_ASSIGN,
10158 (*code)->expr1, (*code)->expr2,
10159 comp1, comp2, (*code)->loc);
10160
10161 /* Convert the assignment if there is a defined assignment for
10162 this type. Otherwise, using the call from gfc_resolve_code,
10163 recurse into its components. */
10164 gfc_resolve_code (this_code, ns);
10165
10166 if (this_code->op == EXEC_ASSIGN_CALL)
10167 {
10168 gfc_formal_arglist *dummy_args;
10169 gfc_symbol *rsym;
10170 /* Check that there is a typebound defined assignment. If not,
10171 then this must be a module defined assignment. We cannot
10172 use the defined_assign_comp attribute here because it must
10173 be this derived type that has the defined assignment and not
10174 a parent type. */
10175 if (!(comp1->ts.u.derived->f2k_derived
10176 && comp1->ts.u.derived->f2k_derived
10177 ->tb_op[INTRINSIC_ASSIGN]))
10178 {
10179 gfc_free_statements (this_code);
10180 this_code = NULL;
10181 continue;
10182 }
10183
10184 /* If the first argument of the subroutine has intent INOUT
10185 a temporary must be generated and used instead. */
10186 rsym = this_code->resolved_sym;
10187 dummy_args = gfc_sym_get_dummy_args (rsym);
10188 if (dummy_args
10189 && dummy_args->sym->attr.intent == INTENT_INOUT)
10190 {
10191 gfc_code *temp_code;
10192 inout = true;
10193
10194 /* Build the temporary required for the assignment and put
10195 it at the head of the generated code. */
10196 if (!t1)
10197 {
10198 t1 = get_temp_from_expr ((*code)->expr1, ns);
10199 temp_code = build_assignment (EXEC_ASSIGN,
10200 t1, (*code)->expr1,
10201 NULL, NULL, (*code)->loc);
10202
10203 /* For allocatable LHS, check whether it is allocated. Note
10204 that allocatable components with defined assignment are
10205 not yet support. See PR 57696. */
10206 if ((*code)->expr1->symtree->n.sym->attr.allocatable)
10207 {
10208 gfc_code *block;
10209 gfc_expr *e =
10210 gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
10211 block = gfc_get_code (EXEC_IF);
10212 block->block = gfc_get_code (EXEC_IF);
10213 block->block->expr1
10214 = gfc_build_intrinsic_call (ns,
10215 GFC_ISYM_ALLOCATED, "allocated",
10216 (*code)->loc, 1, e);
10217 block->block->next = temp_code;
10218 temp_code = block;
10219 }
10220 add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
10221 }
10222
10223 /* Replace the first actual arg with the component of the
10224 temporary. */
10225 gfc_free_expr (this_code->ext.actual->expr);
10226 this_code->ext.actual->expr = gfc_copy_expr (t1);
10227 add_comp_ref (this_code->ext.actual->expr, comp1);
10228
10229 /* If the LHS variable is allocatable and wasn't allocated and
10230 the temporary is allocatable, pointer assign the address of
10231 the freshly allocated LHS to the temporary. */
10232 if ((*code)->expr1->symtree->n.sym->attr.allocatable
10233 && gfc_expr_attr ((*code)->expr1).allocatable)
10234 {
10235 gfc_code *block;
10236 gfc_expr *cond;
10237
10238 cond = gfc_get_expr ();
10239 cond->ts.type = BT_LOGICAL;
10240 cond->ts.kind = gfc_default_logical_kind;
10241 cond->expr_type = EXPR_OP;
10242 cond->where = (*code)->loc;
10243 cond->value.op.op = INTRINSIC_NOT;
10244 cond->value.op.op1 = gfc_build_intrinsic_call (ns,
10245 GFC_ISYM_ALLOCATED, "allocated",
10246 (*code)->loc, 1, gfc_copy_expr (t1));
10247 block = gfc_get_code (EXEC_IF);
10248 block->block = gfc_get_code (EXEC_IF);
10249 block->block->expr1 = cond;
10250 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
10251 t1, (*code)->expr1,
10252 NULL, NULL, (*code)->loc);
10253 add_code_to_chain (&block, &head, &tail);
10254 }
10255 }
10256 }
10257 else if (this_code->op == EXEC_ASSIGN && !this_code->next)
10258 {
10259 /* Don't add intrinsic assignments since they are already
10260 effected by the intrinsic assignment of the structure. */
10261 gfc_free_statements (this_code);
10262 this_code = NULL;
10263 continue;
10264 }
10265
10266 add_code_to_chain (&this_code, &head, &tail);
10267
10268 if (t1 && inout)
10269 {
10270 /* Transfer the value to the final result. */
10271 this_code = build_assignment (EXEC_ASSIGN,
10272 (*code)->expr1, t1,
10273 comp1, comp2, (*code)->loc);
10274 add_code_to_chain (&this_code, &head, &tail);
10275 }
10276 }
10277
10278 /* Put the temporary assignments at the top of the generated code. */
10279 if (tmp_head && component_assignment_level == 1)
10280 {
10281 gfc_append_code (tmp_head, head);
10282 head = tmp_head;
10283 tmp_head = tmp_tail = NULL;
10284 }
10285
10286 // If we did a pointer assignment - thus, we need to ensure that the LHS is
10287 // not accidentally deallocated. Hence, nullify t1.
10288 if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
10289 && gfc_expr_attr ((*code)->expr1).allocatable)
10290 {
10291 gfc_code *block;
10292 gfc_expr *cond;
10293 gfc_expr *e;
10294
10295 e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
10296 cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
10297 (*code)->loc, 2, gfc_copy_expr (t1), e);
10298 block = gfc_get_code (EXEC_IF);
10299 block->block = gfc_get_code (EXEC_IF);
10300 block->block->expr1 = cond;
10301 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
10302 t1, gfc_get_null_expr (&(*code)->loc),
10303 NULL, NULL, (*code)->loc);
10304 gfc_append_code (tail, block);
10305 tail = block;
10306 }
10307
10308 /* Now attach the remaining code chain to the input code. Step on
10309 to the end of the new code since resolution is complete. */
10310 gcc_assert ((*code)->op == EXEC_ASSIGN);
10311 tail->next = (*code)->next;
10312 /* Overwrite 'code' because this would place the intrinsic assignment
10313 before the temporary for the lhs is created. */
10314 gfc_free_expr ((*code)->expr1);
10315 gfc_free_expr ((*code)->expr2);
10316 **code = *head;
10317 if (head != tail)
10318 free (head);
10319 *code = tail;
10320
10321 component_assignment_level--;
10322 }
10323
10324
10325 /* F2008: Pointer function assignments are of the form:
10326 ptr_fcn (args) = expr
10327 This function breaks these assignments into two statements:
10328 temporary_pointer => ptr_fcn(args)
10329 temporary_pointer = expr */
10330
10331 static bool
resolve_ptr_fcn_assign(gfc_code ** code,gfc_namespace * ns)10332 resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
10333 {
10334 gfc_expr *tmp_ptr_expr;
10335 gfc_code *this_code;
10336 gfc_component *comp;
10337 gfc_symbol *s;
10338
10339 if ((*code)->expr1->expr_type != EXPR_FUNCTION)
10340 return false;
10341
10342 /* Even if standard does not support this feature, continue to build
10343 the two statements to avoid upsetting frontend_passes.c. */
10344 gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
10345 "%L", &(*code)->loc);
10346
10347 comp = gfc_get_proc_ptr_comp ((*code)->expr1);
10348
10349 if (comp)
10350 s = comp->ts.interface;
10351 else
10352 s = (*code)->expr1->symtree->n.sym;
10353
10354 if (s == NULL || !s->result->attr.pointer)
10355 {
10356 gfc_error ("The function result on the lhs of the assignment at "
10357 "%L must have the pointer attribute.",
10358 &(*code)->expr1->where);
10359 (*code)->op = EXEC_NOP;
10360 return false;
10361 }
10362
10363 tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns);
10364
10365 /* get_temp_from_expression is set up for ordinary assignments. To that
10366 end, where array bounds are not known, arrays are made allocatable.
10367 Change the temporary to a pointer here. */
10368 tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
10369 tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
10370 tmp_ptr_expr->where = (*code)->loc;
10371
10372 this_code = build_assignment (EXEC_ASSIGN,
10373 tmp_ptr_expr, (*code)->expr2,
10374 NULL, NULL, (*code)->loc);
10375 this_code->next = (*code)->next;
10376 (*code)->next = this_code;
10377 (*code)->op = EXEC_POINTER_ASSIGN;
10378 (*code)->expr2 = (*code)->expr1;
10379 (*code)->expr1 = tmp_ptr_expr;
10380
10381 return true;
10382 }
10383
10384
10385 /* Deferred character length assignments from an operator expression
10386 require a temporary because the character length of the lhs can
10387 change in the course of the assignment. */
10388
10389 static bool
deferred_op_assign(gfc_code ** code,gfc_namespace * ns)10390 deferred_op_assign (gfc_code **code, gfc_namespace *ns)
10391 {
10392 gfc_expr *tmp_expr;
10393 gfc_code *this_code;
10394
10395 if (!((*code)->expr1->ts.type == BT_CHARACTER
10396 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
10397 && (*code)->expr2->expr_type == EXPR_OP))
10398 return false;
10399
10400 if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
10401 return false;
10402
10403 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
10404 tmp_expr->where = (*code)->loc;
10405
10406 /* A new charlen is required to ensure that the variable string
10407 length is different to that of the original lhs. */
10408 tmp_expr->ts.u.cl = gfc_get_charlen();
10409 tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
10410 tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
10411 (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
10412
10413 tmp_expr->symtree->n.sym->ts.deferred = 1;
10414
10415 this_code = build_assignment (EXEC_ASSIGN,
10416 (*code)->expr1,
10417 gfc_copy_expr (tmp_expr),
10418 NULL, NULL, (*code)->loc);
10419
10420 (*code)->expr1 = tmp_expr;
10421
10422 this_code->next = (*code)->next;
10423 (*code)->next = this_code;
10424
10425 return true;
10426 }
10427
10428
10429 /* Given a block of code, recursively resolve everything pointed to by this
10430 code block. */
10431
10432 void
gfc_resolve_code(gfc_code * code,gfc_namespace * ns)10433 gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
10434 {
10435 int omp_workshare_save;
10436 int forall_save, do_concurrent_save;
10437 code_stack frame;
10438 bool t;
10439
10440 frame.prev = cs_base;
10441 frame.head = code;
10442 cs_base = &frame;
10443
10444 find_reachable_labels (code);
10445
10446 for (; code; code = code->next)
10447 {
10448 frame.current = code;
10449 forall_save = forall_flag;
10450 do_concurrent_save = gfc_do_concurrent_flag;
10451
10452 if (code->op == EXEC_FORALL)
10453 {
10454 forall_flag = 1;
10455 gfc_resolve_forall (code, ns, forall_save);
10456 forall_flag = 2;
10457 }
10458 else if (code->block)
10459 {
10460 omp_workshare_save = -1;
10461 switch (code->op)
10462 {
10463 case EXEC_OACC_PARALLEL_LOOP:
10464 case EXEC_OACC_PARALLEL:
10465 case EXEC_OACC_KERNELS_LOOP:
10466 case EXEC_OACC_KERNELS:
10467 case EXEC_OACC_DATA:
10468 case EXEC_OACC_HOST_DATA:
10469 case EXEC_OACC_LOOP:
10470 gfc_resolve_oacc_blocks (code, ns);
10471 break;
10472 case EXEC_OMP_PARALLEL_WORKSHARE:
10473 omp_workshare_save = omp_workshare_flag;
10474 omp_workshare_flag = 1;
10475 gfc_resolve_omp_parallel_blocks (code, ns);
10476 break;
10477 case EXEC_OMP_PARALLEL:
10478 case EXEC_OMP_PARALLEL_DO:
10479 case EXEC_OMP_PARALLEL_DO_SIMD:
10480 case EXEC_OMP_PARALLEL_SECTIONS:
10481 case EXEC_OMP_TARGET_TEAMS:
10482 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10483 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10484 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10485 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10486 case EXEC_OMP_TASK:
10487 case EXEC_OMP_TEAMS:
10488 case EXEC_OMP_TEAMS_DISTRIBUTE:
10489 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10490 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10491 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10492 omp_workshare_save = omp_workshare_flag;
10493 omp_workshare_flag = 0;
10494 gfc_resolve_omp_parallel_blocks (code, ns);
10495 break;
10496 case EXEC_OMP_DISTRIBUTE:
10497 case EXEC_OMP_DISTRIBUTE_SIMD:
10498 case EXEC_OMP_DO:
10499 case EXEC_OMP_DO_SIMD:
10500 case EXEC_OMP_SIMD:
10501 gfc_resolve_omp_do_blocks (code, ns);
10502 break;
10503 case EXEC_SELECT_TYPE:
10504 /* Blocks are handled in resolve_select_type because we have
10505 to transform the SELECT TYPE into ASSOCIATE first. */
10506 break;
10507 case EXEC_DO_CONCURRENT:
10508 gfc_do_concurrent_flag = 1;
10509 gfc_resolve_blocks (code->block, ns);
10510 gfc_do_concurrent_flag = 2;
10511 break;
10512 case EXEC_OMP_WORKSHARE:
10513 omp_workshare_save = omp_workshare_flag;
10514 omp_workshare_flag = 1;
10515 /* FALL THROUGH */
10516 default:
10517 gfc_resolve_blocks (code->block, ns);
10518 break;
10519 }
10520
10521 if (omp_workshare_save != -1)
10522 omp_workshare_flag = omp_workshare_save;
10523 }
10524 start:
10525 t = true;
10526 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
10527 t = gfc_resolve_expr (code->expr1);
10528 forall_flag = forall_save;
10529 gfc_do_concurrent_flag = do_concurrent_save;
10530
10531 if (!gfc_resolve_expr (code->expr2))
10532 t = false;
10533
10534 if (code->op == EXEC_ALLOCATE
10535 && !gfc_resolve_expr (code->expr3))
10536 t = false;
10537
10538 switch (code->op)
10539 {
10540 case EXEC_NOP:
10541 case EXEC_END_BLOCK:
10542 case EXEC_END_NESTED_BLOCK:
10543 case EXEC_CYCLE:
10544 case EXEC_PAUSE:
10545 case EXEC_STOP:
10546 case EXEC_ERROR_STOP:
10547 case EXEC_EXIT:
10548 case EXEC_CONTINUE:
10549 case EXEC_DT_END:
10550 case EXEC_ASSIGN_CALL:
10551 break;
10552
10553 case EXEC_CRITICAL:
10554 resolve_critical (code);
10555 break;
10556
10557 case EXEC_SYNC_ALL:
10558 case EXEC_SYNC_IMAGES:
10559 case EXEC_SYNC_MEMORY:
10560 resolve_sync (code);
10561 break;
10562
10563 case EXEC_LOCK:
10564 case EXEC_UNLOCK:
10565 case EXEC_EVENT_POST:
10566 case EXEC_EVENT_WAIT:
10567 resolve_lock_unlock_event (code);
10568 break;
10569
10570 case EXEC_ENTRY:
10571 /* Keep track of which entry we are up to. */
10572 current_entry_id = code->ext.entry->id;
10573 break;
10574
10575 case EXEC_WHERE:
10576 resolve_where (code, NULL);
10577 break;
10578
10579 case EXEC_GOTO:
10580 if (code->expr1 != NULL)
10581 {
10582 if (code->expr1->ts.type != BT_INTEGER)
10583 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10584 "INTEGER variable", &code->expr1->where);
10585 else if (code->expr1->symtree->n.sym->attr.assign != 1)
10586 gfc_error ("Variable %qs has not been assigned a target "
10587 "label at %L", code->expr1->symtree->n.sym->name,
10588 &code->expr1->where);
10589 }
10590 else
10591 resolve_branch (code->label1, code);
10592 break;
10593
10594 case EXEC_RETURN:
10595 if (code->expr1 != NULL
10596 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
10597 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10598 "INTEGER return specifier", &code->expr1->where);
10599 break;
10600
10601 case EXEC_INIT_ASSIGN:
10602 case EXEC_END_PROCEDURE:
10603 break;
10604
10605 case EXEC_ASSIGN:
10606 if (!t)
10607 break;
10608
10609 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10610 the LHS. */
10611 if (code->expr1->expr_type == EXPR_FUNCTION
10612 && code->expr1->value.function.isym
10613 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
10614 remove_caf_get_intrinsic (code->expr1);
10615
10616 /* If this is a pointer function in an lvalue variable context,
10617 the new code will have to be resolved afresh. This is also the
10618 case with an error, where the code is transformed into NOP to
10619 prevent ICEs downstream. */
10620 if (resolve_ptr_fcn_assign (&code, ns)
10621 || code->op == EXEC_NOP)
10622 goto start;
10623
10624 if (!gfc_check_vardef_context (code->expr1, false, false, false,
10625 _("assignment")))
10626 break;
10627
10628 if (resolve_ordinary_assign (code, ns))
10629 {
10630 if (code->op == EXEC_COMPCALL)
10631 goto compcall;
10632 else
10633 goto call;
10634 }
10635
10636 /* Check for dependencies in deferred character length array
10637 assignments and generate a temporary, if necessary. */
10638 if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
10639 break;
10640
10641 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10642 if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
10643 && code->expr1->ts.u.derived
10644 && code->expr1->ts.u.derived->attr.defined_assign_comp)
10645 generate_component_assignments (&code, ns);
10646
10647 break;
10648
10649 case EXEC_LABEL_ASSIGN:
10650 if (code->label1->defined == ST_LABEL_UNKNOWN)
10651 gfc_error ("Label %d referenced at %L is never defined",
10652 code->label1->value, &code->label1->where);
10653 if (t
10654 && (code->expr1->expr_type != EXPR_VARIABLE
10655 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
10656 || code->expr1->symtree->n.sym->ts.kind
10657 != gfc_default_integer_kind
10658 || code->expr1->symtree->n.sym->as != NULL))
10659 gfc_error ("ASSIGN statement at %L requires a scalar "
10660 "default INTEGER variable", &code->expr1->where);
10661 break;
10662
10663 case EXEC_POINTER_ASSIGN:
10664 {
10665 gfc_expr* e;
10666
10667 if (!t)
10668 break;
10669
10670 /* This is both a variable definition and pointer assignment
10671 context, so check both of them. For rank remapping, a final
10672 array ref may be present on the LHS and fool gfc_expr_attr
10673 used in gfc_check_vardef_context. Remove it. */
10674 e = remove_last_array_ref (code->expr1);
10675 t = gfc_check_vardef_context (e, true, false, false,
10676 _("pointer assignment"));
10677 if (t)
10678 t = gfc_check_vardef_context (e, false, false, false,
10679 _("pointer assignment"));
10680 gfc_free_expr (e);
10681 if (!t)
10682 break;
10683
10684 gfc_check_pointer_assign (code->expr1, code->expr2);
10685 break;
10686 }
10687
10688 case EXEC_ARITHMETIC_IF:
10689 {
10690 gfc_expr *e = code->expr1;
10691
10692 gfc_resolve_expr (e);
10693 if (e->expr_type == EXPR_NULL)
10694 gfc_error ("Invalid NULL at %L", &e->where);
10695
10696 if (t && (e->rank > 0
10697 || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
10698 gfc_error ("Arithmetic IF statement at %L requires a scalar "
10699 "REAL or INTEGER expression", &e->where);
10700
10701 resolve_branch (code->label1, code);
10702 resolve_branch (code->label2, code);
10703 resolve_branch (code->label3, code);
10704 }
10705 break;
10706
10707 case EXEC_IF:
10708 if (t && code->expr1 != NULL
10709 && (code->expr1->ts.type != BT_LOGICAL
10710 || code->expr1->rank != 0))
10711 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10712 &code->expr1->where);
10713 break;
10714
10715 case EXEC_CALL:
10716 call:
10717 resolve_call (code);
10718 break;
10719
10720 case EXEC_COMPCALL:
10721 compcall:
10722 resolve_typebound_subroutine (code);
10723 break;
10724
10725 case EXEC_CALL_PPC:
10726 resolve_ppc_call (code);
10727 break;
10728
10729 case EXEC_SELECT:
10730 /* Select is complicated. Also, a SELECT construct could be
10731 a transformed computed GOTO. */
10732 resolve_select (code, false);
10733 break;
10734
10735 case EXEC_SELECT_TYPE:
10736 resolve_select_type (code, ns);
10737 break;
10738
10739 case EXEC_BLOCK:
10740 resolve_block_construct (code);
10741 break;
10742
10743 case EXEC_DO:
10744 if (code->ext.iterator != NULL)
10745 {
10746 gfc_iterator *iter = code->ext.iterator;
10747 if (gfc_resolve_iterator (iter, true, false))
10748 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
10749 }
10750 break;
10751
10752 case EXEC_DO_WHILE:
10753 if (code->expr1 == NULL)
10754 gfc_internal_error ("gfc_resolve_code(): No expression on "
10755 "DO WHILE");
10756 if (t
10757 && (code->expr1->rank != 0
10758 || code->expr1->ts.type != BT_LOGICAL))
10759 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10760 "a scalar LOGICAL expression", &code->expr1->where);
10761 break;
10762
10763 case EXEC_ALLOCATE:
10764 if (t)
10765 resolve_allocate_deallocate (code, "ALLOCATE");
10766
10767 break;
10768
10769 case EXEC_DEALLOCATE:
10770 if (t)
10771 resolve_allocate_deallocate (code, "DEALLOCATE");
10772
10773 break;
10774
10775 case EXEC_OPEN:
10776 if (!gfc_resolve_open (code->ext.open))
10777 break;
10778
10779 resolve_branch (code->ext.open->err, code);
10780 break;
10781
10782 case EXEC_CLOSE:
10783 if (!gfc_resolve_close (code->ext.close))
10784 break;
10785
10786 resolve_branch (code->ext.close->err, code);
10787 break;
10788
10789 case EXEC_BACKSPACE:
10790 case EXEC_ENDFILE:
10791 case EXEC_REWIND:
10792 case EXEC_FLUSH:
10793 if (!gfc_resolve_filepos (code->ext.filepos))
10794 break;
10795
10796 resolve_branch (code->ext.filepos->err, code);
10797 break;
10798
10799 case EXEC_INQUIRE:
10800 if (!gfc_resolve_inquire (code->ext.inquire))
10801 break;
10802
10803 resolve_branch (code->ext.inquire->err, code);
10804 break;
10805
10806 case EXEC_IOLENGTH:
10807 gcc_assert (code->ext.inquire != NULL);
10808 if (!gfc_resolve_inquire (code->ext.inquire))
10809 break;
10810
10811 resolve_branch (code->ext.inquire->err, code);
10812 break;
10813
10814 case EXEC_WAIT:
10815 if (!gfc_resolve_wait (code->ext.wait))
10816 break;
10817
10818 resolve_branch (code->ext.wait->err, code);
10819 resolve_branch (code->ext.wait->end, code);
10820 resolve_branch (code->ext.wait->eor, code);
10821 break;
10822
10823 case EXEC_READ:
10824 case EXEC_WRITE:
10825 if (!gfc_resolve_dt (code->ext.dt, &code->loc))
10826 break;
10827
10828 resolve_branch (code->ext.dt->err, code);
10829 resolve_branch (code->ext.dt->end, code);
10830 resolve_branch (code->ext.dt->eor, code);
10831 break;
10832
10833 case EXEC_TRANSFER:
10834 resolve_transfer (code);
10835 break;
10836
10837 case EXEC_DO_CONCURRENT:
10838 case EXEC_FORALL:
10839 resolve_forall_iterators (code->ext.forall_iterator);
10840
10841 if (code->expr1 != NULL
10842 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
10843 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10844 "expression", &code->expr1->where);
10845 break;
10846
10847 case EXEC_OACC_PARALLEL_LOOP:
10848 case EXEC_OACC_PARALLEL:
10849 case EXEC_OACC_KERNELS_LOOP:
10850 case EXEC_OACC_KERNELS:
10851 case EXEC_OACC_DATA:
10852 case EXEC_OACC_HOST_DATA:
10853 case EXEC_OACC_LOOP:
10854 case EXEC_OACC_UPDATE:
10855 case EXEC_OACC_WAIT:
10856 case EXEC_OACC_CACHE:
10857 case EXEC_OACC_ENTER_DATA:
10858 case EXEC_OACC_EXIT_DATA:
10859 case EXEC_OACC_ATOMIC:
10860 case EXEC_OACC_DECLARE:
10861 gfc_resolve_oacc_directive (code, ns);
10862 break;
10863
10864 case EXEC_OMP_ATOMIC:
10865 case EXEC_OMP_BARRIER:
10866 case EXEC_OMP_CANCEL:
10867 case EXEC_OMP_CANCELLATION_POINT:
10868 case EXEC_OMP_CRITICAL:
10869 case EXEC_OMP_FLUSH:
10870 case EXEC_OMP_DISTRIBUTE:
10871 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10872 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10873 case EXEC_OMP_DISTRIBUTE_SIMD:
10874 case EXEC_OMP_DO:
10875 case EXEC_OMP_DO_SIMD:
10876 case EXEC_OMP_MASTER:
10877 case EXEC_OMP_ORDERED:
10878 case EXEC_OMP_SECTIONS:
10879 case EXEC_OMP_SIMD:
10880 case EXEC_OMP_SINGLE:
10881 case EXEC_OMP_TARGET:
10882 case EXEC_OMP_TARGET_DATA:
10883 case EXEC_OMP_TARGET_TEAMS:
10884 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10885 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10886 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10887 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10888 case EXEC_OMP_TARGET_UPDATE:
10889 case EXEC_OMP_TASK:
10890 case EXEC_OMP_TASKGROUP:
10891 case EXEC_OMP_TASKWAIT:
10892 case EXEC_OMP_TASKYIELD:
10893 case EXEC_OMP_TEAMS:
10894 case EXEC_OMP_TEAMS_DISTRIBUTE:
10895 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10896 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10897 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10898 case EXEC_OMP_WORKSHARE:
10899 gfc_resolve_omp_directive (code, ns);
10900 break;
10901
10902 case EXEC_OMP_PARALLEL:
10903 case EXEC_OMP_PARALLEL_DO:
10904 case EXEC_OMP_PARALLEL_DO_SIMD:
10905 case EXEC_OMP_PARALLEL_SECTIONS:
10906 case EXEC_OMP_PARALLEL_WORKSHARE:
10907 omp_workshare_save = omp_workshare_flag;
10908 omp_workshare_flag = 0;
10909 gfc_resolve_omp_directive (code, ns);
10910 omp_workshare_flag = omp_workshare_save;
10911 break;
10912
10913 default:
10914 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10915 }
10916 }
10917
10918 cs_base = frame.prev;
10919 }
10920
10921
10922 /* Resolve initial values and make sure they are compatible with
10923 the variable. */
10924
10925 static void
resolve_values(gfc_symbol * sym)10926 resolve_values (gfc_symbol *sym)
10927 {
10928 bool t;
10929
10930 if (sym->value == NULL)
10931 return;
10932
10933 if (sym->value->expr_type == EXPR_STRUCTURE)
10934 t= resolve_structure_cons (sym->value, 1);
10935 else
10936 t = gfc_resolve_expr (sym->value);
10937
10938 if (!t)
10939 return;
10940
10941 gfc_check_assign_symbol (sym, NULL, sym->value);
10942 }
10943
10944
10945 /* Verify any BIND(C) derived types in the namespace so we can report errors
10946 for them once, rather than for each variable declared of that type. */
10947
10948 static void
resolve_bind_c_derived_types(gfc_symbol * derived_sym)10949 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
10950 {
10951 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
10952 && derived_sym->attr.is_bind_c == 1)
10953 verify_bind_c_derived_type (derived_sym);
10954
10955 return;
10956 }
10957
10958
10959 /* Verify that any binding labels used in a given namespace do not collide
10960 with the names or binding labels of any global symbols. Multiple INTERFACE
10961 for the same procedure are permitted. */
10962
10963 static void
gfc_verify_binding_labels(gfc_symbol * sym)10964 gfc_verify_binding_labels (gfc_symbol *sym)
10965 {
10966 gfc_gsymbol *gsym;
10967 const char *module;
10968
10969 if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
10970 || sym->attr.flavor == FL_DERIVED || !sym->binding_label)
10971 return;
10972
10973 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
10974
10975 if (sym->module)
10976 module = sym->module;
10977 else if (sym->ns && sym->ns->proc_name
10978 && sym->ns->proc_name->attr.flavor == FL_MODULE)
10979 module = sym->ns->proc_name->name;
10980 else if (sym->ns && sym->ns->parent
10981 && sym->ns && sym->ns->parent->proc_name
10982 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
10983 module = sym->ns->parent->proc_name->name;
10984 else
10985 module = NULL;
10986
10987 if (!gsym
10988 || (!gsym->defined
10989 && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
10990 {
10991 if (!gsym)
10992 gsym = gfc_get_gsymbol (sym->binding_label);
10993 gsym->where = sym->declared_at;
10994 gsym->sym_name = sym->name;
10995 gsym->binding_label = sym->binding_label;
10996 gsym->ns = sym->ns;
10997 gsym->mod_name = module;
10998 if (sym->attr.function)
10999 gsym->type = GSYM_FUNCTION;
11000 else if (sym->attr.subroutine)
11001 gsym->type = GSYM_SUBROUTINE;
11002 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
11003 gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
11004 return;
11005 }
11006
11007 if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
11008 {
11009 gfc_error ("Variable %s with binding label %s at %L uses the same global "
11010 "identifier as entity at %L", sym->name,
11011 sym->binding_label, &sym->declared_at, &gsym->where);
11012 /* Clear the binding label to prevent checking multiple times. */
11013 sym->binding_label = NULL;
11014
11015 }
11016 else if (sym->attr.flavor == FL_VARIABLE && module
11017 && (strcmp (module, gsym->mod_name) != 0
11018 || strcmp (sym->name, gsym->sym_name) != 0))
11019 {
11020 /* This can only happen if the variable is defined in a module - if it
11021 isn't the same module, reject it. */
11022 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
11023 "the same global identifier as entity at %L from module %s",
11024 sym->name, module, sym->binding_label,
11025 &sym->declared_at, &gsym->where, gsym->mod_name);
11026 sym->binding_label = NULL;
11027 }
11028 else if ((sym->attr.function || sym->attr.subroutine)
11029 && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
11030 || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
11031 && sym != gsym->ns->proc_name
11032 && (module != gsym->mod_name
11033 || strcmp (gsym->sym_name, sym->name) != 0
11034 || (module && strcmp (module, gsym->mod_name) != 0)))
11035 {
11036 /* Print an error if the procedure is defined multiple times; we have to
11037 exclude references to the same procedure via module association or
11038 multiple checks for the same procedure. */
11039 gfc_error ("Procedure %s with binding label %s at %L uses the same "
11040 "global identifier as entity at %L", sym->name,
11041 sym->binding_label, &sym->declared_at, &gsym->where);
11042 sym->binding_label = NULL;
11043 }
11044 }
11045
11046
11047 /* Resolve an index expression. */
11048
11049 static bool
resolve_index_expr(gfc_expr * e)11050 resolve_index_expr (gfc_expr *e)
11051 {
11052 if (!gfc_resolve_expr (e))
11053 return false;
11054
11055 if (!gfc_simplify_expr (e, 0))
11056 return false;
11057
11058 if (!gfc_specification_expr (e))
11059 return false;
11060
11061 return true;
11062 }
11063
11064
11065 /* Resolve a charlen structure. */
11066
11067 static bool
resolve_charlen(gfc_charlen * cl)11068 resolve_charlen (gfc_charlen *cl)
11069 {
11070 int i, k;
11071 bool saved_specification_expr;
11072
11073 if (cl->resolved)
11074 return true;
11075
11076 cl->resolved = 1;
11077 saved_specification_expr = specification_expr;
11078 specification_expr = true;
11079
11080 if (cl->length_from_typespec)
11081 {
11082 if (!gfc_resolve_expr (cl->length))
11083 {
11084 specification_expr = saved_specification_expr;
11085 return false;
11086 }
11087
11088 if (!gfc_simplify_expr (cl->length, 0))
11089 {
11090 specification_expr = saved_specification_expr;
11091 return false;
11092 }
11093
11094 /* cl->length has been resolved. It should have an integer type. */
11095 if (cl->length && cl->length->ts.type != BT_INTEGER)
11096 {
11097 gfc_error ("Scalar INTEGER expression expected at %L",
11098 &cl->length->where);
11099 return false;
11100 }
11101 }
11102 else
11103 {
11104 if (!resolve_index_expr (cl->length))
11105 {
11106 specification_expr = saved_specification_expr;
11107 return false;
11108 }
11109 }
11110
11111 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
11112 a negative value, the length of character entities declared is zero. */
11113 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
11114 gfc_replace_expr (cl->length,
11115 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
11116
11117 /* Check that the character length is not too large. */
11118 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
11119 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
11120 && cl->length->ts.type == BT_INTEGER
11121 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
11122 {
11123 gfc_error ("String length at %L is too large", &cl->length->where);
11124 specification_expr = saved_specification_expr;
11125 return false;
11126 }
11127
11128 specification_expr = saved_specification_expr;
11129 return true;
11130 }
11131
11132
11133 /* Test for non-constant shape arrays. */
11134
11135 static bool
is_non_constant_shape_array(gfc_symbol * sym)11136 is_non_constant_shape_array (gfc_symbol *sym)
11137 {
11138 gfc_expr *e;
11139 int i;
11140 bool not_constant;
11141
11142 not_constant = false;
11143 if (sym->as != NULL)
11144 {
11145 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
11146 has not been simplified; parameter array references. Do the
11147 simplification now. */
11148 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
11149 {
11150 e = sym->as->lower[i];
11151 if (e && (!resolve_index_expr(e)
11152 || !gfc_is_constant_expr (e)))
11153 not_constant = true;
11154 e = sym->as->upper[i];
11155 if (e && (!resolve_index_expr(e)
11156 || !gfc_is_constant_expr (e)))
11157 not_constant = true;
11158 }
11159 }
11160 return not_constant;
11161 }
11162
11163 /* Given a symbol and an initialization expression, add code to initialize
11164 the symbol to the function entry. */
11165 static void
build_init_assign(gfc_symbol * sym,gfc_expr * init)11166 build_init_assign (gfc_symbol *sym, gfc_expr *init)
11167 {
11168 gfc_expr *lval;
11169 gfc_code *init_st;
11170 gfc_namespace *ns = sym->ns;
11171
11172 /* Search for the function namespace if this is a contained
11173 function without an explicit result. */
11174 if (sym->attr.function && sym == sym->result
11175 && sym->name != sym->ns->proc_name->name)
11176 {
11177 ns = ns->contained;
11178 for (;ns; ns = ns->sibling)
11179 if (strcmp (ns->proc_name->name, sym->name) == 0)
11180 break;
11181 }
11182
11183 if (ns == NULL)
11184 {
11185 gfc_free_expr (init);
11186 return;
11187 }
11188
11189 /* Build an l-value expression for the result. */
11190 lval = gfc_lval_expr_from_sym (sym);
11191
11192 /* Add the code at scope entry. */
11193 init_st = gfc_get_code (EXEC_INIT_ASSIGN);
11194 init_st->next = ns->code;
11195 ns->code = init_st;
11196
11197 /* Assign the default initializer to the l-value. */
11198 init_st->loc = sym->declared_at;
11199 init_st->expr1 = lval;
11200 init_st->expr2 = init;
11201 }
11202
11203 /* Assign the default initializer to a derived type variable or result. */
11204
11205 static void
apply_default_init(gfc_symbol * sym)11206 apply_default_init (gfc_symbol *sym)
11207 {
11208 gfc_expr *init = NULL;
11209
11210 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
11211 return;
11212
11213 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
11214 init = gfc_default_initializer (&sym->ts);
11215
11216 if (init == NULL && sym->ts.type != BT_CLASS)
11217 return;
11218
11219 build_init_assign (sym, init);
11220 sym->attr.referenced = 1;
11221 }
11222
11223 /* Build an initializer for a local integer, real, complex, logical, or
11224 character variable, based on the command line flags finit-local-zero,
11225 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
11226 null if the symbol should not have a default initialization. */
11227 static gfc_expr *
build_default_init_expr(gfc_symbol * sym)11228 build_default_init_expr (gfc_symbol *sym)
11229 {
11230 int char_len;
11231 gfc_expr *init_expr;
11232 int i;
11233
11234 /* These symbols should never have a default initialization. */
11235 if (sym->attr.allocatable
11236 || sym->attr.external
11237 || sym->attr.dummy
11238 || sym->attr.pointer
11239 || sym->attr.in_equivalence
11240 || sym->attr.in_common
11241 || sym->attr.data
11242 || sym->module
11243 || sym->attr.cray_pointee
11244 || sym->attr.cray_pointer
11245 || sym->assoc)
11246 return NULL;
11247
11248 /* Now we'll try to build an initializer expression. */
11249 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
11250 &sym->declared_at);
11251
11252 /* We will only initialize integers, reals, complex, logicals, and
11253 characters, and only if the corresponding command-line flags
11254 were set. Otherwise, we free init_expr and return null. */
11255 switch (sym->ts.type)
11256 {
11257 case BT_INTEGER:
11258 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
11259 mpz_set_si (init_expr->value.integer,
11260 gfc_option.flag_init_integer_value);
11261 else
11262 {
11263 gfc_free_expr (init_expr);
11264 init_expr = NULL;
11265 }
11266 break;
11267
11268 case BT_REAL:
11269 switch (flag_init_real)
11270 {
11271 case GFC_INIT_REAL_SNAN:
11272 init_expr->is_snan = 1;
11273 /* Fall through. */
11274 case GFC_INIT_REAL_NAN:
11275 mpfr_set_nan (init_expr->value.real);
11276 break;
11277
11278 case GFC_INIT_REAL_INF:
11279 mpfr_set_inf (init_expr->value.real, 1);
11280 break;
11281
11282 case GFC_INIT_REAL_NEG_INF:
11283 mpfr_set_inf (init_expr->value.real, -1);
11284 break;
11285
11286 case GFC_INIT_REAL_ZERO:
11287 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
11288 break;
11289
11290 default:
11291 gfc_free_expr (init_expr);
11292 init_expr = NULL;
11293 break;
11294 }
11295 break;
11296
11297 case BT_COMPLEX:
11298 switch (flag_init_real)
11299 {
11300 case GFC_INIT_REAL_SNAN:
11301 init_expr->is_snan = 1;
11302 /* Fall through. */
11303 case GFC_INIT_REAL_NAN:
11304 mpfr_set_nan (mpc_realref (init_expr->value.complex));
11305 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
11306 break;
11307
11308 case GFC_INIT_REAL_INF:
11309 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
11310 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
11311 break;
11312
11313 case GFC_INIT_REAL_NEG_INF:
11314 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
11315 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
11316 break;
11317
11318 case GFC_INIT_REAL_ZERO:
11319 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
11320 break;
11321
11322 default:
11323 gfc_free_expr (init_expr);
11324 init_expr = NULL;
11325 break;
11326 }
11327 break;
11328
11329 case BT_LOGICAL:
11330 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
11331 init_expr->value.logical = 0;
11332 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
11333 init_expr->value.logical = 1;
11334 else
11335 {
11336 gfc_free_expr (init_expr);
11337 init_expr = NULL;
11338 }
11339 break;
11340
11341 case BT_CHARACTER:
11342 /* For characters, the length must be constant in order to
11343 create a default initializer. */
11344 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
11345 && sym->ts.u.cl->length
11346 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
11347 {
11348 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
11349 init_expr->value.character.length = char_len;
11350 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
11351 for (i = 0; i < char_len; i++)
11352 init_expr->value.character.string[i]
11353 = (unsigned char) gfc_option.flag_init_character_value;
11354 }
11355 else
11356 {
11357 gfc_free_expr (init_expr);
11358 init_expr = NULL;
11359 }
11360 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
11361 && sym->ts.u.cl->length && flag_max_stack_var_size != 0)
11362 {
11363 gfc_actual_arglist *arg;
11364 init_expr = gfc_get_expr ();
11365 init_expr->where = sym->declared_at;
11366 init_expr->ts = sym->ts;
11367 init_expr->expr_type = EXPR_FUNCTION;
11368 init_expr->value.function.isym =
11369 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
11370 init_expr->value.function.name = "repeat";
11371 arg = gfc_get_actual_arglist ();
11372 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
11373 NULL, 1);
11374 arg->expr->value.character.string[0]
11375 = gfc_option.flag_init_character_value;
11376 arg->next = gfc_get_actual_arglist ();
11377 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
11378 init_expr->value.function.actual = arg;
11379 }
11380 break;
11381
11382 default:
11383 gfc_free_expr (init_expr);
11384 init_expr = NULL;
11385 }
11386 return init_expr;
11387 }
11388
11389 /* Add an initialization expression to a local variable. */
11390 static void
apply_default_init_local(gfc_symbol * sym)11391 apply_default_init_local (gfc_symbol *sym)
11392 {
11393 gfc_expr *init = NULL;
11394
11395 /* The symbol should be a variable or a function return value. */
11396 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
11397 || (sym->attr.function && sym->result != sym))
11398 return;
11399
11400 /* Try to build the initializer expression. If we can't initialize
11401 this symbol, then init will be NULL. */
11402 init = build_default_init_expr (sym);
11403 if (init == NULL)
11404 return;
11405
11406 /* For saved variables, we don't want to add an initializer at function
11407 entry, so we just add a static initializer. Note that automatic variables
11408 are stack allocated even with -fno-automatic; we have also to exclude
11409 result variable, which are also nonstatic. */
11410 if (sym->attr.save || sym->ns->save_all
11411 || (flag_max_stack_var_size == 0 && !sym->attr.result
11412 && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
11413 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
11414 {
11415 /* Don't clobber an existing initializer! */
11416 gcc_assert (sym->value == NULL);
11417 sym->value = init;
11418 return;
11419 }
11420
11421 build_init_assign (sym, init);
11422 }
11423
11424
11425 /* Resolution of common features of flavors variable and procedure. */
11426
11427 static bool
resolve_fl_var_and_proc(gfc_symbol * sym,int mp_flag)11428 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
11429 {
11430 gfc_array_spec *as;
11431
11432 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
11433 as = CLASS_DATA (sym)->as;
11434 else
11435 as = sym->as;
11436
11437 /* Constraints on deferred shape variable. */
11438 if (as == NULL || as->type != AS_DEFERRED)
11439 {
11440 bool pointer, allocatable, dimension;
11441
11442 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
11443 {
11444 pointer = CLASS_DATA (sym)->attr.class_pointer;
11445 allocatable = CLASS_DATA (sym)->attr.allocatable;
11446 dimension = CLASS_DATA (sym)->attr.dimension;
11447 }
11448 else
11449 {
11450 pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
11451 allocatable = sym->attr.allocatable;
11452 dimension = sym->attr.dimension;
11453 }
11454
11455 if (allocatable)
11456 {
11457 if (dimension && as->type != AS_ASSUMED_RANK)
11458 {
11459 gfc_error ("Allocatable array %qs at %L must have a deferred "
11460 "shape or assumed rank", sym->name, &sym->declared_at);
11461 return false;
11462 }
11463 else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
11464 "%qs at %L may not be ALLOCATABLE",
11465 sym->name, &sym->declared_at))
11466 return false;
11467 }
11468
11469 if (pointer && dimension && as->type != AS_ASSUMED_RANK)
11470 {
11471 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
11472 "assumed rank", sym->name, &sym->declared_at);
11473 return false;
11474 }
11475 }
11476 else
11477 {
11478 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
11479 && sym->ts.type != BT_CLASS && !sym->assoc)
11480 {
11481 gfc_error ("Array %qs at %L cannot have a deferred shape",
11482 sym->name, &sym->declared_at);
11483 return false;
11484 }
11485 }
11486
11487 /* Constraints on polymorphic variables. */
11488 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
11489 {
11490 /* F03:C502. */
11491 if (sym->attr.class_ok
11492 && !sym->attr.select_type_temporary
11493 && !UNLIMITED_POLY (sym)
11494 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
11495 {
11496 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
11497 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
11498 &sym->declared_at);
11499 return false;
11500 }
11501
11502 /* F03:C509. */
11503 /* Assume that use associated symbols were checked in the module ns.
11504 Class-variables that are associate-names are also something special
11505 and excepted from the test. */
11506 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
11507 {
11508 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
11509 "or pointer", sym->name, &sym->declared_at);
11510 return false;
11511 }
11512 }
11513
11514 return true;
11515 }
11516
11517
11518 /* Additional checks for symbols with flavor variable and derived
11519 type. To be called from resolve_fl_variable. */
11520
11521 static bool
resolve_fl_variable_derived(gfc_symbol * sym,int no_init_flag)11522 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
11523 {
11524 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
11525
11526 /* Check to see if a derived type is blocked from being host
11527 associated by the presence of another class I symbol in the same
11528 namespace. 14.6.1.3 of the standard and the discussion on
11529 comp.lang.fortran. */
11530 if (sym->ns != sym->ts.u.derived->ns
11531 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
11532 {
11533 gfc_symbol *s;
11534 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
11535 if (s && s->attr.generic)
11536 s = gfc_find_dt_in_generic (s);
11537 if (s && !gfc_fl_struct (s->attr.flavor))
11538 {
11539 gfc_error ("The type %qs cannot be host associated at %L "
11540 "because it is blocked by an incompatible object "
11541 "of the same name declared at %L",
11542 sym->ts.u.derived->name, &sym->declared_at,
11543 &s->declared_at);
11544 return false;
11545 }
11546 }
11547
11548 /* 4th constraint in section 11.3: "If an object of a type for which
11549 component-initialization is specified (R429) appears in the
11550 specification-part of a module and does not have the ALLOCATABLE
11551 or POINTER attribute, the object shall have the SAVE attribute."
11552
11553 The check for initializers is performed with
11554 gfc_has_default_initializer because gfc_default_initializer generates
11555 a hidden default for allocatable components. */
11556 if (!(sym->value || no_init_flag) && sym->ns->proc_name
11557 && sym->ns->proc_name->attr.flavor == FL_MODULE
11558 && !sym->ns->save_all && !sym->attr.save
11559 && !sym->attr.pointer && !sym->attr.allocatable
11560 && gfc_has_default_initializer (sym->ts.u.derived)
11561 && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
11562 "%qs at %L, needed due to the default "
11563 "initialization", sym->name, &sym->declared_at))
11564 return false;
11565
11566 /* Assign default initializer. */
11567 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
11568 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
11569 {
11570 sym->value = gfc_default_initializer (&sym->ts);
11571 }
11572
11573 return true;
11574 }
11575
11576
11577 /* F2008, C402 (R401): A colon shall not be used as a type-param-value
11578 except in the declaration of an entity or component that has the POINTER
11579 or ALLOCATABLE attribute. */
11580
11581 static bool
deferred_requirements(gfc_symbol * sym)11582 deferred_requirements (gfc_symbol *sym)
11583 {
11584 if (sym->ts.deferred
11585 && !(sym->attr.pointer
11586 || sym->attr.allocatable
11587 || sym->attr.omp_udr_artificial_var))
11588 {
11589 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11590 "requires either the POINTER or ALLOCATABLE attribute",
11591 sym->name, &sym->declared_at);
11592 return false;
11593 }
11594 return true;
11595 }
11596
11597
11598 /* Resolve symbols with flavor variable. */
11599
11600 static bool
resolve_fl_variable(gfc_symbol * sym,int mp_flag)11601 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
11602 {
11603 int no_init_flag, automatic_flag;
11604 gfc_expr *e;
11605 const char *auto_save_msg;
11606 bool saved_specification_expr;
11607
11608 auto_save_msg = "Automatic object %qs at %L cannot have the "
11609 "SAVE attribute";
11610
11611 if (!resolve_fl_var_and_proc (sym, mp_flag))
11612 return false;
11613
11614 /* Set this flag to check that variables are parameters of all entries.
11615 This check is effected by the call to gfc_resolve_expr through
11616 is_non_constant_shape_array. */
11617 saved_specification_expr = specification_expr;
11618 specification_expr = true;
11619
11620 if (sym->ns->proc_name
11621 && (sym->ns->proc_name->attr.flavor == FL_MODULE
11622 || sym->ns->proc_name->attr.is_main_program)
11623 && !sym->attr.use_assoc
11624 && !sym->attr.allocatable
11625 && !sym->attr.pointer
11626 && is_non_constant_shape_array (sym))
11627 {
11628 /* The shape of a main program or module array needs to be
11629 constant. */
11630 gfc_error ("The module or main program array %qs at %L must "
11631 "have constant shape", sym->name, &sym->declared_at);
11632 specification_expr = saved_specification_expr;
11633 return false;
11634 }
11635
11636 /* Constraints on deferred type parameter. */
11637 if (!deferred_requirements (sym))
11638 return false;
11639
11640 if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
11641 {
11642 /* Make sure that character string variables with assumed length are
11643 dummy arguments. */
11644 e = sym->ts.u.cl->length;
11645 if (e == NULL && !sym->attr.dummy && !sym->attr.result
11646 && !sym->ts.deferred && !sym->attr.select_type_temporary
11647 && !sym->attr.omp_udr_artificial_var)
11648 {
11649 gfc_error ("Entity with assumed character length at %L must be a "
11650 "dummy argument or a PARAMETER", &sym->declared_at);
11651 specification_expr = saved_specification_expr;
11652 return false;
11653 }
11654
11655 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
11656 {
11657 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
11658 specification_expr = saved_specification_expr;
11659 return false;
11660 }
11661
11662 if (!gfc_is_constant_expr (e)
11663 && !(e->expr_type == EXPR_VARIABLE
11664 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
11665 {
11666 if (!sym->attr.use_assoc && sym->ns->proc_name
11667 && (sym->ns->proc_name->attr.flavor == FL_MODULE
11668 || sym->ns->proc_name->attr.is_main_program))
11669 {
11670 gfc_error ("%qs at %L must have constant character length "
11671 "in this context", sym->name, &sym->declared_at);
11672 specification_expr = saved_specification_expr;
11673 return false;
11674 }
11675 if (sym->attr.in_common)
11676 {
11677 gfc_error ("COMMON variable %qs at %L must have constant "
11678 "character length", sym->name, &sym->declared_at);
11679 specification_expr = saved_specification_expr;
11680 return false;
11681 }
11682 }
11683 }
11684
11685 if (sym->value == NULL && sym->attr.referenced)
11686 apply_default_init_local (sym); /* Try to apply a default initialization. */
11687
11688 /* Determine if the symbol may not have an initializer. */
11689 no_init_flag = automatic_flag = 0;
11690 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
11691 || sym->attr.intrinsic || sym->attr.result)
11692 no_init_flag = 1;
11693 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
11694 && is_non_constant_shape_array (sym))
11695 {
11696 no_init_flag = automatic_flag = 1;
11697
11698 /* Also, they must not have the SAVE attribute.
11699 SAVE_IMPLICIT is checked below. */
11700 if (sym->as && sym->attr.codimension)
11701 {
11702 int corank = sym->as->corank;
11703 sym->as->corank = 0;
11704 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
11705 sym->as->corank = corank;
11706 }
11707 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
11708 {
11709 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
11710 specification_expr = saved_specification_expr;
11711 return false;
11712 }
11713 }
11714
11715 /* Ensure that any initializer is simplified. */
11716 if (sym->value)
11717 gfc_simplify_expr (sym->value, 1);
11718
11719 /* Reject illegal initializers. */
11720 if (!sym->mark && sym->value)
11721 {
11722 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
11723 && CLASS_DATA (sym)->attr.allocatable))
11724 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11725 sym->name, &sym->declared_at);
11726 else if (sym->attr.external)
11727 gfc_error ("External %qs at %L cannot have an initializer",
11728 sym->name, &sym->declared_at);
11729 else if (sym->attr.dummy
11730 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
11731 gfc_error ("Dummy %qs at %L cannot have an initializer",
11732 sym->name, &sym->declared_at);
11733 else if (sym->attr.intrinsic)
11734 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11735 sym->name, &sym->declared_at);
11736 else if (sym->attr.result)
11737 gfc_error ("Function result %qs at %L cannot have an initializer",
11738 sym->name, &sym->declared_at);
11739 else if (automatic_flag)
11740 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11741 sym->name, &sym->declared_at);
11742 else
11743 goto no_init_error;
11744 specification_expr = saved_specification_expr;
11745 return false;
11746 }
11747
11748 no_init_error:
11749 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
11750 {
11751 bool res = resolve_fl_variable_derived (sym, no_init_flag);
11752 specification_expr = saved_specification_expr;
11753 return res;
11754 }
11755
11756 specification_expr = saved_specification_expr;
11757 return true;
11758 }
11759
11760
11761 /* Compare the dummy characteristics of a module procedure interface
11762 declaration with the corresponding declaration in a submodule. */
11763 static gfc_formal_arglist *new_formal;
11764 static char errmsg[200];
11765
11766 static void
compare_fsyms(gfc_symbol * sym)11767 compare_fsyms (gfc_symbol *sym)
11768 {
11769 gfc_symbol *fsym;
11770
11771 if (sym == NULL || new_formal == NULL)
11772 return;
11773
11774 fsym = new_formal->sym;
11775
11776 if (sym == fsym)
11777 return;
11778
11779 if (strcmp (sym->name, fsym->name) == 0)
11780 {
11781 if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
11782 gfc_error ("%s at %L", errmsg, &fsym->declared_at);
11783 }
11784 }
11785
11786
11787 /* Resolve a procedure. */
11788
11789 static bool
resolve_fl_procedure(gfc_symbol * sym,int mp_flag)11790 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
11791 {
11792 gfc_formal_arglist *arg;
11793
11794 if (sym->attr.function
11795 && !resolve_fl_var_and_proc (sym, mp_flag))
11796 return false;
11797
11798 if (sym->ts.type == BT_CHARACTER)
11799 {
11800 gfc_charlen *cl = sym->ts.u.cl;
11801
11802 if (cl && cl->length && gfc_is_constant_expr (cl->length)
11803 && !resolve_charlen (cl))
11804 return false;
11805
11806 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11807 && sym->attr.proc == PROC_ST_FUNCTION)
11808 {
11809 gfc_error ("Character-valued statement function %qs at %L must "
11810 "have constant length", sym->name, &sym->declared_at);
11811 return false;
11812 }
11813 }
11814
11815 /* Ensure that derived type for are not of a private type. Internal
11816 module procedures are excluded by 2.2.3.3 - i.e., they are not
11817 externally accessible and can access all the objects accessible in
11818 the host. */
11819 if (!(sym->ns->parent
11820 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
11821 && gfc_check_symbol_access (sym))
11822 {
11823 gfc_interface *iface;
11824
11825 for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
11826 {
11827 if (arg->sym
11828 && arg->sym->ts.type == BT_DERIVED
11829 && !arg->sym->ts.u.derived->attr.use_assoc
11830 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11831 && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
11832 "and cannot be a dummy argument"
11833 " of %qs, which is PUBLIC at %L",
11834 arg->sym->name, sym->name,
11835 &sym->declared_at))
11836 {
11837 /* Stop this message from recurring. */
11838 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11839 return false;
11840 }
11841 }
11842
11843 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11844 PRIVATE to the containing module. */
11845 for (iface = sym->generic; iface; iface = iface->next)
11846 {
11847 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
11848 {
11849 if (arg->sym
11850 && arg->sym->ts.type == BT_DERIVED
11851 && !arg->sym->ts.u.derived->attr.use_assoc
11852 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11853 && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
11854 "PUBLIC interface %qs at %L "
11855 "takes dummy arguments of %qs which "
11856 "is PRIVATE", iface->sym->name,
11857 sym->name, &iface->sym->declared_at,
11858 gfc_typename(&arg->sym->ts)))
11859 {
11860 /* Stop this message from recurring. */
11861 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11862 return false;
11863 }
11864 }
11865 }
11866 }
11867
11868 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
11869 && !sym->attr.proc_pointer)
11870 {
11871 gfc_error ("Function %qs at %L cannot have an initializer",
11872 sym->name, &sym->declared_at);
11873 return false;
11874 }
11875
11876 /* An external symbol may not have an initializer because it is taken to be
11877 a procedure. Exception: Procedure Pointers. */
11878 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
11879 {
11880 gfc_error ("External object %qs at %L may not have an initializer",
11881 sym->name, &sym->declared_at);
11882 return false;
11883 }
11884
11885 /* An elemental function is required to return a scalar 12.7.1 */
11886 if (sym->attr.elemental && sym->attr.function && sym->as)
11887 {
11888 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11889 "result", sym->name, &sym->declared_at);
11890 /* Reset so that the error only occurs once. */
11891 sym->attr.elemental = 0;
11892 return false;
11893 }
11894
11895 if (sym->attr.proc == PROC_ST_FUNCTION
11896 && (sym->attr.allocatable || sym->attr.pointer))
11897 {
11898 gfc_error ("Statement function %qs at %L may not have pointer or "
11899 "allocatable attribute", sym->name, &sym->declared_at);
11900 return false;
11901 }
11902
11903 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11904 char-len-param shall not be array-valued, pointer-valued, recursive
11905 or pure. ....snip... A character value of * may only be used in the
11906 following ways: (i) Dummy arg of procedure - dummy associates with
11907 actual length; (ii) To declare a named constant; or (iii) External
11908 function - but length must be declared in calling scoping unit. */
11909 if (sym->attr.function
11910 && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
11911 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
11912 {
11913 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
11914 || (sym->attr.recursive) || (sym->attr.pure))
11915 {
11916 if (sym->as && sym->as->rank)
11917 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11918 "array-valued", sym->name, &sym->declared_at);
11919
11920 if (sym->attr.pointer)
11921 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11922 "pointer-valued", sym->name, &sym->declared_at);
11923
11924 if (sym->attr.pure)
11925 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11926 "pure", sym->name, &sym->declared_at);
11927
11928 if (sym->attr.recursive)
11929 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11930 "recursive", sym->name, &sym->declared_at);
11931
11932 return false;
11933 }
11934
11935 /* Appendix B.2 of the standard. Contained functions give an
11936 error anyway. Deferred character length is an F2003 feature.
11937 Don't warn on intrinsic conversion functions, which start
11938 with two underscores. */
11939 if (!sym->attr.contained && !sym->ts.deferred
11940 && (sym->name[0] != '_' || sym->name[1] != '_'))
11941 gfc_notify_std (GFC_STD_F95_OBS,
11942 "CHARACTER(*) function %qs at %L",
11943 sym->name, &sym->declared_at);
11944 }
11945
11946 /* F2008, C1218. */
11947 if (sym->attr.elemental)
11948 {
11949 if (sym->attr.proc_pointer)
11950 {
11951 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11952 sym->name, &sym->declared_at);
11953 return false;
11954 }
11955 if (sym->attr.dummy)
11956 {
11957 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11958 sym->name, &sym->declared_at);
11959 return false;
11960 }
11961 }
11962
11963 /* F2018, C15100: "The result of an elemental function shall be scalar,
11964 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
11965 pointer is tested and caught elsewhere. */
11966 if (sym->attr.elemental && sym->result
11967 && (sym->result->attr.allocatable || sym->result->attr.pointer))
11968 {
11969 gfc_error ("Function result variable %qs at %L of elemental "
11970 "function %qs shall not have an ALLOCATABLE or POINTER "
11971 "attribute", sym->result->name,
11972 &sym->result->declared_at, sym->name);
11973 return false;
11974 }
11975
11976 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
11977 {
11978 gfc_formal_arglist *curr_arg;
11979 int has_non_interop_arg = 0;
11980
11981 if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11982 sym->common_block))
11983 {
11984 /* Clear these to prevent looking at them again if there was an
11985 error. */
11986 sym->attr.is_bind_c = 0;
11987 sym->attr.is_c_interop = 0;
11988 sym->ts.is_c_interop = 0;
11989 }
11990 else
11991 {
11992 /* So far, no errors have been found. */
11993 sym->attr.is_c_interop = 1;
11994 sym->ts.is_c_interop = 1;
11995 }
11996
11997 curr_arg = gfc_sym_get_dummy_args (sym);
11998 while (curr_arg != NULL)
11999 {
12000 /* Skip implicitly typed dummy args here. */
12001 if (curr_arg->sym->attr.implicit_type == 0)
12002 if (!gfc_verify_c_interop_param (curr_arg->sym))
12003 /* If something is found to fail, record the fact so we
12004 can mark the symbol for the procedure as not being
12005 BIND(C) to try and prevent multiple errors being
12006 reported. */
12007 has_non_interop_arg = 1;
12008
12009 curr_arg = curr_arg->next;
12010 }
12011
12012 /* See if any of the arguments were not interoperable and if so, clear
12013 the procedure symbol to prevent duplicate error messages. */
12014 if (has_non_interop_arg != 0)
12015 {
12016 sym->attr.is_c_interop = 0;
12017 sym->ts.is_c_interop = 0;
12018 sym->attr.is_bind_c = 0;
12019 }
12020 }
12021
12022 if (!sym->attr.proc_pointer)
12023 {
12024 if (sym->attr.save == SAVE_EXPLICIT)
12025 {
12026 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
12027 "in %qs at %L", sym->name, &sym->declared_at);
12028 return false;
12029 }
12030 if (sym->attr.intent)
12031 {
12032 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
12033 "in %qs at %L", sym->name, &sym->declared_at);
12034 return false;
12035 }
12036 if (sym->attr.subroutine && sym->attr.result)
12037 {
12038 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
12039 "in %qs at %L", sym->name, &sym->declared_at);
12040 return false;
12041 }
12042 if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
12043 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
12044 || sym->attr.contained))
12045 {
12046 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
12047 "in %qs at %L", sym->name, &sym->declared_at);
12048 return false;
12049 }
12050 if (strcmp ("ppr@", sym->name) == 0)
12051 {
12052 gfc_error ("Procedure pointer result %qs at %L "
12053 "is missing the pointer attribute",
12054 sym->ns->proc_name->name, &sym->declared_at);
12055 return false;
12056 }
12057 }
12058
12059 /* Assume that a procedure whose body is not known has references
12060 to external arrays. */
12061 if (sym->attr.if_source != IFSRC_DECL)
12062 sym->attr.array_outer_dependency = 1;
12063
12064 /* Compare the characteristics of a module procedure with the
12065 interface declaration. Ideally this would be done with
12066 gfc_compare_interfaces but, at present, the formal interface
12067 cannot be copied to the ts.interface. */
12068 if (sym->attr.module_procedure
12069 && sym->attr.if_source == IFSRC_DECL)
12070 {
12071 gfc_symbol *iface;
12072 char name[2*GFC_MAX_SYMBOL_LEN + 1];
12073 char *module_name;
12074 char *submodule_name;
12075 strcpy (name, sym->ns->proc_name->name);
12076 module_name = strtok (name, ".");
12077 submodule_name = strtok (NULL, ".");
12078
12079 /* Stop the dummy characteristics test from using the interface
12080 symbol instead of 'sym'. */
12081 iface = sym->ts.interface;
12082 sym->ts.interface = NULL;
12083
12084 /* Make sure that the result uses the correct charlen for deferred
12085 length results. */
12086 if (iface && sym->result
12087 && iface->ts.type == BT_CHARACTER
12088 && iface->ts.deferred)
12089 sym->result->ts.u.cl = iface->ts.u.cl;
12090
12091 if (iface == NULL)
12092 goto check_formal;
12093
12094 /* Check the procedure characteristics. */
12095 if (sym->attr.elemental != iface->attr.elemental)
12096 {
12097 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
12098 "PROCEDURE at %L and its interface in %s",
12099 &sym->declared_at, module_name);
12100 return false;
12101 }
12102
12103 if (sym->attr.pure != iface->attr.pure)
12104 {
12105 gfc_error ("Mismatch in PURE attribute between MODULE "
12106 "PROCEDURE at %L and its interface in %s",
12107 &sym->declared_at, module_name);
12108 return false;
12109 }
12110
12111 if (sym->attr.recursive != iface->attr.recursive)
12112 {
12113 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
12114 "PROCEDURE at %L and its interface in %s",
12115 &sym->declared_at, module_name);
12116 return false;
12117 }
12118
12119 /* Check the result characteristics. */
12120 if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
12121 {
12122 gfc_error ("%s between the MODULE PROCEDURE declaration "
12123 "in module %s and the declaration at %L in "
12124 "SUBMODULE %s", errmsg, module_name,
12125 &sym->declared_at, submodule_name);
12126 return false;
12127 }
12128
12129 check_formal:
12130 /* Check the charcateristics of the formal arguments. */
12131 if (sym->formal && sym->formal_ns)
12132 {
12133 for (arg = sym->formal; arg && arg->sym; arg = arg->next)
12134 {
12135 new_formal = arg;
12136 gfc_traverse_ns (sym->formal_ns, compare_fsyms);
12137 }
12138 }
12139
12140 sym->ts.interface = iface;
12141 }
12142 return true;
12143 }
12144
12145
12146 /* Resolve a list of finalizer procedures. That is, after they have hopefully
12147 been defined and we now know their defined arguments, check that they fulfill
12148 the requirements of the standard for procedures used as finalizers. */
12149
12150 static bool
gfc_resolve_finalizers(gfc_symbol * derived,bool * finalizable)12151 gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
12152 {
12153 gfc_finalizer* list;
12154 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
12155 bool result = true;
12156 bool seen_scalar = false;
12157 gfc_symbol *vtab;
12158 gfc_component *c;
12159 gfc_symbol *parent = gfc_get_derived_super_type (derived);
12160
12161 if (parent)
12162 gfc_resolve_finalizers (parent, finalizable);
12163
12164 /* Return early when not finalizable. Additionally, ensure that derived-type
12165 components have a their finalizables resolved. */
12166 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
12167 {
12168 bool has_final = false;
12169 for (c = derived->components; c; c = c->next)
12170 if (c->ts.type == BT_DERIVED
12171 && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
12172 {
12173 bool has_final2 = false;
12174 if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final))
12175 return false; /* Error. */
12176 has_final = has_final || has_final2;
12177 }
12178 if (!has_final)
12179 {
12180 if (finalizable)
12181 *finalizable = false;
12182 return true;
12183 }
12184 }
12185
12186 /* Walk over the list of finalizer-procedures, check them, and if any one
12187 does not fit in with the standard's definition, print an error and remove
12188 it from the list. */
12189 prev_link = &derived->f2k_derived->finalizers;
12190 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
12191 {
12192 gfc_formal_arglist *dummy_args;
12193 gfc_symbol* arg;
12194 gfc_finalizer* i;
12195 int my_rank;
12196
12197 /* Skip this finalizer if we already resolved it. */
12198 if (list->proc_tree)
12199 {
12200 prev_link = &(list->next);
12201 continue;
12202 }
12203
12204 /* Check this exists and is a SUBROUTINE. */
12205 if (!list->proc_sym->attr.subroutine)
12206 {
12207 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
12208 list->proc_sym->name, &list->where);
12209 goto error;
12210 }
12211
12212 /* We should have exactly one argument. */
12213 dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
12214 if (!dummy_args || dummy_args->next)
12215 {
12216 gfc_error ("FINAL procedure at %L must have exactly one argument",
12217 &list->where);
12218 goto error;
12219 }
12220 arg = dummy_args->sym;
12221
12222 /* This argument must be of our type. */
12223 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
12224 {
12225 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
12226 &arg->declared_at, derived->name);
12227 goto error;
12228 }
12229
12230 /* It must neither be a pointer nor allocatable nor optional. */
12231 if (arg->attr.pointer)
12232 {
12233 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
12234 &arg->declared_at);
12235 goto error;
12236 }
12237 if (arg->attr.allocatable)
12238 {
12239 gfc_error ("Argument of FINAL procedure at %L must not be"
12240 " ALLOCATABLE", &arg->declared_at);
12241 goto error;
12242 }
12243 if (arg->attr.optional)
12244 {
12245 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
12246 &arg->declared_at);
12247 goto error;
12248 }
12249
12250 /* It must not be INTENT(OUT). */
12251 if (arg->attr.intent == INTENT_OUT)
12252 {
12253 gfc_error ("Argument of FINAL procedure at %L must not be"
12254 " INTENT(OUT)", &arg->declared_at);
12255 goto error;
12256 }
12257
12258 /* Warn if the procedure is non-scalar and not assumed shape. */
12259 if (warn_surprising && arg->as && arg->as->rank != 0
12260 && arg->as->type != AS_ASSUMED_SHAPE)
12261 gfc_warning (OPT_Wsurprising,
12262 "Non-scalar FINAL procedure at %L should have assumed"
12263 " shape argument", &arg->declared_at);
12264
12265 /* Check that it does not match in kind and rank with a FINAL procedure
12266 defined earlier. To really loop over the *earlier* declarations,
12267 we need to walk the tail of the list as new ones were pushed at the
12268 front. */
12269 /* TODO: Handle kind parameters once they are implemented. */
12270 my_rank = (arg->as ? arg->as->rank : 0);
12271 for (i = list->next; i; i = i->next)
12272 {
12273 gfc_formal_arglist *dummy_args;
12274
12275 /* Argument list might be empty; that is an error signalled earlier,
12276 but we nevertheless continued resolving. */
12277 dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
12278 if (dummy_args)
12279 {
12280 gfc_symbol* i_arg = dummy_args->sym;
12281 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
12282 if (i_rank == my_rank)
12283 {
12284 gfc_error ("FINAL procedure %qs declared at %L has the same"
12285 " rank (%d) as %qs",
12286 list->proc_sym->name, &list->where, my_rank,
12287 i->proc_sym->name);
12288 goto error;
12289 }
12290 }
12291 }
12292
12293 /* Is this the/a scalar finalizer procedure? */
12294 if (!arg->as || arg->as->rank == 0)
12295 seen_scalar = true;
12296
12297 /* Find the symtree for this procedure. */
12298 gcc_assert (!list->proc_tree);
12299 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
12300
12301 prev_link = &list->next;
12302 continue;
12303
12304 /* Remove wrong nodes immediately from the list so we don't risk any
12305 troubles in the future when they might fail later expectations. */
12306 error:
12307 i = list;
12308 *prev_link = list->next;
12309 gfc_free_finalizer (i);
12310 result = false;
12311 }
12312
12313 if (result == false)
12314 return false;
12315
12316 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
12317 were nodes in the list, must have been for arrays. It is surely a good
12318 idea to have a scalar version there if there's something to finalize. */
12319 if (warn_surprising && result && !seen_scalar)
12320 gfc_warning (OPT_Wsurprising,
12321 "Only array FINAL procedures declared for derived type %qs"
12322 " defined at %L, suggest also scalar one",
12323 derived->name, &derived->declared_at);
12324
12325 vtab = gfc_find_derived_vtab (derived);
12326 c = vtab->ts.u.derived->components->next->next->next->next->next;
12327 gfc_set_sym_referenced (c->initializer->symtree->n.sym);
12328
12329 if (finalizable)
12330 *finalizable = true;
12331
12332 return true;
12333 }
12334
12335
12336 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
12337
12338 static bool
check_generic_tbp_ambiguity(gfc_tbp_generic * t1,gfc_tbp_generic * t2,const char * generic_name,locus where)12339 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
12340 const char* generic_name, locus where)
12341 {
12342 gfc_symbol *sym1, *sym2;
12343 const char *pass1, *pass2;
12344 gfc_formal_arglist *dummy_args;
12345
12346 gcc_assert (t1->specific && t2->specific);
12347 gcc_assert (!t1->specific->is_generic);
12348 gcc_assert (!t2->specific->is_generic);
12349 gcc_assert (t1->is_operator == t2->is_operator);
12350
12351 sym1 = t1->specific->u.specific->n.sym;
12352 sym2 = t2->specific->u.specific->n.sym;
12353
12354 if (sym1 == sym2)
12355 return true;
12356
12357 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
12358 if (sym1->attr.subroutine != sym2->attr.subroutine
12359 || sym1->attr.function != sym2->attr.function)
12360 {
12361 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
12362 " GENERIC %qs at %L",
12363 sym1->name, sym2->name, generic_name, &where);
12364 return false;
12365 }
12366
12367 /* Determine PASS arguments. */
12368 if (t1->specific->nopass)
12369 pass1 = NULL;
12370 else if (t1->specific->pass_arg)
12371 pass1 = t1->specific->pass_arg;
12372 else
12373 {
12374 dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
12375 if (dummy_args)
12376 pass1 = dummy_args->sym->name;
12377 else
12378 pass1 = NULL;
12379 }
12380 if (t2->specific->nopass)
12381 pass2 = NULL;
12382 else if (t2->specific->pass_arg)
12383 pass2 = t2->specific->pass_arg;
12384 else
12385 {
12386 dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
12387 if (dummy_args)
12388 pass2 = dummy_args->sym->name;
12389 else
12390 pass2 = NULL;
12391 }
12392
12393 /* Compare the interfaces. */
12394 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
12395 NULL, 0, pass1, pass2))
12396 {
12397 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
12398 sym1->name, sym2->name, generic_name, &where);
12399 return false;
12400 }
12401
12402 return true;
12403 }
12404
12405
12406 /* Worker function for resolving a generic procedure binding; this is used to
12407 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
12408
12409 The difference between those cases is finding possible inherited bindings
12410 that are overridden, as one has to look for them in tb_sym_root,
12411 tb_uop_root or tb_op, respectively. Thus the caller must already find
12412 the super-type and set p->overridden correctly. */
12413
12414 static bool
resolve_tb_generic_targets(gfc_symbol * super_type,gfc_typebound_proc * p,const char * name)12415 resolve_tb_generic_targets (gfc_symbol* super_type,
12416 gfc_typebound_proc* p, const char* name)
12417 {
12418 gfc_tbp_generic* target;
12419 gfc_symtree* first_target;
12420 gfc_symtree* inherited;
12421
12422 gcc_assert (p && p->is_generic);
12423
12424 /* Try to find the specific bindings for the symtrees in our target-list. */
12425 gcc_assert (p->u.generic);
12426 for (target = p->u.generic; target; target = target->next)
12427 if (!target->specific)
12428 {
12429 gfc_typebound_proc* overridden_tbp;
12430 gfc_tbp_generic* g;
12431 const char* target_name;
12432
12433 target_name = target->specific_st->name;
12434
12435 /* Defined for this type directly. */
12436 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
12437 {
12438 target->specific = target->specific_st->n.tb;
12439 goto specific_found;
12440 }
12441
12442 /* Look for an inherited specific binding. */
12443 if (super_type)
12444 {
12445 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
12446 true, NULL);
12447
12448 if (inherited)
12449 {
12450 gcc_assert (inherited->n.tb);
12451 target->specific = inherited->n.tb;
12452 goto specific_found;
12453 }
12454 }
12455
12456 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
12457 " at %L", target_name, name, &p->where);
12458 return false;
12459
12460 /* Once we've found the specific binding, check it is not ambiguous with
12461 other specifics already found or inherited for the same GENERIC. */
12462 specific_found:
12463 gcc_assert (target->specific);
12464
12465 /* This must really be a specific binding! */
12466 if (target->specific->is_generic)
12467 {
12468 gfc_error ("GENERIC %qs at %L must target a specific binding,"
12469 " %qs is GENERIC, too", name, &p->where, target_name);
12470 return false;
12471 }
12472
12473 /* Check those already resolved on this type directly. */
12474 for (g = p->u.generic; g; g = g->next)
12475 if (g != target && g->specific
12476 && !check_generic_tbp_ambiguity (target, g, name, p->where))
12477 return false;
12478
12479 /* Check for ambiguity with inherited specific targets. */
12480 for (overridden_tbp = p->overridden; overridden_tbp;
12481 overridden_tbp = overridden_tbp->overridden)
12482 if (overridden_tbp->is_generic)
12483 {
12484 for (g = overridden_tbp->u.generic; g; g = g->next)
12485 {
12486 gcc_assert (g->specific);
12487 if (!check_generic_tbp_ambiguity (target, g, name, p->where))
12488 return false;
12489 }
12490 }
12491 }
12492
12493 /* If we attempt to "overwrite" a specific binding, this is an error. */
12494 if (p->overridden && !p->overridden->is_generic)
12495 {
12496 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
12497 " the same name", name, &p->where);
12498 return false;
12499 }
12500
12501 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
12502 all must have the same attributes here. */
12503 first_target = p->u.generic->specific->u.specific;
12504 gcc_assert (first_target);
12505 p->subroutine = first_target->n.sym->attr.subroutine;
12506 p->function = first_target->n.sym->attr.function;
12507
12508 return true;
12509 }
12510
12511
12512 /* Resolve a GENERIC procedure binding for a derived type. */
12513
12514 static bool
resolve_typebound_generic(gfc_symbol * derived,gfc_symtree * st)12515 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
12516 {
12517 gfc_symbol* super_type;
12518
12519 /* Find the overridden binding if any. */
12520 st->n.tb->overridden = NULL;
12521 super_type = gfc_get_derived_super_type (derived);
12522 if (super_type)
12523 {
12524 gfc_symtree* overridden;
12525 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
12526 true, NULL);
12527
12528 if (overridden && overridden->n.tb)
12529 st->n.tb->overridden = overridden->n.tb;
12530 }
12531
12532 /* Resolve using worker function. */
12533 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
12534 }
12535
12536
12537 /* Retrieve the target-procedure of an operator binding and do some checks in
12538 common for intrinsic and user-defined type-bound operators. */
12539
12540 static gfc_symbol*
get_checked_tb_operator_target(gfc_tbp_generic * target,locus where)12541 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
12542 {
12543 gfc_symbol* target_proc;
12544
12545 gcc_assert (target->specific && !target->specific->is_generic);
12546 target_proc = target->specific->u.specific->n.sym;
12547 gcc_assert (target_proc);
12548
12549 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12550 if (target->specific->nopass)
12551 {
12552 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
12553 return NULL;
12554 }
12555
12556 return target_proc;
12557 }
12558
12559
12560 /* Resolve a type-bound intrinsic operator. */
12561
12562 static bool
resolve_typebound_intrinsic_op(gfc_symbol * derived,gfc_intrinsic_op op,gfc_typebound_proc * p)12563 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
12564 gfc_typebound_proc* p)
12565 {
12566 gfc_symbol* super_type;
12567 gfc_tbp_generic* target;
12568
12569 /* If there's already an error here, do nothing (but don't fail again). */
12570 if (p->error)
12571 return true;
12572
12573 /* Operators should always be GENERIC bindings. */
12574 gcc_assert (p->is_generic);
12575
12576 /* Look for an overridden binding. */
12577 super_type = gfc_get_derived_super_type (derived);
12578 if (super_type && super_type->f2k_derived)
12579 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
12580 op, true, NULL);
12581 else
12582 p->overridden = NULL;
12583
12584 /* Resolve general GENERIC properties using worker function. */
12585 if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
12586 goto error;
12587
12588 /* Check the targets to be procedures of correct interface. */
12589 for (target = p->u.generic; target; target = target->next)
12590 {
12591 gfc_symbol* target_proc;
12592
12593 target_proc = get_checked_tb_operator_target (target, p->where);
12594 if (!target_proc)
12595 goto error;
12596
12597 if (!gfc_check_operator_interface (target_proc, op, p->where))
12598 goto error;
12599
12600 /* Add target to non-typebound operator list. */
12601 if (!target->specific->deferred && !derived->attr.use_assoc
12602 && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
12603 {
12604 gfc_interface *head, *intr;
12605
12606 /* Preempt 'gfc_check_new_interface' for submodules, where the
12607 mechanism for handling module procedures winds up resolving
12608 operator interfaces twice and would otherwise cause an error. */
12609 for (intr = derived->ns->op[op]; intr; intr = intr->next)
12610 if (intr->sym == target_proc
12611 && target_proc->attr.used_in_submodule)
12612 return true;
12613
12614 if (!gfc_check_new_interface (derived->ns->op[op],
12615 target_proc, p->where))
12616 return false;
12617 head = derived->ns->op[op];
12618 intr = gfc_get_interface ();
12619 intr->sym = target_proc;
12620 intr->where = p->where;
12621 intr->next = head;
12622 derived->ns->op[op] = intr;
12623 }
12624 }
12625
12626 return true;
12627
12628 error:
12629 p->error = 1;
12630 return false;
12631 }
12632
12633
12634 /* Resolve a type-bound user operator (tree-walker callback). */
12635
12636 static gfc_symbol* resolve_bindings_derived;
12637 static bool resolve_bindings_result;
12638
12639 static bool check_uop_procedure (gfc_symbol* sym, locus where);
12640
12641 static void
resolve_typebound_user_op(gfc_symtree * stree)12642 resolve_typebound_user_op (gfc_symtree* stree)
12643 {
12644 gfc_symbol* super_type;
12645 gfc_tbp_generic* target;
12646
12647 gcc_assert (stree && stree->n.tb);
12648
12649 if (stree->n.tb->error)
12650 return;
12651
12652 /* Operators should always be GENERIC bindings. */
12653 gcc_assert (stree->n.tb->is_generic);
12654
12655 /* Find overridden procedure, if any. */
12656 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
12657 if (super_type && super_type->f2k_derived)
12658 {
12659 gfc_symtree* overridden;
12660 overridden = gfc_find_typebound_user_op (super_type, NULL,
12661 stree->name, true, NULL);
12662
12663 if (overridden && overridden->n.tb)
12664 stree->n.tb->overridden = overridden->n.tb;
12665 }
12666 else
12667 stree->n.tb->overridden = NULL;
12668
12669 /* Resolve basically using worker function. */
12670 if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
12671 goto error;
12672
12673 /* Check the targets to be functions of correct interface. */
12674 for (target = stree->n.tb->u.generic; target; target = target->next)
12675 {
12676 gfc_symbol* target_proc;
12677
12678 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
12679 if (!target_proc)
12680 goto error;
12681
12682 if (!check_uop_procedure (target_proc, stree->n.tb->where))
12683 goto error;
12684 }
12685
12686 return;
12687
12688 error:
12689 resolve_bindings_result = false;
12690 stree->n.tb->error = 1;
12691 }
12692
12693
12694 /* Resolve the type-bound procedures for a derived type. */
12695
12696 static void
resolve_typebound_procedure(gfc_symtree * stree)12697 resolve_typebound_procedure (gfc_symtree* stree)
12698 {
12699 gfc_symbol* proc;
12700 locus where;
12701 gfc_symbol* me_arg;
12702 gfc_symbol* super_type;
12703 gfc_component* comp;
12704
12705 gcc_assert (stree);
12706
12707 /* Undefined specific symbol from GENERIC target definition. */
12708 if (!stree->n.tb)
12709 return;
12710
12711 if (stree->n.tb->error)
12712 return;
12713
12714 /* If this is a GENERIC binding, use that routine. */
12715 if (stree->n.tb->is_generic)
12716 {
12717 if (!resolve_typebound_generic (resolve_bindings_derived, stree))
12718 goto error;
12719 return;
12720 }
12721
12722 /* Get the target-procedure to check it. */
12723 gcc_assert (!stree->n.tb->is_generic);
12724 gcc_assert (stree->n.tb->u.specific);
12725 proc = stree->n.tb->u.specific->n.sym;
12726 where = stree->n.tb->where;
12727
12728 /* Default access should already be resolved from the parser. */
12729 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
12730
12731 if (stree->n.tb->deferred)
12732 {
12733 if (!check_proc_interface (proc, &where))
12734 goto error;
12735 }
12736 else
12737 {
12738 /* Check for F08:C465. */
12739 if ((!proc->attr.subroutine && !proc->attr.function)
12740 || (proc->attr.proc != PROC_MODULE
12741 && proc->attr.if_source != IFSRC_IFBODY)
12742 || proc->attr.abstract)
12743 {
12744 gfc_error ("%qs must be a module procedure or an external procedure with"
12745 " an explicit interface at %L", proc->name, &where);
12746 goto error;
12747 }
12748 }
12749
12750 stree->n.tb->subroutine = proc->attr.subroutine;
12751 stree->n.tb->function = proc->attr.function;
12752
12753 /* Find the super-type of the current derived type. We could do this once and
12754 store in a global if speed is needed, but as long as not I believe this is
12755 more readable and clearer. */
12756 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
12757
12758 /* If PASS, resolve and check arguments if not already resolved / loaded
12759 from a .mod file. */
12760 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
12761 {
12762 gfc_formal_arglist *dummy_args;
12763
12764 dummy_args = gfc_sym_get_dummy_args (proc);
12765 if (stree->n.tb->pass_arg)
12766 {
12767 gfc_formal_arglist *i;
12768
12769 /* If an explicit passing argument name is given, walk the arg-list
12770 and look for it. */
12771
12772 me_arg = NULL;
12773 stree->n.tb->pass_arg_num = 1;
12774 for (i = dummy_args; i; i = i->next)
12775 {
12776 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
12777 {
12778 me_arg = i->sym;
12779 break;
12780 }
12781 ++stree->n.tb->pass_arg_num;
12782 }
12783
12784 if (!me_arg)
12785 {
12786 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12787 " argument %qs",
12788 proc->name, stree->n.tb->pass_arg, &where,
12789 stree->n.tb->pass_arg);
12790 goto error;
12791 }
12792 }
12793 else
12794 {
12795 /* Otherwise, take the first one; there should in fact be at least
12796 one. */
12797 stree->n.tb->pass_arg_num = 1;
12798 if (!dummy_args)
12799 {
12800 gfc_error ("Procedure %qs with PASS at %L must have at"
12801 " least one argument", proc->name, &where);
12802 goto error;
12803 }
12804 me_arg = dummy_args->sym;
12805 }
12806
12807 /* Now check that the argument-type matches and the passed-object
12808 dummy argument is generally fine. */
12809
12810 gcc_assert (me_arg);
12811
12812 if (me_arg->ts.type != BT_CLASS)
12813 {
12814 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12815 " at %L", proc->name, &where);
12816 goto error;
12817 }
12818
12819 if (CLASS_DATA (me_arg)->ts.u.derived
12820 != resolve_bindings_derived)
12821 {
12822 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12823 " the derived-type %qs", me_arg->name, proc->name,
12824 me_arg->name, &where, resolve_bindings_derived->name);
12825 goto error;
12826 }
12827
12828 gcc_assert (me_arg->ts.type == BT_CLASS);
12829 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
12830 {
12831 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12832 " scalar", proc->name, &where);
12833 goto error;
12834 }
12835 if (CLASS_DATA (me_arg)->attr.allocatable)
12836 {
12837 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12838 " be ALLOCATABLE", proc->name, &where);
12839 goto error;
12840 }
12841 if (CLASS_DATA (me_arg)->attr.class_pointer)
12842 {
12843 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12844 " be POINTER", proc->name, &where);
12845 goto error;
12846 }
12847 }
12848
12849 /* If we are extending some type, check that we don't override a procedure
12850 flagged NON_OVERRIDABLE. */
12851 stree->n.tb->overridden = NULL;
12852 if (super_type)
12853 {
12854 gfc_symtree* overridden;
12855 overridden = gfc_find_typebound_proc (super_type, NULL,
12856 stree->name, true, NULL);
12857
12858 if (overridden)
12859 {
12860 if (overridden->n.tb)
12861 stree->n.tb->overridden = overridden->n.tb;
12862
12863 if (!gfc_check_typebound_override (stree, overridden))
12864 goto error;
12865 }
12866 }
12867
12868 /* See if there's a name collision with a component directly in this type. */
12869 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
12870 if (!strcmp (comp->name, stree->name))
12871 {
12872 gfc_error ("Procedure %qs at %L has the same name as a component of"
12873 " %qs",
12874 stree->name, &where, resolve_bindings_derived->name);
12875 goto error;
12876 }
12877
12878 /* Try to find a name collision with an inherited component. */
12879 if (super_type && gfc_find_component (super_type, stree->name, true, true,
12880 NULL))
12881 {
12882 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12883 " component of %qs",
12884 stree->name, &where, resolve_bindings_derived->name);
12885 goto error;
12886 }
12887
12888 stree->n.tb->error = 0;
12889 return;
12890
12891 error:
12892 resolve_bindings_result = false;
12893 stree->n.tb->error = 1;
12894 }
12895
12896
12897 static bool
resolve_typebound_procedures(gfc_symbol * derived)12898 resolve_typebound_procedures (gfc_symbol* derived)
12899 {
12900 int op;
12901 gfc_symbol* super_type;
12902
12903 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
12904 return true;
12905
12906 super_type = gfc_get_derived_super_type (derived);
12907 if (super_type)
12908 resolve_symbol (super_type);
12909
12910 resolve_bindings_derived = derived;
12911 resolve_bindings_result = true;
12912
12913 if (derived->f2k_derived->tb_sym_root)
12914 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
12915 &resolve_typebound_procedure);
12916
12917 if (derived->f2k_derived->tb_uop_root)
12918 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
12919 &resolve_typebound_user_op);
12920
12921 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
12922 {
12923 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
12924 if (p && !resolve_typebound_intrinsic_op (derived,
12925 (gfc_intrinsic_op)op, p))
12926 resolve_bindings_result = false;
12927 }
12928
12929 return resolve_bindings_result;
12930 }
12931
12932
12933 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12934 to give all identical derived types the same backend_decl. */
12935 static void
add_dt_to_dt_list(gfc_symbol * derived)12936 add_dt_to_dt_list (gfc_symbol *derived)
12937 {
12938 gfc_dt_list *dt_list;
12939
12940 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
12941 if (derived == dt_list->derived)
12942 return;
12943
12944 dt_list = gfc_get_dt_list ();
12945 dt_list->next = gfc_derived_types;
12946 dt_list->derived = derived;
12947 gfc_derived_types = dt_list;
12948 }
12949
12950
12951 /* Ensure that a derived-type is really not abstract, meaning that every
12952 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12953
12954 static bool
ensure_not_abstract_walker(gfc_symbol * sub,gfc_symtree * st)12955 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
12956 {
12957 if (!st)
12958 return true;
12959
12960 if (!ensure_not_abstract_walker (sub, st->left))
12961 return false;
12962 if (!ensure_not_abstract_walker (sub, st->right))
12963 return false;
12964
12965 if (st->n.tb && st->n.tb->deferred)
12966 {
12967 gfc_symtree* overriding;
12968 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
12969 if (!overriding)
12970 return false;
12971 gcc_assert (overriding->n.tb);
12972 if (overriding->n.tb->deferred)
12973 {
12974 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12975 " %qs is DEFERRED and not overridden",
12976 sub->name, &sub->declared_at, st->name);
12977 return false;
12978 }
12979 }
12980
12981 return true;
12982 }
12983
12984 static bool
ensure_not_abstract(gfc_symbol * sub,gfc_symbol * ancestor)12985 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
12986 {
12987 /* The algorithm used here is to recursively travel up the ancestry of sub
12988 and for each ancestor-type, check all bindings. If any of them is
12989 DEFERRED, look it up starting from sub and see if the found (overriding)
12990 binding is not DEFERRED.
12991 This is not the most efficient way to do this, but it should be ok and is
12992 clearer than something sophisticated. */
12993
12994 gcc_assert (ancestor && !sub->attr.abstract);
12995
12996 if (!ancestor->attr.abstract)
12997 return true;
12998
12999 /* Walk bindings of this ancestor. */
13000 if (ancestor->f2k_derived)
13001 {
13002 bool t;
13003 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
13004 if (!t)
13005 return false;
13006 }
13007
13008 /* Find next ancestor type and recurse on it. */
13009 ancestor = gfc_get_derived_super_type (ancestor);
13010 if (ancestor)
13011 return ensure_not_abstract (sub, ancestor);
13012
13013 return true;
13014 }
13015
13016
13017 /* This check for typebound defined assignments is done recursively
13018 since the order in which derived types are resolved is not always in
13019 order of the declarations. */
13020
13021 static void
check_defined_assignments(gfc_symbol * derived)13022 check_defined_assignments (gfc_symbol *derived)
13023 {
13024 gfc_component *c;
13025
13026 for (c = derived->components; c; c = c->next)
13027 {
13028 if (!gfc_bt_struct (c->ts.type)
13029 || c->attr.pointer
13030 || c->attr.allocatable
13031 || c->attr.proc_pointer_comp
13032 || c->attr.class_pointer
13033 || c->attr.proc_pointer)
13034 continue;
13035
13036 if (c->ts.u.derived->attr.defined_assign_comp
13037 || (c->ts.u.derived->f2k_derived
13038 && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
13039 {
13040 derived->attr.defined_assign_comp = 1;
13041 return;
13042 }
13043
13044 check_defined_assignments (c->ts.u.derived);
13045 if (c->ts.u.derived->attr.defined_assign_comp)
13046 {
13047 derived->attr.defined_assign_comp = 1;
13048 return;
13049 }
13050 }
13051 }
13052
13053
13054 /* Resolve a single component of a derived type or structure. */
13055
13056 static bool
resolve_component(gfc_component * c,gfc_symbol * sym)13057 resolve_component (gfc_component *c, gfc_symbol *sym)
13058 {
13059 gfc_symbol *super_type;
13060
13061 if (c->attr.artificial)
13062 return true;
13063
13064 /* F2008, C442. */
13065 if ((!sym->attr.is_class || c != sym->components)
13066 && c->attr.codimension
13067 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
13068 {
13069 gfc_error ("Coarray component %qs at %L must be allocatable with "
13070 "deferred shape", c->name, &c->loc);
13071 return false;
13072 }
13073
13074 /* F2008, C443. */
13075 if (c->attr.codimension && c->ts.type == BT_DERIVED
13076 && c->ts.u.derived->ts.is_iso_c)
13077 {
13078 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13079 "shall not be a coarray", c->name, &c->loc);
13080 return false;
13081 }
13082
13083 /* F2008, C444. */
13084 if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
13085 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
13086 || c->attr.allocatable))
13087 {
13088 gfc_error ("Component %qs at %L with coarray component "
13089 "shall be a nonpointer, nonallocatable scalar",
13090 c->name, &c->loc);
13091 return false;
13092 }
13093
13094 /* F2008, C448. */
13095 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
13096 {
13097 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
13098 "is not an array pointer", c->name, &c->loc);
13099 return false;
13100 }
13101
13102 if (c->attr.proc_pointer && c->ts.interface)
13103 {
13104 gfc_symbol *ifc = c->ts.interface;
13105
13106 if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
13107 {
13108 c->tb->error = 1;
13109 return false;
13110 }
13111
13112 if (ifc->attr.if_source || ifc->attr.intrinsic)
13113 {
13114 /* Resolve interface and copy attributes. */
13115 if (ifc->formal && !ifc->formal_ns)
13116 resolve_symbol (ifc);
13117 if (ifc->attr.intrinsic)
13118 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
13119
13120 if (ifc->result)
13121 {
13122 c->ts = ifc->result->ts;
13123 c->attr.allocatable = ifc->result->attr.allocatable;
13124 c->attr.pointer = ifc->result->attr.pointer;
13125 c->attr.dimension = ifc->result->attr.dimension;
13126 c->as = gfc_copy_array_spec (ifc->result->as);
13127 c->attr.class_ok = ifc->result->attr.class_ok;
13128 }
13129 else
13130 {
13131 c->ts = ifc->ts;
13132 c->attr.allocatable = ifc->attr.allocatable;
13133 c->attr.pointer = ifc->attr.pointer;
13134 c->attr.dimension = ifc->attr.dimension;
13135 c->as = gfc_copy_array_spec (ifc->as);
13136 c->attr.class_ok = ifc->attr.class_ok;
13137 }
13138 c->ts.interface = ifc;
13139 c->attr.function = ifc->attr.function;
13140 c->attr.subroutine = ifc->attr.subroutine;
13141
13142 c->attr.pure = ifc->attr.pure;
13143 c->attr.elemental = ifc->attr.elemental;
13144 c->attr.recursive = ifc->attr.recursive;
13145 c->attr.always_explicit = ifc->attr.always_explicit;
13146 c->attr.ext_attr |= ifc->attr.ext_attr;
13147 /* Copy char length. */
13148 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
13149 {
13150 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
13151 if (cl->length && !cl->resolved
13152 && !gfc_resolve_expr (cl->length))
13153 {
13154 c->tb->error = 1;
13155 return false;
13156 }
13157 c->ts.u.cl = cl;
13158 }
13159 }
13160 }
13161 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
13162 {
13163 /* Since PPCs are not implicitly typed, a PPC without an explicit
13164 interface must be a subroutine. */
13165 gfc_add_subroutine (&c->attr, c->name, &c->loc);
13166 }
13167
13168 /* Procedure pointer components: Check PASS arg. */
13169 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
13170 && !sym->attr.vtype)
13171 {
13172 gfc_symbol* me_arg;
13173
13174 if (c->tb->pass_arg)
13175 {
13176 gfc_formal_arglist* i;
13177
13178 /* If an explicit passing argument name is given, walk the arg-list
13179 and look for it. */
13180
13181 me_arg = NULL;
13182 c->tb->pass_arg_num = 1;
13183 for (i = c->ts.interface->formal; i; i = i->next)
13184 {
13185 if (!strcmp (i->sym->name, c->tb->pass_arg))
13186 {
13187 me_arg = i->sym;
13188 break;
13189 }
13190 c->tb->pass_arg_num++;
13191 }
13192
13193 if (!me_arg)
13194 {
13195 gfc_error ("Procedure pointer component %qs with PASS(%s) "
13196 "at %L has no argument %qs", c->name,
13197 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
13198 c->tb->error = 1;
13199 return false;
13200 }
13201 }
13202 else
13203 {
13204 /* Otherwise, take the first one; there should in fact be at least
13205 one. */
13206 c->tb->pass_arg_num = 1;
13207 if (!c->ts.interface->formal)
13208 {
13209 gfc_error ("Procedure pointer component %qs with PASS at %L "
13210 "must have at least one argument",
13211 c->name, &c->loc);
13212 c->tb->error = 1;
13213 return false;
13214 }
13215 me_arg = c->ts.interface->formal->sym;
13216 }
13217
13218 /* Now check that the argument-type matches. */
13219 gcc_assert (me_arg);
13220 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
13221 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
13222 || (me_arg->ts.type == BT_CLASS
13223 && CLASS_DATA (me_arg)->ts.u.derived != sym))
13224 {
13225 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
13226 " the derived type %qs", me_arg->name, c->name,
13227 me_arg->name, &c->loc, sym->name);
13228 c->tb->error = 1;
13229 return false;
13230 }
13231
13232 /* Check for C453. */
13233 if (me_arg->attr.dimension)
13234 {
13235 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13236 "must be scalar", me_arg->name, c->name, me_arg->name,
13237 &c->loc);
13238 c->tb->error = 1;
13239 return false;
13240 }
13241
13242 if (me_arg->attr.pointer)
13243 {
13244 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13245 "may not have the POINTER attribute", me_arg->name,
13246 c->name, me_arg->name, &c->loc);
13247 c->tb->error = 1;
13248 return false;
13249 }
13250
13251 if (me_arg->attr.allocatable)
13252 {
13253 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
13254 "may not be ALLOCATABLE", me_arg->name, c->name,
13255 me_arg->name, &c->loc);
13256 c->tb->error = 1;
13257 return false;
13258 }
13259
13260 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
13261 {
13262 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
13263 " at %L", c->name, &c->loc);
13264 return false;
13265 }
13266
13267 }
13268
13269 /* Check type-spec if this is not the parent-type component. */
13270 if (((sym->attr.is_class
13271 && (!sym->components->ts.u.derived->attr.extension
13272 || c != sym->components->ts.u.derived->components))
13273 || (!sym->attr.is_class
13274 && (!sym->attr.extension || c != sym->components)))
13275 && !sym->attr.vtype
13276 && !resolve_typespec_used (&c->ts, &c->loc, c->name))
13277 return false;
13278
13279 super_type = gfc_get_derived_super_type (sym);
13280
13281 /* If this type is an extension, set the accessibility of the parent
13282 component. */
13283 if (super_type
13284 && ((sym->attr.is_class
13285 && c == sym->components->ts.u.derived->components)
13286 || (!sym->attr.is_class && c == sym->components))
13287 && strcmp (super_type->name, c->name) == 0)
13288 c->attr.access = super_type->attr.access;
13289
13290 /* If this type is an extension, see if this component has the same name
13291 as an inherited type-bound procedure. */
13292 if (super_type && !sym->attr.is_class
13293 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
13294 {
13295 gfc_error ("Component %qs of %qs at %L has the same name as an"
13296 " inherited type-bound procedure",
13297 c->name, sym->name, &c->loc);
13298 return false;
13299 }
13300
13301 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
13302 && !c->ts.deferred)
13303 {
13304 if (c->ts.u.cl->length == NULL
13305 || (!resolve_charlen(c->ts.u.cl))
13306 || !gfc_is_constant_expr (c->ts.u.cl->length))
13307 {
13308 gfc_error ("Character length of component %qs needs to "
13309 "be a constant specification expression at %L",
13310 c->name,
13311 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
13312 return false;
13313 }
13314 }
13315
13316 if (c->ts.type == BT_CHARACTER && c->ts.deferred
13317 && !c->attr.pointer && !c->attr.allocatable)
13318 {
13319 gfc_error ("Character component %qs of %qs at %L with deferred "
13320 "length must be a POINTER or ALLOCATABLE",
13321 c->name, sym->name, &c->loc);
13322 return false;
13323 }
13324
13325 /* Add the hidden deferred length field. */
13326 if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
13327 && !sym->attr.is_class)
13328 {
13329 char name[GFC_MAX_SYMBOL_LEN+9];
13330 gfc_component *strlen;
13331 sprintf (name, "_%s_length", c->name);
13332 strlen = gfc_find_component (sym, name, true, true, NULL);
13333 if (strlen == NULL)
13334 {
13335 if (!gfc_add_component (sym, name, &strlen))
13336 return false;
13337 strlen->ts.type = BT_INTEGER;
13338 strlen->ts.kind = gfc_charlen_int_kind;
13339 strlen->attr.access = ACCESS_PRIVATE;
13340 strlen->attr.artificial = 1;
13341 }
13342 }
13343
13344 if (c->ts.type == BT_DERIVED
13345 && sym->component_access != ACCESS_PRIVATE
13346 && gfc_check_symbol_access (sym)
13347 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
13348 && !c->ts.u.derived->attr.use_assoc
13349 && !gfc_check_symbol_access (c->ts.u.derived)
13350 && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
13351 "PRIVATE type and cannot be a component of "
13352 "%qs, which is PUBLIC at %L", c->name,
13353 sym->name, &sym->declared_at))
13354 return false;
13355
13356 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
13357 {
13358 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
13359 "type %s", c->name, &c->loc, sym->name);
13360 return false;
13361 }
13362
13363 if (sym->attr.sequence)
13364 {
13365 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
13366 {
13367 gfc_error ("Component %s of SEQUENCE type declared at %L does "
13368 "not have the SEQUENCE attribute",
13369 c->ts.u.derived->name, &sym->declared_at);
13370 return false;
13371 }
13372 }
13373
13374 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
13375 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
13376 else if (c->ts.type == BT_CLASS && c->attr.class_ok
13377 && CLASS_DATA (c)->ts.u.derived->attr.generic)
13378 CLASS_DATA (c)->ts.u.derived
13379 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
13380
13381 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
13382 && c->attr.pointer && c->ts.u.derived->components == NULL
13383 && !c->ts.u.derived->attr.zero_comp)
13384 {
13385 gfc_error ("The pointer component %qs of %qs at %L is a type "
13386 "that has not been declared", c->name, sym->name,
13387 &c->loc);
13388 return false;
13389 }
13390
13391 if (c->ts.type == BT_CLASS && c->attr.class_ok
13392 && CLASS_DATA (c)->attr.class_pointer
13393 && CLASS_DATA (c)->ts.u.derived->components == NULL
13394 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
13395 && !UNLIMITED_POLY (c))
13396 {
13397 gfc_error ("The pointer component %qs of %qs at %L is a type "
13398 "that has not been declared", c->name, sym->name,
13399 &c->loc);
13400 return false;
13401 }
13402
13403 /* C437. */
13404 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
13405 && (!c->attr.class_ok
13406 || !(CLASS_DATA (c)->attr.class_pointer
13407 || CLASS_DATA (c)->attr.allocatable)))
13408 {
13409 gfc_error ("Component %qs with CLASS at %L must be allocatable "
13410 "or pointer", c->name, &c->loc);
13411 /* Prevent a recurrence of the error. */
13412 c->ts.type = BT_UNKNOWN;
13413 return false;
13414 }
13415
13416 /* Ensure that all the derived type components are put on the
13417 derived type list; even in formal namespaces, where derived type
13418 pointer components might not have been declared. */
13419 if (c->ts.type == BT_DERIVED
13420 && c->ts.u.derived
13421 && c->ts.u.derived->components
13422 && c->attr.pointer
13423 && sym != c->ts.u.derived)
13424 add_dt_to_dt_list (c->ts.u.derived);
13425
13426 if (!gfc_resolve_array_spec (c->as,
13427 !(c->attr.pointer || c->attr.proc_pointer
13428 || c->attr.allocatable)))
13429 return false;
13430
13431 if (c->initializer && !sym->attr.vtype
13432 && !gfc_check_assign_symbol (sym, c, c->initializer))
13433 return false;
13434
13435 return true;
13436 }
13437
13438
13439 /* Be nice about the locus for a structure expression - show the locus of the
13440 first non-null sub-expression if we can. */
13441
13442 static locus *
cons_where(gfc_expr * struct_expr)13443 cons_where (gfc_expr *struct_expr)
13444 {
13445 gfc_constructor *cons;
13446
13447 gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
13448
13449 cons = gfc_constructor_first (struct_expr->value.constructor);
13450 for (; cons; cons = gfc_constructor_next (cons))
13451 {
13452 if (cons->expr && cons->expr->expr_type != EXPR_NULL)
13453 return &cons->expr->where;
13454 }
13455
13456 return &struct_expr->where;
13457 }
13458
13459 /* Resolve the components of a structure type. Much less work than derived
13460 types. */
13461
13462 static bool
resolve_fl_struct(gfc_symbol * sym)13463 resolve_fl_struct (gfc_symbol *sym)
13464 {
13465 gfc_component *c;
13466 gfc_expr *init = NULL;
13467 bool success;
13468
13469 /* Make sure UNIONs do not have overlapping initializers. */
13470 if (sym->attr.flavor == FL_UNION)
13471 {
13472 for (c = sym->components; c; c = c->next)
13473 {
13474 if (init && c->initializer)
13475 {
13476 gfc_error ("Conflicting initializers in union at %L and %L",
13477 cons_where (init), cons_where (c->initializer));
13478 gfc_free_expr (c->initializer);
13479 c->initializer = NULL;
13480 }
13481 if (init == NULL)
13482 init = c->initializer;
13483 }
13484 }
13485
13486 success = true;
13487 for (c = sym->components; c; c = c->next)
13488 if (!resolve_component (c, sym))
13489 success = false;
13490
13491 if (!success)
13492 return false;
13493
13494 if (sym->components)
13495 add_dt_to_dt_list (sym);
13496
13497 return true;
13498 }
13499
13500
13501 /* Resolve the components of a derived type. This does not have to wait until
13502 resolution stage, but can be done as soon as the dt declaration has been
13503 parsed. */
13504
13505 static bool
resolve_fl_derived0(gfc_symbol * sym)13506 resolve_fl_derived0 (gfc_symbol *sym)
13507 {
13508 gfc_symbol* super_type;
13509 gfc_component *c;
13510 bool success;
13511
13512 if (sym->attr.unlimited_polymorphic)
13513 return true;
13514
13515 super_type = gfc_get_derived_super_type (sym);
13516
13517 /* F2008, C432. */
13518 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
13519 {
13520 gfc_error ("As extending type %qs at %L has a coarray component, "
13521 "parent type %qs shall also have one", sym->name,
13522 &sym->declared_at, super_type->name);
13523 return false;
13524 }
13525
13526 /* Ensure the extended type gets resolved before we do. */
13527 if (super_type && !resolve_fl_derived0 (super_type))
13528 return false;
13529
13530 /* An ABSTRACT type must be extensible. */
13531 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
13532 {
13533 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
13534 sym->name, &sym->declared_at);
13535 return false;
13536 }
13537
13538 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
13539 : sym->components;
13540
13541 success = true;
13542 for ( ; c != NULL; c = c->next)
13543 if (!resolve_component (c, sym))
13544 success = false;
13545
13546 if (!success)
13547 return false;
13548
13549 check_defined_assignments (sym);
13550
13551 if (!sym->attr.defined_assign_comp && super_type)
13552 sym->attr.defined_assign_comp
13553 = super_type->attr.defined_assign_comp;
13554
13555 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
13556 all DEFERRED bindings are overridden. */
13557 if (super_type && super_type->attr.abstract && !sym->attr.abstract
13558 && !sym->attr.is_class
13559 && !ensure_not_abstract (sym, super_type))
13560 return false;
13561
13562 /* Add derived type to the derived type list. */
13563 add_dt_to_dt_list (sym);
13564
13565 return true;
13566 }
13567
13568
13569 /* The following procedure does the full resolution of a derived type,
13570 including resolution of all type-bound procedures (if present). In contrast
13571 to 'resolve_fl_derived0' this can only be done after the module has been
13572 parsed completely. */
13573
13574 static bool
resolve_fl_derived(gfc_symbol * sym)13575 resolve_fl_derived (gfc_symbol *sym)
13576 {
13577 gfc_symbol *gen_dt = NULL;
13578
13579 if (sym->attr.unlimited_polymorphic)
13580 return true;
13581
13582 if (!sym->attr.is_class)
13583 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
13584 if (gen_dt && gen_dt->generic && gen_dt->generic->next
13585 && (!gen_dt->generic->sym->attr.use_assoc
13586 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
13587 && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
13588 "%qs at %L being the same name as derived "
13589 "type at %L", sym->name,
13590 gen_dt->generic->sym == sym
13591 ? gen_dt->generic->next->sym->name
13592 : gen_dt->generic->sym->name,
13593 gen_dt->generic->sym == sym
13594 ? &gen_dt->generic->next->sym->declared_at
13595 : &gen_dt->generic->sym->declared_at,
13596 &sym->declared_at))
13597 return false;
13598
13599 /* Resolve the finalizer procedures. */
13600 if (!gfc_resolve_finalizers (sym, NULL))
13601 return false;
13602
13603 if (sym->attr.is_class && sym->ts.u.derived == NULL)
13604 {
13605 /* Fix up incomplete CLASS symbols. */
13606 gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
13607 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
13608
13609 /* Nothing more to do for unlimited polymorphic entities. */
13610 if (data->ts.u.derived->attr.unlimited_polymorphic)
13611 return true;
13612 else if (vptr->ts.u.derived == NULL)
13613 {
13614 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
13615 gcc_assert (vtab);
13616 vptr->ts.u.derived = vtab->ts.u.derived;
13617 }
13618 }
13619
13620 if (!resolve_fl_derived0 (sym))
13621 return false;
13622
13623 /* Resolve the type-bound procedures. */
13624 if (!resolve_typebound_procedures (sym))
13625 return false;
13626
13627 return true;
13628 }
13629
13630
13631 static bool
resolve_fl_namelist(gfc_symbol * sym)13632 resolve_fl_namelist (gfc_symbol *sym)
13633 {
13634 gfc_namelist *nl;
13635 gfc_symbol *nlsym;
13636
13637 for (nl = sym->namelist; nl; nl = nl->next)
13638 {
13639 /* Check again, the check in match only works if NAMELIST comes
13640 after the decl. */
13641 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
13642 {
13643 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
13644 "allowed", nl->sym->name, sym->name, &sym->declared_at);
13645 return false;
13646 }
13647
13648 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
13649 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
13650 "with assumed shape in namelist %qs at %L",
13651 nl->sym->name, sym->name, &sym->declared_at))
13652 return false;
13653
13654 if (is_non_constant_shape_array (nl->sym)
13655 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
13656 "with nonconstant shape in namelist %qs at %L",
13657 nl->sym->name, sym->name, &sym->declared_at))
13658 return false;
13659
13660 if (nl->sym->ts.type == BT_CHARACTER
13661 && (nl->sym->ts.u.cl->length == NULL
13662 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
13663 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
13664 "nonconstant character length in "
13665 "namelist %qs at %L", nl->sym->name,
13666 sym->name, &sym->declared_at))
13667 return false;
13668
13669 /* FIXME: Once UDDTIO is implemented, the following can be
13670 removed. */
13671 if (nl->sym->ts.type == BT_CLASS)
13672 {
13673 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
13674 "polymorphic and requires a defined input/output "
13675 "procedure", nl->sym->name, sym->name, &sym->declared_at);
13676 return false;
13677 }
13678
13679 if (nl->sym->ts.type == BT_DERIVED
13680 && (nl->sym->ts.u.derived->attr.alloc_comp
13681 || nl->sym->ts.u.derived->attr.pointer_comp))
13682 {
13683 if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
13684 "namelist %qs at %L with ALLOCATABLE "
13685 "or POINTER components", nl->sym->name,
13686 sym->name, &sym->declared_at))
13687 return false;
13688
13689 /* FIXME: Once UDDTIO is implemented, the following can be
13690 removed. */
13691 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
13692 "ALLOCATABLE or POINTER components and thus requires "
13693 "a defined input/output procedure", nl->sym->name,
13694 sym->name, &sym->declared_at);
13695 return false;
13696 }
13697 }
13698
13699 /* Reject PRIVATE objects in a PUBLIC namelist. */
13700 if (gfc_check_symbol_access (sym))
13701 {
13702 for (nl = sym->namelist; nl; nl = nl->next)
13703 {
13704 if (!nl->sym->attr.use_assoc
13705 && !is_sym_host_assoc (nl->sym, sym->ns)
13706 && !gfc_check_symbol_access (nl->sym))
13707 {
13708 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
13709 "cannot be member of PUBLIC namelist %qs at %L",
13710 nl->sym->name, sym->name, &sym->declared_at);
13711 return false;
13712 }
13713
13714 /* Types with private components that came here by USE-association. */
13715 if (nl->sym->ts.type == BT_DERIVED
13716 && derived_inaccessible (nl->sym->ts.u.derived))
13717 {
13718 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13719 "components and cannot be member of namelist %qs at %L",
13720 nl->sym->name, sym->name, &sym->declared_at);
13721 return false;
13722 }
13723
13724 /* Types with private components that are defined in the same module. */
13725 if (nl->sym->ts.type == BT_DERIVED
13726 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
13727 && nl->sym->ts.u.derived->attr.private_comp)
13728 {
13729 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13730 "cannot be a member of PUBLIC namelist %qs at %L",
13731 nl->sym->name, sym->name, &sym->declared_at);
13732 return false;
13733 }
13734 }
13735 }
13736
13737
13738 /* 14.1.2 A module or internal procedure represent local entities
13739 of the same type as a namelist member and so are not allowed. */
13740 for (nl = sym->namelist; nl; nl = nl->next)
13741 {
13742 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
13743 continue;
13744
13745 if (nl->sym->attr.function && nl->sym == nl->sym->result)
13746 if ((nl->sym == sym->ns->proc_name)
13747 ||
13748 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
13749 continue;
13750
13751 nlsym = NULL;
13752 if (nl->sym->name)
13753 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
13754 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
13755 {
13756 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13757 "attribute in %qs at %L", nlsym->name,
13758 &sym->declared_at);
13759 return false;
13760 }
13761 }
13762
13763 return true;
13764 }
13765
13766
13767 static bool
resolve_fl_parameter(gfc_symbol * sym)13768 resolve_fl_parameter (gfc_symbol *sym)
13769 {
13770 /* A parameter array's shape needs to be constant. */
13771 if (sym->as != NULL
13772 && (sym->as->type == AS_DEFERRED
13773 || is_non_constant_shape_array (sym)))
13774 {
13775 gfc_error ("Parameter array %qs at %L cannot be automatic "
13776 "or of deferred shape", sym->name, &sym->declared_at);
13777 return false;
13778 }
13779
13780 /* Constraints on deferred type parameter. */
13781 if (!deferred_requirements (sym))
13782 return false;
13783
13784 /* Make sure a parameter that has been implicitly typed still
13785 matches the implicit type, since PARAMETER statements can precede
13786 IMPLICIT statements. */
13787 if (sym->attr.implicit_type
13788 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
13789 sym->ns)))
13790 {
13791 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13792 "later IMPLICIT type", sym->name, &sym->declared_at);
13793 return false;
13794 }
13795
13796 /* Make sure the types of derived parameters are consistent. This
13797 type checking is deferred until resolution because the type may
13798 refer to a derived type from the host. */
13799 if (sym->ts.type == BT_DERIVED
13800 && !gfc_compare_types (&sym->ts, &sym->value->ts))
13801 {
13802 gfc_error ("Incompatible derived type in PARAMETER at %L",
13803 &sym->value->where);
13804 return false;
13805 }
13806 return true;
13807 }
13808
13809
13810 /* Do anything necessary to resolve a symbol. Right now, we just
13811 assume that an otherwise unknown symbol is a variable. This sort
13812 of thing commonly happens for symbols in module. */
13813
13814 static void
resolve_symbol(gfc_symbol * sym)13815 resolve_symbol (gfc_symbol *sym)
13816 {
13817 int check_constant, mp_flag;
13818 gfc_symtree *symtree;
13819 gfc_symtree *this_symtree;
13820 gfc_namespace *ns;
13821 gfc_component *c;
13822 symbol_attribute class_attr;
13823 gfc_array_spec *as;
13824 bool saved_specification_expr;
13825
13826 if (sym->resolved)
13827 return;
13828 sym->resolved = 1;
13829
13830 /* No symbol will ever have union type; only components can be unions.
13831 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
13832 (just like derived type declaration symbols have flavor FL_DERIVED). */
13833 gcc_assert (sym->ts.type != BT_UNION);
13834
13835 if (sym->attr.artificial)
13836 return;
13837
13838 if (sym->attr.unlimited_polymorphic)
13839 return;
13840
13841 if (sym->attr.flavor == FL_UNKNOWN
13842 || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
13843 && !sym->attr.generic && !sym->attr.external
13844 && sym->attr.if_source == IFSRC_UNKNOWN
13845 && sym->ts.type == BT_UNKNOWN))
13846 {
13847
13848 /* If we find that a flavorless symbol is an interface in one of the
13849 parent namespaces, find its symtree in this namespace, free the
13850 symbol and set the symtree to point to the interface symbol. */
13851 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
13852 {
13853 symtree = gfc_find_symtree (ns->sym_root, sym->name);
13854 if (symtree && (symtree->n.sym->generic ||
13855 (symtree->n.sym->attr.flavor == FL_PROCEDURE
13856 && sym->ns->construct_entities)))
13857 {
13858 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
13859 sym->name);
13860 if (this_symtree->n.sym == sym)
13861 {
13862 symtree->n.sym->refs++;
13863 gfc_release_symbol (sym);
13864 this_symtree->n.sym = symtree->n.sym;
13865 return;
13866 }
13867 }
13868 }
13869
13870 /* Otherwise give it a flavor according to such attributes as
13871 it has. */
13872 if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
13873 && sym->attr.intrinsic == 0)
13874 sym->attr.flavor = FL_VARIABLE;
13875 else if (sym->attr.flavor == FL_UNKNOWN)
13876 {
13877 sym->attr.flavor = FL_PROCEDURE;
13878 if (sym->attr.dimension)
13879 sym->attr.function = 1;
13880 }
13881 }
13882
13883 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
13884 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
13885
13886 if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
13887 && !resolve_procedure_interface (sym))
13888 return;
13889
13890 if (sym->attr.is_protected && !sym->attr.proc_pointer
13891 && (sym->attr.procedure || sym->attr.external))
13892 {
13893 if (sym->attr.external)
13894 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13895 "at %L", &sym->declared_at);
13896 else
13897 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13898 "at %L", &sym->declared_at);
13899
13900 return;
13901 }
13902
13903 if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
13904 return;
13905
13906 else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
13907 && !resolve_fl_struct (sym))
13908 return;
13909
13910 /* Symbols that are module procedures with results (functions) have
13911 the types and array specification copied for type checking in
13912 procedures that call them, as well as for saving to a module
13913 file. These symbols can't stand the scrutiny that their results
13914 can. */
13915 mp_flag = (sym->result != NULL && sym->result != sym);
13916
13917 /* Make sure that the intrinsic is consistent with its internal
13918 representation. This needs to be done before assigning a default
13919 type to avoid spurious warnings. */
13920 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
13921 && !gfc_resolve_intrinsic (sym, &sym->declared_at))
13922 return;
13923
13924 /* Resolve associate names. */
13925 if (sym->assoc)
13926 resolve_assoc_var (sym, true);
13927
13928 /* Assign default type to symbols that need one and don't have one. */
13929 if (sym->ts.type == BT_UNKNOWN)
13930 {
13931 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
13932 {
13933 gfc_set_default_type (sym, 1, NULL);
13934 }
13935
13936 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
13937 && !sym->attr.function && !sym->attr.subroutine
13938 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
13939 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
13940
13941 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
13942 {
13943 /* The specific case of an external procedure should emit an error
13944 in the case that there is no implicit type. */
13945 if (!mp_flag)
13946 gfc_set_default_type (sym, sym->attr.external, NULL);
13947 else
13948 {
13949 /* Result may be in another namespace. */
13950 resolve_symbol (sym->result);
13951
13952 if (!sym->result->attr.proc_pointer)
13953 {
13954 sym->ts = sym->result->ts;
13955 sym->as = gfc_copy_array_spec (sym->result->as);
13956 sym->attr.dimension = sym->result->attr.dimension;
13957 sym->attr.pointer = sym->result->attr.pointer;
13958 sym->attr.allocatable = sym->result->attr.allocatable;
13959 sym->attr.contiguous = sym->result->attr.contiguous;
13960 }
13961 }
13962 }
13963 }
13964 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
13965 {
13966 bool saved_specification_expr = specification_expr;
13967 specification_expr = true;
13968 gfc_resolve_array_spec (sym->result->as, false);
13969 specification_expr = saved_specification_expr;
13970 }
13971
13972 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
13973 {
13974 as = CLASS_DATA (sym)->as;
13975 class_attr = CLASS_DATA (sym)->attr;
13976 class_attr.pointer = class_attr.class_pointer;
13977 }
13978 else
13979 {
13980 class_attr = sym->attr;
13981 as = sym->as;
13982 }
13983
13984 /* F2008, C530. */
13985 if (sym->attr.contiguous
13986 && (!class_attr.dimension
13987 || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
13988 && !class_attr.pointer)))
13989 {
13990 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13991 "array pointer or an assumed-shape or assumed-rank array",
13992 sym->name, &sym->declared_at);
13993 return;
13994 }
13995
13996 /* Assumed size arrays and assumed shape arrays must be dummy
13997 arguments. Array-spec's of implied-shape should have been resolved to
13998 AS_EXPLICIT already. */
13999
14000 if (as)
14001 {
14002 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
14003 specification expression. */
14004 if (as->type == AS_IMPLIED_SHAPE)
14005 {
14006 int i;
14007 for (i=0; i<as->rank; i++)
14008 {
14009 if (as->lower[i] != NULL && as->upper[i] == NULL)
14010 {
14011 gfc_error ("Bad specification for assumed size array at %L",
14012 &as->lower[i]->where);
14013 return;
14014 }
14015 }
14016 gcc_unreachable();
14017 }
14018
14019 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
14020 || as->type == AS_ASSUMED_SHAPE)
14021 && !sym->attr.dummy && !sym->attr.select_type_temporary)
14022 {
14023 if (as->type == AS_ASSUMED_SIZE)
14024 gfc_error ("Assumed size array at %L must be a dummy argument",
14025 &sym->declared_at);
14026 else
14027 gfc_error ("Assumed shape array at %L must be a dummy argument",
14028 &sym->declared_at);
14029 return;
14030 }
14031 /* TS 29113, C535a. */
14032 if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
14033 && !sym->attr.select_type_temporary)
14034 {
14035 gfc_error ("Assumed-rank array at %L must be a dummy argument",
14036 &sym->declared_at);
14037 return;
14038 }
14039 if (as->type == AS_ASSUMED_RANK
14040 && (sym->attr.codimension || sym->attr.value))
14041 {
14042 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
14043 "CODIMENSION attribute", &sym->declared_at);
14044 return;
14045 }
14046 }
14047
14048 /* Make sure symbols with known intent or optional are really dummy
14049 variable. Because of ENTRY statement, this has to be deferred
14050 until resolution time. */
14051
14052 if (!sym->attr.dummy
14053 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
14054 {
14055 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
14056 return;
14057 }
14058
14059 if (sym->attr.value && !sym->attr.dummy)
14060 {
14061 gfc_error ("%qs at %L cannot have the VALUE attribute because "
14062 "it is not a dummy argument", sym->name, &sym->declared_at);
14063 return;
14064 }
14065
14066 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
14067 {
14068 gfc_charlen *cl = sym->ts.u.cl;
14069 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
14070 {
14071 gfc_error ("Character dummy variable %qs at %L with VALUE "
14072 "attribute must have constant length",
14073 sym->name, &sym->declared_at);
14074 return;
14075 }
14076
14077 if (sym->ts.is_c_interop
14078 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
14079 {
14080 gfc_error ("C interoperable character dummy variable %qs at %L "
14081 "with VALUE attribute must have length one",
14082 sym->name, &sym->declared_at);
14083 return;
14084 }
14085 }
14086
14087 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
14088 && sym->ts.u.derived->attr.generic)
14089 {
14090 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
14091 if (!sym->ts.u.derived)
14092 {
14093 gfc_error ("The derived type %qs at %L is of type %qs, "
14094 "which has not been defined", sym->name,
14095 &sym->declared_at, sym->ts.u.derived->name);
14096 sym->ts.type = BT_UNKNOWN;
14097 return;
14098 }
14099 }
14100
14101 /* Use the same constraints as TYPE(*), except for the type check
14102 and that only scalars and assumed-size arrays are permitted. */
14103 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
14104 {
14105 if (!sym->attr.dummy)
14106 {
14107 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14108 "a dummy argument", sym->name, &sym->declared_at);
14109 return;
14110 }
14111
14112 if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
14113 && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
14114 && sym->ts.type != BT_COMPLEX)
14115 {
14116 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
14117 "of type TYPE(*) or of an numeric intrinsic type",
14118 sym->name, &sym->declared_at);
14119 return;
14120 }
14121
14122 if (sym->attr.allocatable || sym->attr.codimension
14123 || sym->attr.pointer || sym->attr.value)
14124 {
14125 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14126 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
14127 "attribute", sym->name, &sym->declared_at);
14128 return;
14129 }
14130
14131 if (sym->attr.intent == INTENT_OUT)
14132 {
14133 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
14134 "have the INTENT(OUT) attribute",
14135 sym->name, &sym->declared_at);
14136 return;
14137 }
14138 if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
14139 {
14140 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
14141 "either be a scalar or an assumed-size array",
14142 sym->name, &sym->declared_at);
14143 return;
14144 }
14145
14146 /* Set the type to TYPE(*) and add a dimension(*) to ensure
14147 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
14148 packing. */
14149 sym->ts.type = BT_ASSUMED;
14150 sym->as = gfc_get_array_spec ();
14151 sym->as->type = AS_ASSUMED_SIZE;
14152 sym->as->rank = 1;
14153 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
14154 }
14155 else if (sym->ts.type == BT_ASSUMED)
14156 {
14157 /* TS 29113, C407a. */
14158 if (!sym->attr.dummy)
14159 {
14160 gfc_error ("Assumed type of variable %s at %L is only permitted "
14161 "for dummy variables", sym->name, &sym->declared_at);
14162 return;
14163 }
14164 if (sym->attr.allocatable || sym->attr.codimension
14165 || sym->attr.pointer || sym->attr.value)
14166 {
14167 gfc_error ("Assumed-type variable %s at %L may not have the "
14168 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
14169 sym->name, &sym->declared_at);
14170 return;
14171 }
14172 if (sym->attr.intent == INTENT_OUT)
14173 {
14174 gfc_error ("Assumed-type variable %s at %L may not have the "
14175 "INTENT(OUT) attribute",
14176 sym->name, &sym->declared_at);
14177 return;
14178 }
14179 if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
14180 {
14181 gfc_error ("Assumed-type variable %s at %L shall not be an "
14182 "explicit-shape array", sym->name, &sym->declared_at);
14183 return;
14184 }
14185 }
14186
14187 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
14188 do this for something that was implicitly typed because that is handled
14189 in gfc_set_default_type. Handle dummy arguments and procedure
14190 definitions separately. Also, anything that is use associated is not
14191 handled here but instead is handled in the module it is declared in.
14192 Finally, derived type definitions are allowed to be BIND(C) since that
14193 only implies that they're interoperable, and they are checked fully for
14194 interoperability when a variable is declared of that type. */
14195 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
14196 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
14197 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
14198 {
14199 bool t = true;
14200
14201 /* First, make sure the variable is declared at the
14202 module-level scope (J3/04-007, Section 15.3). */
14203 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
14204 sym->attr.in_common == 0)
14205 {
14206 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
14207 "is neither a COMMON block nor declared at the "
14208 "module level scope", sym->name, &(sym->declared_at));
14209 t = false;
14210 }
14211 else if (sym->common_head != NULL)
14212 {
14213 t = verify_com_block_vars_c_interop (sym->common_head);
14214 }
14215 else
14216 {
14217 /* If type() declaration, we need to verify that the components
14218 of the given type are all C interoperable, etc. */
14219 if (sym->ts.type == BT_DERIVED &&
14220 sym->ts.u.derived->attr.is_c_interop != 1)
14221 {
14222 /* Make sure the user marked the derived type as BIND(C). If
14223 not, call the verify routine. This could print an error
14224 for the derived type more than once if multiple variables
14225 of that type are declared. */
14226 if (sym->ts.u.derived->attr.is_bind_c != 1)
14227 verify_bind_c_derived_type (sym->ts.u.derived);
14228 t = false;
14229 }
14230
14231 /* Verify the variable itself as C interoperable if it
14232 is BIND(C). It is not possible for this to succeed if
14233 the verify_bind_c_derived_type failed, so don't have to handle
14234 any error returned by verify_bind_c_derived_type. */
14235 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
14236 sym->common_block);
14237 }
14238
14239 if (!t)
14240 {
14241 /* clear the is_bind_c flag to prevent reporting errors more than
14242 once if something failed. */
14243 sym->attr.is_bind_c = 0;
14244 return;
14245 }
14246 }
14247
14248 /* If a derived type symbol has reached this point, without its
14249 type being declared, we have an error. Notice that most
14250 conditions that produce undefined derived types have already
14251 been dealt with. However, the likes of:
14252 implicit type(t) (t) ..... call foo (t) will get us here if
14253 the type is not declared in the scope of the implicit
14254 statement. Change the type to BT_UNKNOWN, both because it is so
14255 and to prevent an ICE. */
14256 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
14257 && sym->ts.u.derived->components == NULL
14258 && !sym->ts.u.derived->attr.zero_comp)
14259 {
14260 gfc_error ("The derived type %qs at %L is of type %qs, "
14261 "which has not been defined", sym->name,
14262 &sym->declared_at, sym->ts.u.derived->name);
14263 sym->ts.type = BT_UNKNOWN;
14264 return;
14265 }
14266
14267 /* Make sure that the derived type has been resolved and that the
14268 derived type is visible in the symbol's namespace, if it is a
14269 module function and is not PRIVATE. */
14270 if (sym->ts.type == BT_DERIVED
14271 && sym->ts.u.derived->attr.use_assoc
14272 && sym->ns->proc_name
14273 && sym->ns->proc_name->attr.flavor == FL_MODULE
14274 && !resolve_fl_derived (sym->ts.u.derived))
14275 return;
14276
14277 /* Unless the derived-type declaration is use associated, Fortran 95
14278 does not allow public entries of private derived types.
14279 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
14280 161 in 95-006r3. */
14281 if (sym->ts.type == BT_DERIVED
14282 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
14283 && !sym->ts.u.derived->attr.use_assoc
14284 && gfc_check_symbol_access (sym)
14285 && !gfc_check_symbol_access (sym->ts.u.derived)
14286 && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
14287 "derived type %qs",
14288 (sym->attr.flavor == FL_PARAMETER)
14289 ? "parameter" : "variable",
14290 sym->name, &sym->declared_at,
14291 sym->ts.u.derived->name))
14292 return;
14293
14294 /* F2008, C1302. */
14295 if (sym->ts.type == BT_DERIVED
14296 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
14297 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
14298 || sym->ts.u.derived->attr.lock_comp)
14299 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
14300 {
14301 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
14302 "type LOCK_TYPE must be a coarray", sym->name,
14303 &sym->declared_at);
14304 return;
14305 }
14306
14307 /* TS18508, C702/C703. */
14308 if (sym->ts.type == BT_DERIVED
14309 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
14310 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
14311 || sym->ts.u.derived->attr.event_comp)
14312 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
14313 {
14314 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
14315 "type LOCK_TYPE must be a coarray", sym->name,
14316 &sym->declared_at);
14317 return;
14318 }
14319
14320 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
14321 default initialization is defined (5.1.2.4.4). */
14322 if (sym->ts.type == BT_DERIVED
14323 && sym->attr.dummy
14324 && sym->attr.intent == INTENT_OUT
14325 && sym->as
14326 && sym->as->type == AS_ASSUMED_SIZE)
14327 {
14328 for (c = sym->ts.u.derived->components; c; c = c->next)
14329 {
14330 if (c->initializer)
14331 {
14332 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
14333 "ASSUMED SIZE and so cannot have a default initializer",
14334 sym->name, &sym->declared_at);
14335 return;
14336 }
14337 }
14338 }
14339
14340 /* F2008, C542. */
14341 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
14342 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
14343 {
14344 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
14345 "INTENT(OUT)", sym->name, &sym->declared_at);
14346 return;
14347 }
14348
14349 /* TS18508. */
14350 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
14351 && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
14352 {
14353 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
14354 "INTENT(OUT)", sym->name, &sym->declared_at);
14355 return;
14356 }
14357
14358 /* F2008, C525. */
14359 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
14360 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
14361 && CLASS_DATA (sym)->attr.coarray_comp))
14362 || class_attr.codimension)
14363 && (sym->attr.result || sym->result == sym))
14364 {
14365 gfc_error ("Function result %qs at %L shall not be a coarray or have "
14366 "a coarray component", sym->name, &sym->declared_at);
14367 return;
14368 }
14369
14370 /* F2008, C524. */
14371 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
14372 && sym->ts.u.derived->ts.is_iso_c)
14373 {
14374 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14375 "shall not be a coarray", sym->name, &sym->declared_at);
14376 return;
14377 }
14378
14379 /* F2008, C525. */
14380 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
14381 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
14382 && CLASS_DATA (sym)->attr.coarray_comp))
14383 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
14384 || class_attr.allocatable))
14385 {
14386 gfc_error ("Variable %qs at %L with coarray component shall be a "
14387 "nonpointer, nonallocatable scalar, which is not a coarray",
14388 sym->name, &sym->declared_at);
14389 return;
14390 }
14391
14392 /* F2008, C526. The function-result case was handled above. */
14393 if (class_attr.codimension
14394 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
14395 || sym->attr.select_type_temporary
14396 || sym->ns->save_all
14397 || sym->ns->proc_name->attr.flavor == FL_MODULE
14398 || sym->ns->proc_name->attr.is_main_program
14399 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
14400 {
14401 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
14402 "nor a dummy argument", sym->name, &sym->declared_at);
14403 return;
14404 }
14405 /* F2008, C528. */
14406 else if (class_attr.codimension && !sym->attr.select_type_temporary
14407 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
14408 {
14409 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
14410 "deferred shape", sym->name, &sym->declared_at);
14411 return;
14412 }
14413 else if (class_attr.codimension && class_attr.allocatable && as
14414 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
14415 {
14416 gfc_error ("Allocatable coarray variable %qs at %L must have "
14417 "deferred shape", sym->name, &sym->declared_at);
14418 return;
14419 }
14420
14421 /* F2008, C541. */
14422 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
14423 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
14424 && CLASS_DATA (sym)->attr.coarray_comp))
14425 || (class_attr.codimension && class_attr.allocatable))
14426 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
14427 {
14428 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
14429 "allocatable coarray or have coarray components",
14430 sym->name, &sym->declared_at);
14431 return;
14432 }
14433
14434 if (class_attr.codimension && sym->attr.dummy
14435 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
14436 {
14437 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
14438 "procedure %qs", sym->name, &sym->declared_at,
14439 sym->ns->proc_name->name);
14440 return;
14441 }
14442
14443 if (sym->ts.type == BT_LOGICAL
14444 && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
14445 || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
14446 && sym->ns->proc_name->attr.is_bind_c)))
14447 {
14448 int i;
14449 for (i = 0; gfc_logical_kinds[i].kind; i++)
14450 if (gfc_logical_kinds[i].kind == sym->ts.kind)
14451 break;
14452 if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
14453 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
14454 "%L with non-C_Bool kind in BIND(C) procedure "
14455 "%qs", sym->name, &sym->declared_at,
14456 sym->ns->proc_name->name))
14457 return;
14458 else if (!gfc_logical_kinds[i].c_bool
14459 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
14460 "%qs at %L with non-C_Bool kind in "
14461 "BIND(C) procedure %qs", sym->name,
14462 &sym->declared_at,
14463 sym->attr.function ? sym->name
14464 : sym->ns->proc_name->name))
14465 return;
14466 }
14467
14468 switch (sym->attr.flavor)
14469 {
14470 case FL_VARIABLE:
14471 if (!resolve_fl_variable (sym, mp_flag))
14472 return;
14473 break;
14474
14475 case FL_PROCEDURE:
14476 if (sym->formal && !sym->formal_ns)
14477 {
14478 /* Check that none of the arguments are a namelist. */
14479 gfc_formal_arglist *formal = sym->formal;
14480
14481 for (; formal; formal = formal->next)
14482 if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
14483 {
14484 gfc_error ("Namelist '%s' can not be an argument to "
14485 "subroutine or function at %L",
14486 formal->sym->name, &sym->declared_at);
14487 return;
14488 }
14489 }
14490
14491 if (!resolve_fl_procedure (sym, mp_flag))
14492 return;
14493 break;
14494
14495 case FL_NAMELIST:
14496 if (!resolve_fl_namelist (sym))
14497 return;
14498 break;
14499
14500 case FL_PARAMETER:
14501 if (!resolve_fl_parameter (sym))
14502 return;
14503 break;
14504
14505 default:
14506 break;
14507 }
14508
14509 /* Resolve array specifier. Check as well some constraints
14510 on COMMON blocks. */
14511
14512 check_constant = sym->attr.in_common && !sym->attr.pointer;
14513
14514 /* Set the formal_arg_flag so that check_conflict will not throw
14515 an error for host associated variables in the specification
14516 expression for an array_valued function. */
14517 if (sym->attr.function && sym->as)
14518 formal_arg_flag = 1;
14519
14520 saved_specification_expr = specification_expr;
14521 specification_expr = true;
14522 gfc_resolve_array_spec (sym->as, check_constant);
14523 specification_expr = saved_specification_expr;
14524
14525 formal_arg_flag = 0;
14526
14527 /* Resolve formal namespaces. */
14528 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
14529 && !sym->attr.contained && !sym->attr.intrinsic)
14530 gfc_resolve (sym->formal_ns);
14531
14532 /* Make sure the formal namespace is present. */
14533 if (sym->formal && !sym->formal_ns)
14534 {
14535 gfc_formal_arglist *formal = sym->formal;
14536 while (formal && !formal->sym)
14537 formal = formal->next;
14538
14539 if (formal)
14540 {
14541 sym->formal_ns = formal->sym->ns;
14542 if (sym->ns != formal->sym->ns)
14543 sym->formal_ns->refs++;
14544 }
14545 }
14546
14547 /* Check threadprivate restrictions. */
14548 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
14549 && (!sym->attr.in_common
14550 && sym->module == NULL
14551 && (sym->ns->proc_name == NULL
14552 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
14553 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
14554
14555 /* Check omp declare target restrictions. */
14556 if (sym->attr.omp_declare_target
14557 && sym->attr.flavor == FL_VARIABLE
14558 && !sym->attr.save
14559 && !sym->ns->save_all
14560 && (!sym->attr.in_common
14561 && sym->module == NULL
14562 && (sym->ns->proc_name == NULL
14563 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
14564 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
14565 sym->name, &sym->declared_at);
14566
14567 /* If we have come this far we can apply default-initializers, as
14568 described in 14.7.5, to those variables that have not already
14569 been assigned one. */
14570 if (sym->ts.type == BT_DERIVED
14571 && !sym->value
14572 && !sym->attr.allocatable
14573 && !sym->attr.alloc_comp)
14574 {
14575 symbol_attribute *a = &sym->attr;
14576
14577 if ((!a->save && !a->dummy && !a->pointer
14578 && !a->in_common && !a->use_assoc
14579 && a->referenced
14580 && !((a->function || a->result)
14581 && (!a->dimension
14582 || sym->ts.u.derived->attr.alloc_comp
14583 || sym->ts.u.derived->attr.pointer_comp))
14584 && !(a->function && sym != sym->result))
14585 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
14586 apply_default_init (sym);
14587 else if (a->function && sym->result && a->access != ACCESS_PRIVATE
14588 && (sym->ts.u.derived->attr.alloc_comp
14589 || sym->ts.u.derived->attr.pointer_comp))
14590 /* Mark the result symbol to be referenced, when it has allocatable
14591 components. */
14592 sym->result->attr.referenced = 1;
14593 }
14594
14595 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
14596 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
14597 && !CLASS_DATA (sym)->attr.class_pointer
14598 && !CLASS_DATA (sym)->attr.allocatable)
14599 apply_default_init (sym);
14600
14601 /* If this symbol has a type-spec, check it. */
14602 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
14603 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
14604 if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
14605 return;
14606 }
14607
14608
14609 /************* Resolve DATA statements *************/
14610
14611 static struct
14612 {
14613 gfc_data_value *vnode;
14614 mpz_t left;
14615 }
14616 values;
14617
14618
14619 /* Advance the values structure to point to the next value in the data list. */
14620
14621 static bool
next_data_value(void)14622 next_data_value (void)
14623 {
14624 while (mpz_cmp_ui (values.left, 0) == 0)
14625 {
14626
14627 if (values.vnode->next == NULL)
14628 return false;
14629
14630 values.vnode = values.vnode->next;
14631 mpz_set (values.left, values.vnode->repeat);
14632 }
14633
14634 return true;
14635 }
14636
14637
14638 static bool
check_data_variable(gfc_data_variable * var,locus * where)14639 check_data_variable (gfc_data_variable *var, locus *where)
14640 {
14641 gfc_expr *e;
14642 mpz_t size;
14643 mpz_t offset;
14644 bool t;
14645 ar_type mark = AR_UNKNOWN;
14646 int i;
14647 mpz_t section_index[GFC_MAX_DIMENSIONS];
14648 gfc_ref *ref;
14649 gfc_array_ref *ar;
14650 gfc_symbol *sym;
14651 int has_pointer;
14652
14653 if (!gfc_resolve_expr (var->expr))
14654 return false;
14655
14656 ar = NULL;
14657 mpz_init_set_si (offset, 0);
14658 e = var->expr;
14659
14660 if (e->expr_type != EXPR_VARIABLE)
14661 gfc_internal_error ("check_data_variable(): Bad expression");
14662
14663 sym = e->symtree->n.sym;
14664
14665 if (sym->ns->is_block_data && !sym->attr.in_common)
14666 {
14667 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
14668 sym->name, &sym->declared_at);
14669 }
14670
14671 if (e->ref == NULL && sym->as)
14672 {
14673 gfc_error ("DATA array %qs at %L must be specified in a previous"
14674 " declaration", sym->name, where);
14675 return false;
14676 }
14677
14678 has_pointer = sym->attr.pointer;
14679
14680 if (gfc_is_coindexed (e))
14681 {
14682 gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
14683 where);
14684 return false;
14685 }
14686
14687 for (ref = e->ref; ref; ref = ref->next)
14688 {
14689 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
14690 has_pointer = 1;
14691
14692 if (has_pointer
14693 && ref->type == REF_ARRAY
14694 && ref->u.ar.type != AR_FULL)
14695 {
14696 gfc_error ("DATA element %qs at %L is a pointer and so must "
14697 "be a full array", sym->name, where);
14698 return false;
14699 }
14700 }
14701
14702 if (e->rank == 0 || has_pointer)
14703 {
14704 mpz_init_set_ui (size, 1);
14705 ref = NULL;
14706 }
14707 else
14708 {
14709 ref = e->ref;
14710
14711 /* Find the array section reference. */
14712 for (ref = e->ref; ref; ref = ref->next)
14713 {
14714 if (ref->type != REF_ARRAY)
14715 continue;
14716 if (ref->u.ar.type == AR_ELEMENT)
14717 continue;
14718 break;
14719 }
14720 gcc_assert (ref);
14721
14722 /* Set marks according to the reference pattern. */
14723 switch (ref->u.ar.type)
14724 {
14725 case AR_FULL:
14726 mark = AR_FULL;
14727 break;
14728
14729 case AR_SECTION:
14730 ar = &ref->u.ar;
14731 /* Get the start position of array section. */
14732 gfc_get_section_index (ar, section_index, &offset);
14733 mark = AR_SECTION;
14734 break;
14735
14736 default:
14737 gcc_unreachable ();
14738 }
14739
14740 if (!gfc_array_size (e, &size))
14741 {
14742 gfc_error ("Nonconstant array section at %L in DATA statement",
14743 &e->where);
14744 mpz_clear (offset);
14745 return false;
14746 }
14747 }
14748
14749 t = true;
14750
14751 while (mpz_cmp_ui (size, 0) > 0)
14752 {
14753 if (!next_data_value ())
14754 {
14755 gfc_error ("DATA statement at %L has more variables than values",
14756 where);
14757 t = false;
14758 break;
14759 }
14760
14761 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
14762 if (!t)
14763 break;
14764
14765 /* If we have more than one element left in the repeat count,
14766 and we have more than one element left in the target variable,
14767 then create a range assignment. */
14768 /* FIXME: Only done for full arrays for now, since array sections
14769 seem tricky. */
14770 if (mark == AR_FULL && ref && ref->next == NULL
14771 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
14772 {
14773 mpz_t range;
14774
14775 if (mpz_cmp (size, values.left) >= 0)
14776 {
14777 mpz_init_set (range, values.left);
14778 mpz_sub (size, size, values.left);
14779 mpz_set_ui (values.left, 0);
14780 }
14781 else
14782 {
14783 mpz_init_set (range, size);
14784 mpz_sub (values.left, values.left, size);
14785 mpz_set_ui (size, 0);
14786 }
14787
14788 t = gfc_assign_data_value (var->expr, values.vnode->expr,
14789 offset, &range);
14790
14791 mpz_add (offset, offset, range);
14792 mpz_clear (range);
14793
14794 if (!t)
14795 break;
14796 }
14797
14798 /* Assign initial value to symbol. */
14799 else
14800 {
14801 mpz_sub_ui (values.left, values.left, 1);
14802 mpz_sub_ui (size, size, 1);
14803
14804 t = gfc_assign_data_value (var->expr, values.vnode->expr,
14805 offset, NULL);
14806 if (!t)
14807 break;
14808
14809 if (mark == AR_FULL)
14810 mpz_add_ui (offset, offset, 1);
14811
14812 /* Modify the array section indexes and recalculate the offset
14813 for next element. */
14814 else if (mark == AR_SECTION)
14815 gfc_advance_section (section_index, ar, &offset);
14816 }
14817 }
14818
14819 if (mark == AR_SECTION)
14820 {
14821 for (i = 0; i < ar->dimen; i++)
14822 mpz_clear (section_index[i]);
14823 }
14824
14825 mpz_clear (size);
14826 mpz_clear (offset);
14827
14828 return t;
14829 }
14830
14831
14832 static bool traverse_data_var (gfc_data_variable *, locus *);
14833
14834 /* Iterate over a list of elements in a DATA statement. */
14835
14836 static bool
traverse_data_list(gfc_data_variable * var,locus * where)14837 traverse_data_list (gfc_data_variable *var, locus *where)
14838 {
14839 mpz_t trip;
14840 iterator_stack frame;
14841 gfc_expr *e, *start, *end, *step;
14842 bool retval = true;
14843
14844 mpz_init (frame.value);
14845 mpz_init (trip);
14846
14847 start = gfc_copy_expr (var->iter.start);
14848 end = gfc_copy_expr (var->iter.end);
14849 step = gfc_copy_expr (var->iter.step);
14850
14851 if (!gfc_simplify_expr (start, 1)
14852 || start->expr_type != EXPR_CONSTANT)
14853 {
14854 gfc_error ("start of implied-do loop at %L could not be "
14855 "simplified to a constant value", &start->where);
14856 retval = false;
14857 goto cleanup;
14858 }
14859 if (!gfc_simplify_expr (end, 1)
14860 || end->expr_type != EXPR_CONSTANT)
14861 {
14862 gfc_error ("end of implied-do loop at %L could not be "
14863 "simplified to a constant value", &start->where);
14864 retval = false;
14865 goto cleanup;
14866 }
14867 if (!gfc_simplify_expr (step, 1)
14868 || step->expr_type != EXPR_CONSTANT)
14869 {
14870 gfc_error ("step of implied-do loop at %L could not be "
14871 "simplified to a constant value", &start->where);
14872 retval = false;
14873 goto cleanup;
14874 }
14875
14876 mpz_set (trip, end->value.integer);
14877 mpz_sub (trip, trip, start->value.integer);
14878 mpz_add (trip, trip, step->value.integer);
14879
14880 mpz_div (trip, trip, step->value.integer);
14881
14882 mpz_set (frame.value, start->value.integer);
14883
14884 frame.prev = iter_stack;
14885 frame.variable = var->iter.var->symtree;
14886 iter_stack = &frame;
14887
14888 while (mpz_cmp_ui (trip, 0) > 0)
14889 {
14890 if (!traverse_data_var (var->list, where))
14891 {
14892 retval = false;
14893 goto cleanup;
14894 }
14895
14896 e = gfc_copy_expr (var->expr);
14897 if (!gfc_simplify_expr (e, 1))
14898 {
14899 gfc_free_expr (e);
14900 retval = false;
14901 goto cleanup;
14902 }
14903
14904 mpz_add (frame.value, frame.value, step->value.integer);
14905
14906 mpz_sub_ui (trip, trip, 1);
14907 }
14908
14909 cleanup:
14910 mpz_clear (frame.value);
14911 mpz_clear (trip);
14912
14913 gfc_free_expr (start);
14914 gfc_free_expr (end);
14915 gfc_free_expr (step);
14916
14917 iter_stack = frame.prev;
14918 return retval;
14919 }
14920
14921
14922 /* Type resolve variables in the variable list of a DATA statement. */
14923
14924 static bool
traverse_data_var(gfc_data_variable * var,locus * where)14925 traverse_data_var (gfc_data_variable *var, locus *where)
14926 {
14927 bool t;
14928
14929 for (; var; var = var->next)
14930 {
14931 if (var->expr == NULL)
14932 t = traverse_data_list (var, where);
14933 else
14934 t = check_data_variable (var, where);
14935
14936 if (!t)
14937 return false;
14938 }
14939
14940 return true;
14941 }
14942
14943
14944 /* Resolve the expressions and iterators associated with a data statement.
14945 This is separate from the assignment checking because data lists should
14946 only be resolved once. */
14947
14948 static bool
resolve_data_variables(gfc_data_variable * d)14949 resolve_data_variables (gfc_data_variable *d)
14950 {
14951 for (; d; d = d->next)
14952 {
14953 if (d->list == NULL)
14954 {
14955 if (!gfc_resolve_expr (d->expr))
14956 return false;
14957 }
14958 else
14959 {
14960 if (!gfc_resolve_iterator (&d->iter, false, true))
14961 return false;
14962
14963 if (!resolve_data_variables (d->list))
14964 return false;
14965 }
14966 }
14967
14968 return true;
14969 }
14970
14971
14972 /* Resolve a single DATA statement. We implement this by storing a pointer to
14973 the value list into static variables, and then recursively traversing the
14974 variables list, expanding iterators and such. */
14975
14976 static void
resolve_data(gfc_data * d)14977 resolve_data (gfc_data *d)
14978 {
14979
14980 if (!resolve_data_variables (d->var))
14981 return;
14982
14983 values.vnode = d->value;
14984 if (d->value == NULL)
14985 mpz_set_ui (values.left, 0);
14986 else
14987 mpz_set (values.left, d->value->repeat);
14988
14989 if (!traverse_data_var (d->var, &d->where))
14990 return;
14991
14992 /* At this point, we better not have any values left. */
14993
14994 if (next_data_value ())
14995 gfc_error ("DATA statement at %L has more values than variables",
14996 &d->where);
14997 }
14998
14999
15000 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
15001 accessed by host or use association, is a dummy argument to a pure function,
15002 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
15003 is storage associated with any such variable, shall not be used in the
15004 following contexts: (clients of this function). */
15005
15006 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
15007 procedure. Returns zero if assignment is OK, nonzero if there is a
15008 problem. */
15009 int
gfc_impure_variable(gfc_symbol * sym)15010 gfc_impure_variable (gfc_symbol *sym)
15011 {
15012 gfc_symbol *proc;
15013 gfc_namespace *ns;
15014
15015 if (sym->attr.use_assoc || sym->attr.in_common)
15016 return 1;
15017
15018 /* Check if the symbol's ns is inside the pure procedure. */
15019 for (ns = gfc_current_ns; ns; ns = ns->parent)
15020 {
15021 if (ns == sym->ns)
15022 break;
15023 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
15024 return 1;
15025 }
15026
15027 proc = sym->ns->proc_name;
15028 if (sym->attr.dummy
15029 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
15030 || proc->attr.function))
15031 return 1;
15032
15033 /* TODO: Sort out what can be storage associated, if anything, and include
15034 it here. In principle equivalences should be scanned but it does not
15035 seem to be possible to storage associate an impure variable this way. */
15036 return 0;
15037 }
15038
15039
15040 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
15041 current namespace is inside a pure procedure. */
15042
15043 int
gfc_pure(gfc_symbol * sym)15044 gfc_pure (gfc_symbol *sym)
15045 {
15046 symbol_attribute attr;
15047 gfc_namespace *ns;
15048
15049 if (sym == NULL)
15050 {
15051 /* Check if the current namespace or one of its parents
15052 belongs to a pure procedure. */
15053 for (ns = gfc_current_ns; ns; ns = ns->parent)
15054 {
15055 sym = ns->proc_name;
15056 if (sym == NULL)
15057 return 0;
15058 attr = sym->attr;
15059 if (attr.flavor == FL_PROCEDURE && attr.pure)
15060 return 1;
15061 }
15062 return 0;
15063 }
15064
15065 attr = sym->attr;
15066
15067 return attr.flavor == FL_PROCEDURE && attr.pure;
15068 }
15069
15070
15071 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
15072 checks if the current namespace is implicitly pure. Note that this
15073 function returns false for a PURE procedure. */
15074
15075 int
gfc_implicit_pure(gfc_symbol * sym)15076 gfc_implicit_pure (gfc_symbol *sym)
15077 {
15078 gfc_namespace *ns;
15079
15080 if (sym == NULL)
15081 {
15082 /* Check if the current procedure is implicit_pure. Walk up
15083 the procedure list until we find a procedure. */
15084 for (ns = gfc_current_ns; ns; ns = ns->parent)
15085 {
15086 sym = ns->proc_name;
15087 if (sym == NULL)
15088 return 0;
15089
15090 if (sym->attr.flavor == FL_PROCEDURE)
15091 break;
15092 }
15093 }
15094
15095 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
15096 && !sym->attr.pure;
15097 }
15098
15099
15100 void
gfc_unset_implicit_pure(gfc_symbol * sym)15101 gfc_unset_implicit_pure (gfc_symbol *sym)
15102 {
15103 gfc_namespace *ns;
15104
15105 if (sym == NULL)
15106 {
15107 /* Check if the current procedure is implicit_pure. Walk up
15108 the procedure list until we find a procedure. */
15109 for (ns = gfc_current_ns; ns; ns = ns->parent)
15110 {
15111 sym = ns->proc_name;
15112 if (sym == NULL)
15113 return;
15114
15115 if (sym->attr.flavor == FL_PROCEDURE)
15116 break;
15117 }
15118 }
15119
15120 if (sym->attr.flavor == FL_PROCEDURE)
15121 sym->attr.implicit_pure = 0;
15122 else
15123 sym->attr.pure = 0;
15124 }
15125
15126
15127 /* Test whether the current procedure is elemental or not. */
15128
15129 int
gfc_elemental(gfc_symbol * sym)15130 gfc_elemental (gfc_symbol *sym)
15131 {
15132 symbol_attribute attr;
15133
15134 if (sym == NULL)
15135 sym = gfc_current_ns->proc_name;
15136 if (sym == NULL)
15137 return 0;
15138 attr = sym->attr;
15139
15140 return attr.flavor == FL_PROCEDURE && attr.elemental;
15141 }
15142
15143
15144 /* Warn about unused labels. */
15145
15146 static void
warn_unused_fortran_label(gfc_st_label * label)15147 warn_unused_fortran_label (gfc_st_label *label)
15148 {
15149 if (label == NULL)
15150 return;
15151
15152 warn_unused_fortran_label (label->left);
15153
15154 if (label->defined == ST_LABEL_UNKNOWN)
15155 return;
15156
15157 switch (label->referenced)
15158 {
15159 case ST_LABEL_UNKNOWN:
15160 gfc_warning (0, "Label %d at %L defined but not used", label->value,
15161 &label->where);
15162 break;
15163
15164 case ST_LABEL_BAD_TARGET:
15165 gfc_warning (0, "Label %d at %L defined but cannot be used",
15166 label->value, &label->where);
15167 break;
15168
15169 default:
15170 break;
15171 }
15172
15173 warn_unused_fortran_label (label->right);
15174 }
15175
15176
15177 /* Returns the sequence type of a symbol or sequence. */
15178
15179 static seq_type
sequence_type(gfc_typespec ts)15180 sequence_type (gfc_typespec ts)
15181 {
15182 seq_type result;
15183 gfc_component *c;
15184
15185 switch (ts.type)
15186 {
15187 case BT_DERIVED:
15188
15189 if (ts.u.derived->components == NULL)
15190 return SEQ_NONDEFAULT;
15191
15192 result = sequence_type (ts.u.derived->components->ts);
15193 for (c = ts.u.derived->components->next; c; c = c->next)
15194 if (sequence_type (c->ts) != result)
15195 return SEQ_MIXED;
15196
15197 return result;
15198
15199 case BT_CHARACTER:
15200 if (ts.kind != gfc_default_character_kind)
15201 return SEQ_NONDEFAULT;
15202
15203 return SEQ_CHARACTER;
15204
15205 case BT_INTEGER:
15206 if (ts.kind != gfc_default_integer_kind)
15207 return SEQ_NONDEFAULT;
15208
15209 return SEQ_NUMERIC;
15210
15211 case BT_REAL:
15212 if (!(ts.kind == gfc_default_real_kind
15213 || ts.kind == gfc_default_double_kind))
15214 return SEQ_NONDEFAULT;
15215
15216 return SEQ_NUMERIC;
15217
15218 case BT_COMPLEX:
15219 if (ts.kind != gfc_default_complex_kind)
15220 return SEQ_NONDEFAULT;
15221
15222 return SEQ_NUMERIC;
15223
15224 case BT_LOGICAL:
15225 if (ts.kind != gfc_default_logical_kind)
15226 return SEQ_NONDEFAULT;
15227
15228 return SEQ_NUMERIC;
15229
15230 default:
15231 return SEQ_NONDEFAULT;
15232 }
15233 }
15234
15235
15236 /* Resolve derived type EQUIVALENCE object. */
15237
15238 static bool
resolve_equivalence_derived(gfc_symbol * derived,gfc_symbol * sym,gfc_expr * e)15239 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
15240 {
15241 gfc_component *c = derived->components;
15242
15243 if (!derived)
15244 return true;
15245
15246 /* Shall not be an object of nonsequence derived type. */
15247 if (!derived->attr.sequence)
15248 {
15249 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
15250 "attribute to be an EQUIVALENCE object", sym->name,
15251 &e->where);
15252 return false;
15253 }
15254
15255 /* Shall not have allocatable components. */
15256 if (derived->attr.alloc_comp)
15257 {
15258 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
15259 "components to be an EQUIVALENCE object",sym->name,
15260 &e->where);
15261 return false;
15262 }
15263
15264 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
15265 {
15266 gfc_error ("Derived type variable %qs at %L with default "
15267 "initialization cannot be in EQUIVALENCE with a variable "
15268 "in COMMON", sym->name, &e->where);
15269 return false;
15270 }
15271
15272 for (; c ; c = c->next)
15273 {
15274 if (gfc_bt_struct (c->ts.type)
15275 && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
15276 return false;
15277
15278 /* Shall not be an object of sequence derived type containing a pointer
15279 in the structure. */
15280 if (c->attr.pointer)
15281 {
15282 gfc_error ("Derived type variable %qs at %L with pointer "
15283 "component(s) cannot be an EQUIVALENCE object",
15284 sym->name, &e->where);
15285 return false;
15286 }
15287 }
15288 return true;
15289 }
15290
15291
15292 /* Resolve equivalence object.
15293 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
15294 an allocatable array, an object of nonsequence derived type, an object of
15295 sequence derived type containing a pointer at any level of component
15296 selection, an automatic object, a function name, an entry name, a result
15297 name, a named constant, a structure component, or a subobject of any of
15298 the preceding objects. A substring shall not have length zero. A
15299 derived type shall not have components with default initialization nor
15300 shall two objects of an equivalence group be initialized.
15301 Either all or none of the objects shall have an protected attribute.
15302 The simple constraints are done in symbol.c(check_conflict) and the rest
15303 are implemented here. */
15304
15305 static void
resolve_equivalence(gfc_equiv * eq)15306 resolve_equivalence (gfc_equiv *eq)
15307 {
15308 gfc_symbol *sym;
15309 gfc_symbol *first_sym;
15310 gfc_expr *e;
15311 gfc_ref *r;
15312 locus *last_where = NULL;
15313 seq_type eq_type, last_eq_type;
15314 gfc_typespec *last_ts;
15315 int object, cnt_protected;
15316 const char *msg;
15317
15318 last_ts = &eq->expr->symtree->n.sym->ts;
15319
15320 first_sym = eq->expr->symtree->n.sym;
15321
15322 cnt_protected = 0;
15323
15324 for (object = 1; eq; eq = eq->eq, object++)
15325 {
15326 e = eq->expr;
15327
15328 e->ts = e->symtree->n.sym->ts;
15329 /* match_varspec might not know yet if it is seeing
15330 array reference or substring reference, as it doesn't
15331 know the types. */
15332 if (e->ref && e->ref->type == REF_ARRAY)
15333 {
15334 gfc_ref *ref = e->ref;
15335 sym = e->symtree->n.sym;
15336
15337 if (sym->attr.dimension)
15338 {
15339 ref->u.ar.as = sym->as;
15340 ref = ref->next;
15341 }
15342
15343 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
15344 if (e->ts.type == BT_CHARACTER
15345 && ref
15346 && ref->type == REF_ARRAY
15347 && ref->u.ar.dimen == 1
15348 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
15349 && ref->u.ar.stride[0] == NULL)
15350 {
15351 gfc_expr *start = ref->u.ar.start[0];
15352 gfc_expr *end = ref->u.ar.end[0];
15353 void *mem = NULL;
15354
15355 /* Optimize away the (:) reference. */
15356 if (start == NULL && end == NULL)
15357 {
15358 if (e->ref == ref)
15359 e->ref = ref->next;
15360 else
15361 e->ref->next = ref->next;
15362 mem = ref;
15363 }
15364 else
15365 {
15366 ref->type = REF_SUBSTRING;
15367 if (start == NULL)
15368 start = gfc_get_int_expr (gfc_default_integer_kind,
15369 NULL, 1);
15370 ref->u.ss.start = start;
15371 if (end == NULL && e->ts.u.cl)
15372 end = gfc_copy_expr (e->ts.u.cl->length);
15373 ref->u.ss.end = end;
15374 ref->u.ss.length = e->ts.u.cl;
15375 e->ts.u.cl = NULL;
15376 }
15377 ref = ref->next;
15378 free (mem);
15379 }
15380
15381 /* Any further ref is an error. */
15382 if (ref)
15383 {
15384 gcc_assert (ref->type == REF_ARRAY);
15385 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
15386 &ref->u.ar.where);
15387 continue;
15388 }
15389 }
15390
15391 if (!gfc_resolve_expr (e))
15392 continue;
15393
15394 sym = e->symtree->n.sym;
15395
15396 if (sym->attr.is_protected)
15397 cnt_protected++;
15398 if (cnt_protected > 0 && cnt_protected != object)
15399 {
15400 gfc_error ("Either all or none of the objects in the "
15401 "EQUIVALENCE set at %L shall have the "
15402 "PROTECTED attribute",
15403 &e->where);
15404 break;
15405 }
15406
15407 /* Shall not equivalence common block variables in a PURE procedure. */
15408 if (sym->ns->proc_name
15409 && sym->ns->proc_name->attr.pure
15410 && sym->attr.in_common)
15411 {
15412 /* Need to check for symbols that may have entered the pure
15413 procedure via a USE statement. */
15414 bool saw_sym = false;
15415 if (sym->ns->use_stmts)
15416 {
15417 gfc_use_rename *r;
15418 for (r = sym->ns->use_stmts->rename; r; r = r->next)
15419 if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
15420 }
15421 else
15422 saw_sym = true;
15423
15424 if (saw_sym)
15425 gfc_error ("COMMON block member %qs at %L cannot be an "
15426 "EQUIVALENCE object in the pure procedure %qs",
15427 sym->name, &e->where, sym->ns->proc_name->name);
15428 break;
15429 }
15430
15431 /* Shall not be a named constant. */
15432 if (e->expr_type == EXPR_CONSTANT)
15433 {
15434 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
15435 "object", sym->name, &e->where);
15436 continue;
15437 }
15438
15439 if (e->ts.type == BT_DERIVED
15440 && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
15441 continue;
15442
15443 /* Check that the types correspond correctly:
15444 Note 5.28:
15445 A numeric sequence structure may be equivalenced to another sequence
15446 structure, an object of default integer type, default real type, double
15447 precision real type, default logical type such that components of the
15448 structure ultimately only become associated to objects of the same
15449 kind. A character sequence structure may be equivalenced to an object
15450 of default character kind or another character sequence structure.
15451 Other objects may be equivalenced only to objects of the same type and
15452 kind parameters. */
15453
15454 /* Identical types are unconditionally OK. */
15455 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
15456 goto identical_types;
15457
15458 last_eq_type = sequence_type (*last_ts);
15459 eq_type = sequence_type (sym->ts);
15460
15461 /* Since the pair of objects is not of the same type, mixed or
15462 non-default sequences can be rejected. */
15463
15464 msg = "Sequence %s with mixed components in EQUIVALENCE "
15465 "statement at %L with different type objects";
15466 if ((object ==2
15467 && last_eq_type == SEQ_MIXED
15468 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
15469 || (eq_type == SEQ_MIXED
15470 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
15471 continue;
15472
15473 msg = "Non-default type object or sequence %s in EQUIVALENCE "
15474 "statement at %L with objects of different type";
15475 if ((object ==2
15476 && last_eq_type == SEQ_NONDEFAULT
15477 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
15478 || (eq_type == SEQ_NONDEFAULT
15479 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
15480 continue;
15481
15482 msg ="Non-CHARACTER object %qs in default CHARACTER "
15483 "EQUIVALENCE statement at %L";
15484 if (last_eq_type == SEQ_CHARACTER
15485 && eq_type != SEQ_CHARACTER
15486 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
15487 continue;
15488
15489 msg ="Non-NUMERIC object %qs in default NUMERIC "
15490 "EQUIVALENCE statement at %L";
15491 if (last_eq_type == SEQ_NUMERIC
15492 && eq_type != SEQ_NUMERIC
15493 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
15494 continue;
15495
15496 identical_types:
15497 last_ts =&sym->ts;
15498 last_where = &e->where;
15499
15500 if (!e->ref)
15501 continue;
15502
15503 /* Shall not be an automatic array. */
15504 if (e->ref->type == REF_ARRAY
15505 && !gfc_resolve_array_spec (e->ref->u.ar.as, 1))
15506 {
15507 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
15508 "an EQUIVALENCE object", sym->name, &e->where);
15509 continue;
15510 }
15511
15512 r = e->ref;
15513 while (r)
15514 {
15515 /* Shall not be a structure component. */
15516 if (r->type == REF_COMPONENT)
15517 {
15518 gfc_error ("Structure component %qs at %L cannot be an "
15519 "EQUIVALENCE object",
15520 r->u.c.component->name, &e->where);
15521 break;
15522 }
15523
15524 /* A substring shall not have length zero. */
15525 if (r->type == REF_SUBSTRING)
15526 {
15527 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
15528 {
15529 gfc_error ("Substring at %L has length zero",
15530 &r->u.ss.start->where);
15531 break;
15532 }
15533 }
15534 r = r->next;
15535 }
15536 }
15537 }
15538
15539
15540 /* Resolve function and ENTRY types, issue diagnostics if needed. */
15541
15542 static void
resolve_fntype(gfc_namespace * ns)15543 resolve_fntype (gfc_namespace *ns)
15544 {
15545 gfc_entry_list *el;
15546 gfc_symbol *sym;
15547
15548 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
15549 return;
15550
15551 /* If there are any entries, ns->proc_name is the entry master
15552 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
15553 if (ns->entries)
15554 sym = ns->entries->sym;
15555 else
15556 sym = ns->proc_name;
15557 if (sym->result == sym
15558 && sym->ts.type == BT_UNKNOWN
15559 && !gfc_set_default_type (sym, 0, NULL)
15560 && !sym->attr.untyped)
15561 {
15562 gfc_error ("Function %qs at %L has no IMPLICIT type",
15563 sym->name, &sym->declared_at);
15564 sym->attr.untyped = 1;
15565 }
15566
15567 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
15568 && !sym->attr.contained
15569 && !gfc_check_symbol_access (sym->ts.u.derived)
15570 && gfc_check_symbol_access (sym))
15571 {
15572 gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
15573 "%L of PRIVATE type %qs", sym->name,
15574 &sym->declared_at, sym->ts.u.derived->name);
15575 }
15576
15577 if (ns->entries)
15578 for (el = ns->entries->next; el; el = el->next)
15579 {
15580 if (el->sym->result == el->sym
15581 && el->sym->ts.type == BT_UNKNOWN
15582 && !gfc_set_default_type (el->sym, 0, NULL)
15583 && !el->sym->attr.untyped)
15584 {
15585 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
15586 el->sym->name, &el->sym->declared_at);
15587 el->sym->attr.untyped = 1;
15588 }
15589 }
15590 }
15591
15592
15593 /* 12.3.2.1.1 Defined operators. */
15594
15595 static bool
check_uop_procedure(gfc_symbol * sym,locus where)15596 check_uop_procedure (gfc_symbol *sym, locus where)
15597 {
15598 gfc_formal_arglist *formal;
15599
15600 if (!sym->attr.function)
15601 {
15602 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
15603 sym->name, &where);
15604 return false;
15605 }
15606
15607 if (sym->ts.type == BT_CHARACTER
15608 && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
15609 && !(sym->result && ((sym->result->ts.u.cl
15610 && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
15611 {
15612 gfc_error ("User operator procedure %qs at %L cannot be assumed "
15613 "character length", sym->name, &where);
15614 return false;
15615 }
15616
15617 formal = gfc_sym_get_dummy_args (sym);
15618 if (!formal || !formal->sym)
15619 {
15620 gfc_error ("User operator procedure %qs at %L must have at least "
15621 "one argument", sym->name, &where);
15622 return false;
15623 }
15624
15625 if (formal->sym->attr.intent != INTENT_IN)
15626 {
15627 gfc_error ("First argument of operator interface at %L must be "
15628 "INTENT(IN)", &where);
15629 return false;
15630 }
15631
15632 if (formal->sym->attr.optional)
15633 {
15634 gfc_error ("First argument of operator interface at %L cannot be "
15635 "optional", &where);
15636 return false;
15637 }
15638
15639 formal = formal->next;
15640 if (!formal || !formal->sym)
15641 return true;
15642
15643 if (formal->sym->attr.intent != INTENT_IN)
15644 {
15645 gfc_error ("Second argument of operator interface at %L must be "
15646 "INTENT(IN)", &where);
15647 return false;
15648 }
15649
15650 if (formal->sym->attr.optional)
15651 {
15652 gfc_error ("Second argument of operator interface at %L cannot be "
15653 "optional", &where);
15654 return false;
15655 }
15656
15657 if (formal->next)
15658 {
15659 gfc_error ("Operator interface at %L must have, at most, two "
15660 "arguments", &where);
15661 return false;
15662 }
15663
15664 return true;
15665 }
15666
15667 static void
gfc_resolve_uops(gfc_symtree * symtree)15668 gfc_resolve_uops (gfc_symtree *symtree)
15669 {
15670 gfc_interface *itr;
15671
15672 if (symtree == NULL)
15673 return;
15674
15675 gfc_resolve_uops (symtree->left);
15676 gfc_resolve_uops (symtree->right);
15677
15678 for (itr = symtree->n.uop->op; itr; itr = itr->next)
15679 check_uop_procedure (itr->sym, itr->sym->declared_at);
15680 }
15681
15682
15683 /* Examine all of the expressions associated with a program unit,
15684 assign types to all intermediate expressions, make sure that all
15685 assignments are to compatible types and figure out which names
15686 refer to which functions or subroutines. It doesn't check code
15687 block, which is handled by gfc_resolve_code. */
15688
15689 static void
resolve_types(gfc_namespace * ns)15690 resolve_types (gfc_namespace *ns)
15691 {
15692 gfc_namespace *n;
15693 gfc_charlen *cl;
15694 gfc_data *d;
15695 gfc_equiv *eq;
15696 gfc_namespace* old_ns = gfc_current_ns;
15697
15698 if (ns->types_resolved)
15699 return;
15700
15701 /* Check that all IMPLICIT types are ok. */
15702 if (!ns->seen_implicit_none)
15703 {
15704 unsigned letter;
15705 for (letter = 0; letter != GFC_LETTERS; ++letter)
15706 if (ns->set_flag[letter]
15707 && !resolve_typespec_used (&ns->default_type[letter],
15708 &ns->implicit_loc[letter], NULL))
15709 return;
15710 }
15711
15712 gfc_current_ns = ns;
15713
15714 resolve_entries (ns);
15715
15716 resolve_common_vars (&ns->blank_common, false);
15717 resolve_common_blocks (ns->common_root);
15718
15719 resolve_contained_functions (ns);
15720
15721 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
15722 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
15723 resolve_formal_arglist (ns->proc_name);
15724
15725 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
15726
15727 for (cl = ns->cl_list; cl; cl = cl->next)
15728 resolve_charlen (cl);
15729
15730 gfc_traverse_ns (ns, resolve_symbol);
15731
15732 resolve_fntype (ns);
15733
15734 for (n = ns->contained; n; n = n->sibling)
15735 {
15736 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
15737 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
15738 "also be PURE", n->proc_name->name,
15739 &n->proc_name->declared_at);
15740
15741 resolve_types (n);
15742 }
15743
15744 forall_flag = 0;
15745 gfc_do_concurrent_flag = 0;
15746 gfc_check_interfaces (ns);
15747
15748 gfc_traverse_ns (ns, resolve_values);
15749
15750 if (ns->save_all)
15751 gfc_save_all (ns);
15752
15753 iter_stack = NULL;
15754 for (d = ns->data; d; d = d->next)
15755 resolve_data (d);
15756
15757 iter_stack = NULL;
15758 gfc_traverse_ns (ns, gfc_formalize_init_value);
15759
15760 gfc_traverse_ns (ns, gfc_verify_binding_labels);
15761
15762 for (eq = ns->equiv; eq; eq = eq->next)
15763 resolve_equivalence (eq);
15764
15765 /* Warn about unused labels. */
15766 if (warn_unused_label)
15767 warn_unused_fortran_label (ns->st_labels);
15768
15769 gfc_resolve_uops (ns->uop_root);
15770
15771 gfc_resolve_omp_declare_simd (ns);
15772
15773 gfc_resolve_omp_udrs (ns->omp_udr_root);
15774
15775 ns->types_resolved = 1;
15776
15777 gfc_current_ns = old_ns;
15778 }
15779
15780
15781 /* Call gfc_resolve_code recursively. */
15782
15783 static void
resolve_codes(gfc_namespace * ns)15784 resolve_codes (gfc_namespace *ns)
15785 {
15786 gfc_namespace *n;
15787 bitmap_obstack old_obstack;
15788
15789 if (ns->resolved == 1)
15790 return;
15791
15792 for (n = ns->contained; n; n = n->sibling)
15793 resolve_codes (n);
15794
15795 gfc_current_ns = ns;
15796
15797 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
15798 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
15799 cs_base = NULL;
15800
15801 /* Set to an out of range value. */
15802 current_entry_id = -1;
15803
15804 old_obstack = labels_obstack;
15805 bitmap_obstack_initialize (&labels_obstack);
15806
15807 gfc_resolve_oacc_declare (ns);
15808 gfc_resolve_code (ns->code, ns);
15809
15810 bitmap_obstack_release (&labels_obstack);
15811 labels_obstack = old_obstack;
15812 }
15813
15814
15815 /* This function is called after a complete program unit has been compiled.
15816 Its purpose is to examine all of the expressions associated with a program
15817 unit, assign types to all intermediate expressions, make sure that all
15818 assignments are to compatible types and figure out which names refer to
15819 which functions or subroutines. */
15820
15821 void
gfc_resolve(gfc_namespace * ns)15822 gfc_resolve (gfc_namespace *ns)
15823 {
15824 gfc_namespace *old_ns;
15825 code_stack *old_cs_base;
15826 struct gfc_omp_saved_state old_omp_state;
15827
15828 if (ns->resolved)
15829 return;
15830
15831 ns->resolved = -1;
15832 old_ns = gfc_current_ns;
15833 old_cs_base = cs_base;
15834
15835 /* As gfc_resolve can be called during resolution of an OpenMP construct
15836 body, we should clear any state associated to it, so that say NS's
15837 DO loops are not interpreted as OpenMP loops. */
15838 if (!ns->construct_entities)
15839 gfc_omp_save_and_clear_state (&old_omp_state);
15840
15841 resolve_types (ns);
15842 component_assignment_level = 0;
15843 resolve_codes (ns);
15844
15845 gfc_current_ns = old_ns;
15846 cs_base = old_cs_base;
15847 ns->resolved = 1;
15848
15849 gfc_run_passes (ns);
15850
15851 if (!ns->construct_entities)
15852 gfc_omp_restore_state (&old_omp_state);
15853 }
15854