1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2013 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 "flags.h"
25 #include "gfortran.h"
26 #include "obstack.h"
27 #include "bitmap.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
30 #include "data.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
33
34 /* Types used in equivalence statements. */
35
36 typedef enum seq_type
37 {
38 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
39 }
40 seq_type;
41
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
44
45 typedef struct code_stack
46 {
47 struct gfc_code *head, *current;
48 struct code_stack *prev;
49
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
52 blocks. */
53 bitmap reachable_labels;
54 }
55 code_stack;
56
57 static code_stack *cs_base = NULL;
58
59
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
61
62 static int forall_flag;
63 static int do_concurrent_flag;
64
65 /* True when we are resolving an expression that is an actual argument to
66 a procedure. */
67 static bool actual_arg = false;
68 /* True when we are resolving an expression that is the first actual argument
69 to a procedure. */
70 static bool first_actual_arg = false;
71
72
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
74
75 static int omp_workshare_flag;
76
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag = 0;
80
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr = false;
83
84 /* The id of the last entry seen. */
85 static int current_entry_id;
86
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack;
89
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument = false;
92
93
94 int
gfc_is_formal_arg(void)95 gfc_is_formal_arg (void)
96 {
97 return formal_arg_flag;
98 }
99
100 /* Is the symbol host associated? */
101 static bool
is_sym_host_assoc(gfc_symbol * sym,gfc_namespace * ns)102 is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
103 {
104 for (ns = ns->parent; ns; ns = ns->parent)
105 {
106 if (sym->ns == ns)
107 return true;
108 }
109
110 return false;
111 }
112
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
116
117 static gfc_try
resolve_typespec_used(gfc_typespec * ts,locus * where,const char * name)118 resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
119 {
120 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
121 {
122 if (where)
123 {
124 if (name)
125 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
126 name, where, ts->u.derived->name);
127 else
128 gfc_error ("ABSTRACT type '%s' used at %L",
129 ts->u.derived->name, where);
130 }
131
132 return FAILURE;
133 }
134
135 return SUCCESS;
136 }
137
138
139 static gfc_try
check_proc_interface(gfc_symbol * ifc,locus * where)140 check_proc_interface (gfc_symbol *ifc, locus *where)
141 {
142 /* Several checks for F08:C1216. */
143 if (ifc->attr.procedure)
144 {
145 gfc_error ("Interface '%s' at %L is declared "
146 "in a later PROCEDURE statement", ifc->name, where);
147 return FAILURE;
148 }
149 if (ifc->generic)
150 {
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface *gen = ifc->generic;
154 while (gen && strcmp (gen->sym->name, ifc->name) != 0)
155 gen = gen->next;
156 if (!gen)
157 {
158 gfc_error ("Interface '%s' at %L may not be generic",
159 ifc->name, where);
160 return FAILURE;
161 }
162 }
163 if (ifc->attr.proc == PROC_ST_FUNCTION)
164 {
165 gfc_error ("Interface '%s' at %L may not be a statement function",
166 ifc->name, where);
167 return FAILURE;
168 }
169 if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
170 || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
171 ifc->attr.intrinsic = 1;
172 if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
173 {
174 gfc_error ("Intrinsic procedure '%s' not allowed in "
175 "PROCEDURE statement at %L", ifc->name, where);
176 return FAILURE;
177 }
178 if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
179 {
180 gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where);
181 return FAILURE;
182 }
183 return SUCCESS;
184 }
185
186
187 static void resolve_symbol (gfc_symbol *sym);
188
189
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
191
192 static gfc_try
resolve_procedure_interface(gfc_symbol * sym)193 resolve_procedure_interface (gfc_symbol *sym)
194 {
195 gfc_symbol *ifc = sym->ts.interface;
196
197 if (!ifc)
198 return SUCCESS;
199
200 if (ifc == sym)
201 {
202 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
203 sym->name, &sym->declared_at);
204 return FAILURE;
205 }
206 if (check_proc_interface (ifc, &sym->declared_at) == FAILURE)
207 return FAILURE;
208
209 if (ifc->attr.if_source || ifc->attr.intrinsic)
210 {
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc);
213 if (ifc->attr.intrinsic)
214 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
215
216 if (ifc->result)
217 {
218 sym->ts = ifc->result->ts;
219 sym->result = sym;
220 }
221 else
222 sym->ts = ifc->ts;
223 sym->ts.interface = ifc;
224 sym->attr.function = ifc->attr.function;
225 sym->attr.subroutine = ifc->attr.subroutine;
226
227 sym->attr.allocatable = ifc->attr.allocatable;
228 sym->attr.pointer = ifc->attr.pointer;
229 sym->attr.pure = ifc->attr.pure;
230 sym->attr.elemental = ifc->attr.elemental;
231 sym->attr.dimension = ifc->attr.dimension;
232 sym->attr.contiguous = ifc->attr.contiguous;
233 sym->attr.recursive = ifc->attr.recursive;
234 sym->attr.always_explicit = ifc->attr.always_explicit;
235 sym->attr.ext_attr |= ifc->attr.ext_attr;
236 sym->attr.is_bind_c = ifc->attr.is_bind_c;
237 sym->attr.class_ok = ifc->attr.class_ok;
238 /* Copy array spec. */
239 sym->as = gfc_copy_array_spec (ifc->as);
240 /* Copy char length. */
241 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
242 {
243 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
244 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
245 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
246 return FAILURE;
247 }
248 }
249
250 return SUCCESS;
251 }
252
253
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
259
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
262
263 static void
resolve_formal_arglist(gfc_symbol * proc)264 resolve_formal_arglist (gfc_symbol *proc)
265 {
266 gfc_formal_arglist *f;
267 gfc_symbol *sym;
268 bool saved_specification_expr;
269 int i;
270
271 if (proc->result != NULL)
272 sym = proc->result;
273 else
274 sym = proc;
275
276 if (gfc_elemental (proc)
277 || sym->attr.pointer || sym->attr.allocatable
278 || (sym->as && sym->as->rank != 0))
279 {
280 proc->attr.always_explicit = 1;
281 sym->attr.always_explicit = 1;
282 }
283
284 formal_arg_flag = 1;
285
286 for (f = proc->formal; f; f = f->next)
287 {
288 gfc_array_spec *as;
289
290 sym = f->sym;
291
292 if (sym == NULL)
293 {
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "'%s' at %L is not allowed", proc->name,
298 &proc->declared_at);
299 if (proc->attr.function)
300 gfc_error ("Alternate return specifier in function "
301 "'%s' at %L is not allowed", proc->name,
302 &proc->declared_at);
303 continue;
304 }
305 else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
306 && resolve_procedure_interface (sym) == FAILURE)
307 return;
308
309 if (sym->attr.if_source != IFSRC_UNKNOWN)
310 resolve_formal_arglist (sym);
311
312 if (sym->attr.subroutine || sym->attr.external)
313 {
314 if (sym->attr.flavor == FL_UNKNOWN)
315 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
316 }
317 else
318 {
319 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
320 && (!sym->attr.function || sym->result == sym))
321 gfc_set_default_type (sym, 1, sym->ns);
322 }
323
324 as = sym->ts.type == BT_CLASS && sym->attr.class_ok
325 ? CLASS_DATA (sym)->as : sym->as;
326
327 saved_specification_expr = specification_expr;
328 specification_expr = true;
329 gfc_resolve_array_spec (as, 0);
330 specification_expr = saved_specification_expr;
331
332 /* We can't tell if an array with dimension (:) is assumed or deferred
333 shape until we know if it has the pointer or allocatable attributes.
334 */
335 if (as && as->rank > 0 && as->type == AS_DEFERRED
336 && ((sym->ts.type != BT_CLASS
337 && !(sym->attr.pointer || sym->attr.allocatable))
338 || (sym->ts.type == BT_CLASS
339 && !(CLASS_DATA (sym)->attr.class_pointer
340 || CLASS_DATA (sym)->attr.allocatable)))
341 && sym->attr.flavor != FL_PROCEDURE)
342 {
343 as->type = AS_ASSUMED_SHAPE;
344 for (i = 0; i < as->rank; i++)
345 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
346 }
347
348 if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
349 || (as && as->type == AS_ASSUMED_RANK)
350 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
351 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
352 && (CLASS_DATA (sym)->attr.class_pointer
353 || CLASS_DATA (sym)->attr.allocatable
354 || CLASS_DATA (sym)->attr.target))
355 || sym->attr.optional)
356 {
357 proc->attr.always_explicit = 1;
358 if (proc->result)
359 proc->result->attr.always_explicit = 1;
360 }
361
362 /* If the flavor is unknown at this point, it has to be a variable.
363 A procedure specification would have already set the type. */
364
365 if (sym->attr.flavor == FL_UNKNOWN)
366 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
367
368 if (gfc_pure (proc))
369 {
370 if (sym->attr.flavor == FL_PROCEDURE)
371 {
372 /* F08:C1279. */
373 if (!gfc_pure (sym))
374 {
375 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
376 "also be PURE", sym->name, &sym->declared_at);
377 continue;
378 }
379 }
380 else if (!sym->attr.pointer)
381 {
382 if (proc->attr.function && sym->attr.intent != INTENT_IN)
383 {
384 if (sym->attr.value)
385 gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
386 " of pure function '%s' at %L with VALUE "
387 "attribute but without INTENT(IN)",
388 sym->name, proc->name, &sym->declared_at);
389 else
390 gfc_error ("Argument '%s' of pure function '%s' at %L must "
391 "be INTENT(IN) or VALUE", sym->name, proc->name,
392 &sym->declared_at);
393 }
394
395 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
396 {
397 if (sym->attr.value)
398 gfc_notify_std (GFC_STD_F2008, "Argument '%s'"
399 " of pure subroutine '%s' at %L with VALUE "
400 "attribute but without INTENT", sym->name,
401 proc->name, &sym->declared_at);
402 else
403 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
404 "must have its INTENT specified or have the "
405 "VALUE attribute", sym->name, proc->name,
406 &sym->declared_at);
407 }
408 }
409 }
410
411 if (proc->attr.implicit_pure)
412 {
413 if (sym->attr.flavor == FL_PROCEDURE)
414 {
415 if (!gfc_pure(sym))
416 proc->attr.implicit_pure = 0;
417 }
418 else if (!sym->attr.pointer)
419 {
420 if (proc->attr.function && sym->attr.intent != INTENT_IN
421 && !sym->value)
422 proc->attr.implicit_pure = 0;
423
424 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
425 && !sym->value)
426 proc->attr.implicit_pure = 0;
427 }
428 }
429
430 if (gfc_elemental (proc))
431 {
432 /* F08:C1289. */
433 if (sym->attr.codimension
434 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
435 && CLASS_DATA (sym)->attr.codimension))
436 {
437 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
438 "procedure", sym->name, &sym->declared_at);
439 continue;
440 }
441
442 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
443 && CLASS_DATA (sym)->as))
444 {
445 gfc_error ("Argument '%s' of elemental procedure at %L must "
446 "be scalar", sym->name, &sym->declared_at);
447 continue;
448 }
449
450 if (sym->attr.allocatable
451 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
452 && CLASS_DATA (sym)->attr.allocatable))
453 {
454 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
455 "have the ALLOCATABLE attribute", sym->name,
456 &sym->declared_at);
457 continue;
458 }
459
460 if (sym->attr.pointer
461 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
462 && CLASS_DATA (sym)->attr.class_pointer))
463 {
464 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
465 "have the POINTER attribute", sym->name,
466 &sym->declared_at);
467 continue;
468 }
469
470 if (sym->attr.flavor == FL_PROCEDURE)
471 {
472 gfc_error ("Dummy procedure '%s' not allowed in elemental "
473 "procedure '%s' at %L", sym->name, proc->name,
474 &sym->declared_at);
475 continue;
476 }
477
478 /* Fortran 2008 Corrigendum 1, C1290a. */
479 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
480 {
481 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
482 "have its INTENT specified or have the VALUE "
483 "attribute", sym->name, proc->name,
484 &sym->declared_at);
485 continue;
486 }
487 }
488
489 /* Each dummy shall be specified to be scalar. */
490 if (proc->attr.proc == PROC_ST_FUNCTION)
491 {
492 if (sym->as != NULL)
493 {
494 gfc_error ("Argument '%s' of statement function at %L must "
495 "be scalar", sym->name, &sym->declared_at);
496 continue;
497 }
498
499 if (sym->ts.type == BT_CHARACTER)
500 {
501 gfc_charlen *cl = sym->ts.u.cl;
502 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
503 {
504 gfc_error ("Character-valued argument '%s' of statement "
505 "function at %L must have constant length",
506 sym->name, &sym->declared_at);
507 continue;
508 }
509 }
510 }
511 }
512 formal_arg_flag = 0;
513 }
514
515
516 /* Work function called when searching for symbols that have argument lists
517 associated with them. */
518
519 static void
find_arglists(gfc_symbol * sym)520 find_arglists (gfc_symbol *sym)
521 {
522 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
523 || sym->attr.flavor == FL_DERIVED)
524 return;
525
526 resolve_formal_arglist (sym);
527 }
528
529
530 /* Given a namespace, resolve all formal argument lists within the namespace.
531 */
532
533 static void
resolve_formal_arglists(gfc_namespace * ns)534 resolve_formal_arglists (gfc_namespace *ns)
535 {
536 if (ns == NULL)
537 return;
538
539 gfc_traverse_ns (ns, find_arglists);
540 }
541
542
543 static void
resolve_contained_fntype(gfc_symbol * sym,gfc_namespace * ns)544 resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
545 {
546 gfc_try t;
547
548 /* If this namespace is not a function or an entry master function,
549 ignore it. */
550 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
551 || sym->attr.entry_master)
552 return;
553
554 /* Try to find out of what the return type is. */
555 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
556 {
557 t = gfc_set_default_type (sym->result, 0, ns);
558
559 if (t == FAILURE && !sym->result->attr.untyped)
560 {
561 if (sym->result == sym)
562 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
563 sym->name, &sym->declared_at);
564 else if (!sym->result->attr.proc_pointer)
565 gfc_error ("Result '%s' of contained function '%s' at %L has "
566 "no IMPLICIT type", sym->result->name, sym->name,
567 &sym->result->declared_at);
568 sym->result->attr.untyped = 1;
569 }
570 }
571
572 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
573 type, lists the only ways a character length value of * can be used:
574 dummy arguments of procedures, named constants, and function results
575 in external functions. Internal function results and results of module
576 procedures are not on this list, ergo, not permitted. */
577
578 if (sym->result->ts.type == BT_CHARACTER)
579 {
580 gfc_charlen *cl = sym->result->ts.u.cl;
581 if ((!cl || !cl->length) && !sym->result->ts.deferred)
582 {
583 /* See if this is a module-procedure and adapt error message
584 accordingly. */
585 bool module_proc;
586 gcc_assert (ns->parent && ns->parent->proc_name);
587 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
588
589 gfc_error ("Character-valued %s '%s' at %L must not be"
590 " assumed length",
591 module_proc ? _("module procedure")
592 : _("internal function"),
593 sym->name, &sym->declared_at);
594 }
595 }
596 }
597
598
599 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
600 introduce duplicates. */
601
602 static void
merge_argument_lists(gfc_symbol * proc,gfc_formal_arglist * new_args)603 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
604 {
605 gfc_formal_arglist *f, *new_arglist;
606 gfc_symbol *new_sym;
607
608 for (; new_args != NULL; new_args = new_args->next)
609 {
610 new_sym = new_args->sym;
611 /* See if this arg is already in the formal argument list. */
612 for (f = proc->formal; f; f = f->next)
613 {
614 if (new_sym == f->sym)
615 break;
616 }
617
618 if (f)
619 continue;
620
621 /* Add a new argument. Argument order is not important. */
622 new_arglist = gfc_get_formal_arglist ();
623 new_arglist->sym = new_sym;
624 new_arglist->next = proc->formal;
625 proc->formal = new_arglist;
626 }
627 }
628
629
630 /* Flag the arguments that are not present in all entries. */
631
632 static void
check_argument_lists(gfc_symbol * proc,gfc_formal_arglist * new_args)633 check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
634 {
635 gfc_formal_arglist *f, *head;
636 head = new_args;
637
638 for (f = proc->formal; f; f = f->next)
639 {
640 if (f->sym == NULL)
641 continue;
642
643 for (new_args = head; new_args; new_args = new_args->next)
644 {
645 if (new_args->sym == f->sym)
646 break;
647 }
648
649 if (new_args)
650 continue;
651
652 f->sym->attr.not_always_present = 1;
653 }
654 }
655
656
657 /* Resolve alternate entry points. If a symbol has multiple entry points we
658 create a new master symbol for the main routine, and turn the existing
659 symbol into an entry point. */
660
661 static void
resolve_entries(gfc_namespace * ns)662 resolve_entries (gfc_namespace *ns)
663 {
664 gfc_namespace *old_ns;
665 gfc_code *c;
666 gfc_symbol *proc;
667 gfc_entry_list *el;
668 char name[GFC_MAX_SYMBOL_LEN + 1];
669 static int master_count = 0;
670
671 if (ns->proc_name == NULL)
672 return;
673
674 /* No need to do anything if this procedure doesn't have alternate entry
675 points. */
676 if (!ns->entries)
677 return;
678
679 /* We may already have resolved alternate entry points. */
680 if (ns->proc_name->attr.entry_master)
681 return;
682
683 /* If this isn't a procedure something has gone horribly wrong. */
684 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
685
686 /* Remember the current namespace. */
687 old_ns = gfc_current_ns;
688
689 gfc_current_ns = ns;
690
691 /* Add the main entry point to the list of entry points. */
692 el = gfc_get_entry_list ();
693 el->sym = ns->proc_name;
694 el->id = 0;
695 el->next = ns->entries;
696 ns->entries = el;
697 ns->proc_name->attr.entry = 1;
698
699 /* If it is a module function, it needs to be in the right namespace
700 so that gfc_get_fake_result_decl can gather up the results. The
701 need for this arose in get_proc_name, where these beasts were
702 left in their own namespace, to keep prior references linked to
703 the entry declaration.*/
704 if (ns->proc_name->attr.function
705 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
706 el->sym->ns = ns;
707
708 /* Do the same for entries where the master is not a module
709 procedure. These are retained in the module namespace because
710 of the module procedure declaration. */
711 for (el = el->next; el; el = el->next)
712 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
713 && el->sym->attr.mod_proc)
714 el->sym->ns = ns;
715 el = ns->entries;
716
717 /* Add an entry statement for it. */
718 c = gfc_get_code ();
719 c->op = EXEC_ENTRY;
720 c->ext.entry = el;
721 c->next = ns->code;
722 ns->code = c;
723
724 /* Create a new symbol for the master function. */
725 /* Give the internal function a unique name (within this file).
726 Also include the function name so the user has some hope of figuring
727 out what is going on. */
728 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
729 master_count++, ns->proc_name->name);
730 gfc_get_ha_symbol (name, &proc);
731 gcc_assert (proc != NULL);
732
733 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
734 if (ns->proc_name->attr.subroutine)
735 gfc_add_subroutine (&proc->attr, proc->name, NULL);
736 else
737 {
738 gfc_symbol *sym;
739 gfc_typespec *ts, *fts;
740 gfc_array_spec *as, *fas;
741 gfc_add_function (&proc->attr, proc->name, NULL);
742 proc->result = proc;
743 fas = ns->entries->sym->as;
744 fas = fas ? fas : ns->entries->sym->result->as;
745 fts = &ns->entries->sym->result->ts;
746 if (fts->type == BT_UNKNOWN)
747 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
748 for (el = ns->entries->next; el; el = el->next)
749 {
750 ts = &el->sym->result->ts;
751 as = el->sym->as;
752 as = as ? as : el->sym->result->as;
753 if (ts->type == BT_UNKNOWN)
754 ts = gfc_get_default_type (el->sym->result->name, NULL);
755
756 if (! gfc_compare_types (ts, fts)
757 || (el->sym->result->attr.dimension
758 != ns->entries->sym->result->attr.dimension)
759 || (el->sym->result->attr.pointer
760 != ns->entries->sym->result->attr.pointer))
761 break;
762 else if (as && fas && ns->entries->sym->result != el->sym->result
763 && gfc_compare_array_spec (as, fas) == 0)
764 gfc_error ("Function %s at %L has entries with mismatched "
765 "array specifications", ns->entries->sym->name,
766 &ns->entries->sym->declared_at);
767 /* The characteristics need to match and thus both need to have
768 the same string length, i.e. both len=*, or both len=4.
769 Having both len=<variable> is also possible, but difficult to
770 check at compile time. */
771 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
772 && (((ts->u.cl->length && !fts->u.cl->length)
773 ||(!ts->u.cl->length && fts->u.cl->length))
774 || (ts->u.cl->length
775 && ts->u.cl->length->expr_type
776 != fts->u.cl->length->expr_type)
777 || (ts->u.cl->length
778 && ts->u.cl->length->expr_type == EXPR_CONSTANT
779 && mpz_cmp (ts->u.cl->length->value.integer,
780 fts->u.cl->length->value.integer) != 0)))
781 gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
782 "entries returning variables of different "
783 "string lengths", ns->entries->sym->name,
784 &ns->entries->sym->declared_at);
785 }
786
787 if (el == NULL)
788 {
789 sym = ns->entries->sym->result;
790 /* All result types the same. */
791 proc->ts = *fts;
792 if (sym->attr.dimension)
793 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
794 if (sym->attr.pointer)
795 gfc_add_pointer (&proc->attr, NULL);
796 }
797 else
798 {
799 /* Otherwise the result will be passed through a union by
800 reference. */
801 proc->attr.mixed_entry_master = 1;
802 for (el = ns->entries; el; el = el->next)
803 {
804 sym = el->sym->result;
805 if (sym->attr.dimension)
806 {
807 if (el == ns->entries)
808 gfc_error ("FUNCTION result %s can't be an array in "
809 "FUNCTION %s at %L", sym->name,
810 ns->entries->sym->name, &sym->declared_at);
811 else
812 gfc_error ("ENTRY result %s can't be an array in "
813 "FUNCTION %s at %L", sym->name,
814 ns->entries->sym->name, &sym->declared_at);
815 }
816 else if (sym->attr.pointer)
817 {
818 if (el == ns->entries)
819 gfc_error ("FUNCTION result %s can't be a POINTER in "
820 "FUNCTION %s at %L", sym->name,
821 ns->entries->sym->name, &sym->declared_at);
822 else
823 gfc_error ("ENTRY result %s can't be a POINTER in "
824 "FUNCTION %s at %L", sym->name,
825 ns->entries->sym->name, &sym->declared_at);
826 }
827 else
828 {
829 ts = &sym->ts;
830 if (ts->type == BT_UNKNOWN)
831 ts = gfc_get_default_type (sym->name, NULL);
832 switch (ts->type)
833 {
834 case BT_INTEGER:
835 if (ts->kind == gfc_default_integer_kind)
836 sym = NULL;
837 break;
838 case BT_REAL:
839 if (ts->kind == gfc_default_real_kind
840 || ts->kind == gfc_default_double_kind)
841 sym = NULL;
842 break;
843 case BT_COMPLEX:
844 if (ts->kind == gfc_default_complex_kind)
845 sym = NULL;
846 break;
847 case BT_LOGICAL:
848 if (ts->kind == gfc_default_logical_kind)
849 sym = NULL;
850 break;
851 case BT_UNKNOWN:
852 /* We will issue error elsewhere. */
853 sym = NULL;
854 break;
855 default:
856 break;
857 }
858 if (sym)
859 {
860 if (el == ns->entries)
861 gfc_error ("FUNCTION result %s can't be of type %s "
862 "in FUNCTION %s at %L", sym->name,
863 gfc_typename (ts), ns->entries->sym->name,
864 &sym->declared_at);
865 else
866 gfc_error ("ENTRY result %s can't be of type %s "
867 "in FUNCTION %s at %L", sym->name,
868 gfc_typename (ts), ns->entries->sym->name,
869 &sym->declared_at);
870 }
871 }
872 }
873 }
874 }
875 proc->attr.access = ACCESS_PRIVATE;
876 proc->attr.entry_master = 1;
877
878 /* Merge all the entry point arguments. */
879 for (el = ns->entries; el; el = el->next)
880 merge_argument_lists (proc, el->sym->formal);
881
882 /* Check the master formal arguments for any that are not
883 present in all entry points. */
884 for (el = ns->entries; el; el = el->next)
885 check_argument_lists (proc, el->sym->formal);
886
887 /* Use the master function for the function body. */
888 ns->proc_name = proc;
889
890 /* Finalize the new symbols. */
891 gfc_commit_symbols ();
892
893 /* Restore the original namespace. */
894 gfc_current_ns = old_ns;
895 }
896
897
898 /* Resolve common variables. */
899 static void
resolve_common_vars(gfc_symbol * sym,bool named_common)900 resolve_common_vars (gfc_symbol *sym, bool named_common)
901 {
902 gfc_symbol *csym = sym;
903
904 for (; csym; csym = csym->common_next)
905 {
906 if (csym->value || csym->attr.data)
907 {
908 if (!csym->ns->is_block_data)
909 gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
910 "but only in BLOCK DATA initialization is "
911 "allowed", csym->name, &csym->declared_at);
912 else if (!named_common)
913 gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
914 "in a blank COMMON but initialization is only "
915 "allowed in named common blocks", csym->name,
916 &csym->declared_at);
917 }
918
919 if (UNLIMITED_POLY (csym))
920 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
921 "[F2008:C5100]", csym->name, &csym->declared_at);
922
923 if (csym->ts.type != BT_DERIVED)
924 continue;
925
926 if (!(csym->ts.u.derived->attr.sequence
927 || csym->ts.u.derived->attr.is_bind_c))
928 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
929 "has neither the SEQUENCE nor the BIND(C) "
930 "attribute", csym->name, &csym->declared_at);
931 if (csym->ts.u.derived->attr.alloc_comp)
932 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
933 "has an ultimate component that is "
934 "allocatable", csym->name, &csym->declared_at);
935 if (gfc_has_default_initializer (csym->ts.u.derived))
936 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
937 "may not have default initializer", csym->name,
938 &csym->declared_at);
939
940 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
941 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
942 }
943 }
944
945 /* Resolve common blocks. */
946 static void
resolve_common_blocks(gfc_symtree * common_root)947 resolve_common_blocks (gfc_symtree *common_root)
948 {
949 gfc_symbol *sym;
950
951 if (common_root == NULL)
952 return;
953
954 if (common_root->left)
955 resolve_common_blocks (common_root->left);
956 if (common_root->right)
957 resolve_common_blocks (common_root->right);
958
959 resolve_common_vars (common_root->n.common->head, true);
960
961 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
962 if (sym == NULL)
963 return;
964
965 if (sym->attr.flavor == FL_PARAMETER)
966 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
967 sym->name, &common_root->n.common->where, &sym->declared_at);
968
969 if (sym->attr.external)
970 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
971 sym->name, &common_root->n.common->where);
972
973 if (sym->attr.intrinsic)
974 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
975 sym->name, &common_root->n.common->where);
976 else if (sym->attr.result
977 || gfc_is_function_return_value (sym, gfc_current_ns))
978 gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
979 "that is also a function result", sym->name,
980 &common_root->n.common->where);
981 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
982 && sym->attr.proc != PROC_ST_FUNCTION)
983 gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L "
984 "that is also a global procedure", sym->name,
985 &common_root->n.common->where);
986 }
987
988
989 /* Resolve contained function types. Because contained functions can call one
990 another, they have to be worked out before any of the contained procedures
991 can be resolved.
992
993 The good news is that if a function doesn't already have a type, the only
994 way it can get one is through an IMPLICIT type or a RESULT variable, because
995 by definition contained functions are contained namespace they're contained
996 in, not in a sibling or parent namespace. */
997
998 static void
resolve_contained_functions(gfc_namespace * ns)999 resolve_contained_functions (gfc_namespace *ns)
1000 {
1001 gfc_namespace *child;
1002 gfc_entry_list *el;
1003
1004 resolve_formal_arglists (ns);
1005
1006 for (child = ns->contained; child; child = child->sibling)
1007 {
1008 /* Resolve alternate entry points first. */
1009 resolve_entries (child);
1010
1011 /* Then check function return types. */
1012 resolve_contained_fntype (child->proc_name, child);
1013 for (el = child->entries; el; el = el->next)
1014 resolve_contained_fntype (el->sym, child);
1015 }
1016 }
1017
1018
1019 static gfc_try resolve_fl_derived0 (gfc_symbol *sym);
1020
1021
1022 /* Resolve all of the elements of a structure constructor and make sure that
1023 the types are correct. The 'init' flag indicates that the given
1024 constructor is an initializer. */
1025
1026 static gfc_try
resolve_structure_cons(gfc_expr * expr,int init)1027 resolve_structure_cons (gfc_expr *expr, int init)
1028 {
1029 gfc_constructor *cons;
1030 gfc_component *comp;
1031 gfc_try t;
1032 symbol_attribute a;
1033
1034 t = SUCCESS;
1035
1036 if (expr->ts.type == BT_DERIVED)
1037 resolve_fl_derived0 (expr->ts.u.derived);
1038
1039 cons = gfc_constructor_first (expr->value.constructor);
1040
1041 /* See if the user is trying to invoke a structure constructor for one of
1042 the iso_c_binding derived types. */
1043 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
1044 && expr->ts.u.derived->ts.is_iso_c && cons
1045 && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
1046 {
1047 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
1048 expr->ts.u.derived->name, &(expr->where));
1049 return FAILURE;
1050 }
1051
1052 /* Return if structure constructor is c_null_(fun)prt. */
1053 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
1054 && expr->ts.u.derived->ts.is_iso_c && cons
1055 && cons->expr && cons->expr->expr_type == EXPR_NULL)
1056 return SUCCESS;
1057
1058 /* A constructor may have references if it is the result of substituting a
1059 parameter variable. In this case we just pull out the component we
1060 want. */
1061 if (expr->ref)
1062 comp = expr->ref->u.c.sym->components;
1063 else
1064 comp = expr->ts.u.derived->components;
1065
1066 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1067 {
1068 int rank;
1069
1070 if (!cons->expr)
1071 continue;
1072
1073 if (gfc_resolve_expr (cons->expr) == FAILURE)
1074 {
1075 t = FAILURE;
1076 continue;
1077 }
1078
1079 rank = comp->as ? comp->as->rank : 0;
1080 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1081 && (comp->attr.allocatable || cons->expr->rank))
1082 {
1083 gfc_error ("The rank of the element in the structure "
1084 "constructor at %L does not match that of the "
1085 "component (%d/%d)", &cons->expr->where,
1086 cons->expr->rank, rank);
1087 t = FAILURE;
1088 }
1089
1090 /* If we don't have the right type, try to convert it. */
1091
1092 if (!comp->attr.proc_pointer &&
1093 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1094 {
1095 if (strcmp (comp->name, "_extends") == 0)
1096 {
1097 /* Can afford to be brutal with the _extends initializer.
1098 The derived type can get lost because it is PRIVATE
1099 but it is not usage constrained by the standard. */
1100 cons->expr->ts = comp->ts;
1101 }
1102 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1103 {
1104 gfc_error ("The element in the structure constructor at %L, "
1105 "for pointer component '%s', is %s but should be %s",
1106 &cons->expr->where, comp->name,
1107 gfc_basic_typename (cons->expr->ts.type),
1108 gfc_basic_typename (comp->ts.type));
1109 t = FAILURE;
1110 }
1111 else
1112 {
1113 gfc_try t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1114 if (t != FAILURE)
1115 t = t2;
1116 }
1117 }
1118
1119 /* For strings, the length of the constructor should be the same as
1120 the one of the structure, ensure this if the lengths are known at
1121 compile time and when we are dealing with PARAMETER or structure
1122 constructors. */
1123 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1124 && comp->ts.u.cl->length
1125 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1126 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1127 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1128 && cons->expr->rank != 0
1129 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1130 comp->ts.u.cl->length->value.integer) != 0)
1131 {
1132 if (cons->expr->expr_type == EXPR_VARIABLE
1133 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1134 {
1135 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1136 to make use of the gfc_resolve_character_array_constructor
1137 machinery. The expression is later simplified away to
1138 an array of string literals. */
1139 gfc_expr *para = cons->expr;
1140 cons->expr = gfc_get_expr ();
1141 cons->expr->ts = para->ts;
1142 cons->expr->where = para->where;
1143 cons->expr->expr_type = EXPR_ARRAY;
1144 cons->expr->rank = para->rank;
1145 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1146 gfc_constructor_append_expr (&cons->expr->value.constructor,
1147 para, &cons->expr->where);
1148 }
1149 if (cons->expr->expr_type == EXPR_ARRAY)
1150 {
1151 gfc_constructor *p;
1152 p = gfc_constructor_first (cons->expr->value.constructor);
1153 if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
1154 {
1155 gfc_charlen *cl, *cl2;
1156
1157 cl2 = NULL;
1158 for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
1159 {
1160 if (cl == cons->expr->ts.u.cl)
1161 break;
1162 cl2 = cl;
1163 }
1164
1165 gcc_assert (cl);
1166
1167 if (cl2)
1168 cl2->next = cl->next;
1169
1170 gfc_free_expr (cl->length);
1171 free (cl);
1172 }
1173
1174 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1175 cons->expr->ts.u.cl->length_from_typespec = true;
1176 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1177 gfc_resolve_character_array_constructor (cons->expr);
1178 }
1179 }
1180
1181 if (cons->expr->expr_type == EXPR_NULL
1182 && !(comp->attr.pointer || comp->attr.allocatable
1183 || comp->attr.proc_pointer
1184 || (comp->ts.type == BT_CLASS
1185 && (CLASS_DATA (comp)->attr.class_pointer
1186 || CLASS_DATA (comp)->attr.allocatable))))
1187 {
1188 t = FAILURE;
1189 gfc_error ("The NULL in the structure constructor at %L is "
1190 "being applied to component '%s', which is neither "
1191 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1192 comp->name);
1193 }
1194
1195 if (comp->attr.proc_pointer && comp->ts.interface)
1196 {
1197 /* Check procedure pointer interface. */
1198 gfc_symbol *s2 = NULL;
1199 gfc_component *c2;
1200 const char *name;
1201 char err[200];
1202
1203 c2 = gfc_get_proc_ptr_comp (cons->expr);
1204 if (c2)
1205 {
1206 s2 = c2->ts.interface;
1207 name = c2->name;
1208 }
1209 else if (cons->expr->expr_type == EXPR_FUNCTION)
1210 {
1211 s2 = cons->expr->symtree->n.sym->result;
1212 name = cons->expr->symtree->n.sym->result->name;
1213 }
1214 else if (cons->expr->expr_type != EXPR_NULL)
1215 {
1216 s2 = cons->expr->symtree->n.sym;
1217 name = cons->expr->symtree->n.sym->name;
1218 }
1219
1220 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1221 err, sizeof (err), NULL, NULL))
1222 {
1223 gfc_error ("Interface mismatch for procedure-pointer component "
1224 "'%s' in structure constructor at %L: %s",
1225 comp->name, &cons->expr->where, err);
1226 return FAILURE;
1227 }
1228 }
1229
1230 if (!comp->attr.pointer || comp->attr.proc_pointer
1231 || cons->expr->expr_type == EXPR_NULL)
1232 continue;
1233
1234 a = gfc_expr_attr (cons->expr);
1235
1236 if (!a.pointer && !a.target)
1237 {
1238 t = FAILURE;
1239 gfc_error ("The element in the structure constructor at %L, "
1240 "for pointer component '%s' should be a POINTER or "
1241 "a TARGET", &cons->expr->where, comp->name);
1242 }
1243
1244 if (init)
1245 {
1246 /* F08:C461. Additional checks for pointer initialization. */
1247 if (a.allocatable)
1248 {
1249 t = FAILURE;
1250 gfc_error ("Pointer initialization target at %L "
1251 "must not be ALLOCATABLE ", &cons->expr->where);
1252 }
1253 if (!a.save)
1254 {
1255 t = FAILURE;
1256 gfc_error ("Pointer initialization target at %L "
1257 "must have the SAVE attribute", &cons->expr->where);
1258 }
1259 }
1260
1261 /* F2003, C1272 (3). */
1262 if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
1263 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1264 || gfc_is_coindexed (cons->expr)))
1265 {
1266 t = FAILURE;
1267 gfc_error ("Invalid expression in the structure constructor for "
1268 "pointer component '%s' at %L in PURE procedure",
1269 comp->name, &cons->expr->where);
1270 }
1271
1272 if (gfc_implicit_pure (NULL)
1273 && cons->expr->expr_type == EXPR_VARIABLE
1274 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1275 || gfc_is_coindexed (cons->expr)))
1276 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1277
1278 }
1279
1280 return t;
1281 }
1282
1283
1284 /****************** Expression name resolution ******************/
1285
1286 /* Returns 0 if a symbol was not declared with a type or
1287 attribute declaration statement, nonzero otherwise. */
1288
1289 static int
was_declared(gfc_symbol * sym)1290 was_declared (gfc_symbol *sym)
1291 {
1292 symbol_attribute a;
1293
1294 a = sym->attr;
1295
1296 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1297 return 1;
1298
1299 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1300 || a.optional || a.pointer || a.save || a.target || a.volatile_
1301 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1302 || a.asynchronous || a.codimension)
1303 return 1;
1304
1305 return 0;
1306 }
1307
1308
1309 /* Determine if a symbol is generic or not. */
1310
1311 static int
generic_sym(gfc_symbol * sym)1312 generic_sym (gfc_symbol *sym)
1313 {
1314 gfc_symbol *s;
1315
1316 if (sym->attr.generic ||
1317 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1318 return 1;
1319
1320 if (was_declared (sym) || sym->ns->parent == NULL)
1321 return 0;
1322
1323 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1324
1325 if (s != NULL)
1326 {
1327 if (s == sym)
1328 return 0;
1329 else
1330 return generic_sym (s);
1331 }
1332
1333 return 0;
1334 }
1335
1336
1337 /* Determine if a symbol is specific or not. */
1338
1339 static int
specific_sym(gfc_symbol * sym)1340 specific_sym (gfc_symbol *sym)
1341 {
1342 gfc_symbol *s;
1343
1344 if (sym->attr.if_source == IFSRC_IFBODY
1345 || sym->attr.proc == PROC_MODULE
1346 || sym->attr.proc == PROC_INTERNAL
1347 || sym->attr.proc == PROC_ST_FUNCTION
1348 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1349 || sym->attr.external)
1350 return 1;
1351
1352 if (was_declared (sym) || sym->ns->parent == NULL)
1353 return 0;
1354
1355 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1356
1357 return (s == NULL) ? 0 : specific_sym (s);
1358 }
1359
1360
1361 /* Figure out if the procedure is specific, generic or unknown. */
1362
1363 typedef enum
1364 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
1365 proc_type;
1366
1367 static proc_type
procedure_kind(gfc_symbol * sym)1368 procedure_kind (gfc_symbol *sym)
1369 {
1370 if (generic_sym (sym))
1371 return PTYPE_GENERIC;
1372
1373 if (specific_sym (sym))
1374 return PTYPE_SPECIFIC;
1375
1376 return PTYPE_UNKNOWN;
1377 }
1378
1379 /* Check references to assumed size arrays. The flag need_full_assumed_size
1380 is nonzero when matching actual arguments. */
1381
1382 static int need_full_assumed_size = 0;
1383
1384 static bool
check_assumed_size_reference(gfc_symbol * sym,gfc_expr * e)1385 check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1386 {
1387 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1388 return false;
1389
1390 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1391 What should it be? */
1392 if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
1393 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1394 && (e->ref->u.ar.type == AR_FULL))
1395 {
1396 gfc_error ("The upper bound in the last dimension must "
1397 "appear in the reference to the assumed size "
1398 "array '%s' at %L", sym->name, &e->where);
1399 return true;
1400 }
1401 return false;
1402 }
1403
1404
1405 /* Look for bad assumed size array references in argument expressions
1406 of elemental and array valued intrinsic procedures. Since this is
1407 called from procedure resolution functions, it only recurses at
1408 operators. */
1409
1410 static bool
resolve_assumed_size_actual(gfc_expr * e)1411 resolve_assumed_size_actual (gfc_expr *e)
1412 {
1413 if (e == NULL)
1414 return false;
1415
1416 switch (e->expr_type)
1417 {
1418 case EXPR_VARIABLE:
1419 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1420 return true;
1421 break;
1422
1423 case EXPR_OP:
1424 if (resolve_assumed_size_actual (e->value.op.op1)
1425 || resolve_assumed_size_actual (e->value.op.op2))
1426 return true;
1427 break;
1428
1429 default:
1430 break;
1431 }
1432 return false;
1433 }
1434
1435
1436 /* Check a generic procedure, passed as an actual argument, to see if
1437 there is a matching specific name. If none, it is an error, and if
1438 more than one, the reference is ambiguous. */
1439 static int
count_specific_procs(gfc_expr * e)1440 count_specific_procs (gfc_expr *e)
1441 {
1442 int n;
1443 gfc_interface *p;
1444 gfc_symbol *sym;
1445
1446 n = 0;
1447 sym = e->symtree->n.sym;
1448
1449 for (p = sym->generic; p; p = p->next)
1450 if (strcmp (sym->name, p->sym->name) == 0)
1451 {
1452 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1453 sym->name);
1454 n++;
1455 }
1456
1457 if (n > 1)
1458 gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
1459 &e->where);
1460
1461 if (n == 0)
1462 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1463 "argument at %L", sym->name, &e->where);
1464
1465 return n;
1466 }
1467
1468
1469 /* See if a call to sym could possibly be a not allowed RECURSION because of
1470 a missing RECURSIVE declaration. This means that either sym is the current
1471 context itself, or sym is the parent of a contained procedure calling its
1472 non-RECURSIVE containing procedure.
1473 This also works if sym is an ENTRY. */
1474
1475 static bool
is_illegal_recursion(gfc_symbol * sym,gfc_namespace * context)1476 is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1477 {
1478 gfc_symbol* proc_sym;
1479 gfc_symbol* context_proc;
1480 gfc_namespace* real_context;
1481
1482 if (sym->attr.flavor == FL_PROGRAM
1483 || sym->attr.flavor == FL_DERIVED)
1484 return false;
1485
1486 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
1487
1488 /* If we've got an ENTRY, find real procedure. */
1489 if (sym->attr.entry && sym->ns->entries)
1490 proc_sym = sym->ns->entries->sym;
1491 else
1492 proc_sym = sym;
1493
1494 /* If sym is RECURSIVE, all is well of course. */
1495 if (proc_sym->attr.recursive || gfc_option.flag_recursive)
1496 return false;
1497
1498 /* Find the context procedure's "real" symbol if it has entries.
1499 We look for a procedure symbol, so recurse on the parents if we don't
1500 find one (like in case of a BLOCK construct). */
1501 for (real_context = context; ; real_context = real_context->parent)
1502 {
1503 /* We should find something, eventually! */
1504 gcc_assert (real_context);
1505
1506 context_proc = (real_context->entries ? real_context->entries->sym
1507 : real_context->proc_name);
1508
1509 /* In some special cases, there may not be a proc_name, like for this
1510 invalid code:
1511 real(bad_kind()) function foo () ...
1512 when checking the call to bad_kind ().
1513 In these cases, we simply return here and assume that the
1514 call is ok. */
1515 if (!context_proc)
1516 return false;
1517
1518 if (context_proc->attr.flavor != FL_LABEL)
1519 break;
1520 }
1521
1522 /* A call from sym's body to itself is recursion, of course. */
1523 if (context_proc == proc_sym)
1524 return true;
1525
1526 /* The same is true if context is a contained procedure and sym the
1527 containing one. */
1528 if (context_proc->attr.contained)
1529 {
1530 gfc_symbol* parent_proc;
1531
1532 gcc_assert (context->parent);
1533 parent_proc = (context->parent->entries ? context->parent->entries->sym
1534 : context->parent->proc_name);
1535
1536 if (parent_proc == proc_sym)
1537 return true;
1538 }
1539
1540 return false;
1541 }
1542
1543
1544 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1545 its typespec and formal argument list. */
1546
1547 gfc_try
gfc_resolve_intrinsic(gfc_symbol * sym,locus * loc)1548 gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1549 {
1550 gfc_intrinsic_sym* isym = NULL;
1551 const char* symstd;
1552
1553 if (sym->formal)
1554 return SUCCESS;
1555
1556 /* Already resolved. */
1557 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1558 return SUCCESS;
1559
1560 /* We already know this one is an intrinsic, so we don't call
1561 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1562 gfc_find_subroutine directly to check whether it is a function or
1563 subroutine. */
1564
1565 if (sym->intmod_sym_id)
1566 isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
1567 else if (!sym->attr.subroutine)
1568 isym = gfc_find_function (sym->name);
1569
1570 if (isym)
1571 {
1572 if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
1573 && !sym->attr.implicit_type)
1574 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1575 " ignored", sym->name, &sym->declared_at);
1576
1577 if (!sym->attr.function &&
1578 gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
1579 return FAILURE;
1580
1581 sym->ts = isym->ts;
1582 }
1583 else if ((isym = gfc_find_subroutine (sym->name)))
1584 {
1585 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1586 {
1587 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1588 " specifier", sym->name, &sym->declared_at);
1589 return FAILURE;
1590 }
1591
1592 if (!sym->attr.subroutine &&
1593 gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
1594 return FAILURE;
1595 }
1596 else
1597 {
1598 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
1599 &sym->declared_at);
1600 return FAILURE;
1601 }
1602
1603 gfc_copy_formal_args_intr (sym, isym);
1604
1605 /* Check it is actually available in the standard settings. */
1606 if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
1607 == FAILURE)
1608 {
1609 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1610 " available in the current standard settings but %s. Use"
1611 " an appropriate -std=* option or enable -fall-intrinsics"
1612 " in order to use it.",
1613 sym->name, &sym->declared_at, symstd);
1614 return FAILURE;
1615 }
1616
1617 return SUCCESS;
1618 }
1619
1620
1621 /* Resolve a procedure expression, like passing it to a called procedure or as
1622 RHS for a procedure pointer assignment. */
1623
1624 static gfc_try
resolve_procedure_expression(gfc_expr * expr)1625 resolve_procedure_expression (gfc_expr* expr)
1626 {
1627 gfc_symbol* sym;
1628
1629 if (expr->expr_type != EXPR_VARIABLE)
1630 return SUCCESS;
1631 gcc_assert (expr->symtree);
1632
1633 sym = expr->symtree->n.sym;
1634
1635 if (sym->attr.intrinsic)
1636 gfc_resolve_intrinsic (sym, &expr->where);
1637
1638 if (sym->attr.flavor != FL_PROCEDURE
1639 || (sym->attr.function && sym->result == sym))
1640 return SUCCESS;
1641
1642 /* A non-RECURSIVE procedure that is used as procedure expression within its
1643 own body is in danger of being called recursively. */
1644 if (is_illegal_recursion (sym, gfc_current_ns))
1645 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1646 " itself recursively. Declare it RECURSIVE or use"
1647 " -frecursive", sym->name, &expr->where);
1648
1649 return SUCCESS;
1650 }
1651
1652
1653 /* Resolve an actual argument list. Most of the time, this is just
1654 resolving the expressions in the list.
1655 The exception is that we sometimes have to decide whether arguments
1656 that look like procedure arguments are really simple variable
1657 references. */
1658
1659 static gfc_try
resolve_actual_arglist(gfc_actual_arglist * arg,procedure_type ptype,bool no_formal_args)1660 resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1661 bool no_formal_args)
1662 {
1663 gfc_symbol *sym;
1664 gfc_symtree *parent_st;
1665 gfc_expr *e;
1666 int save_need_full_assumed_size;
1667 gfc_try return_value = FAILURE;
1668 bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
1669
1670 actual_arg = true;
1671 first_actual_arg = true;
1672
1673 for (; arg; arg = arg->next)
1674 {
1675 e = arg->expr;
1676 if (e == NULL)
1677 {
1678 /* Check the label is a valid branching target. */
1679 if (arg->label)
1680 {
1681 if (arg->label->defined == ST_LABEL_UNKNOWN)
1682 {
1683 gfc_error ("Label %d referenced at %L is never defined",
1684 arg->label->value, &arg->label->where);
1685 goto cleanup;
1686 }
1687 }
1688 first_actual_arg = false;
1689 continue;
1690 }
1691
1692 if (e->expr_type == EXPR_VARIABLE
1693 && e->symtree->n.sym->attr.generic
1694 && no_formal_args
1695 && count_specific_procs (e) != 1)
1696 goto cleanup;
1697
1698 if (e->ts.type != BT_PROCEDURE)
1699 {
1700 save_need_full_assumed_size = need_full_assumed_size;
1701 if (e->expr_type != EXPR_VARIABLE)
1702 need_full_assumed_size = 0;
1703 if (gfc_resolve_expr (e) != SUCCESS)
1704 goto cleanup;
1705 need_full_assumed_size = save_need_full_assumed_size;
1706 goto argument_list;
1707 }
1708
1709 /* See if the expression node should really be a variable reference. */
1710
1711 sym = e->symtree->n.sym;
1712
1713 if (sym->attr.flavor == FL_PROCEDURE
1714 || sym->attr.intrinsic
1715 || sym->attr.external)
1716 {
1717 int actual_ok;
1718
1719 /* If a procedure is not already determined to be something else
1720 check if it is intrinsic. */
1721 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
1722 sym->attr.intrinsic = 1;
1723
1724 if (sym->attr.proc == PROC_ST_FUNCTION)
1725 {
1726 gfc_error ("Statement function '%s' at %L is not allowed as an "
1727 "actual argument", sym->name, &e->where);
1728 }
1729
1730 actual_ok = gfc_intrinsic_actual_ok (sym->name,
1731 sym->attr.subroutine);
1732 if (sym->attr.intrinsic && actual_ok == 0)
1733 {
1734 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1735 "actual argument", sym->name, &e->where);
1736 }
1737
1738 if (sym->attr.contained && !sym->attr.use_assoc
1739 && sym->ns->proc_name->attr.flavor != FL_MODULE)
1740 {
1741 if (gfc_notify_std (GFC_STD_F2008,
1742 "Internal procedure '%s' is"
1743 " used as actual argument at %L",
1744 sym->name, &e->where) == FAILURE)
1745 goto cleanup;
1746 }
1747
1748 if (sym->attr.elemental && !sym->attr.intrinsic)
1749 {
1750 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1751 "allowed as an actual argument at %L", sym->name,
1752 &e->where);
1753 }
1754
1755 /* Check if a generic interface has a specific procedure
1756 with the same name before emitting an error. */
1757 if (sym->attr.generic && count_specific_procs (e) != 1)
1758 goto cleanup;
1759
1760 /* Just in case a specific was found for the expression. */
1761 sym = e->symtree->n.sym;
1762
1763 /* If the symbol is the function that names the current (or
1764 parent) scope, then we really have a variable reference. */
1765
1766 if (gfc_is_function_return_value (sym, sym->ns))
1767 goto got_variable;
1768
1769 /* If all else fails, see if we have a specific intrinsic. */
1770 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
1771 {
1772 gfc_intrinsic_sym *isym;
1773
1774 isym = gfc_find_function (sym->name);
1775 if (isym == NULL || !isym->specific)
1776 {
1777 gfc_error ("Unable to find a specific INTRINSIC procedure "
1778 "for the reference '%s' at %L", sym->name,
1779 &e->where);
1780 goto cleanup;
1781 }
1782 sym->ts = isym->ts;
1783 sym->attr.intrinsic = 1;
1784 sym->attr.function = 1;
1785 }
1786
1787 if (gfc_resolve_expr (e) == FAILURE)
1788 goto cleanup;
1789 goto argument_list;
1790 }
1791
1792 /* See if the name is a module procedure in a parent unit. */
1793
1794 if (was_declared (sym) || sym->ns->parent == NULL)
1795 goto got_variable;
1796
1797 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
1798 {
1799 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
1800 goto cleanup;
1801 }
1802
1803 if (parent_st == NULL)
1804 goto got_variable;
1805
1806 sym = parent_st->n.sym;
1807 e->symtree = parent_st; /* Point to the right thing. */
1808
1809 if (sym->attr.flavor == FL_PROCEDURE
1810 || sym->attr.intrinsic
1811 || sym->attr.external)
1812 {
1813 if (gfc_resolve_expr (e) == FAILURE)
1814 goto cleanup;
1815 goto argument_list;
1816 }
1817
1818 got_variable:
1819 e->expr_type = EXPR_VARIABLE;
1820 e->ts = sym->ts;
1821 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
1822 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1823 && CLASS_DATA (sym)->as))
1824 {
1825 e->rank = sym->ts.type == BT_CLASS
1826 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
1827 e->ref = gfc_get_ref ();
1828 e->ref->type = REF_ARRAY;
1829 e->ref->u.ar.type = AR_FULL;
1830 e->ref->u.ar.as = sym->ts.type == BT_CLASS
1831 ? CLASS_DATA (sym)->as : sym->as;
1832 }
1833
1834 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1835 primary.c (match_actual_arg). If above code determines that it
1836 is a variable instead, it needs to be resolved as it was not
1837 done at the beginning of this function. */
1838 save_need_full_assumed_size = need_full_assumed_size;
1839 if (e->expr_type != EXPR_VARIABLE)
1840 need_full_assumed_size = 0;
1841 if (gfc_resolve_expr (e) != SUCCESS)
1842 goto cleanup;
1843 need_full_assumed_size = save_need_full_assumed_size;
1844
1845 argument_list:
1846 /* Check argument list functions %VAL, %LOC and %REF. There is
1847 nothing to do for %REF. */
1848 if (arg->name && arg->name[0] == '%')
1849 {
1850 if (strncmp ("%VAL", arg->name, 4) == 0)
1851 {
1852 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
1853 {
1854 gfc_error ("By-value argument at %L is not of numeric "
1855 "type", &e->where);
1856 goto cleanup;
1857 }
1858
1859 if (e->rank)
1860 {
1861 gfc_error ("By-value argument at %L cannot be an array or "
1862 "an array section", &e->where);
1863 goto cleanup;
1864 }
1865
1866 /* Intrinsics are still PROC_UNKNOWN here. However,
1867 since same file external procedures are not resolvable
1868 in gfortran, it is a good deal easier to leave them to
1869 intrinsic.c. */
1870 if (ptype != PROC_UNKNOWN
1871 && ptype != PROC_DUMMY
1872 && ptype != PROC_EXTERNAL
1873 && ptype != PROC_MODULE)
1874 {
1875 gfc_error ("By-value argument at %L is not allowed "
1876 "in this context", &e->where);
1877 goto cleanup;
1878 }
1879 }
1880
1881 /* Statement functions have already been excluded above. */
1882 else if (strncmp ("%LOC", arg->name, 4) == 0
1883 && e->ts.type == BT_PROCEDURE)
1884 {
1885 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
1886 {
1887 gfc_error ("Passing internal procedure at %L by location "
1888 "not allowed", &e->where);
1889 goto cleanup;
1890 }
1891 }
1892 }
1893
1894 /* Fortran 2008, C1237. */
1895 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
1896 && gfc_has_ultimate_pointer (e))
1897 {
1898 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1899 "component", &e->where);
1900 goto cleanup;
1901 }
1902
1903 first_actual_arg = false;
1904 }
1905
1906 return_value = SUCCESS;
1907
1908 cleanup:
1909 actual_arg = actual_arg_sav;
1910 first_actual_arg = first_actual_arg_sav;
1911
1912 return return_value;
1913 }
1914
1915
1916 /* Do the checks of the actual argument list that are specific to elemental
1917 procedures. If called with c == NULL, we have a function, otherwise if
1918 expr == NULL, we have a subroutine. */
1919
1920 static gfc_try
resolve_elemental_actual(gfc_expr * expr,gfc_code * c)1921 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
1922 {
1923 gfc_actual_arglist *arg0;
1924 gfc_actual_arglist *arg;
1925 gfc_symbol *esym = NULL;
1926 gfc_intrinsic_sym *isym = NULL;
1927 gfc_expr *e = NULL;
1928 gfc_intrinsic_arg *iformal = NULL;
1929 gfc_formal_arglist *eformal = NULL;
1930 bool formal_optional = false;
1931 bool set_by_optional = false;
1932 int i;
1933 int rank = 0;
1934
1935 /* Is this an elemental procedure? */
1936 if (expr && expr->value.function.actual != NULL)
1937 {
1938 if (expr->value.function.esym != NULL
1939 && expr->value.function.esym->attr.elemental)
1940 {
1941 arg0 = expr->value.function.actual;
1942 esym = expr->value.function.esym;
1943 }
1944 else if (expr->value.function.isym != NULL
1945 && expr->value.function.isym->elemental)
1946 {
1947 arg0 = expr->value.function.actual;
1948 isym = expr->value.function.isym;
1949 }
1950 else
1951 return SUCCESS;
1952 }
1953 else if (c && c->ext.actual != NULL)
1954 {
1955 arg0 = c->ext.actual;
1956
1957 if (c->resolved_sym)
1958 esym = c->resolved_sym;
1959 else
1960 esym = c->symtree->n.sym;
1961 gcc_assert (esym);
1962
1963 if (!esym->attr.elemental)
1964 return SUCCESS;
1965 }
1966 else
1967 return SUCCESS;
1968
1969 /* The rank of an elemental is the rank of its array argument(s). */
1970 for (arg = arg0; arg; arg = arg->next)
1971 {
1972 if (arg->expr != NULL && arg->expr->rank != 0)
1973 {
1974 rank = arg->expr->rank;
1975 if (arg->expr->expr_type == EXPR_VARIABLE
1976 && arg->expr->symtree->n.sym->attr.optional)
1977 set_by_optional = true;
1978
1979 /* Function specific; set the result rank and shape. */
1980 if (expr)
1981 {
1982 expr->rank = rank;
1983 if (!expr->shape && arg->expr->shape)
1984 {
1985 expr->shape = gfc_get_shape (rank);
1986 for (i = 0; i < rank; i++)
1987 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1988 }
1989 }
1990 break;
1991 }
1992 }
1993
1994 /* If it is an array, it shall not be supplied as an actual argument
1995 to an elemental procedure unless an array of the same rank is supplied
1996 as an actual argument corresponding to a nonoptional dummy argument of
1997 that elemental procedure(12.4.1.5). */
1998 formal_optional = false;
1999 if (isym)
2000 iformal = isym->formal;
2001 else
2002 eformal = esym->formal;
2003
2004 for (arg = arg0; arg; arg = arg->next)
2005 {
2006 if (eformal)
2007 {
2008 if (eformal->sym && eformal->sym->attr.optional)
2009 formal_optional = true;
2010 eformal = eformal->next;
2011 }
2012 else if (isym && iformal)
2013 {
2014 if (iformal->optional)
2015 formal_optional = true;
2016 iformal = iformal->next;
2017 }
2018 else if (isym)
2019 formal_optional = true;
2020
2021 if (pedantic && arg->expr != NULL
2022 && arg->expr->expr_type == EXPR_VARIABLE
2023 && arg->expr->symtree->n.sym->attr.optional
2024 && formal_optional
2025 && arg->expr->rank
2026 && (set_by_optional || arg->expr->rank != rank)
2027 && !(isym && isym->id == GFC_ISYM_CONVERSION))
2028 {
2029 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2030 "MISSING, it cannot be the actual argument of an "
2031 "ELEMENTAL procedure unless there is a non-optional "
2032 "argument with the same rank (12.4.1.5)",
2033 arg->expr->symtree->n.sym->name, &arg->expr->where);
2034 }
2035 }
2036
2037 for (arg = arg0; arg; arg = arg->next)
2038 {
2039 if (arg->expr == NULL || arg->expr->rank == 0)
2040 continue;
2041
2042 /* Being elemental, the last upper bound of an assumed size array
2043 argument must be present. */
2044 if (resolve_assumed_size_actual (arg->expr))
2045 return FAILURE;
2046
2047 /* Elemental procedure's array actual arguments must conform. */
2048 if (e != NULL)
2049 {
2050 if (gfc_check_conformance (arg->expr, e,
2051 "elemental procedure") == FAILURE)
2052 return FAILURE;
2053 }
2054 else
2055 e = arg->expr;
2056 }
2057
2058 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2059 is an array, the intent inout/out variable needs to be also an array. */
2060 if (rank > 0 && esym && expr == NULL)
2061 for (eformal = esym->formal, arg = arg0; arg && eformal;
2062 arg = arg->next, eformal = eformal->next)
2063 if ((eformal->sym->attr.intent == INTENT_OUT
2064 || eformal->sym->attr.intent == INTENT_INOUT)
2065 && arg->expr && arg->expr->rank == 0)
2066 {
2067 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2068 "ELEMENTAL subroutine '%s' is a scalar, but another "
2069 "actual argument is an array", &arg->expr->where,
2070 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2071 : "INOUT", eformal->sym->name, esym->name);
2072 return FAILURE;
2073 }
2074 return SUCCESS;
2075 }
2076
2077
2078 /* This function does the checking of references to global procedures
2079 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2080 77 and 95 standards. It checks for a gsymbol for the name, making
2081 one if it does not already exist. If it already exists, then the
2082 reference being resolved must correspond to the type of gsymbol.
2083 Otherwise, the new symbol is equipped with the attributes of the
2084 reference. The corresponding code that is called in creating
2085 global entities is parse.c.
2086
2087 In addition, for all but -std=legacy, the gsymbols are used to
2088 check the interfaces of external procedures from the same file.
2089 The namespace of the gsymbol is resolved and then, once this is
2090 done the interface is checked. */
2091
2092
2093 static bool
not_in_recursive(gfc_symbol * sym,gfc_namespace * gsym_ns)2094 not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2095 {
2096 if (!gsym_ns->proc_name->attr.recursive)
2097 return true;
2098
2099 if (sym->ns == gsym_ns)
2100 return false;
2101
2102 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2103 return false;
2104
2105 return true;
2106 }
2107
2108 static bool
not_entry_self_reference(gfc_symbol * sym,gfc_namespace * gsym_ns)2109 not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2110 {
2111 if (gsym_ns->entries)
2112 {
2113 gfc_entry_list *entry = gsym_ns->entries;
2114
2115 for (; entry; entry = entry->next)
2116 {
2117 if (strcmp (sym->name, entry->sym->name) == 0)
2118 {
2119 if (strcmp (gsym_ns->proc_name->name,
2120 sym->ns->proc_name->name) == 0)
2121 return false;
2122
2123 if (sym->ns->parent
2124 && strcmp (gsym_ns->proc_name->name,
2125 sym->ns->parent->proc_name->name) == 0)
2126 return false;
2127 }
2128 }
2129 }
2130 return true;
2131 }
2132
2133 static void
resolve_global_procedure(gfc_symbol * sym,locus * where,gfc_actual_arglist ** actual,int sub)2134 resolve_global_procedure (gfc_symbol *sym, locus *where,
2135 gfc_actual_arglist **actual, int sub)
2136 {
2137 gfc_gsymbol * gsym;
2138 gfc_namespace *ns;
2139 enum gfc_symbol_type type;
2140
2141 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2142
2143 gsym = gfc_get_gsymbol (sym->name);
2144
2145 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2146 gfc_global_used (gsym, where);
2147
2148 if (gfc_option.flag_whole_file
2149 && (sym->attr.if_source == IFSRC_UNKNOWN
2150 || sym->attr.if_source == IFSRC_IFBODY)
2151 && gsym->type != GSYM_UNKNOWN
2152 && gsym->ns
2153 && gsym->ns->resolved != -1
2154 && gsym->ns->proc_name
2155 && not_in_recursive (sym, gsym->ns)
2156 && not_entry_self_reference (sym, gsym->ns))
2157 {
2158 gfc_symbol *def_sym;
2159
2160 /* Resolve the gsymbol namespace if needed. */
2161 if (!gsym->ns->resolved)
2162 {
2163 gfc_dt_list *old_dt_list;
2164 struct gfc_omp_saved_state old_omp_state;
2165
2166 /* Stash away derived types so that the backend_decls do not
2167 get mixed up. */
2168 old_dt_list = gfc_derived_types;
2169 gfc_derived_types = NULL;
2170 /* And stash away openmp state. */
2171 gfc_omp_save_and_clear_state (&old_omp_state);
2172
2173 gfc_resolve (gsym->ns);
2174
2175 /* Store the new derived types with the global namespace. */
2176 if (gfc_derived_types)
2177 gsym->ns->derived_types = gfc_derived_types;
2178
2179 /* Restore the derived types of this namespace. */
2180 gfc_derived_types = old_dt_list;
2181 /* And openmp state. */
2182 gfc_omp_restore_state (&old_omp_state);
2183 }
2184
2185 /* Make sure that translation for the gsymbol occurs before
2186 the procedure currently being resolved. */
2187 ns = gfc_global_ns_list;
2188 for (; ns && ns != gsym->ns; ns = ns->sibling)
2189 {
2190 if (ns->sibling == gsym->ns)
2191 {
2192 ns->sibling = gsym->ns->sibling;
2193 gsym->ns->sibling = gfc_global_ns_list;
2194 gfc_global_ns_list = gsym->ns;
2195 break;
2196 }
2197 }
2198
2199 def_sym = gsym->ns->proc_name;
2200 if (def_sym->attr.entry_master)
2201 {
2202 gfc_entry_list *entry;
2203 for (entry = gsym->ns->entries; entry; entry = entry->next)
2204 if (strcmp (entry->sym->name, sym->name) == 0)
2205 {
2206 def_sym = entry->sym;
2207 break;
2208 }
2209 }
2210
2211 /* Differences in constant character lengths. */
2212 if (sym->attr.function && sym->ts.type == BT_CHARACTER)
2213 {
2214 long int l1 = 0, l2 = 0;
2215 gfc_charlen *cl1 = sym->ts.u.cl;
2216 gfc_charlen *cl2 = def_sym->ts.u.cl;
2217
2218 if (cl1 != NULL
2219 && cl1->length != NULL
2220 && cl1->length->expr_type == EXPR_CONSTANT)
2221 l1 = mpz_get_si (cl1->length->value.integer);
2222
2223 if (cl2 != NULL
2224 && cl2->length != NULL
2225 && cl2->length->expr_type == EXPR_CONSTANT)
2226 l2 = mpz_get_si (cl2->length->value.integer);
2227
2228 if (l1 && l2 && l1 != l2)
2229 gfc_error ("Character length mismatch in return type of "
2230 "function '%s' at %L (%ld/%ld)", sym->name,
2231 &sym->declared_at, l1, l2);
2232 }
2233
2234 /* Type mismatch of function return type and expected type. */
2235 if (sym->attr.function
2236 && !gfc_compare_types (&sym->ts, &def_sym->ts))
2237 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2238 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2239 gfc_typename (&def_sym->ts));
2240
2241 if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
2242 {
2243 gfc_formal_arglist *arg = def_sym->formal;
2244 for ( ; arg; arg = arg->next)
2245 if (!arg->sym)
2246 continue;
2247 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2248 else if (arg->sym->attr.allocatable
2249 || arg->sym->attr.asynchronous
2250 || arg->sym->attr.optional
2251 || arg->sym->attr.pointer
2252 || arg->sym->attr.target
2253 || arg->sym->attr.value
2254 || arg->sym->attr.volatile_)
2255 {
2256 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2257 "has an attribute that requires an explicit "
2258 "interface for this procedure", arg->sym->name,
2259 sym->name, &sym->declared_at);
2260 break;
2261 }
2262 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2263 else if (arg->sym && arg->sym->as
2264 && arg->sym->as->type == AS_ASSUMED_SHAPE)
2265 {
2266 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2267 "argument '%s' must have an explicit interface",
2268 sym->name, &sym->declared_at, arg->sym->name);
2269 break;
2270 }
2271 /* TS 29113, 6.2. */
2272 else if (arg->sym && arg->sym->as
2273 && arg->sym->as->type == AS_ASSUMED_RANK)
2274 {
2275 gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
2276 "argument '%s' must have an explicit interface",
2277 sym->name, &sym->declared_at, arg->sym->name);
2278 break;
2279 }
2280 /* F2008, 12.4.2.2 (2c) */
2281 else if (arg->sym->attr.codimension)
2282 {
2283 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2284 "'%s' must have an explicit interface",
2285 sym->name, &sym->declared_at, arg->sym->name);
2286 break;
2287 }
2288 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2289 else if (false) /* TODO: is a parametrized derived type */
2290 {
2291 gfc_error ("Procedure '%s' at %L with parametrized derived "
2292 "type argument '%s' must have an explicit "
2293 "interface", sym->name, &sym->declared_at,
2294 arg->sym->name);
2295 break;
2296 }
2297 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2298 else if (arg->sym->ts.type == BT_CLASS)
2299 {
2300 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2301 "argument '%s' must have an explicit interface",
2302 sym->name, &sym->declared_at, arg->sym->name);
2303 break;
2304 }
2305 /* As assumed-type is unlimited polymorphic (cf. above).
2306 See also TS 29113, Note 6.1. */
2307 else if (arg->sym->ts.type == BT_ASSUMED)
2308 {
2309 gfc_error ("Procedure '%s' at %L with assumed-type dummy "
2310 "argument '%s' must have an explicit interface",
2311 sym->name, &sym->declared_at, arg->sym->name);
2312 break;
2313 }
2314 }
2315
2316 if (def_sym->attr.function)
2317 {
2318 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2319 if (def_sym->as && def_sym->as->rank
2320 && (!sym->as || sym->as->rank != def_sym->as->rank))
2321 gfc_error ("The reference to function '%s' at %L either needs an "
2322 "explicit INTERFACE or the rank is incorrect", sym->name,
2323 where);
2324
2325 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2326 if ((def_sym->result->attr.pointer
2327 || def_sym->result->attr.allocatable)
2328 && (sym->attr.if_source != IFSRC_IFBODY
2329 || def_sym->result->attr.pointer
2330 != sym->result->attr.pointer
2331 || def_sym->result->attr.allocatable
2332 != sym->result->attr.allocatable))
2333 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2334 "result must have an explicit interface", sym->name,
2335 where);
2336
2337 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2338 if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
2339 && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
2340 {
2341 gfc_charlen *cl = sym->ts.u.cl;
2342
2343 if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
2344 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
2345 {
2346 gfc_error ("Nonconstant character-length function '%s' at %L "
2347 "must have an explicit interface", sym->name,
2348 &sym->declared_at);
2349 }
2350 }
2351 }
2352
2353 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2354 if (def_sym->attr.elemental && !sym->attr.elemental)
2355 {
2356 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2357 "interface", sym->name, &sym->declared_at);
2358 }
2359
2360 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2361 if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
2362 {
2363 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2364 "an explicit interface", sym->name, &sym->declared_at);
2365 }
2366
2367 if (gfc_option.flag_whole_file == 1
2368 || ((gfc_option.warn_std & GFC_STD_LEGACY)
2369 && !(gfc_option.warn_std & GFC_STD_GNU)))
2370 gfc_errors_to_warnings (1);
2371
2372 if (sym->attr.if_source != IFSRC_IFBODY)
2373 gfc_procedure_use (def_sym, actual, where);
2374
2375 gfc_errors_to_warnings (0);
2376 }
2377
2378 if (gsym->type == GSYM_UNKNOWN)
2379 {
2380 gsym->type = type;
2381 gsym->where = *where;
2382 }
2383
2384 gsym->used = 1;
2385 }
2386
2387
2388 /************* Function resolution *************/
2389
2390 /* Resolve a function call known to be generic.
2391 Section 14.1.2.4.1. */
2392
2393 static match
resolve_generic_f0(gfc_expr * expr,gfc_symbol * sym)2394 resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2395 {
2396 gfc_symbol *s;
2397
2398 if (sym->attr.generic)
2399 {
2400 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2401 if (s != NULL)
2402 {
2403 expr->value.function.name = s->name;
2404 expr->value.function.esym = s;
2405
2406 if (s->ts.type != BT_UNKNOWN)
2407 expr->ts = s->ts;
2408 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2409 expr->ts = s->result->ts;
2410
2411 if (s->as != NULL)
2412 expr->rank = s->as->rank;
2413 else if (s->result != NULL && s->result->as != NULL)
2414 expr->rank = s->result->as->rank;
2415
2416 gfc_set_sym_referenced (expr->value.function.esym);
2417
2418 return MATCH_YES;
2419 }
2420
2421 /* TODO: Need to search for elemental references in generic
2422 interface. */
2423 }
2424
2425 if (sym->attr.intrinsic)
2426 return gfc_intrinsic_func_interface (expr, 0);
2427
2428 return MATCH_NO;
2429 }
2430
2431
2432 static gfc_try
resolve_generic_f(gfc_expr * expr)2433 resolve_generic_f (gfc_expr *expr)
2434 {
2435 gfc_symbol *sym;
2436 match m;
2437 gfc_interface *intr = NULL;
2438
2439 sym = expr->symtree->n.sym;
2440
2441 for (;;)
2442 {
2443 m = resolve_generic_f0 (expr, sym);
2444 if (m == MATCH_YES)
2445 return SUCCESS;
2446 else if (m == MATCH_ERROR)
2447 return FAILURE;
2448
2449 generic:
2450 if (!intr)
2451 for (intr = sym->generic; intr; intr = intr->next)
2452 if (intr->sym->attr.flavor == FL_DERIVED)
2453 break;
2454
2455 if (sym->ns->parent == NULL)
2456 break;
2457 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2458
2459 if (sym == NULL)
2460 break;
2461 if (!generic_sym (sym))
2462 goto generic;
2463 }
2464
2465 /* Last ditch attempt. See if the reference is to an intrinsic
2466 that possesses a matching interface. 14.1.2.4 */
2467 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2468 {
2469 gfc_error ("There is no specific function for the generic '%s' "
2470 "at %L", expr->symtree->n.sym->name, &expr->where);
2471 return FAILURE;
2472 }
2473
2474 if (intr)
2475 {
2476 if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
2477 false) != SUCCESS)
2478 return FAILURE;
2479 return resolve_structure_cons (expr, 0);
2480 }
2481
2482 m = gfc_intrinsic_func_interface (expr, 0);
2483 if (m == MATCH_YES)
2484 return SUCCESS;
2485
2486 if (m == MATCH_NO)
2487 gfc_error ("Generic function '%s' at %L is not consistent with a "
2488 "specific intrinsic interface", expr->symtree->n.sym->name,
2489 &expr->where);
2490
2491 return FAILURE;
2492 }
2493
2494
2495 /* Resolve a function call known to be specific. */
2496
2497 static match
resolve_specific_f0(gfc_symbol * sym,gfc_expr * expr)2498 resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2499 {
2500 match m;
2501
2502 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2503 {
2504 if (sym->attr.dummy)
2505 {
2506 sym->attr.proc = PROC_DUMMY;
2507 goto found;
2508 }
2509
2510 sym->attr.proc = PROC_EXTERNAL;
2511 goto found;
2512 }
2513
2514 if (sym->attr.proc == PROC_MODULE
2515 || sym->attr.proc == PROC_ST_FUNCTION
2516 || sym->attr.proc == PROC_INTERNAL)
2517 goto found;
2518
2519 if (sym->attr.intrinsic)
2520 {
2521 m = gfc_intrinsic_func_interface (expr, 1);
2522 if (m == MATCH_YES)
2523 return MATCH_YES;
2524 if (m == MATCH_NO)
2525 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2526 "with an intrinsic", sym->name, &expr->where);
2527
2528 return MATCH_ERROR;
2529 }
2530
2531 return MATCH_NO;
2532
2533 found:
2534 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2535
2536 if (sym->result)
2537 expr->ts = sym->result->ts;
2538 else
2539 expr->ts = sym->ts;
2540 expr->value.function.name = sym->name;
2541 expr->value.function.esym = sym;
2542 if (sym->as != NULL)
2543 expr->rank = sym->as->rank;
2544
2545 return MATCH_YES;
2546 }
2547
2548
2549 static gfc_try
resolve_specific_f(gfc_expr * expr)2550 resolve_specific_f (gfc_expr *expr)
2551 {
2552 gfc_symbol *sym;
2553 match m;
2554
2555 sym = expr->symtree->n.sym;
2556
2557 for (;;)
2558 {
2559 m = resolve_specific_f0 (sym, expr);
2560 if (m == MATCH_YES)
2561 return SUCCESS;
2562 if (m == MATCH_ERROR)
2563 return FAILURE;
2564
2565 if (sym->ns->parent == NULL)
2566 break;
2567
2568 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2569
2570 if (sym == NULL)
2571 break;
2572 }
2573
2574 gfc_error ("Unable to resolve the specific function '%s' at %L",
2575 expr->symtree->n.sym->name, &expr->where);
2576
2577 return SUCCESS;
2578 }
2579
2580
2581 /* Resolve a procedure call not known to be generic nor specific. */
2582
2583 static gfc_try
resolve_unknown_f(gfc_expr * expr)2584 resolve_unknown_f (gfc_expr *expr)
2585 {
2586 gfc_symbol *sym;
2587 gfc_typespec *ts;
2588
2589 sym = expr->symtree->n.sym;
2590
2591 if (sym->attr.dummy)
2592 {
2593 sym->attr.proc = PROC_DUMMY;
2594 expr->value.function.name = sym->name;
2595 goto set_type;
2596 }
2597
2598 /* See if we have an intrinsic function reference. */
2599
2600 if (gfc_is_intrinsic (sym, 0, expr->where))
2601 {
2602 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2603 return SUCCESS;
2604 return FAILURE;
2605 }
2606
2607 /* The reference is to an external name. */
2608
2609 sym->attr.proc = PROC_EXTERNAL;
2610 expr->value.function.name = sym->name;
2611 expr->value.function.esym = expr->symtree->n.sym;
2612
2613 if (sym->as != NULL)
2614 expr->rank = sym->as->rank;
2615
2616 /* Type of the expression is either the type of the symbol or the
2617 default type of the symbol. */
2618
2619 set_type:
2620 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2621
2622 if (sym->ts.type != BT_UNKNOWN)
2623 expr->ts = sym->ts;
2624 else
2625 {
2626 ts = gfc_get_default_type (sym->name, sym->ns);
2627
2628 if (ts->type == BT_UNKNOWN)
2629 {
2630 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2631 sym->name, &expr->where);
2632 return FAILURE;
2633 }
2634 else
2635 expr->ts = *ts;
2636 }
2637
2638 return SUCCESS;
2639 }
2640
2641
2642 /* Return true, if the symbol is an external procedure. */
2643 static bool
is_external_proc(gfc_symbol * sym)2644 is_external_proc (gfc_symbol *sym)
2645 {
2646 if (!sym->attr.dummy && !sym->attr.contained
2647 && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
2648 && sym->attr.proc != PROC_ST_FUNCTION
2649 && !sym->attr.proc_pointer
2650 && !sym->attr.use_assoc
2651 && sym->name)
2652 return true;
2653
2654 return false;
2655 }
2656
2657
2658 /* Figure out if a function reference is pure or not. Also set the name
2659 of the function for a potential error message. Return nonzero if the
2660 function is PURE, zero if not. */
2661 static int
2662 pure_stmt_function (gfc_expr *, gfc_symbol *);
2663
2664 static int
pure_function(gfc_expr * e,const char ** name)2665 pure_function (gfc_expr *e, const char **name)
2666 {
2667 int pure;
2668
2669 *name = NULL;
2670
2671 if (e->symtree != NULL
2672 && e->symtree->n.sym != NULL
2673 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2674 return pure_stmt_function (e, e->symtree->n.sym);
2675
2676 if (e->value.function.esym)
2677 {
2678 pure = gfc_pure (e->value.function.esym);
2679 *name = e->value.function.esym->name;
2680 }
2681 else if (e->value.function.isym)
2682 {
2683 pure = e->value.function.isym->pure
2684 || e->value.function.isym->elemental;
2685 *name = e->value.function.isym->name;
2686 }
2687 else
2688 {
2689 /* Implicit functions are not pure. */
2690 pure = 0;
2691 *name = e->value.function.name;
2692 }
2693
2694 return pure;
2695 }
2696
2697
2698 static bool
impure_stmt_fcn(gfc_expr * e,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)2699 impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
2700 int *f ATTRIBUTE_UNUSED)
2701 {
2702 const char *name;
2703
2704 /* Don't bother recursing into other statement functions
2705 since they will be checked individually for purity. */
2706 if (e->expr_type != EXPR_FUNCTION
2707 || !e->symtree
2708 || e->symtree->n.sym == sym
2709 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2710 return false;
2711
2712 return pure_function (e, &name) ? false : true;
2713 }
2714
2715
2716 static int
pure_stmt_function(gfc_expr * e,gfc_symbol * sym)2717 pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
2718 {
2719 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
2720 }
2721
2722
2723 static gfc_try
is_scalar_expr_ptr(gfc_expr * expr)2724 is_scalar_expr_ptr (gfc_expr *expr)
2725 {
2726 gfc_try retval = SUCCESS;
2727 gfc_ref *ref;
2728 int start;
2729 int end;
2730
2731 /* See if we have a gfc_ref, which means we have a substring, array
2732 reference, or a component. */
2733 if (expr->ref != NULL)
2734 {
2735 ref = expr->ref;
2736 while (ref->next != NULL)
2737 ref = ref->next;
2738
2739 switch (ref->type)
2740 {
2741 case REF_SUBSTRING:
2742 if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
2743 || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
2744 retval = FAILURE;
2745 break;
2746
2747 case REF_ARRAY:
2748 if (ref->u.ar.type == AR_ELEMENT)
2749 retval = SUCCESS;
2750 else if (ref->u.ar.type == AR_FULL)
2751 {
2752 /* The user can give a full array if the array is of size 1. */
2753 if (ref->u.ar.as != NULL
2754 && ref->u.ar.as->rank == 1
2755 && ref->u.ar.as->type == AS_EXPLICIT
2756 && ref->u.ar.as->lower[0] != NULL
2757 && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
2758 && ref->u.ar.as->upper[0] != NULL
2759 && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
2760 {
2761 /* If we have a character string, we need to check if
2762 its length is one. */
2763 if (expr->ts.type == BT_CHARACTER)
2764 {
2765 if (expr->ts.u.cl == NULL
2766 || expr->ts.u.cl->length == NULL
2767 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
2768 != 0)
2769 retval = FAILURE;
2770 }
2771 else
2772 {
2773 /* We have constant lower and upper bounds. If the
2774 difference between is 1, it can be considered a
2775 scalar.
2776 FIXME: Use gfc_dep_compare_expr instead. */
2777 start = (int) mpz_get_si
2778 (ref->u.ar.as->lower[0]->value.integer);
2779 end = (int) mpz_get_si
2780 (ref->u.ar.as->upper[0]->value.integer);
2781 if (end - start + 1 != 1)
2782 retval = FAILURE;
2783 }
2784 }
2785 else
2786 retval = FAILURE;
2787 }
2788 else
2789 retval = FAILURE;
2790 break;
2791 default:
2792 retval = SUCCESS;
2793 break;
2794 }
2795 }
2796 else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
2797 {
2798 /* Character string. Make sure it's of length 1. */
2799 if (expr->ts.u.cl == NULL
2800 || expr->ts.u.cl->length == NULL
2801 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
2802 retval = FAILURE;
2803 }
2804 else if (expr->rank != 0)
2805 retval = FAILURE;
2806
2807 return retval;
2808 }
2809
2810
2811 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2812 and, in the case of c_associated, set the binding label based on
2813 the arguments. */
2814
2815 static gfc_try
gfc_iso_c_func_interface(gfc_symbol * sym,gfc_actual_arglist * args,gfc_symbol ** new_sym)2816 gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
2817 gfc_symbol **new_sym)
2818 {
2819 char name[GFC_MAX_SYMBOL_LEN + 1];
2820 int optional_arg = 0;
2821 gfc_try retval = SUCCESS;
2822 gfc_symbol *args_sym;
2823 gfc_typespec *arg_ts;
2824 symbol_attribute arg_attr;
2825
2826 if (args->expr->expr_type == EXPR_CONSTANT
2827 || args->expr->expr_type == EXPR_OP
2828 || args->expr->expr_type == EXPR_NULL)
2829 {
2830 gfc_error ("Argument to '%s' at %L is not a variable",
2831 sym->name, &(args->expr->where));
2832 return FAILURE;
2833 }
2834
2835 args_sym = args->expr->symtree->n.sym;
2836
2837 /* The typespec for the actual arg should be that stored in the expr
2838 and not necessarily that of the expr symbol (args_sym), because
2839 the actual expression could be a part-ref of the expr symbol. */
2840 arg_ts = &(args->expr->ts);
2841 arg_attr = gfc_expr_attr (args->expr);
2842
2843 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2844 {
2845 /* If the user gave two args then they are providing something for
2846 the optional arg (the second cptr). Therefore, set the name and
2847 binding label to the c_associated for two cptrs. Otherwise,
2848 set c_associated to expect one cptr. */
2849 if (args->next)
2850 {
2851 /* two args. */
2852 sprintf (name, "%s_2", sym->name);
2853 optional_arg = 1;
2854 }
2855 else
2856 {
2857 /* one arg. */
2858 sprintf (name, "%s_1", sym->name);
2859 optional_arg = 0;
2860 }
2861
2862 /* Get a new symbol for the version of c_associated that
2863 will get called. */
2864 *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
2865 }
2866 else if (sym->intmod_sym_id == ISOCBINDING_LOC
2867 || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2868 {
2869 sprintf (name, "%s", sym->name);
2870
2871 /* Error check the call. */
2872 if (args->next != NULL)
2873 {
2874 gfc_error_now ("More actual than formal arguments in '%s' "
2875 "call at %L", name, &(args->expr->where));
2876 retval = FAILURE;
2877 }
2878 else if (sym->intmod_sym_id == ISOCBINDING_LOC)
2879 {
2880 gfc_ref *ref;
2881 bool seen_section;
2882
2883 /* Make sure we have either the target or pointer attribute. */
2884 if (!arg_attr.target && !arg_attr.pointer)
2885 {
2886 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2887 "a TARGET or an associated pointer",
2888 args_sym->name,
2889 sym->name, &(args->expr->where));
2890 retval = FAILURE;
2891 }
2892
2893 if (gfc_is_coindexed (args->expr))
2894 {
2895 gfc_error_now ("Coindexed argument not permitted"
2896 " in '%s' call at %L", name,
2897 &(args->expr->where));
2898 retval = FAILURE;
2899 }
2900
2901 /* Follow references to make sure there are no array
2902 sections. */
2903 seen_section = false;
2904
2905 for (ref=args->expr->ref; ref; ref = ref->next)
2906 {
2907 if (ref->type == REF_ARRAY)
2908 {
2909 if (ref->u.ar.type == AR_SECTION)
2910 seen_section = true;
2911
2912 if (ref->u.ar.type != AR_ELEMENT)
2913 {
2914 gfc_ref *r;
2915 for (r = ref->next; r; r=r->next)
2916 if (r->type == REF_COMPONENT)
2917 {
2918 gfc_error_now ("Array section not permitted"
2919 " in '%s' call at %L", name,
2920 &(args->expr->where));
2921 retval = FAILURE;
2922 break;
2923 }
2924 }
2925 }
2926 }
2927
2928 if (seen_section && retval == SUCCESS)
2929 gfc_warning ("Array section in '%s' call at %L", name,
2930 &(args->expr->where));
2931
2932 /* See if we have interoperable type and type param. */
2933 if (gfc_verify_c_interop (arg_ts) == SUCCESS
2934 || gfc_check_any_c_kind (arg_ts) == SUCCESS)
2935 {
2936 if (args_sym->attr.target == 1)
2937 {
2938 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2939 has the target attribute and is interoperable. */
2940 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2941 allocatable variable that has the TARGET attribute and
2942 is not an array of zero size. */
2943 if (args_sym->attr.allocatable == 1)
2944 {
2945 if (args_sym->attr.dimension != 0
2946 && (args_sym->as && args_sym->as->rank == 0))
2947 {
2948 gfc_error_now ("Allocatable variable '%s' used as a "
2949 "parameter to '%s' at %L must not be "
2950 "an array of zero size",
2951 args_sym->name, sym->name,
2952 &(args->expr->where));
2953 retval = FAILURE;
2954 }
2955 }
2956 else
2957 {
2958 /* A non-allocatable target variable with C
2959 interoperable type and type parameters must be
2960 interoperable. */
2961 if (args_sym && args_sym->attr.dimension)
2962 {
2963 if (args_sym->as->type == AS_ASSUMED_SHAPE)
2964 {
2965 gfc_error ("Assumed-shape array '%s' at %L "
2966 "cannot be an argument to the "
2967 "procedure '%s' because "
2968 "it is not C interoperable",
2969 args_sym->name,
2970 &(args->expr->where), sym->name);
2971 retval = FAILURE;
2972 }
2973 else if (args_sym->as->type == AS_DEFERRED)
2974 {
2975 gfc_error ("Deferred-shape array '%s' at %L "
2976 "cannot be an argument to the "
2977 "procedure '%s' because "
2978 "it is not C interoperable",
2979 args_sym->name,
2980 &(args->expr->where), sym->name);
2981 retval = FAILURE;
2982 }
2983 }
2984
2985 /* Make sure it's not a character string. Arrays of
2986 any type should be ok if the variable is of a C
2987 interoperable type. */
2988 if (arg_ts->type == BT_CHARACTER)
2989 if (arg_ts->u.cl != NULL
2990 && (arg_ts->u.cl->length == NULL
2991 || arg_ts->u.cl->length->expr_type
2992 != EXPR_CONSTANT
2993 || mpz_cmp_si
2994 (arg_ts->u.cl->length->value.integer, 1)
2995 != 0)
2996 && is_scalar_expr_ptr (args->expr) != SUCCESS)
2997 {
2998 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2999 "at %L must have a length of 1",
3000 args_sym->name, sym->name,
3001 &(args->expr->where));
3002 retval = FAILURE;
3003 }
3004 }
3005 }
3006 else if (arg_attr.pointer
3007 && is_scalar_expr_ptr (args->expr) != SUCCESS)
3008 {
3009 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
3010 scalar pointer. */
3011 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
3012 "associated scalar POINTER", args_sym->name,
3013 sym->name, &(args->expr->where));
3014 retval = FAILURE;
3015 }
3016 }
3017 else
3018 {
3019 /* The parameter is not required to be C interoperable. If it
3020 is not C interoperable, it must be a nonpolymorphic scalar
3021 with no length type parameters. It still must have either
3022 the pointer or target attribute, and it can be
3023 allocatable (but must be allocated when c_loc is called). */
3024 if (args->expr->rank != 0
3025 && is_scalar_expr_ptr (args->expr) != SUCCESS)
3026 {
3027 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
3028 "scalar", args_sym->name, sym->name,
3029 &(args->expr->where));
3030 retval = FAILURE;
3031 }
3032 else if (arg_ts->type == BT_CHARACTER
3033 && is_scalar_expr_ptr (args->expr) != SUCCESS)
3034 {
3035 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
3036 "%L must have a length of 1",
3037 args_sym->name, sym->name,
3038 &(args->expr->where));
3039 retval = FAILURE;
3040 }
3041 else if (arg_ts->type == BT_CLASS)
3042 {
3043 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
3044 "polymorphic", args_sym->name, sym->name,
3045 &(args->expr->where));
3046 retval = FAILURE;
3047 }
3048 }
3049 }
3050 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
3051 {
3052 if (args_sym->attr.flavor != FL_PROCEDURE)
3053 {
3054 /* TODO: Update this error message to allow for procedure
3055 pointers once they are implemented. */
3056 gfc_error_now ("Argument '%s' to '%s' at %L must be a "
3057 "procedure",
3058 args_sym->name, sym->name,
3059 &(args->expr->where));
3060 retval = FAILURE;
3061 }
3062 else if (args_sym->attr.is_bind_c != 1
3063 && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
3064 "argument '%s' to '%s' at %L",
3065 args_sym->name, sym->name,
3066 &(args->expr->where)) == FAILURE)
3067 retval = FAILURE;
3068 }
3069
3070 /* for c_loc/c_funloc, the new symbol is the same as the old one */
3071 *new_sym = sym;
3072 }
3073 else
3074 {
3075 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
3076 "iso_c_binding function: '%s'!\n", sym->name);
3077 }
3078
3079 return retval;
3080 }
3081
3082
3083 /* Resolve a function call, which means resolving the arguments, then figuring
3084 out which entity the name refers to. */
3085
3086 static gfc_try
resolve_function(gfc_expr * expr)3087 resolve_function (gfc_expr *expr)
3088 {
3089 gfc_actual_arglist *arg;
3090 gfc_symbol *sym;
3091 const char *name;
3092 gfc_try t;
3093 int temp;
3094 procedure_type p = PROC_INTRINSIC;
3095 bool no_formal_args;
3096
3097 sym = NULL;
3098 if (expr->symtree)
3099 sym = expr->symtree->n.sym;
3100
3101 /* If this is a procedure pointer component, it has already been resolved. */
3102 if (gfc_is_proc_ptr_comp (expr))
3103 return SUCCESS;
3104
3105 if (sym && sym->attr.intrinsic
3106 && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE)
3107 return FAILURE;
3108
3109 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3110 {
3111 gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
3112 return FAILURE;
3113 }
3114
3115 /* If this ia a deferred TBP with an abstract interface (which may
3116 of course be referenced), expr->value.function.esym will be set. */
3117 if (sym && sym->attr.abstract && !expr->value.function.esym)
3118 {
3119 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3120 sym->name, &expr->where);
3121 return FAILURE;
3122 }
3123
3124 /* Switch off assumed size checking and do this again for certain kinds
3125 of procedure, once the procedure itself is resolved. */
3126 need_full_assumed_size++;
3127
3128 if (expr->symtree && expr->symtree->n.sym)
3129 p = expr->symtree->n.sym->attr.proc;
3130
3131 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3132 inquiry_argument = true;
3133 no_formal_args = sym && is_external_proc (sym)
3134 && gfc_sym_get_dummy_args (sym) == NULL;
3135
3136 if (resolve_actual_arglist (expr->value.function.actual,
3137 p, no_formal_args) == FAILURE)
3138 {
3139 inquiry_argument = false;
3140 return FAILURE;
3141 }
3142
3143 inquiry_argument = false;
3144
3145 /* Need to setup the call to the correct c_associated, depending on
3146 the number of cptrs to user gives to compare. */
3147 if (sym && sym->attr.is_iso_c == 1)
3148 {
3149 if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
3150 == FAILURE)
3151 return FAILURE;
3152
3153 /* Get the symtree for the new symbol (resolved func).
3154 the old one will be freed later, when it's no longer used. */
3155 gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
3156 }
3157
3158 /* Resume assumed_size checking. */
3159 need_full_assumed_size--;
3160
3161 /* If the procedure is external, check for usage. */
3162 if (sym && is_external_proc (sym))
3163 resolve_global_procedure (sym, &expr->where,
3164 &expr->value.function.actual, 0);
3165
3166 if (sym && sym->ts.type == BT_CHARACTER
3167 && sym->ts.u.cl
3168 && sym->ts.u.cl->length == NULL
3169 && !sym->attr.dummy
3170 && !sym->ts.deferred
3171 && expr->value.function.esym == NULL
3172 && !sym->attr.contained)
3173 {
3174 /* Internal procedures are taken care of in resolve_contained_fntype. */
3175 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3176 "be used at %L since it is not a dummy argument",
3177 sym->name, &expr->where);
3178 return FAILURE;
3179 }
3180
3181 /* See if function is already resolved. */
3182
3183 if (expr->value.function.name != NULL)
3184 {
3185 if (expr->ts.type == BT_UNKNOWN)
3186 expr->ts = sym->ts;
3187 t = SUCCESS;
3188 }
3189 else
3190 {
3191 /* Apply the rules of section 14.1.2. */
3192
3193 switch (procedure_kind (sym))
3194 {
3195 case PTYPE_GENERIC:
3196 t = resolve_generic_f (expr);
3197 break;
3198
3199 case PTYPE_SPECIFIC:
3200 t = resolve_specific_f (expr);
3201 break;
3202
3203 case PTYPE_UNKNOWN:
3204 t = resolve_unknown_f (expr);
3205 break;
3206
3207 default:
3208 gfc_internal_error ("resolve_function(): bad function type");
3209 }
3210 }
3211
3212 /* If the expression is still a function (it might have simplified),
3213 then we check to see if we are calling an elemental function. */
3214
3215 if (expr->expr_type != EXPR_FUNCTION)
3216 return t;
3217
3218 temp = need_full_assumed_size;
3219 need_full_assumed_size = 0;
3220
3221 if (resolve_elemental_actual (expr, NULL) == FAILURE)
3222 return FAILURE;
3223
3224 if (omp_workshare_flag
3225 && expr->value.function.esym
3226 && ! gfc_elemental (expr->value.function.esym))
3227 {
3228 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3229 "in WORKSHARE construct", expr->value.function.esym->name,
3230 &expr->where);
3231 t = FAILURE;
3232 }
3233
3234 #define GENERIC_ID expr->value.function.isym->id
3235 else if (expr->value.function.actual != NULL
3236 && expr->value.function.isym != NULL
3237 && GENERIC_ID != GFC_ISYM_LBOUND
3238 && GENERIC_ID != GFC_ISYM_LEN
3239 && GENERIC_ID != GFC_ISYM_LOC
3240 && GENERIC_ID != GFC_ISYM_PRESENT)
3241 {
3242 /* Array intrinsics must also have the last upper bound of an
3243 assumed size array argument. UBOUND and SIZE have to be
3244 excluded from the check if the second argument is anything
3245 than a constant. */
3246
3247 for (arg = expr->value.function.actual; arg; arg = arg->next)
3248 {
3249 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3250 && arg == expr->value.function.actual
3251 && arg->next != NULL && arg->next->expr)
3252 {
3253 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3254 break;
3255
3256 if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
3257 break;
3258
3259 if ((int)mpz_get_si (arg->next->expr->value.integer)
3260 < arg->expr->rank)
3261 break;
3262 }
3263
3264 if (arg->expr != NULL
3265 && arg->expr->rank > 0
3266 && resolve_assumed_size_actual (arg->expr))
3267 return FAILURE;
3268 }
3269 }
3270 #undef GENERIC_ID
3271
3272 need_full_assumed_size = temp;
3273 name = NULL;
3274
3275 if (!pure_function (expr, &name) && name)
3276 {
3277 if (forall_flag)
3278 {
3279 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3280 "FORALL %s", name, &expr->where,
3281 forall_flag == 2 ? "mask" : "block");
3282 t = FAILURE;
3283 }
3284 else if (do_concurrent_flag)
3285 {
3286 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3287 "DO CONCURRENT %s", name, &expr->where,
3288 do_concurrent_flag == 2 ? "mask" : "block");
3289 t = FAILURE;
3290 }
3291 else if (gfc_pure (NULL))
3292 {
3293 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3294 "procedure within a PURE procedure", name, &expr->where);
3295 t = FAILURE;
3296 }
3297
3298 if (gfc_implicit_pure (NULL))
3299 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3300 }
3301
3302 /* Functions without the RECURSIVE attribution are not allowed to
3303 * call themselves. */
3304 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3305 {
3306 gfc_symbol *esym;
3307 esym = expr->value.function.esym;
3308
3309 if (is_illegal_recursion (esym, gfc_current_ns))
3310 {
3311 if (esym->attr.entry && esym->ns->entries)
3312 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3313 " function '%s' is not RECURSIVE",
3314 esym->name, &expr->where, esym->ns->entries->sym->name);
3315 else
3316 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3317 " is not RECURSIVE", esym->name, &expr->where);
3318
3319 t = FAILURE;
3320 }
3321 }
3322
3323 /* Character lengths of use associated functions may contains references to
3324 symbols not referenced from the current program unit otherwise. Make sure
3325 those symbols are marked as referenced. */
3326
3327 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3328 && expr->value.function.esym->attr.use_assoc)
3329 {
3330 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3331 }
3332
3333 /* Make sure that the expression has a typespec that works. */
3334 if (expr->ts.type == BT_UNKNOWN)
3335 {
3336 if (expr->symtree->n.sym->result
3337 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3338 && !expr->symtree->n.sym->result->attr.proc_pointer)
3339 expr->ts = expr->symtree->n.sym->result->ts;
3340 }
3341
3342 return t;
3343 }
3344
3345
3346 /************* Subroutine resolution *************/
3347
3348 static void
pure_subroutine(gfc_code * c,gfc_symbol * sym)3349 pure_subroutine (gfc_code *c, gfc_symbol *sym)
3350 {
3351 if (gfc_pure (sym))
3352 return;
3353
3354 if (forall_flag)
3355 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3356 sym->name, &c->loc);
3357 else if (do_concurrent_flag)
3358 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3359 "PURE", sym->name, &c->loc);
3360 else if (gfc_pure (NULL))
3361 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
3362 &c->loc);
3363
3364 if (gfc_implicit_pure (NULL))
3365 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3366 }
3367
3368
3369 static match
resolve_generic_s0(gfc_code * c,gfc_symbol * sym)3370 resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3371 {
3372 gfc_symbol *s;
3373
3374 if (sym->attr.generic)
3375 {
3376 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3377 if (s != NULL)
3378 {
3379 c->resolved_sym = s;
3380 pure_subroutine (c, s);
3381 return MATCH_YES;
3382 }
3383
3384 /* TODO: Need to search for elemental references in generic interface. */
3385 }
3386
3387 if (sym->attr.intrinsic)
3388 return gfc_intrinsic_sub_interface (c, 0);
3389
3390 return MATCH_NO;
3391 }
3392
3393
3394 static gfc_try
resolve_generic_s(gfc_code * c)3395 resolve_generic_s (gfc_code *c)
3396 {
3397 gfc_symbol *sym;
3398 match m;
3399
3400 sym = c->symtree->n.sym;
3401
3402 for (;;)
3403 {
3404 m = resolve_generic_s0 (c, sym);
3405 if (m == MATCH_YES)
3406 return SUCCESS;
3407 else if (m == MATCH_ERROR)
3408 return FAILURE;
3409
3410 generic:
3411 if (sym->ns->parent == NULL)
3412 break;
3413 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3414
3415 if (sym == NULL)
3416 break;
3417 if (!generic_sym (sym))
3418 goto generic;
3419 }
3420
3421 /* Last ditch attempt. See if the reference is to an intrinsic
3422 that possesses a matching interface. 14.1.2.4 */
3423 sym = c->symtree->n.sym;
3424
3425 if (!gfc_is_intrinsic (sym, 1, c->loc))
3426 {
3427 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3428 sym->name, &c->loc);
3429 return FAILURE;
3430 }
3431
3432 m = gfc_intrinsic_sub_interface (c, 0);
3433 if (m == MATCH_YES)
3434 return SUCCESS;
3435 if (m == MATCH_NO)
3436 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3437 "intrinsic subroutine interface", sym->name, &c->loc);
3438
3439 return FAILURE;
3440 }
3441
3442
3443 /* Set the name and binding label of the subroutine symbol in the call
3444 expression represented by 'c' to include the type and kind of the
3445 second parameter. This function is for resolving the appropriate
3446 version of c_f_pointer() and c_f_procpointer(). For example, a
3447 call to c_f_pointer() for a default integer pointer could have a
3448 name of c_f_pointer_i4. If no second arg exists, which is an error
3449 for these two functions, it defaults to the generic symbol's name
3450 and binding label. */
3451
3452 static void
set_name_and_label(gfc_code * c,gfc_symbol * sym,char * name,const char ** binding_label)3453 set_name_and_label (gfc_code *c, gfc_symbol *sym,
3454 char *name, const char **binding_label)
3455 {
3456 gfc_expr *arg = NULL;
3457 char type;
3458 int kind;
3459
3460 /* The second arg of c_f_pointer and c_f_procpointer determines
3461 the type and kind for the procedure name. */
3462 arg = c->ext.actual->next->expr;
3463
3464 if (arg != NULL)
3465 {
3466 /* Set up the name to have the given symbol's name,
3467 plus the type and kind. */
3468 /* a derived type is marked with the type letter 'u' */
3469 if (arg->ts.type == BT_DERIVED)
3470 {
3471 type = 'd';
3472 kind = 0; /* set the kind as 0 for now */
3473 }
3474 else
3475 {
3476 type = gfc_type_letter (arg->ts.type);
3477 kind = arg->ts.kind;
3478 }
3479
3480 if (arg->ts.type == BT_CHARACTER)
3481 /* Kind info for character strings not needed. */
3482 kind = 0;
3483
3484 sprintf (name, "%s_%c%d", sym->name, type, kind);
3485 /* Set up the binding label as the given symbol's label plus
3486 the type and kind. */
3487 *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
3488 kind);
3489 }
3490 else
3491 {
3492 /* If the second arg is missing, set the name and label as
3493 was, cause it should at least be found, and the missing
3494 arg error will be caught by compare_parameters(). */
3495 sprintf (name, "%s", sym->name);
3496 *binding_label = sym->binding_label;
3497 }
3498
3499 return;
3500 }
3501
3502
3503 /* Resolve a generic version of the iso_c_binding procedure given
3504 (sym) to the specific one based on the type and kind of the
3505 argument(s). Currently, this function resolves c_f_pointer() and
3506 c_f_procpointer based on the type and kind of the second argument
3507 (FPTR). Other iso_c_binding procedures aren't specially handled.
3508 Upon successfully exiting, c->resolved_sym will hold the resolved
3509 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3510 otherwise. */
3511
3512 match
gfc_iso_c_sub_interface(gfc_code * c,gfc_symbol * sym)3513 gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
3514 {
3515 gfc_symbol *new_sym;
3516 /* this is fine, since we know the names won't use the max */
3517 char name[GFC_MAX_SYMBOL_LEN + 1];
3518 const char* binding_label;
3519 /* default to success; will override if find error */
3520 match m = MATCH_YES;
3521
3522 /* Make sure the actual arguments are in the necessary order (based on the
3523 formal args) before resolving. */
3524 if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
3525 {
3526 c->resolved_sym = sym;
3527 return MATCH_ERROR;
3528 }
3529
3530 if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3531 (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3532 {
3533 set_name_and_label (c, sym, name, &binding_label);
3534
3535 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3536 {
3537 if (c->ext.actual != NULL && c->ext.actual->next != NULL)
3538 {
3539 gfc_actual_arglist *arg1 = c->ext.actual;
3540 gfc_actual_arglist *arg2 = c->ext.actual->next;
3541 gfc_actual_arglist *arg3 = c->ext.actual->next->next;
3542
3543 /* Check first argument (CPTR). */
3544 if (arg1->expr->ts.type != BT_DERIVED
3545 || arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
3546 {
3547 gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
3548 "the type C_PTR", &arg1->expr->where);
3549 m = MATCH_ERROR;
3550 }
3551
3552 /* Check second argument (FPTR). */
3553 if (arg2->expr->ts.type == BT_CLASS)
3554 {
3555 gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
3556 "polymorphic", &arg2->expr->where);
3557 m = MATCH_ERROR;
3558 }
3559
3560 /* Make sure we got a third arg (SHAPE) if the second arg has
3561 non-zero rank. We must also check that the type and rank are
3562 correct since we short-circuit this check in
3563 gfc_procedure_use() (called above to sort actual args). */
3564 if (arg2->expr->rank != 0)
3565 {
3566 if (arg3 == NULL || arg3->expr == NULL)
3567 {
3568 m = MATCH_ERROR;
3569 gfc_error ("Missing SHAPE argument for call to %s at %L",
3570 sym->name, &c->loc);
3571 }
3572 else if (arg3->expr->ts.type != BT_INTEGER
3573 || arg3->expr->rank != 1)
3574 {
3575 m = MATCH_ERROR;
3576 gfc_error ("SHAPE argument for call to %s at %L must be "
3577 "a rank 1 INTEGER array", sym->name, &c->loc);
3578 }
3579 }
3580 }
3581 }
3582 else /* ISOCBINDING_F_PROCPOINTER. */
3583 {
3584 if (c->ext.actual
3585 && (c->ext.actual->expr->ts.type != BT_DERIVED
3586 || c->ext.actual->expr->ts.u.derived->intmod_sym_id
3587 != ISOCBINDING_FUNPTR))
3588 {
3589 gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
3590 "C_FUNPTR", &c->ext.actual->expr->where);
3591 m = MATCH_ERROR;
3592 }
3593 if (c->ext.actual && c->ext.actual->next
3594 && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
3595 && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
3596 "procedure-pointer at %L to C_F_FUNPOINTER",
3597 &c->ext.actual->next->expr->where)
3598 == FAILURE)
3599 m = MATCH_ERROR;
3600 }
3601
3602 if (m != MATCH_ERROR)
3603 {
3604 /* the 1 means to add the optional arg to formal list */
3605 new_sym = get_iso_c_sym (sym, name, binding_label, 1);
3606
3607 /* for error reporting, say it's declared where the original was */
3608 new_sym->declared_at = sym->declared_at;
3609 }
3610 }
3611 else
3612 {
3613 /* no differences for c_loc or c_funloc */
3614 new_sym = sym;
3615 }
3616
3617 /* set the resolved symbol */
3618 if (m != MATCH_ERROR)
3619 c->resolved_sym = new_sym;
3620 else
3621 c->resolved_sym = sym;
3622
3623 return m;
3624 }
3625
3626
3627 /* Resolve a subroutine call known to be specific. */
3628
3629 static match
resolve_specific_s0(gfc_code * c,gfc_symbol * sym)3630 resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3631 {
3632 match m;
3633
3634 if(sym->attr.is_iso_c)
3635 {
3636 m = gfc_iso_c_sub_interface (c,sym);
3637 return m;
3638 }
3639
3640 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3641 {
3642 if (sym->attr.dummy)
3643 {
3644 sym->attr.proc = PROC_DUMMY;
3645 goto found;
3646 }
3647
3648 sym->attr.proc = PROC_EXTERNAL;
3649 goto found;
3650 }
3651
3652 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3653 goto found;
3654
3655 if (sym->attr.intrinsic)
3656 {
3657 m = gfc_intrinsic_sub_interface (c, 1);
3658 if (m == MATCH_YES)
3659 return MATCH_YES;
3660 if (m == MATCH_NO)
3661 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3662 "with an intrinsic", sym->name, &c->loc);
3663
3664 return MATCH_ERROR;
3665 }
3666
3667 return MATCH_NO;
3668
3669 found:
3670 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3671
3672 c->resolved_sym = sym;
3673 pure_subroutine (c, sym);
3674
3675 return MATCH_YES;
3676 }
3677
3678
3679 static gfc_try
resolve_specific_s(gfc_code * c)3680 resolve_specific_s (gfc_code *c)
3681 {
3682 gfc_symbol *sym;
3683 match m;
3684
3685 sym = c->symtree->n.sym;
3686
3687 for (;;)
3688 {
3689 m = resolve_specific_s0 (c, sym);
3690 if (m == MATCH_YES)
3691 return SUCCESS;
3692 if (m == MATCH_ERROR)
3693 return FAILURE;
3694
3695 if (sym->ns->parent == NULL)
3696 break;
3697
3698 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3699
3700 if (sym == NULL)
3701 break;
3702 }
3703
3704 sym = c->symtree->n.sym;
3705 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3706 sym->name, &c->loc);
3707
3708 return FAILURE;
3709 }
3710
3711
3712 /* Resolve a subroutine call not known to be generic nor specific. */
3713
3714 static gfc_try
resolve_unknown_s(gfc_code * c)3715 resolve_unknown_s (gfc_code *c)
3716 {
3717 gfc_symbol *sym;
3718
3719 sym = c->symtree->n.sym;
3720
3721 if (sym->attr.dummy)
3722 {
3723 sym->attr.proc = PROC_DUMMY;
3724 goto found;
3725 }
3726
3727 /* See if we have an intrinsic function reference. */
3728
3729 if (gfc_is_intrinsic (sym, 1, c->loc))
3730 {
3731 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3732 return SUCCESS;
3733 return FAILURE;
3734 }
3735
3736 /* The reference is to an external name. */
3737
3738 found:
3739 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3740
3741 c->resolved_sym = sym;
3742
3743 pure_subroutine (c, sym);
3744
3745 return SUCCESS;
3746 }
3747
3748
3749 /* Resolve a subroutine call. Although it was tempting to use the same code
3750 for functions, subroutines and functions are stored differently and this
3751 makes things awkward. */
3752
3753 static gfc_try
resolve_call(gfc_code * c)3754 resolve_call (gfc_code *c)
3755 {
3756 gfc_try t;
3757 procedure_type ptype = PROC_INTRINSIC;
3758 gfc_symbol *csym, *sym;
3759 bool no_formal_args;
3760
3761 csym = c->symtree ? c->symtree->n.sym : NULL;
3762
3763 if (csym && csym->ts.type != BT_UNKNOWN)
3764 {
3765 gfc_error ("'%s' at %L has a type, which is not consistent with "
3766 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3767 return FAILURE;
3768 }
3769
3770 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3771 {
3772 gfc_symtree *st;
3773 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3774 sym = st ? st->n.sym : NULL;
3775 if (sym && csym != sym
3776 && sym->ns == gfc_current_ns
3777 && sym->attr.flavor == FL_PROCEDURE
3778 && sym->attr.contained)
3779 {
3780 sym->refs++;
3781 if (csym->attr.generic)
3782 c->symtree->n.sym = sym;
3783 else
3784 c->symtree = st;
3785 csym = c->symtree->n.sym;
3786 }
3787 }
3788
3789 /* If this ia a deferred TBP, c->expr1 will be set. */
3790 if (!c->expr1 && csym)
3791 {
3792 if (csym->attr.abstract)
3793 {
3794 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3795 csym->name, &c->loc);
3796 return FAILURE;
3797 }
3798
3799 /* Subroutines without the RECURSIVE attribution are not allowed to
3800 call themselves. */
3801 if (is_illegal_recursion (csym, gfc_current_ns))
3802 {
3803 if (csym->attr.entry && csym->ns->entries)
3804 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3805 "as subroutine '%s' is not RECURSIVE",
3806 csym->name, &c->loc, csym->ns->entries->sym->name);
3807 else
3808 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3809 "as it is not RECURSIVE", csym->name, &c->loc);
3810
3811 t = FAILURE;
3812 }
3813 }
3814
3815 /* Switch off assumed size checking and do this again for certain kinds
3816 of procedure, once the procedure itself is resolved. */
3817 need_full_assumed_size++;
3818
3819 if (csym)
3820 ptype = csym->attr.proc;
3821
3822 no_formal_args = csym && is_external_proc (csym)
3823 && gfc_sym_get_dummy_args (csym) == NULL;
3824 if (resolve_actual_arglist (c->ext.actual, ptype,
3825 no_formal_args) == FAILURE)
3826 return FAILURE;
3827
3828 /* Resume assumed_size checking. */
3829 need_full_assumed_size--;
3830
3831 /* If external, check for usage. */
3832 if (csym && is_external_proc (csym))
3833 resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
3834
3835 t = SUCCESS;
3836 if (c->resolved_sym == NULL)
3837 {
3838 c->resolved_isym = NULL;
3839 switch (procedure_kind (csym))
3840 {
3841 case PTYPE_GENERIC:
3842 t = resolve_generic_s (c);
3843 break;
3844
3845 case PTYPE_SPECIFIC:
3846 t = resolve_specific_s (c);
3847 break;
3848
3849 case PTYPE_UNKNOWN:
3850 t = resolve_unknown_s (c);
3851 break;
3852
3853 default:
3854 gfc_internal_error ("resolve_subroutine(): bad function type");
3855 }
3856 }
3857
3858 /* Some checks of elemental subroutine actual arguments. */
3859 if (resolve_elemental_actual (NULL, c) == FAILURE)
3860 return FAILURE;
3861
3862 return t;
3863 }
3864
3865
3866 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3867 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3868 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3869 if their shapes do not match. If either op1->shape or op2->shape is
3870 NULL, return SUCCESS. */
3871
3872 static gfc_try
compare_shapes(gfc_expr * op1,gfc_expr * op2)3873 compare_shapes (gfc_expr *op1, gfc_expr *op2)
3874 {
3875 gfc_try t;
3876 int i;
3877
3878 t = SUCCESS;
3879
3880 if (op1->shape != NULL && op2->shape != NULL)
3881 {
3882 for (i = 0; i < op1->rank; i++)
3883 {
3884 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3885 {
3886 gfc_error ("Shapes for operands at %L and %L are not conformable",
3887 &op1->where, &op2->where);
3888 t = FAILURE;
3889 break;
3890 }
3891 }
3892 }
3893
3894 return t;
3895 }
3896
3897
3898 /* Resolve an operator expression node. This can involve replacing the
3899 operation with a user defined function call. */
3900
3901 static gfc_try
resolve_operator(gfc_expr * e)3902 resolve_operator (gfc_expr *e)
3903 {
3904 gfc_expr *op1, *op2;
3905 char msg[200];
3906 bool dual_locus_error;
3907 gfc_try t;
3908
3909 /* Resolve all subnodes-- give them types. */
3910
3911 switch (e->value.op.op)
3912 {
3913 default:
3914 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
3915 return FAILURE;
3916
3917 /* Fall through... */
3918
3919 case INTRINSIC_NOT:
3920 case INTRINSIC_UPLUS:
3921 case INTRINSIC_UMINUS:
3922 case INTRINSIC_PARENTHESES:
3923 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
3924 return FAILURE;
3925 break;
3926 }
3927
3928 /* Typecheck the new node. */
3929
3930 op1 = e->value.op.op1;
3931 op2 = e->value.op.op2;
3932 dual_locus_error = false;
3933
3934 if ((op1 && op1->expr_type == EXPR_NULL)
3935 || (op2 && op2->expr_type == EXPR_NULL))
3936 {
3937 sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
3938 goto bad_op;
3939 }
3940
3941 switch (e->value.op.op)
3942 {
3943 case INTRINSIC_UPLUS:
3944 case INTRINSIC_UMINUS:
3945 if (op1->ts.type == BT_INTEGER
3946 || op1->ts.type == BT_REAL
3947 || op1->ts.type == BT_COMPLEX)
3948 {
3949 e->ts = op1->ts;
3950 break;
3951 }
3952
3953 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
3954 gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
3955 goto bad_op;
3956
3957 case INTRINSIC_PLUS:
3958 case INTRINSIC_MINUS:
3959 case INTRINSIC_TIMES:
3960 case INTRINSIC_DIVIDE:
3961 case INTRINSIC_POWER:
3962 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
3963 {
3964 gfc_type_convert_binary (e, 1);
3965 break;
3966 }
3967
3968 sprintf (msg,
3969 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3970 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
3971 gfc_typename (&op2->ts));
3972 goto bad_op;
3973
3974 case INTRINSIC_CONCAT:
3975 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
3976 && op1->ts.kind == op2->ts.kind)
3977 {
3978 e->ts.type = BT_CHARACTER;
3979 e->ts.kind = op1->ts.kind;
3980 break;
3981 }
3982
3983 sprintf (msg,
3984 _("Operands of string concatenation operator at %%L are %s/%s"),
3985 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
3986 goto bad_op;
3987
3988 case INTRINSIC_AND:
3989 case INTRINSIC_OR:
3990 case INTRINSIC_EQV:
3991 case INTRINSIC_NEQV:
3992 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
3993 {
3994 e->ts.type = BT_LOGICAL;
3995 e->ts.kind = gfc_kind_max (op1, op2);
3996 if (op1->ts.kind < e->ts.kind)
3997 gfc_convert_type (op1, &e->ts, 2);
3998 else if (op2->ts.kind < e->ts.kind)
3999 gfc_convert_type (op2, &e->ts, 2);
4000 break;
4001 }
4002
4003 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
4004 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
4005 gfc_typename (&op2->ts));
4006
4007 goto bad_op;
4008
4009 case INTRINSIC_NOT:
4010 if (op1->ts.type == BT_LOGICAL)
4011 {
4012 e->ts.type = BT_LOGICAL;
4013 e->ts.kind = op1->ts.kind;
4014 break;
4015 }
4016
4017 sprintf (msg, _("Operand of .not. operator at %%L is %s"),
4018 gfc_typename (&op1->ts));
4019 goto bad_op;
4020
4021 case INTRINSIC_GT:
4022 case INTRINSIC_GT_OS:
4023 case INTRINSIC_GE:
4024 case INTRINSIC_GE_OS:
4025 case INTRINSIC_LT:
4026 case INTRINSIC_LT_OS:
4027 case INTRINSIC_LE:
4028 case INTRINSIC_LE_OS:
4029 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4030 {
4031 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
4032 goto bad_op;
4033 }
4034
4035 /* Fall through... */
4036
4037 case INTRINSIC_EQ:
4038 case INTRINSIC_EQ_OS:
4039 case INTRINSIC_NE:
4040 case INTRINSIC_NE_OS:
4041 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4042 && op1->ts.kind == op2->ts.kind)
4043 {
4044 e->ts.type = BT_LOGICAL;
4045 e->ts.kind = gfc_default_logical_kind;
4046 break;
4047 }
4048
4049 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4050 {
4051 gfc_type_convert_binary (e, 1);
4052
4053 e->ts.type = BT_LOGICAL;
4054 e->ts.kind = gfc_default_logical_kind;
4055
4056 if (gfc_option.warn_compare_reals)
4057 {
4058 gfc_intrinsic_op op = e->value.op.op;
4059
4060 /* Type conversion has made sure that the types of op1 and op2
4061 agree, so it is only necessary to check the first one. */
4062 if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4063 && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4064 || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4065 {
4066 const char *msg;
4067
4068 if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4069 msg = "Equality comparison for %s at %L";
4070 else
4071 msg = "Inequality comparison for %s at %L";
4072
4073 gfc_warning (msg, gfc_typename (&op1->ts), &op1->where);
4074 }
4075 }
4076
4077 break;
4078 }
4079
4080 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4081 sprintf (msg,
4082 _("Logicals at %%L must be compared with %s instead of %s"),
4083 (e->value.op.op == INTRINSIC_EQ
4084 || e->value.op.op == INTRINSIC_EQ_OS)
4085 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4086 else
4087 sprintf (msg,
4088 _("Operands of comparison operator '%s' at %%L are %s/%s"),
4089 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
4090 gfc_typename (&op2->ts));
4091
4092 goto bad_op;
4093
4094 case INTRINSIC_USER:
4095 if (e->value.op.uop->op == NULL)
4096 sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
4097 else if (op2 == NULL)
4098 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
4099 e->value.op.uop->name, gfc_typename (&op1->ts));
4100 else
4101 {
4102 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
4103 e->value.op.uop->name, gfc_typename (&op1->ts),
4104 gfc_typename (&op2->ts));
4105 e->value.op.uop->op->sym->attr.referenced = 1;
4106 }
4107
4108 goto bad_op;
4109
4110 case INTRINSIC_PARENTHESES:
4111 e->ts = op1->ts;
4112 if (e->ts.type == BT_CHARACTER)
4113 e->ts.u.cl = op1->ts.u.cl;
4114 break;
4115
4116 default:
4117 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4118 }
4119
4120 /* Deal with arrayness of an operand through an operator. */
4121
4122 t = SUCCESS;
4123
4124 switch (e->value.op.op)
4125 {
4126 case INTRINSIC_PLUS:
4127 case INTRINSIC_MINUS:
4128 case INTRINSIC_TIMES:
4129 case INTRINSIC_DIVIDE:
4130 case INTRINSIC_POWER:
4131 case INTRINSIC_CONCAT:
4132 case INTRINSIC_AND:
4133 case INTRINSIC_OR:
4134 case INTRINSIC_EQV:
4135 case INTRINSIC_NEQV:
4136 case INTRINSIC_EQ:
4137 case INTRINSIC_EQ_OS:
4138 case INTRINSIC_NE:
4139 case INTRINSIC_NE_OS:
4140 case INTRINSIC_GT:
4141 case INTRINSIC_GT_OS:
4142 case INTRINSIC_GE:
4143 case INTRINSIC_GE_OS:
4144 case INTRINSIC_LT:
4145 case INTRINSIC_LT_OS:
4146 case INTRINSIC_LE:
4147 case INTRINSIC_LE_OS:
4148
4149 if (op1->rank == 0 && op2->rank == 0)
4150 e->rank = 0;
4151
4152 if (op1->rank == 0 && op2->rank != 0)
4153 {
4154 e->rank = op2->rank;
4155
4156 if (e->shape == NULL)
4157 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4158 }
4159
4160 if (op1->rank != 0 && op2->rank == 0)
4161 {
4162 e->rank = op1->rank;
4163
4164 if (e->shape == NULL)
4165 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4166 }
4167
4168 if (op1->rank != 0 && op2->rank != 0)
4169 {
4170 if (op1->rank == op2->rank)
4171 {
4172 e->rank = op1->rank;
4173 if (e->shape == NULL)
4174 {
4175 t = compare_shapes (op1, op2);
4176 if (t == FAILURE)
4177 e->shape = NULL;
4178 else
4179 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4180 }
4181 }
4182 else
4183 {
4184 /* Allow higher level expressions to work. */
4185 e->rank = 0;
4186
4187 /* Try user-defined operators, and otherwise throw an error. */
4188 dual_locus_error = true;
4189 sprintf (msg,
4190 _("Inconsistent ranks for operator at %%L and %%L"));
4191 goto bad_op;
4192 }
4193 }
4194
4195 break;
4196
4197 case INTRINSIC_PARENTHESES:
4198 case INTRINSIC_NOT:
4199 case INTRINSIC_UPLUS:
4200 case INTRINSIC_UMINUS:
4201 /* Simply copy arrayness attribute */
4202 e->rank = op1->rank;
4203
4204 if (e->shape == NULL)
4205 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4206
4207 break;
4208
4209 default:
4210 break;
4211 }
4212
4213 /* Attempt to simplify the expression. */
4214 if (t == SUCCESS)
4215 {
4216 t = gfc_simplify_expr (e, 0);
4217 /* Some calls do not succeed in simplification and return FAILURE
4218 even though there is no error; e.g. variable references to
4219 PARAMETER arrays. */
4220 if (!gfc_is_constant_expr (e))
4221 t = SUCCESS;
4222 }
4223 return t;
4224
4225 bad_op:
4226
4227 {
4228 match m = gfc_extend_expr (e);
4229 if (m == MATCH_YES)
4230 return SUCCESS;
4231 if (m == MATCH_ERROR)
4232 return FAILURE;
4233 }
4234
4235 if (dual_locus_error)
4236 gfc_error (msg, &op1->where, &op2->where);
4237 else
4238 gfc_error (msg, &e->where);
4239
4240 return FAILURE;
4241 }
4242
4243
4244 /************** Array resolution subroutines **************/
4245
4246 typedef enum
4247 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
4248 comparison;
4249
4250 /* Compare two integer expressions. */
4251
4252 static comparison
compare_bound(gfc_expr * a,gfc_expr * b)4253 compare_bound (gfc_expr *a, gfc_expr *b)
4254 {
4255 int i;
4256
4257 if (a == NULL || a->expr_type != EXPR_CONSTANT
4258 || b == NULL || b->expr_type != EXPR_CONSTANT)
4259 return CMP_UNKNOWN;
4260
4261 /* If either of the types isn't INTEGER, we must have
4262 raised an error earlier. */
4263
4264 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4265 return CMP_UNKNOWN;
4266
4267 i = mpz_cmp (a->value.integer, b->value.integer);
4268
4269 if (i < 0)
4270 return CMP_LT;
4271 if (i > 0)
4272 return CMP_GT;
4273 return CMP_EQ;
4274 }
4275
4276
4277 /* Compare an integer expression with an integer. */
4278
4279 static comparison
compare_bound_int(gfc_expr * a,int b)4280 compare_bound_int (gfc_expr *a, int b)
4281 {
4282 int i;
4283
4284 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4285 return CMP_UNKNOWN;
4286
4287 if (a->ts.type != BT_INTEGER)
4288 gfc_internal_error ("compare_bound_int(): Bad expression");
4289
4290 i = mpz_cmp_si (a->value.integer, b);
4291
4292 if (i < 0)
4293 return CMP_LT;
4294 if (i > 0)
4295 return CMP_GT;
4296 return CMP_EQ;
4297 }
4298
4299
4300 /* Compare an integer expression with a mpz_t. */
4301
4302 static comparison
compare_bound_mpz_t(gfc_expr * a,mpz_t b)4303 compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4304 {
4305 int i;
4306
4307 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4308 return CMP_UNKNOWN;
4309
4310 if (a->ts.type != BT_INTEGER)
4311 gfc_internal_error ("compare_bound_int(): Bad expression");
4312
4313 i = mpz_cmp (a->value.integer, b);
4314
4315 if (i < 0)
4316 return CMP_LT;
4317 if (i > 0)
4318 return CMP_GT;
4319 return CMP_EQ;
4320 }
4321
4322
4323 /* Compute the last value of a sequence given by a triplet.
4324 Return 0 if it wasn't able to compute the last value, or if the
4325 sequence if empty, and 1 otherwise. */
4326
4327 static int
compute_last_value_for_triplet(gfc_expr * start,gfc_expr * end,gfc_expr * stride,mpz_t last)4328 compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4329 gfc_expr *stride, mpz_t last)
4330 {
4331 mpz_t rem;
4332
4333 if (start == NULL || start->expr_type != EXPR_CONSTANT
4334 || end == NULL || end->expr_type != EXPR_CONSTANT
4335 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4336 return 0;
4337
4338 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4339 || (stride != NULL && stride->ts.type != BT_INTEGER))
4340 return 0;
4341
4342 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
4343 {
4344 if (compare_bound (start, end) == CMP_GT)
4345 return 0;
4346 mpz_set (last, end->value.integer);
4347 return 1;
4348 }
4349
4350 if (compare_bound_int (stride, 0) == CMP_GT)
4351 {
4352 /* Stride is positive */
4353 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4354 return 0;
4355 }
4356 else
4357 {
4358 /* Stride is negative */
4359 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4360 return 0;
4361 }
4362
4363 mpz_init (rem);
4364 mpz_sub (rem, end->value.integer, start->value.integer);
4365 mpz_tdiv_r (rem, rem, stride->value.integer);
4366 mpz_sub (last, end->value.integer, rem);
4367 mpz_clear (rem);
4368
4369 return 1;
4370 }
4371
4372
4373 /* Compare a single dimension of an array reference to the array
4374 specification. */
4375
4376 static gfc_try
check_dimension(int i,gfc_array_ref * ar,gfc_array_spec * as)4377 check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4378 {
4379 mpz_t last_value;
4380
4381 if (ar->dimen_type[i] == DIMEN_STAR)
4382 {
4383 gcc_assert (ar->stride[i] == NULL);
4384 /* This implies [*] as [*:] and [*:3] are not possible. */
4385 if (ar->start[i] == NULL)
4386 {
4387 gcc_assert (ar->end[i] == NULL);
4388 return SUCCESS;
4389 }
4390 }
4391
4392 /* Given start, end and stride values, calculate the minimum and
4393 maximum referenced indexes. */
4394
4395 switch (ar->dimen_type[i])
4396 {
4397 case DIMEN_VECTOR:
4398 case DIMEN_THIS_IMAGE:
4399 break;
4400
4401 case DIMEN_STAR:
4402 case DIMEN_ELEMENT:
4403 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4404 {
4405 if (i < as->rank)
4406 gfc_warning ("Array reference at %L is out of bounds "
4407 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4408 mpz_get_si (ar->start[i]->value.integer),
4409 mpz_get_si (as->lower[i]->value.integer), i+1);
4410 else
4411 gfc_warning ("Array reference at %L is out of bounds "
4412 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4413 mpz_get_si (ar->start[i]->value.integer),
4414 mpz_get_si (as->lower[i]->value.integer),
4415 i + 1 - as->rank);
4416 return SUCCESS;
4417 }
4418 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4419 {
4420 if (i < as->rank)
4421 gfc_warning ("Array reference at %L is out of bounds "
4422 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4423 mpz_get_si (ar->start[i]->value.integer),
4424 mpz_get_si (as->upper[i]->value.integer), i+1);
4425 else
4426 gfc_warning ("Array reference at %L is out of bounds "
4427 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4428 mpz_get_si (ar->start[i]->value.integer),
4429 mpz_get_si (as->upper[i]->value.integer),
4430 i + 1 - as->rank);
4431 return SUCCESS;
4432 }
4433
4434 break;
4435
4436 case DIMEN_RANGE:
4437 {
4438 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4439 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4440
4441 comparison comp_start_end = compare_bound (AR_START, AR_END);
4442
4443 /* Check for zero stride, which is not allowed. */
4444 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4445 {
4446 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4447 return FAILURE;
4448 }
4449
4450 /* if start == len || (stride > 0 && start < len)
4451 || (stride < 0 && start > len),
4452 then the array section contains at least one element. In this
4453 case, there is an out-of-bounds access if
4454 (start < lower || start > upper). */
4455 if (compare_bound (AR_START, AR_END) == CMP_EQ
4456 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4457 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4458 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4459 && comp_start_end == CMP_GT))
4460 {
4461 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4462 {
4463 gfc_warning ("Lower array reference at %L is out of bounds "
4464 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4465 mpz_get_si (AR_START->value.integer),
4466 mpz_get_si (as->lower[i]->value.integer), i+1);
4467 return SUCCESS;
4468 }
4469 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4470 {
4471 gfc_warning ("Lower array reference at %L is out of bounds "
4472 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4473 mpz_get_si (AR_START->value.integer),
4474 mpz_get_si (as->upper[i]->value.integer), i+1);
4475 return SUCCESS;
4476 }
4477 }
4478
4479 /* If we can compute the highest index of the array section,
4480 then it also has to be between lower and upper. */
4481 mpz_init (last_value);
4482 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4483 last_value))
4484 {
4485 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4486 {
4487 gfc_warning ("Upper array reference at %L is out of bounds "
4488 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4489 mpz_get_si (last_value),
4490 mpz_get_si (as->lower[i]->value.integer), i+1);
4491 mpz_clear (last_value);
4492 return SUCCESS;
4493 }
4494 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4495 {
4496 gfc_warning ("Upper array reference at %L is out of bounds "
4497 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4498 mpz_get_si (last_value),
4499 mpz_get_si (as->upper[i]->value.integer), i+1);
4500 mpz_clear (last_value);
4501 return SUCCESS;
4502 }
4503 }
4504 mpz_clear (last_value);
4505
4506 #undef AR_START
4507 #undef AR_END
4508 }
4509 break;
4510
4511 default:
4512 gfc_internal_error ("check_dimension(): Bad array reference");
4513 }
4514
4515 return SUCCESS;
4516 }
4517
4518
4519 /* Compare an array reference with an array specification. */
4520
4521 static gfc_try
compare_spec_to_ref(gfc_array_ref * ar)4522 compare_spec_to_ref (gfc_array_ref *ar)
4523 {
4524 gfc_array_spec *as;
4525 int i;
4526
4527 as = ar->as;
4528 i = as->rank - 1;
4529 /* TODO: Full array sections are only allowed as actual parameters. */
4530 if (as->type == AS_ASSUMED_SIZE
4531 && (/*ar->type == AR_FULL
4532 ||*/ (ar->type == AR_SECTION
4533 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
4534 {
4535 gfc_error ("Rightmost upper bound of assumed size array section "
4536 "not specified at %L", &ar->where);
4537 return FAILURE;
4538 }
4539
4540 if (ar->type == AR_FULL)
4541 return SUCCESS;
4542
4543 if (as->rank != ar->dimen)
4544 {
4545 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4546 &ar->where, ar->dimen, as->rank);
4547 return FAILURE;
4548 }
4549
4550 /* ar->codimen == 0 is a local array. */
4551 if (as->corank != ar->codimen && ar->codimen != 0)
4552 {
4553 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4554 &ar->where, ar->codimen, as->corank);
4555 return FAILURE;
4556 }
4557
4558 for (i = 0; i < as->rank; i++)
4559 if (check_dimension (i, ar, as) == FAILURE)
4560 return FAILURE;
4561
4562 /* Local access has no coarray spec. */
4563 if (ar->codimen != 0)
4564 for (i = as->rank; i < as->rank + as->corank; i++)
4565 {
4566 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4567 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4568 {
4569 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4570 i + 1 - as->rank, &ar->where);
4571 return FAILURE;
4572 }
4573 if (check_dimension (i, ar, as) == FAILURE)
4574 return FAILURE;
4575 }
4576
4577 return SUCCESS;
4578 }
4579
4580
4581 /* Resolve one part of an array index. */
4582
4583 static gfc_try
gfc_resolve_index_1(gfc_expr * index,int check_scalar,int force_index_integer_kind)4584 gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4585 int force_index_integer_kind)
4586 {
4587 gfc_typespec ts;
4588
4589 if (index == NULL)
4590 return SUCCESS;
4591
4592 if (gfc_resolve_expr (index) == FAILURE)
4593 return FAILURE;
4594
4595 if (check_scalar && index->rank != 0)
4596 {
4597 gfc_error ("Array index at %L must be scalar", &index->where);
4598 return FAILURE;
4599 }
4600
4601 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4602 {
4603 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4604 &index->where, gfc_basic_typename (index->ts.type));
4605 return FAILURE;
4606 }
4607
4608 if (index->ts.type == BT_REAL)
4609 if (gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
4610 &index->where) == FAILURE)
4611 return FAILURE;
4612
4613 if ((index->ts.kind != gfc_index_integer_kind
4614 && force_index_integer_kind)
4615 || index->ts.type != BT_INTEGER)
4616 {
4617 gfc_clear_ts (&ts);
4618 ts.type = BT_INTEGER;
4619 ts.kind = gfc_index_integer_kind;
4620
4621 gfc_convert_type_warn (index, &ts, 2, 0);
4622 }
4623
4624 return SUCCESS;
4625 }
4626
4627 /* Resolve one part of an array index. */
4628
4629 gfc_try
gfc_resolve_index(gfc_expr * index,int check_scalar)4630 gfc_resolve_index (gfc_expr *index, int check_scalar)
4631 {
4632 return gfc_resolve_index_1 (index, check_scalar, 1);
4633 }
4634
4635 /* Resolve a dim argument to an intrinsic function. */
4636
4637 gfc_try
gfc_resolve_dim_arg(gfc_expr * dim)4638 gfc_resolve_dim_arg (gfc_expr *dim)
4639 {
4640 if (dim == NULL)
4641 return SUCCESS;
4642
4643 if (gfc_resolve_expr (dim) == FAILURE)
4644 return FAILURE;
4645
4646 if (dim->rank != 0)
4647 {
4648 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4649 return FAILURE;
4650
4651 }
4652
4653 if (dim->ts.type != BT_INTEGER)
4654 {
4655 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4656 return FAILURE;
4657 }
4658
4659 if (dim->ts.kind != gfc_index_integer_kind)
4660 {
4661 gfc_typespec ts;
4662
4663 gfc_clear_ts (&ts);
4664 ts.type = BT_INTEGER;
4665 ts.kind = gfc_index_integer_kind;
4666
4667 gfc_convert_type_warn (dim, &ts, 2, 0);
4668 }
4669
4670 return SUCCESS;
4671 }
4672
4673 /* Given an expression that contains array references, update those array
4674 references to point to the right array specifications. While this is
4675 filled in during matching, this information is difficult to save and load
4676 in a module, so we take care of it here.
4677
4678 The idea here is that the original array reference comes from the
4679 base symbol. We traverse the list of reference structures, setting
4680 the stored reference to references. Component references can
4681 provide an additional array specification. */
4682
4683 static void
find_array_spec(gfc_expr * e)4684 find_array_spec (gfc_expr *e)
4685 {
4686 gfc_array_spec *as;
4687 gfc_component *c;
4688 gfc_ref *ref;
4689
4690 if (e->symtree->n.sym->ts.type == BT_CLASS)
4691 as = CLASS_DATA (e->symtree->n.sym)->as;
4692 else
4693 as = e->symtree->n.sym->as;
4694
4695 for (ref = e->ref; ref; ref = ref->next)
4696 switch (ref->type)
4697 {
4698 case REF_ARRAY:
4699 if (as == NULL)
4700 gfc_internal_error ("find_array_spec(): Missing spec");
4701
4702 ref->u.ar.as = as;
4703 as = NULL;
4704 break;
4705
4706 case REF_COMPONENT:
4707 c = ref->u.c.component;
4708 if (c->attr.dimension)
4709 {
4710 if (as != NULL)
4711 gfc_internal_error ("find_array_spec(): unused as(1)");
4712 as = c->as;
4713 }
4714
4715 break;
4716
4717 case REF_SUBSTRING:
4718 break;
4719 }
4720
4721 if (as != NULL)
4722 gfc_internal_error ("find_array_spec(): unused as(2)");
4723 }
4724
4725
4726 /* Resolve an array reference. */
4727
4728 static gfc_try
resolve_array_ref(gfc_array_ref * ar)4729 resolve_array_ref (gfc_array_ref *ar)
4730 {
4731 int i, check_scalar;
4732 gfc_expr *e;
4733
4734 for (i = 0; i < ar->dimen + ar->codimen; i++)
4735 {
4736 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
4737
4738 /* Do not force gfc_index_integer_kind for the start. We can
4739 do fine with any integer kind. This avoids temporary arrays
4740 created for indexing with a vector. */
4741 if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
4742 return FAILURE;
4743 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
4744 return FAILURE;
4745 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
4746 return FAILURE;
4747
4748 e = ar->start[i];
4749
4750 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
4751 switch (e->rank)
4752 {
4753 case 0:
4754 ar->dimen_type[i] = DIMEN_ELEMENT;
4755 break;
4756
4757 case 1:
4758 ar->dimen_type[i] = DIMEN_VECTOR;
4759 if (e->expr_type == EXPR_VARIABLE
4760 && e->symtree->n.sym->ts.type == BT_DERIVED)
4761 ar->start[i] = gfc_get_parentheses (e);
4762 break;
4763
4764 default:
4765 gfc_error ("Array index at %L is an array of rank %d",
4766 &ar->c_where[i], e->rank);
4767 return FAILURE;
4768 }
4769
4770 /* Fill in the upper bound, which may be lower than the
4771 specified one for something like a(2:10:5), which is
4772 identical to a(2:7:5). Only relevant for strides not equal
4773 to one. Don't try a division by zero. */
4774 if (ar->dimen_type[i] == DIMEN_RANGE
4775 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
4776 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
4777 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
4778 {
4779 mpz_t size, end;
4780
4781 if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
4782 {
4783 if (ar->end[i] == NULL)
4784 {
4785 ar->end[i] =
4786 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
4787 &ar->where);
4788 mpz_set (ar->end[i]->value.integer, end);
4789 }
4790 else if (ar->end[i]->ts.type == BT_INTEGER
4791 && ar->end[i]->expr_type == EXPR_CONSTANT)
4792 {
4793 mpz_set (ar->end[i]->value.integer, end);
4794 }
4795 else
4796 gcc_unreachable ();
4797
4798 mpz_clear (size);
4799 mpz_clear (end);
4800 }
4801 }
4802 }
4803
4804 if (ar->type == AR_FULL)
4805 {
4806 if (ar->as->rank == 0)
4807 ar->type = AR_ELEMENT;
4808
4809 /* Make sure array is the same as array(:,:), this way
4810 we don't need to special case all the time. */
4811 ar->dimen = ar->as->rank;
4812 for (i = 0; i < ar->dimen; i++)
4813 {
4814 ar->dimen_type[i] = DIMEN_RANGE;
4815
4816 gcc_assert (ar->start[i] == NULL);
4817 gcc_assert (ar->end[i] == NULL);
4818 gcc_assert (ar->stride[i] == NULL);
4819 }
4820 }
4821
4822 /* If the reference type is unknown, figure out what kind it is. */
4823
4824 if (ar->type == AR_UNKNOWN)
4825 {
4826 ar->type = AR_ELEMENT;
4827 for (i = 0; i < ar->dimen; i++)
4828 if (ar->dimen_type[i] == DIMEN_RANGE
4829 || ar->dimen_type[i] == DIMEN_VECTOR)
4830 {
4831 ar->type = AR_SECTION;
4832 break;
4833 }
4834 }
4835
4836 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
4837 return FAILURE;
4838
4839 if (ar->as->corank && ar->codimen == 0)
4840 {
4841 int n;
4842 ar->codimen = ar->as->corank;
4843 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
4844 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
4845 }
4846
4847 return SUCCESS;
4848 }
4849
4850
4851 static gfc_try
resolve_substring(gfc_ref * ref)4852 resolve_substring (gfc_ref *ref)
4853 {
4854 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4855
4856 if (ref->u.ss.start != NULL)
4857 {
4858 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
4859 return FAILURE;
4860
4861 if (ref->u.ss.start->ts.type != BT_INTEGER)
4862 {
4863 gfc_error ("Substring start index at %L must be of type INTEGER",
4864 &ref->u.ss.start->where);
4865 return FAILURE;
4866 }
4867
4868 if (ref->u.ss.start->rank != 0)
4869 {
4870 gfc_error ("Substring start index at %L must be scalar",
4871 &ref->u.ss.start->where);
4872 return FAILURE;
4873 }
4874
4875 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
4876 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4877 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4878 {
4879 gfc_error ("Substring start index at %L is less than one",
4880 &ref->u.ss.start->where);
4881 return FAILURE;
4882 }
4883 }
4884
4885 if (ref->u.ss.end != NULL)
4886 {
4887 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
4888 return FAILURE;
4889
4890 if (ref->u.ss.end->ts.type != BT_INTEGER)
4891 {
4892 gfc_error ("Substring end index at %L must be of type INTEGER",
4893 &ref->u.ss.end->where);
4894 return FAILURE;
4895 }
4896
4897 if (ref->u.ss.end->rank != 0)
4898 {
4899 gfc_error ("Substring end index at %L must be scalar",
4900 &ref->u.ss.end->where);
4901 return FAILURE;
4902 }
4903
4904 if (ref->u.ss.length != NULL
4905 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
4906 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4907 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4908 {
4909 gfc_error ("Substring end index at %L exceeds the string length",
4910 &ref->u.ss.start->where);
4911 return FAILURE;
4912 }
4913
4914 if (compare_bound_mpz_t (ref->u.ss.end,
4915 gfc_integer_kinds[k].huge) == CMP_GT
4916 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
4917 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
4918 {
4919 gfc_error ("Substring end index at %L is too large",
4920 &ref->u.ss.end->where);
4921 return FAILURE;
4922 }
4923 }
4924
4925 return SUCCESS;
4926 }
4927
4928
4929 /* This function supplies missing substring charlens. */
4930
4931 void
gfc_resolve_substring_charlen(gfc_expr * e)4932 gfc_resolve_substring_charlen (gfc_expr *e)
4933 {
4934 gfc_ref *char_ref;
4935 gfc_expr *start, *end;
4936
4937 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
4938 if (char_ref->type == REF_SUBSTRING)
4939 break;
4940
4941 if (!char_ref)
4942 return;
4943
4944 gcc_assert (char_ref->next == NULL);
4945
4946 if (e->ts.u.cl)
4947 {
4948 if (e->ts.u.cl->length)
4949 gfc_free_expr (e->ts.u.cl->length);
4950 else if (e->expr_type == EXPR_VARIABLE
4951 && e->symtree->n.sym->attr.dummy)
4952 return;
4953 }
4954
4955 e->ts.type = BT_CHARACTER;
4956 e->ts.kind = gfc_default_character_kind;
4957
4958 if (!e->ts.u.cl)
4959 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4960
4961 if (char_ref->u.ss.start)
4962 start = gfc_copy_expr (char_ref->u.ss.start);
4963 else
4964 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
4965
4966 if (char_ref->u.ss.end)
4967 end = gfc_copy_expr (char_ref->u.ss.end);
4968 else if (e->expr_type == EXPR_VARIABLE)
4969 end = gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
4970 else
4971 end = NULL;
4972
4973 if (!start || !end)
4974 {
4975 gfc_free_expr (start);
4976 gfc_free_expr (end);
4977 return;
4978 }
4979
4980 /* Length = (end - start +1). */
4981 e->ts.u.cl->length = gfc_subtract (end, start);
4982 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
4983 gfc_get_int_expr (gfc_default_integer_kind,
4984 NULL, 1));
4985
4986 e->ts.u.cl->length->ts.type = BT_INTEGER;
4987 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
4988
4989 /* Make sure that the length is simplified. */
4990 gfc_simplify_expr (e->ts.u.cl->length, 1);
4991 gfc_resolve_expr (e->ts.u.cl->length);
4992 }
4993
4994
4995 /* Resolve subtype references. */
4996
4997 static gfc_try
resolve_ref(gfc_expr * expr)4998 resolve_ref (gfc_expr *expr)
4999 {
5000 int current_part_dimension, n_components, seen_part_dimension;
5001 gfc_ref *ref;
5002
5003 for (ref = expr->ref; ref; ref = ref->next)
5004 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
5005 {
5006 find_array_spec (expr);
5007 break;
5008 }
5009
5010 for (ref = expr->ref; ref; ref = ref->next)
5011 switch (ref->type)
5012 {
5013 case REF_ARRAY:
5014 if (resolve_array_ref (&ref->u.ar) == FAILURE)
5015 return FAILURE;
5016 break;
5017
5018 case REF_COMPONENT:
5019 break;
5020
5021 case REF_SUBSTRING:
5022 if (resolve_substring (ref) == FAILURE)
5023 return FAILURE;
5024 break;
5025 }
5026
5027 /* Check constraints on part references. */
5028
5029 current_part_dimension = 0;
5030 seen_part_dimension = 0;
5031 n_components = 0;
5032
5033 for (ref = expr->ref; ref; ref = ref->next)
5034 {
5035 switch (ref->type)
5036 {
5037 case REF_ARRAY:
5038 switch (ref->u.ar.type)
5039 {
5040 case AR_FULL:
5041 /* Coarray scalar. */
5042 if (ref->u.ar.as->rank == 0)
5043 {
5044 current_part_dimension = 0;
5045 break;
5046 }
5047 /* Fall through. */
5048 case AR_SECTION:
5049 current_part_dimension = 1;
5050 break;
5051
5052 case AR_ELEMENT:
5053 current_part_dimension = 0;
5054 break;
5055
5056 case AR_UNKNOWN:
5057 gfc_internal_error ("resolve_ref(): Bad array reference");
5058 }
5059
5060 break;
5061
5062 case REF_COMPONENT:
5063 if (current_part_dimension || seen_part_dimension)
5064 {
5065 /* F03:C614. */
5066 if (ref->u.c.component->attr.pointer
5067 || ref->u.c.component->attr.proc_pointer
5068 || (ref->u.c.component->ts.type == BT_CLASS
5069 && CLASS_DATA (ref->u.c.component)->attr.pointer))
5070 {
5071 gfc_error ("Component to the right of a part reference "
5072 "with nonzero rank must not have the POINTER "
5073 "attribute at %L", &expr->where);
5074 return FAILURE;
5075 }
5076 else if (ref->u.c.component->attr.allocatable
5077 || (ref->u.c.component->ts.type == BT_CLASS
5078 && CLASS_DATA (ref->u.c.component)->attr.allocatable))
5079
5080 {
5081 gfc_error ("Component to the right of a part reference "
5082 "with nonzero rank must not have the ALLOCATABLE "
5083 "attribute at %L", &expr->where);
5084 return FAILURE;
5085 }
5086 }
5087
5088 n_components++;
5089 break;
5090
5091 case REF_SUBSTRING:
5092 break;
5093 }
5094
5095 if (((ref->type == REF_COMPONENT && n_components > 1)
5096 || ref->next == NULL)
5097 && current_part_dimension
5098 && seen_part_dimension)
5099 {
5100 gfc_error ("Two or more part references with nonzero rank must "
5101 "not be specified at %L", &expr->where);
5102 return FAILURE;
5103 }
5104
5105 if (ref->type == REF_COMPONENT)
5106 {
5107 if (current_part_dimension)
5108 seen_part_dimension = 1;
5109
5110 /* reset to make sure */
5111 current_part_dimension = 0;
5112 }
5113 }
5114
5115 return SUCCESS;
5116 }
5117
5118
5119 /* Given an expression, determine its shape. This is easier than it sounds.
5120 Leaves the shape array NULL if it is not possible to determine the shape. */
5121
5122 static void
expression_shape(gfc_expr * e)5123 expression_shape (gfc_expr *e)
5124 {
5125 mpz_t array[GFC_MAX_DIMENSIONS];
5126 int i;
5127
5128 if (e->rank <= 0 || e->shape != NULL)
5129 return;
5130
5131 for (i = 0; i < e->rank; i++)
5132 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
5133 goto fail;
5134
5135 e->shape = gfc_get_shape (e->rank);
5136
5137 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
5138
5139 return;
5140
5141 fail:
5142 for (i--; i >= 0; i--)
5143 mpz_clear (array[i]);
5144 }
5145
5146
5147 /* Given a variable expression node, compute the rank of the expression by
5148 examining the base symbol and any reference structures it may have. */
5149
5150 static void
expression_rank(gfc_expr * e)5151 expression_rank (gfc_expr *e)
5152 {
5153 gfc_ref *ref;
5154 int i, rank;
5155
5156 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5157 could lead to serious confusion... */
5158 gcc_assert (e->expr_type != EXPR_COMPCALL);
5159
5160 if (e->ref == NULL)
5161 {
5162 if (e->expr_type == EXPR_ARRAY)
5163 goto done;
5164 /* Constructors can have a rank different from one via RESHAPE(). */
5165
5166 if (e->symtree == NULL)
5167 {
5168 e->rank = 0;
5169 goto done;
5170 }
5171
5172 e->rank = (e->symtree->n.sym->as == NULL)
5173 ? 0 : e->symtree->n.sym->as->rank;
5174 goto done;
5175 }
5176
5177 rank = 0;
5178
5179 for (ref = e->ref; ref; ref = ref->next)
5180 {
5181 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5182 && ref->u.c.component->attr.function && !ref->next)
5183 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5184
5185 if (ref->type != REF_ARRAY)
5186 continue;
5187
5188 if (ref->u.ar.type == AR_FULL)
5189 {
5190 rank = ref->u.ar.as->rank;
5191 break;
5192 }
5193
5194 if (ref->u.ar.type == AR_SECTION)
5195 {
5196 /* Figure out the rank of the section. */
5197 if (rank != 0)
5198 gfc_internal_error ("expression_rank(): Two array specs");
5199
5200 for (i = 0; i < ref->u.ar.dimen; i++)
5201 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5202 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5203 rank++;
5204
5205 break;
5206 }
5207 }
5208
5209 e->rank = rank;
5210
5211 done:
5212 expression_shape (e);
5213 }
5214
5215
5216 /* Resolve a variable expression. */
5217
5218 static gfc_try
resolve_variable(gfc_expr * e)5219 resolve_variable (gfc_expr *e)
5220 {
5221 gfc_symbol *sym;
5222 gfc_try t;
5223
5224 t = SUCCESS;
5225
5226 if (e->symtree == NULL)
5227 return FAILURE;
5228 sym = e->symtree->n.sym;
5229
5230 /* TS 29113, 407b. */
5231 if (e->ts.type == BT_ASSUMED)
5232 {
5233 if (!actual_arg)
5234 {
5235 gfc_error ("Assumed-type variable %s at %L may only be used "
5236 "as actual argument", sym->name, &e->where);
5237 return FAILURE;
5238 }
5239 else if (inquiry_argument && !first_actual_arg)
5240 {
5241 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5242 for all inquiry functions in resolve_function; the reason is
5243 that the function-name resolution happens too late in that
5244 function. */
5245 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5246 "an inquiry function shall be the first argument",
5247 sym->name, &e->where);
5248 return FAILURE;
5249 }
5250 }
5251
5252 /* TS 29113, C535b. */
5253 if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
5254 && CLASS_DATA (sym)->as
5255 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5256 || (sym->ts.type != BT_CLASS && sym->as
5257 && sym->as->type == AS_ASSUMED_RANK))
5258 {
5259 if (!actual_arg)
5260 {
5261 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5262 "actual argument", sym->name, &e->where);
5263 return FAILURE;
5264 }
5265 else if (inquiry_argument && !first_actual_arg)
5266 {
5267 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5268 for all inquiry functions in resolve_function; the reason is
5269 that the function-name resolution happens too late in that
5270 function. */
5271 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5272 "to an inquiry function shall be the first argument",
5273 sym->name, &e->where);
5274 return FAILURE;
5275 }
5276 }
5277
5278 /* TS 29113, 407b. */
5279 if (e->ts.type == BT_ASSUMED && e->ref
5280 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5281 && e->ref->next == NULL))
5282 {
5283 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5284 "reference", sym->name, &e->ref->u.ar.where);
5285 return FAILURE;
5286 }
5287
5288 /* TS 29113, C535b. */
5289 if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5290 && CLASS_DATA (sym)->as
5291 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5292 || (sym->ts.type != BT_CLASS && sym->as
5293 && sym->as->type == AS_ASSUMED_RANK))
5294 && e->ref
5295 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5296 && e->ref->next == NULL))
5297 {
5298 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5299 "reference", sym->name, &e->ref->u.ar.where);
5300 return FAILURE;
5301 }
5302
5303
5304 /* If this is an associate-name, it may be parsed with an array reference
5305 in error even though the target is scalar. Fail directly in this case.
5306 TODO Understand why class scalar expressions must be excluded. */
5307 if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5308 {
5309 if (sym->ts.type == BT_CLASS)
5310 gfc_fix_class_refs (e);
5311 if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5312 return FAILURE;
5313 }
5314
5315 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5316 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5317
5318 /* On the other hand, the parser may not have known this is an array;
5319 in this case, we have to add a FULL reference. */
5320 if (sym->assoc && sym->attr.dimension && !e->ref)
5321 {
5322 e->ref = gfc_get_ref ();
5323 e->ref->type = REF_ARRAY;
5324 e->ref->u.ar.type = AR_FULL;
5325 e->ref->u.ar.dimen = 0;
5326 }
5327
5328 if (e->ref && resolve_ref (e) == FAILURE)
5329 return FAILURE;
5330
5331 if (sym->attr.flavor == FL_PROCEDURE
5332 && (!sym->attr.function
5333 || (sym->attr.function && sym->result
5334 && sym->result->attr.proc_pointer
5335 && !sym->result->attr.function)))
5336 {
5337 e->ts.type = BT_PROCEDURE;
5338 goto resolve_procedure;
5339 }
5340
5341 if (sym->ts.type != BT_UNKNOWN)
5342 gfc_variable_attr (e, &e->ts);
5343 else
5344 {
5345 /* Must be a simple variable reference. */
5346 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
5347 return FAILURE;
5348 e->ts = sym->ts;
5349 }
5350
5351 if (check_assumed_size_reference (sym, e))
5352 return FAILURE;
5353
5354 /* Deal with forward references to entries during resolve_code, to
5355 satisfy, at least partially, 12.5.2.5. */
5356 if (gfc_current_ns->entries
5357 && current_entry_id == sym->entry_id
5358 && cs_base
5359 && cs_base->current
5360 && cs_base->current->op != EXEC_ENTRY)
5361 {
5362 gfc_entry_list *entry;
5363 gfc_formal_arglist *formal;
5364 int n;
5365 bool seen, saved_specification_expr;
5366
5367 /* If the symbol is a dummy... */
5368 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5369 {
5370 entry = gfc_current_ns->entries;
5371 seen = false;
5372
5373 /* ...test if the symbol is a parameter of previous entries. */
5374 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5375 for (formal = entry->sym->formal; formal; formal = formal->next)
5376 {
5377 if (formal->sym && sym->name == formal->sym->name)
5378 seen = true;
5379 }
5380
5381 /* If it has not been seen as a dummy, this is an error. */
5382 if (!seen)
5383 {
5384 if (specification_expr)
5385 gfc_error ("Variable '%s', used in a specification expression"
5386 ", is referenced at %L before the ENTRY statement "
5387 "in which it is a parameter",
5388 sym->name, &cs_base->current->loc);
5389 else
5390 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5391 "statement in which it is a parameter",
5392 sym->name, &cs_base->current->loc);
5393 t = FAILURE;
5394 }
5395 }
5396
5397 /* Now do the same check on the specification expressions. */
5398 saved_specification_expr = specification_expr;
5399 specification_expr = true;
5400 if (sym->ts.type == BT_CHARACTER
5401 && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
5402 t = FAILURE;
5403
5404 if (sym->as)
5405 for (n = 0; n < sym->as->rank; n++)
5406 {
5407 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
5408 t = FAILURE;
5409 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
5410 t = FAILURE;
5411 }
5412 specification_expr = saved_specification_expr;
5413
5414 if (t == SUCCESS)
5415 /* Update the symbol's entry level. */
5416 sym->entry_id = current_entry_id + 1;
5417 }
5418
5419 /* If a symbol has been host_associated mark it. This is used latter,
5420 to identify if aliasing is possible via host association. */
5421 if (sym->attr.flavor == FL_VARIABLE
5422 && gfc_current_ns->parent
5423 && (gfc_current_ns->parent == sym->ns
5424 || (gfc_current_ns->parent->parent
5425 && gfc_current_ns->parent->parent == sym->ns)))
5426 sym->attr.host_assoc = 1;
5427
5428 resolve_procedure:
5429 if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
5430 t = FAILURE;
5431
5432 /* F2008, C617 and C1229. */
5433 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5434 && gfc_is_coindexed (e))
5435 {
5436 gfc_ref *ref, *ref2 = NULL;
5437
5438 for (ref = e->ref; ref; ref = ref->next)
5439 {
5440 if (ref->type == REF_COMPONENT)
5441 ref2 = ref;
5442 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5443 break;
5444 }
5445
5446 for ( ; ref; ref = ref->next)
5447 if (ref->type == REF_COMPONENT)
5448 break;
5449
5450 /* Expression itself is not coindexed object. */
5451 if (ref && e->ts.type == BT_CLASS)
5452 {
5453 gfc_error ("Polymorphic subobject of coindexed object at %L",
5454 &e->where);
5455 t = FAILURE;
5456 }
5457
5458 /* Expression itself is coindexed object. */
5459 if (ref == NULL)
5460 {
5461 gfc_component *c;
5462 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5463 for ( ; c; c = c->next)
5464 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5465 {
5466 gfc_error ("Coindexed object with polymorphic allocatable "
5467 "subcomponent at %L", &e->where);
5468 t = FAILURE;
5469 break;
5470 }
5471 }
5472 }
5473
5474 return t;
5475 }
5476
5477
5478 /* Checks to see that the correct symbol has been host associated.
5479 The only situation where this arises is that in which a twice
5480 contained function is parsed after the host association is made.
5481 Therefore, on detecting this, change the symbol in the expression
5482 and convert the array reference into an actual arglist if the old
5483 symbol is a variable. */
5484 static bool
check_host_association(gfc_expr * e)5485 check_host_association (gfc_expr *e)
5486 {
5487 gfc_symbol *sym, *old_sym;
5488 gfc_symtree *st;
5489 int n;
5490 gfc_ref *ref;
5491 gfc_actual_arglist *arg, *tail = NULL;
5492 bool retval = e->expr_type == EXPR_FUNCTION;
5493
5494 /* If the expression is the result of substitution in
5495 interface.c(gfc_extend_expr) because there is no way in
5496 which the host association can be wrong. */
5497 if (e->symtree == NULL
5498 || e->symtree->n.sym == NULL
5499 || e->user_operator)
5500 return retval;
5501
5502 old_sym = e->symtree->n.sym;
5503
5504 if (gfc_current_ns->parent
5505 && old_sym->ns != gfc_current_ns)
5506 {
5507 /* Use the 'USE' name so that renamed module symbols are
5508 correctly handled. */
5509 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
5510
5511 if (sym && old_sym != sym
5512 && sym->ts.type == old_sym->ts.type
5513 && sym->attr.flavor == FL_PROCEDURE
5514 && sym->attr.contained)
5515 {
5516 /* Clear the shape, since it might not be valid. */
5517 gfc_free_shape (&e->shape, e->rank);
5518
5519 /* Give the expression the right symtree! */
5520 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
5521 gcc_assert (st != NULL);
5522
5523 if (old_sym->attr.flavor == FL_PROCEDURE
5524 || e->expr_type == EXPR_FUNCTION)
5525 {
5526 /* Original was function so point to the new symbol, since
5527 the actual argument list is already attached to the
5528 expression. */
5529 e->value.function.esym = NULL;
5530 e->symtree = st;
5531 }
5532 else
5533 {
5534 /* Original was variable so convert array references into
5535 an actual arglist. This does not need any checking now
5536 since resolve_function will take care of it. */
5537 e->value.function.actual = NULL;
5538 e->expr_type = EXPR_FUNCTION;
5539 e->symtree = st;
5540
5541 /* Ambiguity will not arise if the array reference is not
5542 the last reference. */
5543 for (ref = e->ref; ref; ref = ref->next)
5544 if (ref->type == REF_ARRAY && ref->next == NULL)
5545 break;
5546
5547 gcc_assert (ref->type == REF_ARRAY);
5548
5549 /* Grab the start expressions from the array ref and
5550 copy them into actual arguments. */
5551 for (n = 0; n < ref->u.ar.dimen; n++)
5552 {
5553 arg = gfc_get_actual_arglist ();
5554 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
5555 if (e->value.function.actual == NULL)
5556 tail = e->value.function.actual = arg;
5557 else
5558 {
5559 tail->next = arg;
5560 tail = arg;
5561 }
5562 }
5563
5564 /* Dump the reference list and set the rank. */
5565 gfc_free_ref_list (e->ref);
5566 e->ref = NULL;
5567 e->rank = sym->as ? sym->as->rank : 0;
5568 }
5569
5570 gfc_resolve_expr (e);
5571 sym->refs++;
5572 }
5573 }
5574 /* This might have changed! */
5575 return e->expr_type == EXPR_FUNCTION;
5576 }
5577
5578
5579 static void
gfc_resolve_character_operator(gfc_expr * e)5580 gfc_resolve_character_operator (gfc_expr *e)
5581 {
5582 gfc_expr *op1 = e->value.op.op1;
5583 gfc_expr *op2 = e->value.op.op2;
5584 gfc_expr *e1 = NULL;
5585 gfc_expr *e2 = NULL;
5586
5587 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
5588
5589 if (op1->ts.u.cl && op1->ts.u.cl->length)
5590 e1 = gfc_copy_expr (op1->ts.u.cl->length);
5591 else if (op1->expr_type == EXPR_CONSTANT)
5592 e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5593 op1->value.character.length);
5594
5595 if (op2->ts.u.cl && op2->ts.u.cl->length)
5596 e2 = gfc_copy_expr (op2->ts.u.cl->length);
5597 else if (op2->expr_type == EXPR_CONSTANT)
5598 e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5599 op2->value.character.length);
5600
5601 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5602
5603 if (!e1 || !e2)
5604 {
5605 gfc_free_expr (e1);
5606 gfc_free_expr (e2);
5607
5608 return;
5609 }
5610
5611 e->ts.u.cl->length = gfc_add (e1, e2);
5612 e->ts.u.cl->length->ts.type = BT_INTEGER;
5613 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5614 gfc_simplify_expr (e->ts.u.cl->length, 0);
5615 gfc_resolve_expr (e->ts.u.cl->length);
5616
5617 return;
5618 }
5619
5620
5621 /* Ensure that an character expression has a charlen and, if possible, a
5622 length expression. */
5623
5624 static void
fixup_charlen(gfc_expr * e)5625 fixup_charlen (gfc_expr *e)
5626 {
5627 /* The cases fall through so that changes in expression type and the need
5628 for multiple fixes are picked up. In all circumstances, a charlen should
5629 be available for the middle end to hang a backend_decl on. */
5630 switch (e->expr_type)
5631 {
5632 case EXPR_OP:
5633 gfc_resolve_character_operator (e);
5634
5635 case EXPR_ARRAY:
5636 if (e->expr_type == EXPR_ARRAY)
5637 gfc_resolve_character_array_constructor (e);
5638
5639 case EXPR_SUBSTRING:
5640 if (!e->ts.u.cl && e->ref)
5641 gfc_resolve_substring_charlen (e);
5642
5643 default:
5644 if (!e->ts.u.cl)
5645 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5646
5647 break;
5648 }
5649 }
5650
5651
5652 /* Update an actual argument to include the passed-object for type-bound
5653 procedures at the right position. */
5654
5655 static gfc_actual_arglist*
update_arglist_pass(gfc_actual_arglist * lst,gfc_expr * po,unsigned argpos,const char * name)5656 update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
5657 const char *name)
5658 {
5659 gcc_assert (argpos > 0);
5660
5661 if (argpos == 1)
5662 {
5663 gfc_actual_arglist* result;
5664
5665 result = gfc_get_actual_arglist ();
5666 result->expr = po;
5667 result->next = lst;
5668 if (name)
5669 result->name = name;
5670
5671 return result;
5672 }
5673
5674 if (lst)
5675 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
5676 else
5677 lst = update_arglist_pass (NULL, po, argpos - 1, name);
5678 return lst;
5679 }
5680
5681
5682 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5683
5684 static gfc_expr*
extract_compcall_passed_object(gfc_expr * e)5685 extract_compcall_passed_object (gfc_expr* e)
5686 {
5687 gfc_expr* po;
5688
5689 gcc_assert (e->expr_type == EXPR_COMPCALL);
5690
5691 if (e->value.compcall.base_object)
5692 po = gfc_copy_expr (e->value.compcall.base_object);
5693 else
5694 {
5695 po = gfc_get_expr ();
5696 po->expr_type = EXPR_VARIABLE;
5697 po->symtree = e->symtree;
5698 po->ref = gfc_copy_ref (e->ref);
5699 po->where = e->where;
5700 }
5701
5702 if (gfc_resolve_expr (po) == FAILURE)
5703 return NULL;
5704
5705 return po;
5706 }
5707
5708
5709 /* Update the arglist of an EXPR_COMPCALL expression to include the
5710 passed-object. */
5711
5712 static gfc_try
update_compcall_arglist(gfc_expr * e)5713 update_compcall_arglist (gfc_expr* e)
5714 {
5715 gfc_expr* po;
5716 gfc_typebound_proc* tbp;
5717
5718 tbp = e->value.compcall.tbp;
5719
5720 if (tbp->error)
5721 return FAILURE;
5722
5723 po = extract_compcall_passed_object (e);
5724 if (!po)
5725 return FAILURE;
5726
5727 if (tbp->nopass || e->value.compcall.ignore_pass)
5728 {
5729 gfc_free_expr (po);
5730 return SUCCESS;
5731 }
5732
5733 gcc_assert (tbp->pass_arg_num > 0);
5734 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5735 tbp->pass_arg_num,
5736 tbp->pass_arg);
5737
5738 return SUCCESS;
5739 }
5740
5741
5742 /* Extract the passed object from a PPC call (a copy of it). */
5743
5744 static gfc_expr*
extract_ppc_passed_object(gfc_expr * e)5745 extract_ppc_passed_object (gfc_expr *e)
5746 {
5747 gfc_expr *po;
5748 gfc_ref **ref;
5749
5750 po = gfc_get_expr ();
5751 po->expr_type = EXPR_VARIABLE;
5752 po->symtree = e->symtree;
5753 po->ref = gfc_copy_ref (e->ref);
5754 po->where = e->where;
5755
5756 /* Remove PPC reference. */
5757 ref = &po->ref;
5758 while ((*ref)->next)
5759 ref = &(*ref)->next;
5760 gfc_free_ref_list (*ref);
5761 *ref = NULL;
5762
5763 if (gfc_resolve_expr (po) == FAILURE)
5764 return NULL;
5765
5766 return po;
5767 }
5768
5769
5770 /* Update the actual arglist of a procedure pointer component to include the
5771 passed-object. */
5772
5773 static gfc_try
update_ppc_arglist(gfc_expr * e)5774 update_ppc_arglist (gfc_expr* e)
5775 {
5776 gfc_expr* po;
5777 gfc_component *ppc;
5778 gfc_typebound_proc* tb;
5779
5780 ppc = gfc_get_proc_ptr_comp (e);
5781 if (!ppc)
5782 return FAILURE;
5783
5784 tb = ppc->tb;
5785
5786 if (tb->error)
5787 return FAILURE;
5788 else if (tb->nopass)
5789 return SUCCESS;
5790
5791 po = extract_ppc_passed_object (e);
5792 if (!po)
5793 return FAILURE;
5794
5795 /* F08:R739. */
5796 if (po->rank != 0)
5797 {
5798 gfc_error ("Passed-object at %L must be scalar", &e->where);
5799 return FAILURE;
5800 }
5801
5802 /* F08:C611. */
5803 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
5804 {
5805 gfc_error ("Base object for procedure-pointer component call at %L is of"
5806 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
5807 return FAILURE;
5808 }
5809
5810 gcc_assert (tb->pass_arg_num > 0);
5811 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
5812 tb->pass_arg_num,
5813 tb->pass_arg);
5814
5815 return SUCCESS;
5816 }
5817
5818
5819 /* Check that the object a TBP is called on is valid, i.e. it must not be
5820 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5821
5822 static gfc_try
check_typebound_baseobject(gfc_expr * e)5823 check_typebound_baseobject (gfc_expr* e)
5824 {
5825 gfc_expr* base;
5826 gfc_try return_value = FAILURE;
5827
5828 base = extract_compcall_passed_object (e);
5829 if (!base)
5830 return FAILURE;
5831
5832 gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
5833
5834 if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
5835 return FAILURE;
5836
5837 /* F08:C611. */
5838 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
5839 {
5840 gfc_error ("Base object for type-bound procedure call at %L is of"
5841 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
5842 goto cleanup;
5843 }
5844
5845 /* F08:C1230. If the procedure called is NOPASS,
5846 the base object must be scalar. */
5847 if (e->value.compcall.tbp->nopass && base->rank != 0)
5848 {
5849 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5850 " be scalar", &e->where);
5851 goto cleanup;
5852 }
5853
5854 return_value = SUCCESS;
5855
5856 cleanup:
5857 gfc_free_expr (base);
5858 return return_value;
5859 }
5860
5861
5862 /* Resolve a call to a type-bound procedure, either function or subroutine,
5863 statically from the data in an EXPR_COMPCALL expression. The adapted
5864 arglist and the target-procedure symtree are returned. */
5865
5866 static gfc_try
resolve_typebound_static(gfc_expr * e,gfc_symtree ** target,gfc_actual_arglist ** actual)5867 resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
5868 gfc_actual_arglist** actual)
5869 {
5870 gcc_assert (e->expr_type == EXPR_COMPCALL);
5871 gcc_assert (!e->value.compcall.tbp->is_generic);
5872
5873 /* Update the actual arglist for PASS. */
5874 if (update_compcall_arglist (e) == FAILURE)
5875 return FAILURE;
5876
5877 *actual = e->value.compcall.actual;
5878 *target = e->value.compcall.tbp->u.specific;
5879
5880 gfc_free_ref_list (e->ref);
5881 e->ref = NULL;
5882 e->value.compcall.actual = NULL;
5883
5884 /* If we find a deferred typebound procedure, check for derived types
5885 that an overriding typebound procedure has not been missed. */
5886 if (e->value.compcall.name
5887 && !e->value.compcall.tbp->non_overridable
5888 && e->value.compcall.base_object
5889 && e->value.compcall.base_object->ts.type == BT_DERIVED)
5890 {
5891 gfc_symtree *st;
5892 gfc_symbol *derived;
5893
5894 /* Use the derived type of the base_object. */
5895 derived = e->value.compcall.base_object->ts.u.derived;
5896 st = NULL;
5897
5898 /* If necessary, go through the inheritance chain. */
5899 while (!st && derived)
5900 {
5901 /* Look for the typebound procedure 'name'. */
5902 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
5903 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
5904 e->value.compcall.name);
5905 if (!st)
5906 derived = gfc_get_derived_super_type (derived);
5907 }
5908
5909 /* Now find the specific name in the derived type namespace. */
5910 if (st && st->n.tb && st->n.tb->u.specific)
5911 gfc_find_sym_tree (st->n.tb->u.specific->name,
5912 derived->ns, 1, &st);
5913 if (st)
5914 *target = st;
5915 }
5916 return SUCCESS;
5917 }
5918
5919
5920 /* Get the ultimate declared type from an expression. In addition,
5921 return the last class/derived type reference and the copy of the
5922 reference list. If check_types is set true, derived types are
5923 identified as well as class references. */
5924 static gfc_symbol*
get_declared_from_expr(gfc_ref ** class_ref,gfc_ref ** new_ref,gfc_expr * e,bool check_types)5925 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
5926 gfc_expr *e, bool check_types)
5927 {
5928 gfc_symbol *declared;
5929 gfc_ref *ref;
5930
5931 declared = NULL;
5932 if (class_ref)
5933 *class_ref = NULL;
5934 if (new_ref)
5935 *new_ref = gfc_copy_ref (e->ref);
5936
5937 for (ref = e->ref; ref; ref = ref->next)
5938 {
5939 if (ref->type != REF_COMPONENT)
5940 continue;
5941
5942 if ((ref->u.c.component->ts.type == BT_CLASS
5943 || (check_types && ref->u.c.component->ts.type == BT_DERIVED))
5944 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
5945 {
5946 declared = ref->u.c.component->ts.u.derived;
5947 if (class_ref)
5948 *class_ref = ref;
5949 }
5950 }
5951
5952 if (declared == NULL)
5953 declared = e->symtree->n.sym->ts.u.derived;
5954
5955 return declared;
5956 }
5957
5958
5959 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5960 which of the specific bindings (if any) matches the arglist and transform
5961 the expression into a call of that binding. */
5962
5963 static gfc_try
resolve_typebound_generic_call(gfc_expr * e,const char ** name)5964 resolve_typebound_generic_call (gfc_expr* e, const char **name)
5965 {
5966 gfc_typebound_proc* genproc;
5967 const char* genname;
5968 gfc_symtree *st;
5969 gfc_symbol *derived;
5970
5971 gcc_assert (e->expr_type == EXPR_COMPCALL);
5972 genname = e->value.compcall.name;
5973 genproc = e->value.compcall.tbp;
5974
5975 if (!genproc->is_generic)
5976 return SUCCESS;
5977
5978 /* Try the bindings on this type and in the inheritance hierarchy. */
5979 for (; genproc; genproc = genproc->overridden)
5980 {
5981 gfc_tbp_generic* g;
5982
5983 gcc_assert (genproc->is_generic);
5984 for (g = genproc->u.generic; g; g = g->next)
5985 {
5986 gfc_symbol* target;
5987 gfc_actual_arglist* args;
5988 bool matches;
5989
5990 gcc_assert (g->specific);
5991
5992 if (g->specific->error)
5993 continue;
5994
5995 target = g->specific->u.specific->n.sym;
5996
5997 /* Get the right arglist by handling PASS/NOPASS. */
5998 args = gfc_copy_actual_arglist (e->value.compcall.actual);
5999 if (!g->specific->nopass)
6000 {
6001 gfc_expr* po;
6002 po = extract_compcall_passed_object (e);
6003 if (!po)
6004 {
6005 gfc_free_actual_arglist (args);
6006 return FAILURE;
6007 }
6008
6009 gcc_assert (g->specific->pass_arg_num > 0);
6010 gcc_assert (!g->specific->error);
6011 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
6012 g->specific->pass_arg);
6013 }
6014 resolve_actual_arglist (args, target->attr.proc,
6015 is_external_proc (target)
6016 && gfc_sym_get_dummy_args (target) == NULL);
6017
6018 /* Check if this arglist matches the formal. */
6019 matches = gfc_arglist_matches_symbol (&args, target);
6020
6021 /* Clean up and break out of the loop if we've found it. */
6022 gfc_free_actual_arglist (args);
6023 if (matches)
6024 {
6025 e->value.compcall.tbp = g->specific;
6026 genname = g->specific_st->name;
6027 /* Pass along the name for CLASS methods, where the vtab
6028 procedure pointer component has to be referenced. */
6029 if (name)
6030 *name = genname;
6031 goto success;
6032 }
6033 }
6034 }
6035
6036 /* Nothing matching found! */
6037 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6038 " '%s' at %L", genname, &e->where);
6039 return FAILURE;
6040
6041 success:
6042 /* Make sure that we have the right specific instance for the name. */
6043 derived = get_declared_from_expr (NULL, NULL, e, true);
6044
6045 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
6046 if (st)
6047 e->value.compcall.tbp = st->n.tb;
6048
6049 return SUCCESS;
6050 }
6051
6052
6053 /* Resolve a call to a type-bound subroutine. */
6054
6055 static gfc_try
resolve_typebound_call(gfc_code * c,const char ** name)6056 resolve_typebound_call (gfc_code* c, const char **name)
6057 {
6058 gfc_actual_arglist* newactual;
6059 gfc_symtree* target;
6060
6061 /* Check that's really a SUBROUTINE. */
6062 if (!c->expr1->value.compcall.tbp->subroutine)
6063 {
6064 gfc_error ("'%s' at %L should be a SUBROUTINE",
6065 c->expr1->value.compcall.name, &c->loc);
6066 return FAILURE;
6067 }
6068
6069 if (check_typebound_baseobject (c->expr1) == FAILURE)
6070 return FAILURE;
6071
6072 /* Pass along the name for CLASS methods, where the vtab
6073 procedure pointer component has to be referenced. */
6074 if (name)
6075 *name = c->expr1->value.compcall.name;
6076
6077 if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
6078 return FAILURE;
6079
6080 /* Transform into an ordinary EXEC_CALL for now. */
6081
6082 if (resolve_typebound_static (c->expr1, &target, &newactual) == FAILURE)
6083 return FAILURE;
6084
6085 c->ext.actual = newactual;
6086 c->symtree = target;
6087 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
6088
6089 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
6090
6091 gfc_free_expr (c->expr1);
6092 c->expr1 = gfc_get_expr ();
6093 c->expr1->expr_type = EXPR_FUNCTION;
6094 c->expr1->symtree = target;
6095 c->expr1->where = c->loc;
6096
6097 return resolve_call (c);
6098 }
6099
6100
6101 /* Resolve a component-call expression. */
6102 static gfc_try
resolve_compcall(gfc_expr * e,const char ** name)6103 resolve_compcall (gfc_expr* e, const char **name)
6104 {
6105 gfc_actual_arglist* newactual;
6106 gfc_symtree* target;
6107
6108 /* Check that's really a FUNCTION. */
6109 if (!e->value.compcall.tbp->function)
6110 {
6111 gfc_error ("'%s' at %L should be a FUNCTION",
6112 e->value.compcall.name, &e->where);
6113 return FAILURE;
6114 }
6115
6116 /* These must not be assign-calls! */
6117 gcc_assert (!e->value.compcall.assign);
6118
6119 if (check_typebound_baseobject (e) == FAILURE)
6120 return FAILURE;
6121
6122 /* Pass along the name for CLASS methods, where the vtab
6123 procedure pointer component has to be referenced. */
6124 if (name)
6125 *name = e->value.compcall.name;
6126
6127 if (resolve_typebound_generic_call (e, name) == FAILURE)
6128 return FAILURE;
6129 gcc_assert (!e->value.compcall.tbp->is_generic);
6130
6131 /* Take the rank from the function's symbol. */
6132 if (e->value.compcall.tbp->u.specific->n.sym->as)
6133 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
6134
6135 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6136 arglist to the TBP's binding target. */
6137
6138 if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
6139 return FAILURE;
6140
6141 e->value.function.actual = newactual;
6142 e->value.function.name = NULL;
6143 e->value.function.esym = target->n.sym;
6144 e->value.function.isym = NULL;
6145 e->symtree = target;
6146 e->ts = target->n.sym->ts;
6147 e->expr_type = EXPR_FUNCTION;
6148
6149 /* Resolution is not necessary if this is a class subroutine; this
6150 function only has to identify the specific proc. Resolution of
6151 the call will be done next in resolve_typebound_call. */
6152 return gfc_resolve_expr (e);
6153 }
6154
6155
6156
6157 /* Resolve a typebound function, or 'method'. First separate all
6158 the non-CLASS references by calling resolve_compcall directly. */
6159
6160 static gfc_try
resolve_typebound_function(gfc_expr * e)6161 resolve_typebound_function (gfc_expr* e)
6162 {
6163 gfc_symbol *declared;
6164 gfc_component *c;
6165 gfc_ref *new_ref;
6166 gfc_ref *class_ref;
6167 gfc_symtree *st;
6168 const char *name;
6169 gfc_typespec ts;
6170 gfc_expr *expr;
6171 bool overridable;
6172
6173 st = e->symtree;
6174
6175 /* Deal with typebound operators for CLASS objects. */
6176 expr = e->value.compcall.base_object;
6177 overridable = !e->value.compcall.tbp->non_overridable;
6178 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
6179 {
6180 /* If the base_object is not a variable, the corresponding actual
6181 argument expression must be stored in e->base_expression so
6182 that the corresponding tree temporary can be used as the base
6183 object in gfc_conv_procedure_call. */
6184 if (expr->expr_type != EXPR_VARIABLE)
6185 {
6186 gfc_actual_arglist *args;
6187
6188 for (args= e->value.function.actual; args; args = args->next)
6189 {
6190 if (expr == args->expr)
6191 expr = args->expr;
6192 }
6193 }
6194
6195 /* Since the typebound operators are generic, we have to ensure
6196 that any delays in resolution are corrected and that the vtab
6197 is present. */
6198 ts = expr->ts;
6199 declared = ts.u.derived;
6200 c = gfc_find_component (declared, "_vptr", true, true);
6201 if (c->ts.u.derived == NULL)
6202 c->ts.u.derived = gfc_find_derived_vtab (declared);
6203
6204 if (resolve_compcall (e, &name) == FAILURE)
6205 return FAILURE;
6206
6207 /* Use the generic name if it is there. */
6208 name = name ? name : e->value.function.esym->name;
6209 e->symtree = expr->symtree;
6210 e->ref = gfc_copy_ref (expr->ref);
6211 get_declared_from_expr (&class_ref, NULL, e, false);
6212
6213 /* Trim away the extraneous references that emerge from nested
6214 use of interface.c (extend_expr). */
6215 if (class_ref && class_ref->next)
6216 {
6217 gfc_free_ref_list (class_ref->next);
6218 class_ref->next = NULL;
6219 }
6220 else if (e->ref && !class_ref)
6221 {
6222 gfc_free_ref_list (e->ref);
6223 e->ref = NULL;
6224 }
6225
6226 gfc_add_vptr_component (e);
6227 gfc_add_component_ref (e, name);
6228 e->value.function.esym = NULL;
6229 if (expr->expr_type != EXPR_VARIABLE)
6230 e->base_expr = expr;
6231 return SUCCESS;
6232 }
6233
6234 if (st == NULL)
6235 return resolve_compcall (e, NULL);
6236
6237 if (resolve_ref (e) == FAILURE)
6238 return FAILURE;
6239
6240 /* Get the CLASS declared type. */
6241 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
6242
6243 /* Weed out cases of the ultimate component being a derived type. */
6244 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6245 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6246 {
6247 gfc_free_ref_list (new_ref);
6248 return resolve_compcall (e, NULL);
6249 }
6250
6251 c = gfc_find_component (declared, "_data", true, true);
6252 declared = c->ts.u.derived;
6253
6254 /* Treat the call as if it is a typebound procedure, in order to roll
6255 out the correct name for the specific function. */
6256 if (resolve_compcall (e, &name) == FAILURE)
6257 {
6258 gfc_free_ref_list (new_ref);
6259 return FAILURE;
6260 }
6261 ts = e->ts;
6262
6263 if (overridable)
6264 {
6265 /* Convert the expression to a procedure pointer component call. */
6266 e->value.function.esym = NULL;
6267 e->symtree = st;
6268
6269 if (new_ref)
6270 e->ref = new_ref;
6271
6272 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6273 gfc_add_vptr_component (e);
6274 gfc_add_component_ref (e, name);
6275
6276 /* Recover the typespec for the expression. This is really only
6277 necessary for generic procedures, where the additional call
6278 to gfc_add_component_ref seems to throw the collection of the
6279 correct typespec. */
6280 e->ts = ts;
6281 }
6282
6283 return SUCCESS;
6284 }
6285
6286 /* Resolve a typebound subroutine, or 'method'. First separate all
6287 the non-CLASS references by calling resolve_typebound_call
6288 directly. */
6289
6290 static gfc_try
resolve_typebound_subroutine(gfc_code * code)6291 resolve_typebound_subroutine (gfc_code *code)
6292 {
6293 gfc_symbol *declared;
6294 gfc_component *c;
6295 gfc_ref *new_ref;
6296 gfc_ref *class_ref;
6297 gfc_symtree *st;
6298 const char *name;
6299 gfc_typespec ts;
6300 gfc_expr *expr;
6301 bool overridable;
6302
6303 st = code->expr1->symtree;
6304
6305 /* Deal with typebound operators for CLASS objects. */
6306 expr = code->expr1->value.compcall.base_object;
6307 overridable = !code->expr1->value.compcall.tbp->non_overridable;
6308 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
6309 {
6310 /* If the base_object is not a variable, the corresponding actual
6311 argument expression must be stored in e->base_expression so
6312 that the corresponding tree temporary can be used as the base
6313 object in gfc_conv_procedure_call. */
6314 if (expr->expr_type != EXPR_VARIABLE)
6315 {
6316 gfc_actual_arglist *args;
6317
6318 args= code->expr1->value.function.actual;
6319 for (; args; args = args->next)
6320 if (expr == args->expr)
6321 expr = args->expr;
6322 }
6323
6324 /* Since the typebound operators are generic, we have to ensure
6325 that any delays in resolution are corrected and that the vtab
6326 is present. */
6327 declared = expr->ts.u.derived;
6328 c = gfc_find_component (declared, "_vptr", true, true);
6329 if (c->ts.u.derived == NULL)
6330 c->ts.u.derived = gfc_find_derived_vtab (declared);
6331
6332 if (resolve_typebound_call (code, &name) == FAILURE)
6333 return FAILURE;
6334
6335 /* Use the generic name if it is there. */
6336 name = name ? name : code->expr1->value.function.esym->name;
6337 code->expr1->symtree = expr->symtree;
6338 code->expr1->ref = gfc_copy_ref (expr->ref);
6339
6340 /* Trim away the extraneous references that emerge from nested
6341 use of interface.c (extend_expr). */
6342 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6343 if (class_ref && class_ref->next)
6344 {
6345 gfc_free_ref_list (class_ref->next);
6346 class_ref->next = NULL;
6347 }
6348 else if (code->expr1->ref && !class_ref)
6349 {
6350 gfc_free_ref_list (code->expr1->ref);
6351 code->expr1->ref = NULL;
6352 }
6353
6354 /* Now use the procedure in the vtable. */
6355 gfc_add_vptr_component (code->expr1);
6356 gfc_add_component_ref (code->expr1, name);
6357 code->expr1->value.function.esym = NULL;
6358 if (expr->expr_type != EXPR_VARIABLE)
6359 code->expr1->base_expr = expr;
6360 return SUCCESS;
6361 }
6362
6363 if (st == NULL)
6364 return resolve_typebound_call (code, NULL);
6365
6366 if (resolve_ref (code->expr1) == FAILURE)
6367 return FAILURE;
6368
6369 /* Get the CLASS declared type. */
6370 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
6371
6372 /* Weed out cases of the ultimate component being a derived type. */
6373 if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
6374 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
6375 {
6376 gfc_free_ref_list (new_ref);
6377 return resolve_typebound_call (code, NULL);
6378 }
6379
6380 if (resolve_typebound_call (code, &name) == FAILURE)
6381 {
6382 gfc_free_ref_list (new_ref);
6383 return FAILURE;
6384 }
6385 ts = code->expr1->ts;
6386
6387 if (overridable)
6388 {
6389 /* Convert the expression to a procedure pointer component call. */
6390 code->expr1->value.function.esym = NULL;
6391 code->expr1->symtree = st;
6392
6393 if (new_ref)
6394 code->expr1->ref = new_ref;
6395
6396 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6397 gfc_add_vptr_component (code->expr1);
6398 gfc_add_component_ref (code->expr1, name);
6399
6400 /* Recover the typespec for the expression. This is really only
6401 necessary for generic procedures, where the additional call
6402 to gfc_add_component_ref seems to throw the collection of the
6403 correct typespec. */
6404 code->expr1->ts = ts;
6405 }
6406
6407 return SUCCESS;
6408 }
6409
6410
6411 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6412
6413 static gfc_try
resolve_ppc_call(gfc_code * c)6414 resolve_ppc_call (gfc_code* c)
6415 {
6416 gfc_component *comp;
6417
6418 comp = gfc_get_proc_ptr_comp (c->expr1);
6419 gcc_assert (comp != NULL);
6420
6421 c->resolved_sym = c->expr1->symtree->n.sym;
6422 c->expr1->expr_type = EXPR_VARIABLE;
6423
6424 if (!comp->attr.subroutine)
6425 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
6426
6427 if (resolve_ref (c->expr1) == FAILURE)
6428 return FAILURE;
6429
6430 if (update_ppc_arglist (c->expr1) == FAILURE)
6431 return FAILURE;
6432
6433 c->ext.actual = c->expr1->value.compcall.actual;
6434
6435 if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
6436 !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE)
6437 return FAILURE;
6438
6439 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
6440
6441 return SUCCESS;
6442 }
6443
6444
6445 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6446
6447 static gfc_try
resolve_expr_ppc(gfc_expr * e)6448 resolve_expr_ppc (gfc_expr* e)
6449 {
6450 gfc_component *comp;
6451
6452 comp = gfc_get_proc_ptr_comp (e);
6453 gcc_assert (comp != NULL);
6454
6455 /* Convert to EXPR_FUNCTION. */
6456 e->expr_type = EXPR_FUNCTION;
6457 e->value.function.isym = NULL;
6458 e->value.function.actual = e->value.compcall.actual;
6459 e->ts = comp->ts;
6460 if (comp->as != NULL)
6461 e->rank = comp->as->rank;
6462
6463 if (!comp->attr.function)
6464 gfc_add_function (&comp->attr, comp->name, &e->where);
6465
6466 if (resolve_ref (e) == FAILURE)
6467 return FAILURE;
6468
6469 if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
6470 !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE)
6471 return FAILURE;
6472
6473 if (update_ppc_arglist (e) == FAILURE)
6474 return FAILURE;
6475
6476 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
6477
6478 return SUCCESS;
6479 }
6480
6481
6482 static bool
gfc_is_expandable_expr(gfc_expr * e)6483 gfc_is_expandable_expr (gfc_expr *e)
6484 {
6485 gfc_constructor *con;
6486
6487 if (e->expr_type == EXPR_ARRAY)
6488 {
6489 /* Traverse the constructor looking for variables that are flavor
6490 parameter. Parameters must be expanded since they are fully used at
6491 compile time. */
6492 con = gfc_constructor_first (e->value.constructor);
6493 for (; con; con = gfc_constructor_next (con))
6494 {
6495 if (con->expr->expr_type == EXPR_VARIABLE
6496 && con->expr->symtree
6497 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6498 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
6499 return true;
6500 if (con->expr->expr_type == EXPR_ARRAY
6501 && gfc_is_expandable_expr (con->expr))
6502 return true;
6503 }
6504 }
6505
6506 return false;
6507 }
6508
6509 /* Resolve an expression. That is, make sure that types of operands agree
6510 with their operators, intrinsic operators are converted to function calls
6511 for overloaded types and unresolved function references are resolved. */
6512
6513 gfc_try
gfc_resolve_expr(gfc_expr * e)6514 gfc_resolve_expr (gfc_expr *e)
6515 {
6516 gfc_try t;
6517 bool inquiry_save, actual_arg_save, first_actual_arg_save;
6518
6519 if (e == NULL)
6520 return SUCCESS;
6521
6522 /* inquiry_argument only applies to variables. */
6523 inquiry_save = inquiry_argument;
6524 actual_arg_save = actual_arg;
6525 first_actual_arg_save = first_actual_arg;
6526
6527 if (e->expr_type != EXPR_VARIABLE)
6528 {
6529 inquiry_argument = false;
6530 actual_arg = false;
6531 first_actual_arg = false;
6532 }
6533
6534 switch (e->expr_type)
6535 {
6536 case EXPR_OP:
6537 t = resolve_operator (e);
6538 break;
6539
6540 case EXPR_FUNCTION:
6541 case EXPR_VARIABLE:
6542
6543 if (check_host_association (e))
6544 t = resolve_function (e);
6545 else
6546 {
6547 t = resolve_variable (e);
6548 if (t == SUCCESS)
6549 expression_rank (e);
6550 }
6551
6552 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
6553 && e->ref->type != REF_SUBSTRING)
6554 gfc_resolve_substring_charlen (e);
6555
6556 break;
6557
6558 case EXPR_COMPCALL:
6559 t = resolve_typebound_function (e);
6560 break;
6561
6562 case EXPR_SUBSTRING:
6563 t = resolve_ref (e);
6564 break;
6565
6566 case EXPR_CONSTANT:
6567 case EXPR_NULL:
6568 t = SUCCESS;
6569 break;
6570
6571 case EXPR_PPC:
6572 t = resolve_expr_ppc (e);
6573 break;
6574
6575 case EXPR_ARRAY:
6576 t = FAILURE;
6577 if (resolve_ref (e) == FAILURE)
6578 break;
6579
6580 t = gfc_resolve_array_constructor (e);
6581 /* Also try to expand a constructor. */
6582 if (t == SUCCESS)
6583 {
6584 expression_rank (e);
6585 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
6586 gfc_expand_constructor (e, false);
6587 }
6588
6589 /* This provides the opportunity for the length of constructors with
6590 character valued function elements to propagate the string length
6591 to the expression. */
6592 if (t == SUCCESS && e->ts.type == BT_CHARACTER)
6593 {
6594 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6595 here rather then add a duplicate test for it above. */
6596 gfc_expand_constructor (e, false);
6597 t = gfc_resolve_character_array_constructor (e);
6598 }
6599
6600 break;
6601
6602 case EXPR_STRUCTURE:
6603 t = resolve_ref (e);
6604 if (t == FAILURE)
6605 break;
6606
6607 t = resolve_structure_cons (e, 0);
6608 if (t == FAILURE)
6609 break;
6610
6611 t = gfc_simplify_expr (e, 0);
6612 break;
6613
6614 default:
6615 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6616 }
6617
6618 if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
6619 fixup_charlen (e);
6620
6621 inquiry_argument = inquiry_save;
6622 actual_arg = actual_arg_save;
6623 first_actual_arg = first_actual_arg_save;
6624
6625 return t;
6626 }
6627
6628
6629 /* Resolve an expression from an iterator. They must be scalar and have
6630 INTEGER or (optionally) REAL type. */
6631
6632 static gfc_try
gfc_resolve_iterator_expr(gfc_expr * expr,bool real_ok,const char * name_msgid)6633 gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
6634 const char *name_msgid)
6635 {
6636 if (gfc_resolve_expr (expr) == FAILURE)
6637 return FAILURE;
6638
6639 if (expr->rank != 0)
6640 {
6641 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
6642 return FAILURE;
6643 }
6644
6645 if (expr->ts.type != BT_INTEGER)
6646 {
6647 if (expr->ts.type == BT_REAL)
6648 {
6649 if (real_ok)
6650 return gfc_notify_std (GFC_STD_F95_DEL,
6651 "%s at %L must be integer",
6652 _(name_msgid), &expr->where);
6653 else
6654 {
6655 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
6656 &expr->where);
6657 return FAILURE;
6658 }
6659 }
6660 else
6661 {
6662 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
6663 return FAILURE;
6664 }
6665 }
6666 return SUCCESS;
6667 }
6668
6669
6670 /* Resolve the expressions in an iterator structure. If REAL_OK is
6671 false allow only INTEGER type iterators, otherwise allow REAL types.
6672 Set own_scope to true for ac-implied-do and data-implied-do as those
6673 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6674
6675 gfc_try
gfc_resolve_iterator(gfc_iterator * iter,bool real_ok,bool own_scope)6676 gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
6677 {
6678 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
6679 == FAILURE)
6680 return FAILURE;
6681
6682 if (gfc_check_vardef_context (iter->var, false, false, own_scope,
6683 _("iterator variable"))
6684 == FAILURE)
6685 return FAILURE;
6686
6687 if (gfc_resolve_iterator_expr (iter->start, real_ok,
6688 "Start expression in DO loop") == FAILURE)
6689 return FAILURE;
6690
6691 if (gfc_resolve_iterator_expr (iter->end, real_ok,
6692 "End expression in DO loop") == FAILURE)
6693 return FAILURE;
6694
6695 if (gfc_resolve_iterator_expr (iter->step, real_ok,
6696 "Step expression in DO loop") == FAILURE)
6697 return FAILURE;
6698
6699 if (iter->step->expr_type == EXPR_CONSTANT)
6700 {
6701 if ((iter->step->ts.type == BT_INTEGER
6702 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
6703 || (iter->step->ts.type == BT_REAL
6704 && mpfr_sgn (iter->step->value.real) == 0))
6705 {
6706 gfc_error ("Step expression in DO loop at %L cannot be zero",
6707 &iter->step->where);
6708 return FAILURE;
6709 }
6710 }
6711
6712 /* Convert start, end, and step to the same type as var. */
6713 if (iter->start->ts.kind != iter->var->ts.kind
6714 || iter->start->ts.type != iter->var->ts.type)
6715 gfc_convert_type (iter->start, &iter->var->ts, 2);
6716
6717 if (iter->end->ts.kind != iter->var->ts.kind
6718 || iter->end->ts.type != iter->var->ts.type)
6719 gfc_convert_type (iter->end, &iter->var->ts, 2);
6720
6721 if (iter->step->ts.kind != iter->var->ts.kind
6722 || iter->step->ts.type != iter->var->ts.type)
6723 gfc_convert_type (iter->step, &iter->var->ts, 2);
6724
6725 if (iter->start->expr_type == EXPR_CONSTANT
6726 && iter->end->expr_type == EXPR_CONSTANT
6727 && iter->step->expr_type == EXPR_CONSTANT)
6728 {
6729 int sgn, cmp;
6730 if (iter->start->ts.type == BT_INTEGER)
6731 {
6732 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
6733 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
6734 }
6735 else
6736 {
6737 sgn = mpfr_sgn (iter->step->value.real);
6738 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
6739 }
6740 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
6741 gfc_warning ("DO loop at %L will be executed zero times",
6742 &iter->step->where);
6743 }
6744
6745 return SUCCESS;
6746 }
6747
6748
6749 /* Traversal function for find_forall_index. f == 2 signals that
6750 that variable itself is not to be checked - only the references. */
6751
6752 static bool
forall_index(gfc_expr * expr,gfc_symbol * sym,int * f)6753 forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
6754 {
6755 if (expr->expr_type != EXPR_VARIABLE)
6756 return false;
6757
6758 /* A scalar assignment */
6759 if (!expr->ref || *f == 1)
6760 {
6761 if (expr->symtree->n.sym == sym)
6762 return true;
6763 else
6764 return false;
6765 }
6766
6767 if (*f == 2)
6768 *f = 1;
6769 return false;
6770 }
6771
6772
6773 /* Check whether the FORALL index appears in the expression or not.
6774 Returns SUCCESS if SYM is found in EXPR. */
6775
6776 gfc_try
find_forall_index(gfc_expr * expr,gfc_symbol * sym,int f)6777 find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
6778 {
6779 if (gfc_traverse_expr (expr, sym, forall_index, f))
6780 return SUCCESS;
6781 else
6782 return FAILURE;
6783 }
6784
6785
6786 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6787 to be a scalar INTEGER variable. The subscripts and stride are scalar
6788 INTEGERs, and if stride is a constant it must be nonzero.
6789 Furthermore "A subscript or stride in a forall-triplet-spec shall
6790 not contain a reference to any index-name in the
6791 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6792
6793 static void
resolve_forall_iterators(gfc_forall_iterator * it)6794 resolve_forall_iterators (gfc_forall_iterator *it)
6795 {
6796 gfc_forall_iterator *iter, *iter2;
6797
6798 for (iter = it; iter; iter = iter->next)
6799 {
6800 if (gfc_resolve_expr (iter->var) == SUCCESS
6801 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
6802 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6803 &iter->var->where);
6804
6805 if (gfc_resolve_expr (iter->start) == SUCCESS
6806 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
6807 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6808 &iter->start->where);
6809 if (iter->var->ts.kind != iter->start->ts.kind)
6810 gfc_convert_type (iter->start, &iter->var->ts, 1);
6811
6812 if (gfc_resolve_expr (iter->end) == SUCCESS
6813 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
6814 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6815 &iter->end->where);
6816 if (iter->var->ts.kind != iter->end->ts.kind)
6817 gfc_convert_type (iter->end, &iter->var->ts, 1);
6818
6819 if (gfc_resolve_expr (iter->stride) == SUCCESS)
6820 {
6821 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
6822 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6823 &iter->stride->where, "INTEGER");
6824
6825 if (iter->stride->expr_type == EXPR_CONSTANT
6826 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
6827 gfc_error ("FORALL stride expression at %L cannot be zero",
6828 &iter->stride->where);
6829 }
6830 if (iter->var->ts.kind != iter->stride->ts.kind)
6831 gfc_convert_type (iter->stride, &iter->var->ts, 1);
6832 }
6833
6834 for (iter = it; iter; iter = iter->next)
6835 for (iter2 = iter; iter2; iter2 = iter2->next)
6836 {
6837 if (find_forall_index (iter2->start,
6838 iter->var->symtree->n.sym, 0) == SUCCESS
6839 || find_forall_index (iter2->end,
6840 iter->var->symtree->n.sym, 0) == SUCCESS
6841 || find_forall_index (iter2->stride,
6842 iter->var->symtree->n.sym, 0) == SUCCESS)
6843 gfc_error ("FORALL index '%s' may not appear in triplet "
6844 "specification at %L", iter->var->symtree->name,
6845 &iter2->start->where);
6846 }
6847 }
6848
6849
6850 /* Given a pointer to a symbol that is a derived type, see if it's
6851 inaccessible, i.e. if it's defined in another module and the components are
6852 PRIVATE. The search is recursive if necessary. Returns zero if no
6853 inaccessible components are found, nonzero otherwise. */
6854
6855 static int
derived_inaccessible(gfc_symbol * sym)6856 derived_inaccessible (gfc_symbol *sym)
6857 {
6858 gfc_component *c;
6859
6860 if (sym->attr.use_assoc && sym->attr.private_comp)
6861 return 1;
6862
6863 for (c = sym->components; c; c = c->next)
6864 {
6865 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
6866 return 1;
6867 }
6868
6869 return 0;
6870 }
6871
6872
6873 /* Resolve the argument of a deallocate expression. The expression must be
6874 a pointer or a full array. */
6875
6876 static gfc_try
resolve_deallocate_expr(gfc_expr * e)6877 resolve_deallocate_expr (gfc_expr *e)
6878 {
6879 symbol_attribute attr;
6880 int allocatable, pointer;
6881 gfc_ref *ref;
6882 gfc_symbol *sym;
6883 gfc_component *c;
6884 bool unlimited;
6885
6886 if (gfc_resolve_expr (e) == FAILURE)
6887 return FAILURE;
6888
6889 if (e->expr_type != EXPR_VARIABLE)
6890 goto bad;
6891
6892 sym = e->symtree->n.sym;
6893 unlimited = UNLIMITED_POLY(sym);
6894
6895 if (sym->ts.type == BT_CLASS)
6896 {
6897 allocatable = CLASS_DATA (sym)->attr.allocatable;
6898 pointer = CLASS_DATA (sym)->attr.class_pointer;
6899 }
6900 else
6901 {
6902 allocatable = sym->attr.allocatable;
6903 pointer = sym->attr.pointer;
6904 }
6905 for (ref = e->ref; ref; ref = ref->next)
6906 {
6907 switch (ref->type)
6908 {
6909 case REF_ARRAY:
6910 if (ref->u.ar.type != AR_FULL
6911 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
6912 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
6913 allocatable = 0;
6914 break;
6915
6916 case REF_COMPONENT:
6917 c = ref->u.c.component;
6918 if (c->ts.type == BT_CLASS)
6919 {
6920 allocatable = CLASS_DATA (c)->attr.allocatable;
6921 pointer = CLASS_DATA (c)->attr.class_pointer;
6922 }
6923 else
6924 {
6925 allocatable = c->attr.allocatable;
6926 pointer = c->attr.pointer;
6927 }
6928 break;
6929
6930 case REF_SUBSTRING:
6931 allocatable = 0;
6932 break;
6933 }
6934 }
6935
6936 attr = gfc_expr_attr (e);
6937
6938 if (allocatable == 0 && attr.pointer == 0 && !unlimited)
6939 {
6940 bad:
6941 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6942 &e->where);
6943 return FAILURE;
6944 }
6945
6946 /* F2008, C644. */
6947 if (gfc_is_coindexed (e))
6948 {
6949 gfc_error ("Coindexed allocatable object at %L", &e->where);
6950 return FAILURE;
6951 }
6952
6953 if (pointer
6954 && gfc_check_vardef_context (e, true, true, false, _("DEALLOCATE object"))
6955 == FAILURE)
6956 return FAILURE;
6957 if (gfc_check_vardef_context (e, false, true, false, _("DEALLOCATE object"))
6958 == FAILURE)
6959 return FAILURE;
6960
6961 return SUCCESS;
6962 }
6963
6964
6965 /* Returns true if the expression e contains a reference to the symbol sym. */
6966 static bool
sym_in_expr(gfc_expr * e,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)6967 sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
6968 {
6969 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
6970 return true;
6971
6972 return false;
6973 }
6974
6975 bool
gfc_find_sym_in_expr(gfc_symbol * sym,gfc_expr * e)6976 gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
6977 {
6978 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
6979 }
6980
6981
6982 /* Given the expression node e for an allocatable/pointer of derived type to be
6983 allocated, get the expression node to be initialized afterwards (needed for
6984 derived types with default initializers, and derived types with allocatable
6985 components that need nullification.) */
6986
6987 gfc_expr *
gfc_expr_to_initialize(gfc_expr * e)6988 gfc_expr_to_initialize (gfc_expr *e)
6989 {
6990 gfc_expr *result;
6991 gfc_ref *ref;
6992 int i;
6993
6994 result = gfc_copy_expr (e);
6995
6996 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6997 for (ref = result->ref; ref; ref = ref->next)
6998 if (ref->type == REF_ARRAY && ref->next == NULL)
6999 {
7000 ref->u.ar.type = AR_FULL;
7001
7002 for (i = 0; i < ref->u.ar.dimen; i++)
7003 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
7004
7005 break;
7006 }
7007
7008 gfc_free_shape (&result->shape, result->rank);
7009
7010 /* Recalculate rank, shape, etc. */
7011 gfc_resolve_expr (result);
7012 return result;
7013 }
7014
7015
7016 /* If the last ref of an expression is an array ref, return a copy of the
7017 expression with that one removed. Otherwise, a copy of the original
7018 expression. This is used for allocate-expressions and pointer assignment
7019 LHS, where there may be an array specification that needs to be stripped
7020 off when using gfc_check_vardef_context. */
7021
7022 static gfc_expr*
remove_last_array_ref(gfc_expr * e)7023 remove_last_array_ref (gfc_expr* e)
7024 {
7025 gfc_expr* e2;
7026 gfc_ref** r;
7027
7028 e2 = gfc_copy_expr (e);
7029 for (r = &e2->ref; *r; r = &(*r)->next)
7030 if ((*r)->type == REF_ARRAY && !(*r)->next)
7031 {
7032 gfc_free_ref_list (*r);
7033 *r = NULL;
7034 break;
7035 }
7036
7037 return e2;
7038 }
7039
7040
7041 /* Used in resolve_allocate_expr to check that a allocation-object and
7042 a source-expr are conformable. This does not catch all possible
7043 cases; in particular a runtime checking is needed. */
7044
7045 static gfc_try
conformable_arrays(gfc_expr * e1,gfc_expr * e2)7046 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
7047 {
7048 gfc_ref *tail;
7049 for (tail = e2->ref; tail && tail->next; tail = tail->next);
7050
7051 /* First compare rank. */
7052 if (tail && e1->rank != tail->u.ar.as->rank)
7053 {
7054 gfc_error ("Source-expr at %L must be scalar or have the "
7055 "same rank as the allocate-object at %L",
7056 &e1->where, &e2->where);
7057 return FAILURE;
7058 }
7059
7060 if (e1->shape)
7061 {
7062 int i;
7063 mpz_t s;
7064
7065 mpz_init (s);
7066
7067 for (i = 0; i < e1->rank; i++)
7068 {
7069 if (tail->u.ar.end[i])
7070 {
7071 mpz_set (s, tail->u.ar.end[i]->value.integer);
7072 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
7073 mpz_add_ui (s, s, 1);
7074 }
7075 else
7076 {
7077 mpz_set (s, tail->u.ar.start[i]->value.integer);
7078 }
7079
7080 if (mpz_cmp (e1->shape[i], s) != 0)
7081 {
7082 gfc_error ("Source-expr at %L and allocate-object at %L must "
7083 "have the same shape", &e1->where, &e2->where);
7084 mpz_clear (s);
7085 return FAILURE;
7086 }
7087 }
7088
7089 mpz_clear (s);
7090 }
7091
7092 return SUCCESS;
7093 }
7094
7095
7096 /* Resolve the expression in an ALLOCATE statement, doing the additional
7097 checks to see whether the expression is OK or not. The expression must
7098 have a trailing array reference that gives the size of the array. */
7099
7100 static gfc_try
resolve_allocate_expr(gfc_expr * e,gfc_code * code)7101 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
7102 {
7103 int i, pointer, allocatable, dimension, is_abstract;
7104 int codimension;
7105 bool coindexed;
7106 bool unlimited;
7107 symbol_attribute attr;
7108 gfc_ref *ref, *ref2;
7109 gfc_expr *e2;
7110 gfc_array_ref *ar;
7111 gfc_symbol *sym = NULL;
7112 gfc_alloc *a;
7113 gfc_component *c;
7114 gfc_try t;
7115
7116 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7117 checking of coarrays. */
7118 for (ref = e->ref; ref; ref = ref->next)
7119 if (ref->next == NULL)
7120 break;
7121
7122 if (ref && ref->type == REF_ARRAY)
7123 ref->u.ar.in_allocate = true;
7124
7125 if (gfc_resolve_expr (e) == FAILURE)
7126 goto failure;
7127
7128 /* Make sure the expression is allocatable or a pointer. If it is
7129 pointer, the next-to-last reference must be a pointer. */
7130
7131 ref2 = NULL;
7132 if (e->symtree)
7133 sym = e->symtree->n.sym;
7134
7135 /* Check whether ultimate component is abstract and CLASS. */
7136 is_abstract = 0;
7137
7138 /* Is the allocate-object unlimited polymorphic? */
7139 unlimited = UNLIMITED_POLY(e);
7140
7141 if (e->expr_type != EXPR_VARIABLE)
7142 {
7143 allocatable = 0;
7144 attr = gfc_expr_attr (e);
7145 pointer = attr.pointer;
7146 dimension = attr.dimension;
7147 codimension = attr.codimension;
7148 }
7149 else
7150 {
7151 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
7152 {
7153 allocatable = CLASS_DATA (sym)->attr.allocatable;
7154 pointer = CLASS_DATA (sym)->attr.class_pointer;
7155 dimension = CLASS_DATA (sym)->attr.dimension;
7156 codimension = CLASS_DATA (sym)->attr.codimension;
7157 is_abstract = CLASS_DATA (sym)->attr.abstract;
7158 }
7159 else
7160 {
7161 allocatable = sym->attr.allocatable;
7162 pointer = sym->attr.pointer;
7163 dimension = sym->attr.dimension;
7164 codimension = sym->attr.codimension;
7165 }
7166
7167 coindexed = false;
7168
7169 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
7170 {
7171 switch (ref->type)
7172 {
7173 case REF_ARRAY:
7174 if (ref->u.ar.codimen > 0)
7175 {
7176 int n;
7177 for (n = ref->u.ar.dimen;
7178 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
7179 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
7180 {
7181 coindexed = true;
7182 break;
7183 }
7184 }
7185
7186 if (ref->next != NULL)
7187 pointer = 0;
7188 break;
7189
7190 case REF_COMPONENT:
7191 /* F2008, C644. */
7192 if (coindexed)
7193 {
7194 gfc_error ("Coindexed allocatable object at %L",
7195 &e->where);
7196 goto failure;
7197 }
7198
7199 c = ref->u.c.component;
7200 if (c->ts.type == BT_CLASS)
7201 {
7202 allocatable = CLASS_DATA (c)->attr.allocatable;
7203 pointer = CLASS_DATA (c)->attr.class_pointer;
7204 dimension = CLASS_DATA (c)->attr.dimension;
7205 codimension = CLASS_DATA (c)->attr.codimension;
7206 is_abstract = CLASS_DATA (c)->attr.abstract;
7207 }
7208 else
7209 {
7210 allocatable = c->attr.allocatable;
7211 pointer = c->attr.pointer;
7212 dimension = c->attr.dimension;
7213 codimension = c->attr.codimension;
7214 is_abstract = c->attr.abstract;
7215 }
7216 break;
7217
7218 case REF_SUBSTRING:
7219 allocatable = 0;
7220 pointer = 0;
7221 break;
7222 }
7223 }
7224 }
7225
7226 /* Check for F08:C628. */
7227 if (allocatable == 0 && pointer == 0 && !unlimited)
7228 {
7229 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7230 &e->where);
7231 goto failure;
7232 }
7233
7234 /* Some checks for the SOURCE tag. */
7235 if (code->expr3)
7236 {
7237 /* Check F03:C631. */
7238 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
7239 {
7240 gfc_error ("Type of entity at %L is type incompatible with "
7241 "source-expr at %L", &e->where, &code->expr3->where);
7242 goto failure;
7243 }
7244
7245 /* Check F03:C632 and restriction following Note 6.18. */
7246 if (code->expr3->rank > 0 && !unlimited
7247 && conformable_arrays (code->expr3, e) == FAILURE)
7248 goto failure;
7249
7250 /* Check F03:C633. */
7251 if (code->expr3->ts.kind != e->ts.kind && !unlimited)
7252 {
7253 gfc_error ("The allocate-object at %L and the source-expr at %L "
7254 "shall have the same kind type parameter",
7255 &e->where, &code->expr3->where);
7256 goto failure;
7257 }
7258
7259 /* Check F2008, C642. */
7260 if (code->expr3->ts.type == BT_DERIVED
7261 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
7262 || (code->expr3->ts.u.derived->from_intmod
7263 == INTMOD_ISO_FORTRAN_ENV
7264 && code->expr3->ts.u.derived->intmod_sym_id
7265 == ISOFORTRAN_LOCK_TYPE)))
7266 {
7267 gfc_error ("The source-expr at %L shall neither be of type "
7268 "LOCK_TYPE nor have a LOCK_TYPE component if "
7269 "allocate-object at %L is a coarray",
7270 &code->expr3->where, &e->where);
7271 goto failure;
7272 }
7273 }
7274
7275 /* Check F08:C629. */
7276 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7277 && !code->expr3)
7278 {
7279 gcc_assert (e->ts.type == BT_CLASS);
7280 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7281 "type-spec or source-expr", sym->name, &e->where);
7282 goto failure;
7283 }
7284
7285 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
7286 {
7287 int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7288 code->ext.alloc.ts.u.cl->length);
7289 if (cmp == 1 || cmp == -1 || cmp == -3)
7290 {
7291 gfc_error ("Allocating %s at %L with type-spec requires the same "
7292 "character-length parameter as in the declaration",
7293 sym->name, &e->where);
7294 goto failure;
7295 }
7296 }
7297
7298 /* In the variable definition context checks, gfc_expr_attr is used
7299 on the expression. This is fooled by the array specification
7300 present in e, thus we have to eliminate that one temporarily. */
7301 e2 = remove_last_array_ref (e);
7302 t = SUCCESS;
7303 if (t == SUCCESS && pointer)
7304 t = gfc_check_vardef_context (e2, true, true, false, _("ALLOCATE object"));
7305 if (t == SUCCESS)
7306 t = gfc_check_vardef_context (e2, false, true, false, _("ALLOCATE object"));
7307 gfc_free_expr (e2);
7308 if (t == FAILURE)
7309 goto failure;
7310
7311 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
7312 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
7313 {
7314 /* For class arrays, the initialization with SOURCE is done
7315 using _copy and trans_call. It is convenient to exploit that
7316 when the allocated type is different from the declared type but
7317 no SOURCE exists by setting expr3. */
7318 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
7319 }
7320 else if (!code->expr3)
7321 {
7322 /* Set up default initializer if needed. */
7323 gfc_typespec ts;
7324 gfc_expr *init_e;
7325
7326 if (code->ext.alloc.ts.type == BT_DERIVED)
7327 ts = code->ext.alloc.ts;
7328 else
7329 ts = e->ts;
7330
7331 if (ts.type == BT_CLASS)
7332 ts = ts.u.derived->components->ts;
7333
7334 if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
7335 {
7336 gfc_code *init_st = gfc_get_code ();
7337 init_st->loc = code->loc;
7338 init_st->op = EXEC_INIT_ASSIGN;
7339 init_st->expr1 = gfc_expr_to_initialize (e);
7340 init_st->expr2 = init_e;
7341 init_st->next = code->next;
7342 code->next = init_st;
7343 }
7344 }
7345 else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
7346 {
7347 /* Default initialization via MOLD (non-polymorphic). */
7348 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
7349 gfc_resolve_expr (rhs);
7350 gfc_free_expr (code->expr3);
7351 code->expr3 = rhs;
7352 }
7353
7354 if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
7355 {
7356 /* Make sure the vtab symbol is present when
7357 the module variables are generated. */
7358 gfc_typespec ts = e->ts;
7359 if (code->expr3)
7360 ts = code->expr3->ts;
7361 else if (code->ext.alloc.ts.type == BT_DERIVED)
7362 ts = code->ext.alloc.ts;
7363
7364 gfc_find_derived_vtab (ts.u.derived);
7365
7366 if (dimension)
7367 e = gfc_expr_to_initialize (e);
7368 }
7369 else if (unlimited && !UNLIMITED_POLY (code->expr3))
7370 {
7371 /* Again, make sure the vtab symbol is present when
7372 the module variables are generated. */
7373 gfc_typespec *ts = NULL;
7374 if (code->expr3)
7375 ts = &code->expr3->ts;
7376 else
7377 ts = &code->ext.alloc.ts;
7378
7379 gcc_assert (ts);
7380
7381 if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
7382 gfc_find_derived_vtab (ts->u.derived);
7383 else
7384 gfc_find_intrinsic_vtab (ts);
7385
7386 if (dimension)
7387 e = gfc_expr_to_initialize (e);
7388 }
7389
7390 if (dimension == 0 && codimension == 0)
7391 goto success;
7392
7393 /* Make sure the last reference node is an array specification. */
7394
7395 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
7396 || (dimension && ref2->u.ar.dimen == 0))
7397 {
7398 gfc_error ("Array specification required in ALLOCATE statement "
7399 "at %L", &e->where);
7400 goto failure;
7401 }
7402
7403 /* Make sure that the array section reference makes sense in the
7404 context of an ALLOCATE specification. */
7405
7406 ar = &ref2->u.ar;
7407
7408 if (codimension)
7409 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
7410 if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
7411 {
7412 gfc_error ("Coarray specification required in ALLOCATE statement "
7413 "at %L", &e->where);
7414 goto failure;
7415 }
7416
7417 for (i = 0; i < ar->dimen; i++)
7418 {
7419 if (ref2->u.ar.type == AR_ELEMENT)
7420 goto check_symbols;
7421
7422 switch (ar->dimen_type[i])
7423 {
7424 case DIMEN_ELEMENT:
7425 break;
7426
7427 case DIMEN_RANGE:
7428 if (ar->start[i] != NULL
7429 && ar->end[i] != NULL
7430 && ar->stride[i] == NULL)
7431 break;
7432
7433 /* Fall Through... */
7434
7435 case DIMEN_UNKNOWN:
7436 case DIMEN_VECTOR:
7437 case DIMEN_STAR:
7438 case DIMEN_THIS_IMAGE:
7439 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7440 &e->where);
7441 goto failure;
7442 }
7443
7444 check_symbols:
7445 for (a = code->ext.alloc.list; a; a = a->next)
7446 {
7447 sym = a->expr->symtree->n.sym;
7448
7449 /* TODO - check derived type components. */
7450 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
7451 continue;
7452
7453 if ((ar->start[i] != NULL
7454 && gfc_find_sym_in_expr (sym, ar->start[i]))
7455 || (ar->end[i] != NULL
7456 && gfc_find_sym_in_expr (sym, ar->end[i])))
7457 {
7458 gfc_error ("'%s' must not appear in the array specification at "
7459 "%L in the same ALLOCATE statement where it is "
7460 "itself allocated", sym->name, &ar->where);
7461 goto failure;
7462 }
7463 }
7464 }
7465
7466 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
7467 {
7468 if (ar->dimen_type[i] == DIMEN_ELEMENT
7469 || ar->dimen_type[i] == DIMEN_RANGE)
7470 {
7471 if (i == (ar->dimen + ar->codimen - 1))
7472 {
7473 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7474 "statement at %L", &e->where);
7475 goto failure;
7476 }
7477 continue;
7478 }
7479
7480 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
7481 && ar->stride[i] == NULL)
7482 break;
7483
7484 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7485 &e->where);
7486 goto failure;
7487 }
7488
7489 success:
7490 return SUCCESS;
7491
7492 failure:
7493 return FAILURE;
7494 }
7495
7496 static void
resolve_allocate_deallocate(gfc_code * code,const char * fcn)7497 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
7498 {
7499 gfc_expr *stat, *errmsg, *pe, *qe;
7500 gfc_alloc *a, *p, *q;
7501
7502 stat = code->expr1;
7503 errmsg = code->expr2;
7504
7505 /* Check the stat variable. */
7506 if (stat)
7507 {
7508 gfc_check_vardef_context (stat, false, false, false, _("STAT variable"));
7509
7510 if ((stat->ts.type != BT_INTEGER
7511 && !(stat->ref && (stat->ref->type == REF_ARRAY
7512 || stat->ref->type == REF_COMPONENT)))
7513 || stat->rank > 0)
7514 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7515 "variable", &stat->where);
7516
7517 for (p = code->ext.alloc.list; p; p = p->next)
7518 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
7519 {
7520 gfc_ref *ref1, *ref2;
7521 bool found = true;
7522
7523 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
7524 ref1 = ref1->next, ref2 = ref2->next)
7525 {
7526 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7527 continue;
7528 if (ref1->u.c.component->name != ref2->u.c.component->name)
7529 {
7530 found = false;
7531 break;
7532 }
7533 }
7534
7535 if (found)
7536 {
7537 gfc_error ("Stat-variable at %L shall not be %sd within "
7538 "the same %s statement", &stat->where, fcn, fcn);
7539 break;
7540 }
7541 }
7542 }
7543
7544 /* Check the errmsg variable. */
7545 if (errmsg)
7546 {
7547 if (!stat)
7548 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7549 &errmsg->where);
7550
7551 gfc_check_vardef_context (errmsg, false, false, false,
7552 _("ERRMSG variable"));
7553
7554 if ((errmsg->ts.type != BT_CHARACTER
7555 && !(errmsg->ref
7556 && (errmsg->ref->type == REF_ARRAY
7557 || errmsg->ref->type == REF_COMPONENT)))
7558 || errmsg->rank > 0 )
7559 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7560 "variable", &errmsg->where);
7561
7562 for (p = code->ext.alloc.list; p; p = p->next)
7563 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
7564 {
7565 gfc_ref *ref1, *ref2;
7566 bool found = true;
7567
7568 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
7569 ref1 = ref1->next, ref2 = ref2->next)
7570 {
7571 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
7572 continue;
7573 if (ref1->u.c.component->name != ref2->u.c.component->name)
7574 {
7575 found = false;
7576 break;
7577 }
7578 }
7579
7580 if (found)
7581 {
7582 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7583 "the same %s statement", &errmsg->where, fcn, fcn);
7584 break;
7585 }
7586 }
7587 }
7588
7589 /* Check that an allocate-object appears only once in the statement. */
7590
7591 for (p = code->ext.alloc.list; p; p = p->next)
7592 {
7593 pe = p->expr;
7594 for (q = p->next; q; q = q->next)
7595 {
7596 qe = q->expr;
7597 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
7598 {
7599 /* This is a potential collision. */
7600 gfc_ref *pr = pe->ref;
7601 gfc_ref *qr = qe->ref;
7602
7603 /* Follow the references until
7604 a) They start to differ, in which case there is no error;
7605 you can deallocate a%b and a%c in a single statement
7606 b) Both of them stop, which is an error
7607 c) One of them stops, which is also an error. */
7608 while (1)
7609 {
7610 if (pr == NULL && qr == NULL)
7611 {
7612 gfc_error ("Allocate-object at %L also appears at %L",
7613 &pe->where, &qe->where);
7614 break;
7615 }
7616 else if (pr != NULL && qr == NULL)
7617 {
7618 gfc_error ("Allocate-object at %L is subobject of"
7619 " object at %L", &pe->where, &qe->where);
7620 break;
7621 }
7622 else if (pr == NULL && qr != NULL)
7623 {
7624 gfc_error ("Allocate-object at %L is subobject of"
7625 " object at %L", &qe->where, &pe->where);
7626 break;
7627 }
7628 /* Here, pr != NULL && qr != NULL */
7629 gcc_assert(pr->type == qr->type);
7630 if (pr->type == REF_ARRAY)
7631 {
7632 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7633 which are legal. */
7634 gcc_assert (qr->type == REF_ARRAY);
7635
7636 if (pr->next && qr->next)
7637 {
7638 int i;
7639 gfc_array_ref *par = &(pr->u.ar);
7640 gfc_array_ref *qar = &(qr->u.ar);
7641
7642 for (i=0; i<par->dimen; i++)
7643 {
7644 if ((par->start[i] != NULL
7645 || qar->start[i] != NULL)
7646 && gfc_dep_compare_expr (par->start[i],
7647 qar->start[i]) != 0)
7648 goto break_label;
7649 }
7650 }
7651 }
7652 else
7653 {
7654 if (pr->u.c.component->name != qr->u.c.component->name)
7655 break;
7656 }
7657
7658 pr = pr->next;
7659 qr = qr->next;
7660 }
7661 break_label:
7662 ;
7663 }
7664 }
7665 }
7666
7667 if (strcmp (fcn, "ALLOCATE") == 0)
7668 {
7669 for (a = code->ext.alloc.list; a; a = a->next)
7670 resolve_allocate_expr (a->expr, code);
7671 }
7672 else
7673 {
7674 for (a = code->ext.alloc.list; a; a = a->next)
7675 resolve_deallocate_expr (a->expr);
7676 }
7677 }
7678
7679
7680 /************ SELECT CASE resolution subroutines ************/
7681
7682 /* Callback function for our mergesort variant. Determines interval
7683 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7684 op1 > op2. Assumes we're not dealing with the default case.
7685 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7686 There are nine situations to check. */
7687
7688 static int
compare_cases(const gfc_case * op1,const gfc_case * op2)7689 compare_cases (const gfc_case *op1, const gfc_case *op2)
7690 {
7691 int retval;
7692
7693 if (op1->low == NULL) /* op1 = (:L) */
7694 {
7695 /* op2 = (:N), so overlap. */
7696 retval = 0;
7697 /* op2 = (M:) or (M:N), L < M */
7698 if (op2->low != NULL
7699 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7700 retval = -1;
7701 }
7702 else if (op1->high == NULL) /* op1 = (K:) */
7703 {
7704 /* op2 = (M:), so overlap. */
7705 retval = 0;
7706 /* op2 = (:N) or (M:N), K > N */
7707 if (op2->high != NULL
7708 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7709 retval = 1;
7710 }
7711 else /* op1 = (K:L) */
7712 {
7713 if (op2->low == NULL) /* op2 = (:N), K > N */
7714 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7715 ? 1 : 0;
7716 else if (op2->high == NULL) /* op2 = (M:), L < M */
7717 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7718 ? -1 : 0;
7719 else /* op2 = (M:N) */
7720 {
7721 retval = 0;
7722 /* L < M */
7723 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
7724 retval = -1;
7725 /* K > N */
7726 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
7727 retval = 1;
7728 }
7729 }
7730
7731 return retval;
7732 }
7733
7734
7735 /* Merge-sort a double linked case list, detecting overlap in the
7736 process. LIST is the head of the double linked case list before it
7737 is sorted. Returns the head of the sorted list if we don't see any
7738 overlap, or NULL otherwise. */
7739
7740 static gfc_case *
check_case_overlap(gfc_case * list)7741 check_case_overlap (gfc_case *list)
7742 {
7743 gfc_case *p, *q, *e, *tail;
7744 int insize, nmerges, psize, qsize, cmp, overlap_seen;
7745
7746 /* If the passed list was empty, return immediately. */
7747 if (!list)
7748 return NULL;
7749
7750 overlap_seen = 0;
7751 insize = 1;
7752
7753 /* Loop unconditionally. The only exit from this loop is a return
7754 statement, when we've finished sorting the case list. */
7755 for (;;)
7756 {
7757 p = list;
7758 list = NULL;
7759 tail = NULL;
7760
7761 /* Count the number of merges we do in this pass. */
7762 nmerges = 0;
7763
7764 /* Loop while there exists a merge to be done. */
7765 while (p)
7766 {
7767 int i;
7768
7769 /* Count this merge. */
7770 nmerges++;
7771
7772 /* Cut the list in two pieces by stepping INSIZE places
7773 forward in the list, starting from P. */
7774 psize = 0;
7775 q = p;
7776 for (i = 0; i < insize; i++)
7777 {
7778 psize++;
7779 q = q->right;
7780 if (!q)
7781 break;
7782 }
7783 qsize = insize;
7784
7785 /* Now we have two lists. Merge them! */
7786 while (psize > 0 || (qsize > 0 && q != NULL))
7787 {
7788 /* See from which the next case to merge comes from. */
7789 if (psize == 0)
7790 {
7791 /* P is empty so the next case must come from Q. */
7792 e = q;
7793 q = q->right;
7794 qsize--;
7795 }
7796 else if (qsize == 0 || q == NULL)
7797 {
7798 /* Q is empty. */
7799 e = p;
7800 p = p->right;
7801 psize--;
7802 }
7803 else
7804 {
7805 cmp = compare_cases (p, q);
7806 if (cmp < 0)
7807 {
7808 /* The whole case range for P is less than the
7809 one for Q. */
7810 e = p;
7811 p = p->right;
7812 psize--;
7813 }
7814 else if (cmp > 0)
7815 {
7816 /* The whole case range for Q is greater than
7817 the case range for P. */
7818 e = q;
7819 q = q->right;
7820 qsize--;
7821 }
7822 else
7823 {
7824 /* The cases overlap, or they are the same
7825 element in the list. Either way, we must
7826 issue an error and get the next case from P. */
7827 /* FIXME: Sort P and Q by line number. */
7828 gfc_error ("CASE label at %L overlaps with CASE "
7829 "label at %L", &p->where, &q->where);
7830 overlap_seen = 1;
7831 e = p;
7832 p = p->right;
7833 psize--;
7834 }
7835 }
7836
7837 /* Add the next element to the merged list. */
7838 if (tail)
7839 tail->right = e;
7840 else
7841 list = e;
7842 e->left = tail;
7843 tail = e;
7844 }
7845
7846 /* P has now stepped INSIZE places along, and so has Q. So
7847 they're the same. */
7848 p = q;
7849 }
7850 tail->right = NULL;
7851
7852 /* If we have done only one merge or none at all, we've
7853 finished sorting the cases. */
7854 if (nmerges <= 1)
7855 {
7856 if (!overlap_seen)
7857 return list;
7858 else
7859 return NULL;
7860 }
7861
7862 /* Otherwise repeat, merging lists twice the size. */
7863 insize *= 2;
7864 }
7865 }
7866
7867
7868 /* Check to see if an expression is suitable for use in a CASE statement.
7869 Makes sure that all case expressions are scalar constants of the same
7870 type. Return FAILURE if anything is wrong. */
7871
7872 static gfc_try
validate_case_label_expr(gfc_expr * e,gfc_expr * case_expr)7873 validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
7874 {
7875 if (e == NULL) return SUCCESS;
7876
7877 if (e->ts.type != case_expr->ts.type)
7878 {
7879 gfc_error ("Expression in CASE statement at %L must be of type %s",
7880 &e->where, gfc_basic_typename (case_expr->ts.type));
7881 return FAILURE;
7882 }
7883
7884 /* C805 (R808) For a given case-construct, each case-value shall be of
7885 the same type as case-expr. For character type, length differences
7886 are allowed, but the kind type parameters shall be the same. */
7887
7888 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
7889 {
7890 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7891 &e->where, case_expr->ts.kind);
7892 return FAILURE;
7893 }
7894
7895 /* Convert the case value kind to that of case expression kind,
7896 if needed */
7897
7898 if (e->ts.kind != case_expr->ts.kind)
7899 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
7900
7901 if (e->rank != 0)
7902 {
7903 gfc_error ("Expression in CASE statement at %L must be scalar",
7904 &e->where);
7905 return FAILURE;
7906 }
7907
7908 return SUCCESS;
7909 }
7910
7911
7912 /* Given a completely parsed select statement, we:
7913
7914 - Validate all expressions and code within the SELECT.
7915 - Make sure that the selection expression is not of the wrong type.
7916 - Make sure that no case ranges overlap.
7917 - Eliminate unreachable cases and unreachable code resulting from
7918 removing case labels.
7919
7920 The standard does allow unreachable cases, e.g. CASE (5:3). But
7921 they are a hassle for code generation, and to prevent that, we just
7922 cut them out here. This is not necessary for overlapping cases
7923 because they are illegal and we never even try to generate code.
7924
7925 We have the additional caveat that a SELECT construct could have
7926 been a computed GOTO in the source code. Fortunately we can fairly
7927 easily work around that here: The case_expr for a "real" SELECT CASE
7928 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7929 we have to do is make sure that the case_expr is a scalar integer
7930 expression. */
7931
7932 static void
resolve_select(gfc_code * code,bool select_type)7933 resolve_select (gfc_code *code, bool select_type)
7934 {
7935 gfc_code *body;
7936 gfc_expr *case_expr;
7937 gfc_case *cp, *default_case, *tail, *head;
7938 int seen_unreachable;
7939 int seen_logical;
7940 int ncases;
7941 bt type;
7942 gfc_try t;
7943
7944 if (code->expr1 == NULL)
7945 {
7946 /* This was actually a computed GOTO statement. */
7947 case_expr = code->expr2;
7948 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
7949 gfc_error ("Selection expression in computed GOTO statement "
7950 "at %L must be a scalar integer expression",
7951 &case_expr->where);
7952
7953 /* Further checking is not necessary because this SELECT was built
7954 by the compiler, so it should always be OK. Just move the
7955 case_expr from expr2 to expr so that we can handle computed
7956 GOTOs as normal SELECTs from here on. */
7957 code->expr1 = code->expr2;
7958 code->expr2 = NULL;
7959 return;
7960 }
7961
7962 case_expr = code->expr1;
7963 type = case_expr->ts.type;
7964
7965 /* F08:C830. */
7966 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
7967 {
7968 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7969 &case_expr->where, gfc_typename (&case_expr->ts));
7970
7971 /* Punt. Going on here just produce more garbage error messages. */
7972 return;
7973 }
7974
7975 /* F08:R842. */
7976 if (!select_type && case_expr->rank != 0)
7977 {
7978 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7979 "expression", &case_expr->where);
7980
7981 /* Punt. */
7982 return;
7983 }
7984
7985 /* Raise a warning if an INTEGER case value exceeds the range of
7986 the case-expr. Later, all expressions will be promoted to the
7987 largest kind of all case-labels. */
7988
7989 if (type == BT_INTEGER)
7990 for (body = code->block; body; body = body->block)
7991 for (cp = body->ext.block.case_list; cp; cp = cp->next)
7992 {
7993 if (cp->low
7994 && gfc_check_integer_range (cp->low->value.integer,
7995 case_expr->ts.kind) != ARITH_OK)
7996 gfc_warning ("Expression in CASE statement at %L is "
7997 "not in the range of %s", &cp->low->where,
7998 gfc_typename (&case_expr->ts));
7999
8000 if (cp->high
8001 && cp->low != cp->high
8002 && gfc_check_integer_range (cp->high->value.integer,
8003 case_expr->ts.kind) != ARITH_OK)
8004 gfc_warning ("Expression in CASE statement at %L is "
8005 "not in the range of %s", &cp->high->where,
8006 gfc_typename (&case_expr->ts));
8007 }
8008
8009 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8010 of the SELECT CASE expression and its CASE values. Walk the lists
8011 of case values, and if we find a mismatch, promote case_expr to
8012 the appropriate kind. */
8013
8014 if (type == BT_LOGICAL || type == BT_INTEGER)
8015 {
8016 for (body = code->block; body; body = body->block)
8017 {
8018 /* Walk the case label list. */
8019 for (cp = body->ext.block.case_list; cp; cp = cp->next)
8020 {
8021 /* Intercept the DEFAULT case. It does not have a kind. */
8022 if (cp->low == NULL && cp->high == NULL)
8023 continue;
8024
8025 /* Unreachable case ranges are discarded, so ignore. */
8026 if (cp->low != NULL && cp->high != NULL
8027 && cp->low != cp->high
8028 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8029 continue;
8030
8031 if (cp->low != NULL
8032 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
8033 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
8034
8035 if (cp->high != NULL
8036 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
8037 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
8038 }
8039 }
8040 }
8041
8042 /* Assume there is no DEFAULT case. */
8043 default_case = NULL;
8044 head = tail = NULL;
8045 ncases = 0;
8046 seen_logical = 0;
8047
8048 for (body = code->block; body; body = body->block)
8049 {
8050 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8051 t = SUCCESS;
8052 seen_unreachable = 0;
8053
8054 /* Walk the case label list, making sure that all case labels
8055 are legal. */
8056 for (cp = body->ext.block.case_list; cp; cp = cp->next)
8057 {
8058 /* Count the number of cases in the whole construct. */
8059 ncases++;
8060
8061 /* Intercept the DEFAULT case. */
8062 if (cp->low == NULL && cp->high == NULL)
8063 {
8064 if (default_case != NULL)
8065 {
8066 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8067 "by a second DEFAULT CASE at %L",
8068 &default_case->where, &cp->where);
8069 t = FAILURE;
8070 break;
8071 }
8072 else
8073 {
8074 default_case = cp;
8075 continue;
8076 }
8077 }
8078
8079 /* Deal with single value cases and case ranges. Errors are
8080 issued from the validation function. */
8081 if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
8082 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
8083 {
8084 t = FAILURE;
8085 break;
8086 }
8087
8088 if (type == BT_LOGICAL
8089 && ((cp->low == NULL || cp->high == NULL)
8090 || cp->low != cp->high))
8091 {
8092 gfc_error ("Logical range in CASE statement at %L is not "
8093 "allowed", &cp->low->where);
8094 t = FAILURE;
8095 break;
8096 }
8097
8098 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
8099 {
8100 int value;
8101 value = cp->low->value.logical == 0 ? 2 : 1;
8102 if (value & seen_logical)
8103 {
8104 gfc_error ("Constant logical value in CASE statement "
8105 "is repeated at %L",
8106 &cp->low->where);
8107 t = FAILURE;
8108 break;
8109 }
8110 seen_logical |= value;
8111 }
8112
8113 if (cp->low != NULL && cp->high != NULL
8114 && cp->low != cp->high
8115 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
8116 {
8117 if (gfc_option.warn_surprising)
8118 gfc_warning ("Range specification at %L can never "
8119 "be matched", &cp->where);
8120
8121 cp->unreachable = 1;
8122 seen_unreachable = 1;
8123 }
8124 else
8125 {
8126 /* If the case range can be matched, it can also overlap with
8127 other cases. To make sure it does not, we put it in a
8128 double linked list here. We sort that with a merge sort
8129 later on to detect any overlapping cases. */
8130 if (!head)
8131 {
8132 head = tail = cp;
8133 head->right = head->left = NULL;
8134 }
8135 else
8136 {
8137 tail->right = cp;
8138 tail->right->left = tail;
8139 tail = tail->right;
8140 tail->right = NULL;
8141 }
8142 }
8143 }
8144
8145 /* It there was a failure in the previous case label, give up
8146 for this case label list. Continue with the next block. */
8147 if (t == FAILURE)
8148 continue;
8149
8150 /* See if any case labels that are unreachable have been seen.
8151 If so, we eliminate them. This is a bit of a kludge because
8152 the case lists for a single case statement (label) is a
8153 single forward linked lists. */
8154 if (seen_unreachable)
8155 {
8156 /* Advance until the first case in the list is reachable. */
8157 while (body->ext.block.case_list != NULL
8158 && body->ext.block.case_list->unreachable)
8159 {
8160 gfc_case *n = body->ext.block.case_list;
8161 body->ext.block.case_list = body->ext.block.case_list->next;
8162 n->next = NULL;
8163 gfc_free_case_list (n);
8164 }
8165
8166 /* Strip all other unreachable cases. */
8167 if (body->ext.block.case_list)
8168 {
8169 for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
8170 {
8171 if (cp->next->unreachable)
8172 {
8173 gfc_case *n = cp->next;
8174 cp->next = cp->next->next;
8175 n->next = NULL;
8176 gfc_free_case_list (n);
8177 }
8178 }
8179 }
8180 }
8181 }
8182
8183 /* See if there were overlapping cases. If the check returns NULL,
8184 there was overlap. In that case we don't do anything. If head
8185 is non-NULL, we prepend the DEFAULT case. The sorted list can
8186 then used during code generation for SELECT CASE constructs with
8187 a case expression of a CHARACTER type. */
8188 if (head)
8189 {
8190 head = check_case_overlap (head);
8191
8192 /* Prepend the default_case if it is there. */
8193 if (head != NULL && default_case)
8194 {
8195 default_case->left = NULL;
8196 default_case->right = head;
8197 head->left = default_case;
8198 }
8199 }
8200
8201 /* Eliminate dead blocks that may be the result if we've seen
8202 unreachable case labels for a block. */
8203 for (body = code; body && body->block; body = body->block)
8204 {
8205 if (body->block->ext.block.case_list == NULL)
8206 {
8207 /* Cut the unreachable block from the code chain. */
8208 gfc_code *c = body->block;
8209 body->block = c->block;
8210
8211 /* Kill the dead block, but not the blocks below it. */
8212 c->block = NULL;
8213 gfc_free_statements (c);
8214 }
8215 }
8216
8217 /* More than two cases is legal but insane for logical selects.
8218 Issue a warning for it. */
8219 if (gfc_option.warn_surprising && type == BT_LOGICAL
8220 && ncases > 2)
8221 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
8222 &code->loc);
8223 }
8224
8225
8226 /* Check if a derived type is extensible. */
8227
8228 bool
gfc_type_is_extensible(gfc_symbol * sym)8229 gfc_type_is_extensible (gfc_symbol *sym)
8230 {
8231 return !(sym->attr.is_bind_c || sym->attr.sequence
8232 || (sym->attr.is_class
8233 && sym->components->ts.u.derived->attr.unlimited_polymorphic));
8234 }
8235
8236
8237 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8238 correct as well as possibly the array-spec. */
8239
8240 static void
resolve_assoc_var(gfc_symbol * sym,bool resolve_target)8241 resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
8242 {
8243 gfc_expr* target;
8244
8245 gcc_assert (sym->assoc);
8246 gcc_assert (sym->attr.flavor == FL_VARIABLE);
8247
8248 /* If this is for SELECT TYPE, the target may not yet be set. In that
8249 case, return. Resolution will be called later manually again when
8250 this is done. */
8251 target = sym->assoc->target;
8252 if (!target)
8253 return;
8254 gcc_assert (!sym->assoc->dangling);
8255
8256 if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
8257 return;
8258
8259 /* For variable targets, we get some attributes from the target. */
8260 if (target->expr_type == EXPR_VARIABLE)
8261 {
8262 gfc_symbol* tsym;
8263
8264 gcc_assert (target->symtree);
8265 tsym = target->symtree->n.sym;
8266
8267 sym->attr.asynchronous = tsym->attr.asynchronous;
8268 sym->attr.volatile_ = tsym->attr.volatile_;
8269
8270 sym->attr.target = tsym->attr.target
8271 || gfc_expr_attr (target).pointer;
8272 }
8273
8274 /* Get type if this was not already set. Note that it can be
8275 some other type than the target in case this is a SELECT TYPE
8276 selector! So we must not update when the type is already there. */
8277 if (sym->ts.type == BT_UNKNOWN)
8278 sym->ts = target->ts;
8279 gcc_assert (sym->ts.type != BT_UNKNOWN);
8280
8281 /* See if this is a valid association-to-variable. */
8282 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
8283 && !gfc_has_vector_subscript (target));
8284
8285 /* Finally resolve if this is an array or not. */
8286 if (sym->attr.dimension && target->rank == 0)
8287 {
8288 gfc_error ("Associate-name '%s' at %L is used as array",
8289 sym->name, &sym->declared_at);
8290 sym->attr.dimension = 0;
8291 return;
8292 }
8293
8294 /* We cannot deal with class selectors that need temporaries. */
8295 if (target->ts.type == BT_CLASS
8296 && gfc_ref_needs_temporary_p (target->ref))
8297 {
8298 gfc_error ("CLASS selector at %L needs a temporary which is not "
8299 "yet implemented", &target->where);
8300 return;
8301 }
8302
8303 if (target->ts.type != BT_CLASS && target->rank > 0)
8304 sym->attr.dimension = 1;
8305 else if (target->ts.type == BT_CLASS)
8306 gfc_fix_class_refs (target);
8307
8308 /* The associate-name will have a correct type by now. Make absolutely
8309 sure that it has not picked up a dimension attribute. */
8310 if (sym->ts.type == BT_CLASS)
8311 sym->attr.dimension = 0;
8312
8313 if (sym->attr.dimension)
8314 {
8315 sym->as = gfc_get_array_spec ();
8316 sym->as->rank = target->rank;
8317 sym->as->type = AS_DEFERRED;
8318
8319 /* Target must not be coindexed, thus the associate-variable
8320 has no corank. */
8321 sym->as->corank = 0;
8322 }
8323
8324 /* Mark this as an associate variable. */
8325 sym->attr.associate_var = 1;
8326
8327 /* If the target is a good class object, so is the associate variable. */
8328 if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
8329 sym->attr.class_ok = 1;
8330 }
8331
8332
8333 /* Resolve a SELECT TYPE statement. */
8334
8335 static void
resolve_select_type(gfc_code * code,gfc_namespace * old_ns)8336 resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
8337 {
8338 gfc_symbol *selector_type;
8339 gfc_code *body, *new_st, *if_st, *tail;
8340 gfc_code *class_is = NULL, *default_case = NULL;
8341 gfc_case *c;
8342 gfc_symtree *st;
8343 char name[GFC_MAX_SYMBOL_LEN];
8344 gfc_namespace *ns;
8345 int error = 0;
8346 int charlen = 0;
8347
8348 ns = code->ext.block.ns;
8349 gfc_resolve (ns);
8350
8351 /* Check for F03:C813. */
8352 if (code->expr1->ts.type != BT_CLASS
8353 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
8354 {
8355 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8356 "at %L", &code->loc);
8357 return;
8358 }
8359
8360 if (!code->expr1->symtree->n.sym->attr.class_ok)
8361 return;
8362
8363 if (code->expr2)
8364 {
8365 if (code->expr1->symtree->n.sym->attr.untyped)
8366 code->expr1->symtree->n.sym->ts = code->expr2->ts;
8367 selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
8368
8369 /* F2008: C803 The selector expression must not be coindexed. */
8370 if (gfc_is_coindexed (code->expr2))
8371 {
8372 gfc_error ("Selector at %L must not be coindexed",
8373 &code->expr2->where);
8374 return;
8375 }
8376
8377 }
8378 else
8379 {
8380 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
8381
8382 if (gfc_is_coindexed (code->expr1))
8383 {
8384 gfc_error ("Selector at %L must not be coindexed",
8385 &code->expr1->where);
8386 return;
8387 }
8388 }
8389
8390 /* Loop over TYPE IS / CLASS IS cases. */
8391 for (body = code->block; body; body = body->block)
8392 {
8393 c = body->ext.block.case_list;
8394
8395 /* Check F03:C815. */
8396 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8397 && !selector_type->attr.unlimited_polymorphic
8398 && !gfc_type_is_extensible (c->ts.u.derived))
8399 {
8400 gfc_error ("Derived type '%s' at %L must be extensible",
8401 c->ts.u.derived->name, &c->where);
8402 error++;
8403 continue;
8404 }
8405
8406 /* Check F03:C816. */
8407 if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
8408 && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
8409 || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
8410 {
8411 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
8412 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8413 c->ts.u.derived->name, &c->where, selector_type->name);
8414 else
8415 gfc_error ("Unexpected intrinsic type '%s' at %L",
8416 gfc_basic_typename (c->ts.type), &c->where);
8417 error++;
8418 continue;
8419 }
8420
8421 /* Check F03:C814. */
8422 if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length != NULL)
8423 {
8424 gfc_error ("The type-spec at %L shall specify that each length "
8425 "type parameter is assumed", &c->where);
8426 error++;
8427 continue;
8428 }
8429
8430 /* Intercept the DEFAULT case. */
8431 if (c->ts.type == BT_UNKNOWN)
8432 {
8433 /* Check F03:C818. */
8434 if (default_case)
8435 {
8436 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8437 "by a second DEFAULT CASE at %L",
8438 &default_case->ext.block.case_list->where, &c->where);
8439 error++;
8440 continue;
8441 }
8442
8443 default_case = body;
8444 }
8445 }
8446
8447 if (error > 0)
8448 return;
8449
8450 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8451 target if present. If there are any EXIT statements referring to the
8452 SELECT TYPE construct, this is no problem because the gfc_code
8453 reference stays the same and EXIT is equally possible from the BLOCK
8454 it is changed to. */
8455 code->op = EXEC_BLOCK;
8456 if (code->expr2)
8457 {
8458 gfc_association_list* assoc;
8459
8460 assoc = gfc_get_association_list ();
8461 assoc->st = code->expr1->symtree;
8462 assoc->target = gfc_copy_expr (code->expr2);
8463 assoc->target->where = code->expr2->where;
8464 /* assoc->variable will be set by resolve_assoc_var. */
8465
8466 code->ext.block.assoc = assoc;
8467 code->expr1->symtree->n.sym->assoc = assoc;
8468
8469 resolve_assoc_var (code->expr1->symtree->n.sym, false);
8470 }
8471 else
8472 code->ext.block.assoc = NULL;
8473
8474 /* Add EXEC_SELECT to switch on type. */
8475 new_st = gfc_get_code ();
8476 new_st->op = code->op;
8477 new_st->expr1 = code->expr1;
8478 new_st->expr2 = code->expr2;
8479 new_st->block = code->block;
8480 code->expr1 = code->expr2 = NULL;
8481 code->block = NULL;
8482 if (!ns->code)
8483 ns->code = new_st;
8484 else
8485 ns->code->next = new_st;
8486 code = new_st;
8487 code->op = EXEC_SELECT;
8488
8489 gfc_add_vptr_component (code->expr1);
8490 gfc_add_hash_component (code->expr1);
8491
8492 /* Loop over TYPE IS / CLASS IS cases. */
8493 for (body = code->block; body; body = body->block)
8494 {
8495 c = body->ext.block.case_list;
8496
8497 if (c->ts.type == BT_DERIVED)
8498 c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8499 c->ts.u.derived->hash_value);
8500 else if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
8501 {
8502 gfc_symbol *ivtab;
8503 gfc_expr *e;
8504
8505 ivtab = gfc_find_intrinsic_vtab (&c->ts);
8506 gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
8507 e = CLASS_DATA (ivtab)->initializer;
8508 c->low = c->high = gfc_copy_expr (e);
8509 }
8510
8511 else if (c->ts.type == BT_UNKNOWN)
8512 continue;
8513
8514 /* Associate temporary to selector. This should only be done
8515 when this case is actually true, so build a new ASSOCIATE
8516 that does precisely this here (instead of using the
8517 'global' one). */
8518
8519 if (c->ts.type == BT_CLASS)
8520 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
8521 else if (c->ts.type == BT_DERIVED)
8522 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
8523 else if (c->ts.type == BT_CHARACTER)
8524 {
8525 if (c->ts.u.cl && c->ts.u.cl->length
8526 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8527 charlen = mpz_get_si (c->ts.u.cl->length->value.integer);
8528 sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (c->ts.type),
8529 charlen, c->ts.kind);
8530 }
8531 else
8532 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
8533 c->ts.kind);
8534
8535 st = gfc_find_symtree (ns->sym_root, name);
8536 gcc_assert (st->n.sym->assoc);
8537 st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
8538 st->n.sym->assoc->target->where = code->expr1->where;
8539 if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
8540 gfc_add_data_component (st->n.sym->assoc->target);
8541
8542 new_st = gfc_get_code ();
8543 new_st->op = EXEC_BLOCK;
8544 new_st->ext.block.ns = gfc_build_block_ns (ns);
8545 new_st->ext.block.ns->code = body->next;
8546 body->next = new_st;
8547
8548 /* Chain in the new list only if it is marked as dangling. Otherwise
8549 there is a CASE label overlap and this is already used. Just ignore,
8550 the error is diagnosed elsewhere. */
8551 if (st->n.sym->assoc->dangling)
8552 {
8553 new_st->ext.block.assoc = st->n.sym->assoc;
8554 st->n.sym->assoc->dangling = 0;
8555 }
8556
8557 resolve_assoc_var (st->n.sym, false);
8558 }
8559
8560 /* Take out CLASS IS cases for separate treatment. */
8561 body = code;
8562 while (body && body->block)
8563 {
8564 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
8565 {
8566 /* Add to class_is list. */
8567 if (class_is == NULL)
8568 {
8569 class_is = body->block;
8570 tail = class_is;
8571 }
8572 else
8573 {
8574 for (tail = class_is; tail->block; tail = tail->block) ;
8575 tail->block = body->block;
8576 tail = tail->block;
8577 }
8578 /* Remove from EXEC_SELECT list. */
8579 body->block = body->block->block;
8580 tail->block = NULL;
8581 }
8582 else
8583 body = body->block;
8584 }
8585
8586 if (class_is)
8587 {
8588 gfc_symbol *vtab;
8589
8590 if (!default_case)
8591 {
8592 /* Add a default case to hold the CLASS IS cases. */
8593 for (tail = code; tail->block; tail = tail->block) ;
8594 tail->block = gfc_get_code ();
8595 tail = tail->block;
8596 tail->op = EXEC_SELECT_TYPE;
8597 tail->ext.block.case_list = gfc_get_case ();
8598 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
8599 tail->next = NULL;
8600 default_case = tail;
8601 }
8602
8603 /* More than one CLASS IS block? */
8604 if (class_is->block)
8605 {
8606 gfc_code **c1,*c2;
8607 bool swapped;
8608 /* Sort CLASS IS blocks by extension level. */
8609 do
8610 {
8611 swapped = false;
8612 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
8613 {
8614 c2 = (*c1)->block;
8615 /* F03:C817 (check for doubles). */
8616 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
8617 == c2->ext.block.case_list->ts.u.derived->hash_value)
8618 {
8619 gfc_error ("Double CLASS IS block in SELECT TYPE "
8620 "statement at %L",
8621 &c2->ext.block.case_list->where);
8622 return;
8623 }
8624 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
8625 < c2->ext.block.case_list->ts.u.derived->attr.extension)
8626 {
8627 /* Swap. */
8628 (*c1)->block = c2->block;
8629 c2->block = *c1;
8630 *c1 = c2;
8631 swapped = true;
8632 }
8633 }
8634 }
8635 while (swapped);
8636 }
8637
8638 /* Generate IF chain. */
8639 if_st = gfc_get_code ();
8640 if_st->op = EXEC_IF;
8641 new_st = if_st;
8642 for (body = class_is; body; body = body->block)
8643 {
8644 new_st->block = gfc_get_code ();
8645 new_st = new_st->block;
8646 new_st->op = EXEC_IF;
8647 /* Set up IF condition: Call _gfortran_is_extension_of. */
8648 new_st->expr1 = gfc_get_expr ();
8649 new_st->expr1->expr_type = EXPR_FUNCTION;
8650 new_st->expr1->ts.type = BT_LOGICAL;
8651 new_st->expr1->ts.kind = 4;
8652 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
8653 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
8654 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
8655 /* Set up arguments. */
8656 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
8657 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
8658 new_st->expr1->value.function.actual->expr->where = code->loc;
8659 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
8660 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
8661 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
8662 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
8663 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
8664 new_st->next = body->next;
8665 }
8666 if (default_case->next)
8667 {
8668 new_st->block = gfc_get_code ();
8669 new_st = new_st->block;
8670 new_st->op = EXEC_IF;
8671 new_st->next = default_case->next;
8672 }
8673
8674 /* Replace CLASS DEFAULT code by the IF chain. */
8675 default_case->next = if_st;
8676 }
8677
8678 /* Resolve the internal code. This can not be done earlier because
8679 it requires that the sym->assoc of selectors is set already. */
8680 gfc_current_ns = ns;
8681 gfc_resolve_blocks (code->block, gfc_current_ns);
8682 gfc_current_ns = old_ns;
8683
8684 resolve_select (code, true);
8685 }
8686
8687
8688 /* Resolve a transfer statement. This is making sure that:
8689 -- a derived type being transferred has only non-pointer components
8690 -- a derived type being transferred doesn't have private components, unless
8691 it's being transferred from the module where the type was defined
8692 -- we're not trying to transfer a whole assumed size array. */
8693
8694 static void
resolve_transfer(gfc_code * code)8695 resolve_transfer (gfc_code *code)
8696 {
8697 gfc_typespec *ts;
8698 gfc_symbol *sym;
8699 gfc_ref *ref;
8700 gfc_expr *exp;
8701
8702 exp = code->expr1;
8703
8704 while (exp != NULL && exp->expr_type == EXPR_OP
8705 && exp->value.op.op == INTRINSIC_PARENTHESES)
8706 exp = exp->value.op.op1;
8707
8708 if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
8709 {
8710 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8711 "MOLD=", &exp->where);
8712 return;
8713 }
8714
8715 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
8716 && exp->expr_type != EXPR_FUNCTION))
8717 return;
8718
8719 /* If we are reading, the variable will be changed. Note that
8720 code->ext.dt may be NULL if the TRANSFER is related to
8721 an INQUIRE statement -- but in this case, we are not reading, either. */
8722 if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
8723 && gfc_check_vardef_context (exp, false, false, false, _("item in READ"))
8724 == FAILURE)
8725 return;
8726
8727 sym = exp->symtree->n.sym;
8728 ts = &sym->ts;
8729
8730 /* Go to actual component transferred. */
8731 for (ref = exp->ref; ref; ref = ref->next)
8732 if (ref->type == REF_COMPONENT)
8733 ts = &ref->u.c.component->ts;
8734
8735 if (ts->type == BT_CLASS)
8736 {
8737 /* FIXME: Test for defined input/output. */
8738 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8739 "it is processed by a defined input/output procedure",
8740 &code->loc);
8741 return;
8742 }
8743
8744 if (ts->type == BT_DERIVED)
8745 {
8746 /* Check that transferred derived type doesn't contain POINTER
8747 components. */
8748 if (ts->u.derived->attr.pointer_comp)
8749 {
8750 gfc_error ("Data transfer element at %L cannot have POINTER "
8751 "components unless it is processed by a defined "
8752 "input/output procedure", &code->loc);
8753 return;
8754 }
8755
8756 /* F08:C935. */
8757 if (ts->u.derived->attr.proc_pointer_comp)
8758 {
8759 gfc_error ("Data transfer element at %L cannot have "
8760 "procedure pointer components", &code->loc);
8761 return;
8762 }
8763
8764 if (ts->u.derived->attr.alloc_comp)
8765 {
8766 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8767 "components unless it is processed by a defined "
8768 "input/output procedure", &code->loc);
8769 return;
8770 }
8771
8772 if (derived_inaccessible (ts->u.derived))
8773 {
8774 gfc_error ("Data transfer element at %L cannot have "
8775 "PRIVATE components",&code->loc);
8776 return;
8777 }
8778 }
8779
8780 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
8781 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
8782 {
8783 gfc_error ("Data transfer element at %L cannot be a full reference to "
8784 "an assumed-size array", &code->loc);
8785 return;
8786 }
8787 }
8788
8789
8790 /*********** Toplevel code resolution subroutines ***********/
8791
8792 /* Find the set of labels that are reachable from this block. We also
8793 record the last statement in each block. */
8794
8795 static void
find_reachable_labels(gfc_code * block)8796 find_reachable_labels (gfc_code *block)
8797 {
8798 gfc_code *c;
8799
8800 if (!block)
8801 return;
8802
8803 cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
8804
8805 /* Collect labels in this block. We don't keep those corresponding
8806 to END {IF|SELECT}, these are checked in resolve_branch by going
8807 up through the code_stack. */
8808 for (c = block; c; c = c->next)
8809 {
8810 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
8811 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
8812 }
8813
8814 /* Merge with labels from parent block. */
8815 if (cs_base->prev)
8816 {
8817 gcc_assert (cs_base->prev->reachable_labels);
8818 bitmap_ior_into (cs_base->reachable_labels,
8819 cs_base->prev->reachable_labels);
8820 }
8821 }
8822
8823
8824 static void
resolve_lock_unlock(gfc_code * code)8825 resolve_lock_unlock (gfc_code *code)
8826 {
8827 if (code->expr1->ts.type != BT_DERIVED
8828 || code->expr1->expr_type != EXPR_VARIABLE
8829 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
8830 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
8831 || code->expr1->rank != 0
8832 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
8833 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8834 &code->expr1->where);
8835
8836 /* Check STAT. */
8837 if (code->expr2
8838 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8839 || code->expr2->expr_type != EXPR_VARIABLE))
8840 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8841 &code->expr2->where);
8842
8843 if (code->expr2
8844 && gfc_check_vardef_context (code->expr2, false, false, false,
8845 _("STAT variable")) == FAILURE)
8846 return;
8847
8848 /* Check ERRMSG. */
8849 if (code->expr3
8850 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8851 || code->expr3->expr_type != EXPR_VARIABLE))
8852 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8853 &code->expr3->where);
8854
8855 if (code->expr3
8856 && gfc_check_vardef_context (code->expr3, false, false, false,
8857 _("ERRMSG variable")) == FAILURE)
8858 return;
8859
8860 /* Check ACQUIRED_LOCK. */
8861 if (code->expr4
8862 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
8863 || code->expr4->expr_type != EXPR_VARIABLE))
8864 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8865 "variable", &code->expr4->where);
8866
8867 if (code->expr4
8868 && gfc_check_vardef_context (code->expr4, false, false, false,
8869 _("ACQUIRED_LOCK variable")) == FAILURE)
8870 return;
8871 }
8872
8873
8874 static void
resolve_sync(gfc_code * code)8875 resolve_sync (gfc_code *code)
8876 {
8877 /* Check imageset. The * case matches expr1 == NULL. */
8878 if (code->expr1)
8879 {
8880 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
8881 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8882 "INTEGER expression", &code->expr1->where);
8883 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
8884 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
8885 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8886 &code->expr1->where);
8887 else if (code->expr1->expr_type == EXPR_ARRAY
8888 && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
8889 {
8890 gfc_constructor *cons;
8891 cons = gfc_constructor_first (code->expr1->value.constructor);
8892 for (; cons; cons = gfc_constructor_next (cons))
8893 if (cons->expr->expr_type == EXPR_CONSTANT
8894 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
8895 gfc_error ("Imageset argument at %L must between 1 and "
8896 "num_images()", &cons->expr->where);
8897 }
8898 }
8899
8900 /* Check STAT. */
8901 if (code->expr2
8902 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
8903 || code->expr2->expr_type != EXPR_VARIABLE))
8904 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8905 &code->expr2->where);
8906
8907 /* Check ERRMSG. */
8908 if (code->expr3
8909 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
8910 || code->expr3->expr_type != EXPR_VARIABLE))
8911 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8912 &code->expr3->where);
8913 }
8914
8915
8916 /* Given a branch to a label, see if the branch is conforming.
8917 The code node describes where the branch is located. */
8918
8919 static void
resolve_branch(gfc_st_label * label,gfc_code * code)8920 resolve_branch (gfc_st_label *label, gfc_code *code)
8921 {
8922 code_stack *stack;
8923
8924 if (label == NULL)
8925 return;
8926
8927 /* Step one: is this a valid branching target? */
8928
8929 if (label->defined == ST_LABEL_UNKNOWN)
8930 {
8931 gfc_error ("Label %d referenced at %L is never defined", label->value,
8932 &label->where);
8933 return;
8934 }
8935
8936 if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
8937 {
8938 gfc_error ("Statement at %L is not a valid branch target statement "
8939 "for the branch statement at %L", &label->where, &code->loc);
8940 return;
8941 }
8942
8943 /* Step two: make sure this branch is not a branch to itself ;-) */
8944
8945 if (code->here == label)
8946 {
8947 gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
8948 return;
8949 }
8950
8951 /* Step three: See if the label is in the same block as the
8952 branching statement. The hard work has been done by setting up
8953 the bitmap reachable_labels. */
8954
8955 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
8956 {
8957 /* Check now whether there is a CRITICAL construct; if so, check
8958 whether the label is still visible outside of the CRITICAL block,
8959 which is invalid. */
8960 for (stack = cs_base; stack; stack = stack->prev)
8961 {
8962 if (stack->current->op == EXEC_CRITICAL
8963 && bitmap_bit_p (stack->reachable_labels, label->value))
8964 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8965 "label at %L", &code->loc, &label->where);
8966 else if (stack->current->op == EXEC_DO_CONCURRENT
8967 && bitmap_bit_p (stack->reachable_labels, label->value))
8968 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8969 "for label at %L", &code->loc, &label->where);
8970 }
8971
8972 return;
8973 }
8974
8975 /* Step four: If we haven't found the label in the bitmap, it may
8976 still be the label of the END of the enclosing block, in which
8977 case we find it by going up the code_stack. */
8978
8979 for (stack = cs_base; stack; stack = stack->prev)
8980 {
8981 if (stack->current->next && stack->current->next->here == label)
8982 break;
8983 if (stack->current->op == EXEC_CRITICAL)
8984 {
8985 /* Note: A label at END CRITICAL does not leave the CRITICAL
8986 construct as END CRITICAL is still part of it. */
8987 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8988 " at %L", &code->loc, &label->where);
8989 return;
8990 }
8991 else if (stack->current->op == EXEC_DO_CONCURRENT)
8992 {
8993 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8994 "label at %L", &code->loc, &label->where);
8995 return;
8996 }
8997 }
8998
8999 if (stack)
9000 {
9001 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
9002 return;
9003 }
9004
9005 /* The label is not in an enclosing block, so illegal. This was
9006 allowed in Fortran 66, so we allow it as extension. No
9007 further checks are necessary in this case. */
9008 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
9009 "as the GOTO statement at %L", &label->where,
9010 &code->loc);
9011 return;
9012 }
9013
9014
9015 /* Check whether EXPR1 has the same shape as EXPR2. */
9016
9017 static gfc_try
resolve_where_shape(gfc_expr * expr1,gfc_expr * expr2)9018 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
9019 {
9020 mpz_t shape[GFC_MAX_DIMENSIONS];
9021 mpz_t shape2[GFC_MAX_DIMENSIONS];
9022 gfc_try result = FAILURE;
9023 int i;
9024
9025 /* Compare the rank. */
9026 if (expr1->rank != expr2->rank)
9027 return result;
9028
9029 /* Compare the size of each dimension. */
9030 for (i=0; i<expr1->rank; i++)
9031 {
9032 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
9033 goto ignore;
9034
9035 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
9036 goto ignore;
9037
9038 if (mpz_cmp (shape[i], shape2[i]))
9039 goto over;
9040 }
9041
9042 /* When either of the two expression is an assumed size array, we
9043 ignore the comparison of dimension sizes. */
9044 ignore:
9045 result = SUCCESS;
9046
9047 over:
9048 gfc_clear_shape (shape, i);
9049 gfc_clear_shape (shape2, i);
9050 return result;
9051 }
9052
9053
9054 /* Check whether a WHERE assignment target or a WHERE mask expression
9055 has the same shape as the outmost WHERE mask expression. */
9056
9057 static void
resolve_where(gfc_code * code,gfc_expr * mask)9058 resolve_where (gfc_code *code, gfc_expr *mask)
9059 {
9060 gfc_code *cblock;
9061 gfc_code *cnext;
9062 gfc_expr *e = NULL;
9063
9064 cblock = code->block;
9065
9066 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9067 In case of nested WHERE, only the outmost one is stored. */
9068 if (mask == NULL) /* outmost WHERE */
9069 e = cblock->expr1;
9070 else /* inner WHERE */
9071 e = mask;
9072
9073 while (cblock)
9074 {
9075 if (cblock->expr1)
9076 {
9077 /* Check if the mask-expr has a consistent shape with the
9078 outmost WHERE mask-expr. */
9079 if (resolve_where_shape (cblock->expr1, e) == FAILURE)
9080 gfc_error ("WHERE mask at %L has inconsistent shape",
9081 &cblock->expr1->where);
9082 }
9083
9084 /* the assignment statement of a WHERE statement, or the first
9085 statement in where-body-construct of a WHERE construct */
9086 cnext = cblock->next;
9087 while (cnext)
9088 {
9089 switch (cnext->op)
9090 {
9091 /* WHERE assignment statement */
9092 case EXEC_ASSIGN:
9093
9094 /* Check shape consistent for WHERE assignment target. */
9095 if (e && resolve_where_shape (cnext->expr1, e) == FAILURE)
9096 gfc_error ("WHERE assignment target at %L has "
9097 "inconsistent shape", &cnext->expr1->where);
9098 break;
9099
9100
9101 case EXEC_ASSIGN_CALL:
9102 resolve_call (cnext);
9103 if (!cnext->resolved_sym->attr.elemental)
9104 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9105 &cnext->ext.actual->expr->where);
9106 break;
9107
9108 /* WHERE or WHERE construct is part of a where-body-construct */
9109 case EXEC_WHERE:
9110 resolve_where (cnext, e);
9111 break;
9112
9113 default:
9114 gfc_error ("Unsupported statement inside WHERE at %L",
9115 &cnext->loc);
9116 }
9117 /* the next statement within the same where-body-construct */
9118 cnext = cnext->next;
9119 }
9120 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9121 cblock = cblock->block;
9122 }
9123 }
9124
9125
9126 /* Resolve assignment in FORALL construct.
9127 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9128 FORALL index variables. */
9129
9130 static void
gfc_resolve_assign_in_forall(gfc_code * code,int nvar,gfc_expr ** var_expr)9131 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
9132 {
9133 int n;
9134
9135 for (n = 0; n < nvar; n++)
9136 {
9137 gfc_symbol *forall_index;
9138
9139 forall_index = var_expr[n]->symtree->n.sym;
9140
9141 /* Check whether the assignment target is one of the FORALL index
9142 variable. */
9143 if ((code->expr1->expr_type == EXPR_VARIABLE)
9144 && (code->expr1->symtree->n.sym == forall_index))
9145 gfc_error ("Assignment to a FORALL index variable at %L",
9146 &code->expr1->where);
9147 else
9148 {
9149 /* If one of the FORALL index variables doesn't appear in the
9150 assignment variable, then there could be a many-to-one
9151 assignment. Emit a warning rather than an error because the
9152 mask could be resolving this problem. */
9153 if (find_forall_index (code->expr1, forall_index, 0) == FAILURE)
9154 gfc_warning ("The FORALL with index '%s' is not used on the "
9155 "left side of the assignment at %L and so might "
9156 "cause multiple assignment to this object",
9157 var_expr[n]->symtree->name, &code->expr1->where);
9158 }
9159 }
9160 }
9161
9162
9163 /* Resolve WHERE statement in FORALL construct. */
9164
9165 static void
gfc_resolve_where_code_in_forall(gfc_code * code,int nvar,gfc_expr ** var_expr)9166 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
9167 gfc_expr **var_expr)
9168 {
9169 gfc_code *cblock;
9170 gfc_code *cnext;
9171
9172 cblock = code->block;
9173 while (cblock)
9174 {
9175 /* the assignment statement of a WHERE statement, or the first
9176 statement in where-body-construct of a WHERE construct */
9177 cnext = cblock->next;
9178 while (cnext)
9179 {
9180 switch (cnext->op)
9181 {
9182 /* WHERE assignment statement */
9183 case EXEC_ASSIGN:
9184 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
9185 break;
9186
9187 /* WHERE operator assignment statement */
9188 case EXEC_ASSIGN_CALL:
9189 resolve_call (cnext);
9190 if (!cnext->resolved_sym->attr.elemental)
9191 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9192 &cnext->ext.actual->expr->where);
9193 break;
9194
9195 /* WHERE or WHERE construct is part of a where-body-construct */
9196 case EXEC_WHERE:
9197 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
9198 break;
9199
9200 default:
9201 gfc_error ("Unsupported statement inside WHERE at %L",
9202 &cnext->loc);
9203 }
9204 /* the next statement within the same where-body-construct */
9205 cnext = cnext->next;
9206 }
9207 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9208 cblock = cblock->block;
9209 }
9210 }
9211
9212
9213 /* Traverse the FORALL body to check whether the following errors exist:
9214 1. For assignment, check if a many-to-one assignment happens.
9215 2. For WHERE statement, check the WHERE body to see if there is any
9216 many-to-one assignment. */
9217
9218 static void
gfc_resolve_forall_body(gfc_code * code,int nvar,gfc_expr ** var_expr)9219 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
9220 {
9221 gfc_code *c;
9222
9223 c = code->block->next;
9224 while (c)
9225 {
9226 switch (c->op)
9227 {
9228 case EXEC_ASSIGN:
9229 case EXEC_POINTER_ASSIGN:
9230 gfc_resolve_assign_in_forall (c, nvar, var_expr);
9231 break;
9232
9233 case EXEC_ASSIGN_CALL:
9234 resolve_call (c);
9235 break;
9236
9237 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9238 there is no need to handle it here. */
9239 case EXEC_FORALL:
9240 break;
9241 case EXEC_WHERE:
9242 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
9243 break;
9244 default:
9245 break;
9246 }
9247 /* The next statement in the FORALL body. */
9248 c = c->next;
9249 }
9250 }
9251
9252
9253 /* Counts the number of iterators needed inside a forall construct, including
9254 nested forall constructs. This is used to allocate the needed memory
9255 in gfc_resolve_forall. */
9256
9257 static int
gfc_count_forall_iterators(gfc_code * code)9258 gfc_count_forall_iterators (gfc_code *code)
9259 {
9260 int max_iters, sub_iters, current_iters;
9261 gfc_forall_iterator *fa;
9262
9263 gcc_assert(code->op == EXEC_FORALL);
9264 max_iters = 0;
9265 current_iters = 0;
9266
9267 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
9268 current_iters ++;
9269
9270 code = code->block->next;
9271
9272 while (code)
9273 {
9274 if (code->op == EXEC_FORALL)
9275 {
9276 sub_iters = gfc_count_forall_iterators (code);
9277 if (sub_iters > max_iters)
9278 max_iters = sub_iters;
9279 }
9280 code = code->next;
9281 }
9282
9283 return current_iters + max_iters;
9284 }
9285
9286
9287 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9288 gfc_resolve_forall_body to resolve the FORALL body. */
9289
9290 static void
gfc_resolve_forall(gfc_code * code,gfc_namespace * ns,int forall_save)9291 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
9292 {
9293 static gfc_expr **var_expr;
9294 static int total_var = 0;
9295 static int nvar = 0;
9296 int old_nvar, tmp;
9297 gfc_forall_iterator *fa;
9298 int i;
9299
9300 old_nvar = nvar;
9301
9302 /* Start to resolve a FORALL construct */
9303 if (forall_save == 0)
9304 {
9305 /* Count the total number of FORALL index in the nested FORALL
9306 construct in order to allocate the VAR_EXPR with proper size. */
9307 total_var = gfc_count_forall_iterators (code);
9308
9309 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9310 var_expr = XCNEWVEC (gfc_expr *, total_var);
9311 }
9312
9313 /* The information about FORALL iterator, including FORALL index start, end
9314 and stride. The FORALL index can not appear in start, end or stride. */
9315 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
9316 {
9317 /* Check if any outer FORALL index name is the same as the current
9318 one. */
9319 for (i = 0; i < nvar; i++)
9320 {
9321 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
9322 {
9323 gfc_error ("An outer FORALL construct already has an index "
9324 "with this name %L", &fa->var->where);
9325 }
9326 }
9327
9328 /* Record the current FORALL index. */
9329 var_expr[nvar] = gfc_copy_expr (fa->var);
9330
9331 nvar++;
9332
9333 /* No memory leak. */
9334 gcc_assert (nvar <= total_var);
9335 }
9336
9337 /* Resolve the FORALL body. */
9338 gfc_resolve_forall_body (code, nvar, var_expr);
9339
9340 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9341 gfc_resolve_blocks (code->block, ns);
9342
9343 tmp = nvar;
9344 nvar = old_nvar;
9345 /* Free only the VAR_EXPRs allocated in this frame. */
9346 for (i = nvar; i < tmp; i++)
9347 gfc_free_expr (var_expr[i]);
9348
9349 if (nvar == 0)
9350 {
9351 /* We are in the outermost FORALL construct. */
9352 gcc_assert (forall_save == 0);
9353
9354 /* VAR_EXPR is not needed any more. */
9355 free (var_expr);
9356 total_var = 0;
9357 }
9358 }
9359
9360
9361 /* Resolve a BLOCK construct statement. */
9362
9363 static void
resolve_block_construct(gfc_code * code)9364 resolve_block_construct (gfc_code* code)
9365 {
9366 /* Resolve the BLOCK's namespace. */
9367 gfc_resolve (code->ext.block.ns);
9368
9369 /* For an ASSOCIATE block, the associations (and their targets) are already
9370 resolved during resolve_symbol. */
9371 }
9372
9373
9374 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9375 DO code nodes. */
9376
9377 static void resolve_code (gfc_code *, gfc_namespace *);
9378
9379 void
gfc_resolve_blocks(gfc_code * b,gfc_namespace * ns)9380 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
9381 {
9382 gfc_try t;
9383
9384 for (; b; b = b->block)
9385 {
9386 t = gfc_resolve_expr (b->expr1);
9387 if (gfc_resolve_expr (b->expr2) == FAILURE)
9388 t = FAILURE;
9389
9390 switch (b->op)
9391 {
9392 case EXEC_IF:
9393 if (t == SUCCESS && b->expr1 != NULL
9394 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
9395 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9396 &b->expr1->where);
9397 break;
9398
9399 case EXEC_WHERE:
9400 if (t == SUCCESS
9401 && b->expr1 != NULL
9402 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
9403 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9404 &b->expr1->where);
9405 break;
9406
9407 case EXEC_GOTO:
9408 resolve_branch (b->label1, b);
9409 break;
9410
9411 case EXEC_BLOCK:
9412 resolve_block_construct (b);
9413 break;
9414
9415 case EXEC_SELECT:
9416 case EXEC_SELECT_TYPE:
9417 case EXEC_FORALL:
9418 case EXEC_DO:
9419 case EXEC_DO_WHILE:
9420 case EXEC_DO_CONCURRENT:
9421 case EXEC_CRITICAL:
9422 case EXEC_READ:
9423 case EXEC_WRITE:
9424 case EXEC_IOLENGTH:
9425 case EXEC_WAIT:
9426 break;
9427
9428 case EXEC_OMP_ATOMIC:
9429 case EXEC_OMP_CRITICAL:
9430 case EXEC_OMP_DO:
9431 case EXEC_OMP_MASTER:
9432 case EXEC_OMP_ORDERED:
9433 case EXEC_OMP_PARALLEL:
9434 case EXEC_OMP_PARALLEL_DO:
9435 case EXEC_OMP_PARALLEL_SECTIONS:
9436 case EXEC_OMP_PARALLEL_WORKSHARE:
9437 case EXEC_OMP_SECTIONS:
9438 case EXEC_OMP_SINGLE:
9439 case EXEC_OMP_TASK:
9440 case EXEC_OMP_TASKWAIT:
9441 case EXEC_OMP_TASKYIELD:
9442 case EXEC_OMP_WORKSHARE:
9443 break;
9444
9445 default:
9446 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9447 }
9448
9449 resolve_code (b->next, ns);
9450 }
9451 }
9452
9453
9454 /* Does everything to resolve an ordinary assignment. Returns true
9455 if this is an interface assignment. */
9456 static bool
resolve_ordinary_assign(gfc_code * code,gfc_namespace * ns)9457 resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
9458 {
9459 bool rval = false;
9460 gfc_expr *lhs;
9461 gfc_expr *rhs;
9462 int llen = 0;
9463 int rlen = 0;
9464 int n;
9465 gfc_ref *ref;
9466
9467 if (gfc_extend_assign (code, ns) == SUCCESS)
9468 {
9469 gfc_expr** rhsptr;
9470
9471 if (code->op == EXEC_ASSIGN_CALL)
9472 {
9473 lhs = code->ext.actual->expr;
9474 rhsptr = &code->ext.actual->next->expr;
9475 }
9476 else
9477 {
9478 gfc_actual_arglist* args;
9479 gfc_typebound_proc* tbp;
9480
9481 gcc_assert (code->op == EXEC_COMPCALL);
9482
9483 args = code->expr1->value.compcall.actual;
9484 lhs = args->expr;
9485 rhsptr = &args->next->expr;
9486
9487 tbp = code->expr1->value.compcall.tbp;
9488 gcc_assert (!tbp->is_generic);
9489 }
9490
9491 /* Make a temporary rhs when there is a default initializer
9492 and rhs is the same symbol as the lhs. */
9493 if ((*rhsptr)->expr_type == EXPR_VARIABLE
9494 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
9495 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
9496 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
9497 *rhsptr = gfc_get_parentheses (*rhsptr);
9498
9499 return true;
9500 }
9501
9502 lhs = code->expr1;
9503 rhs = code->expr2;
9504
9505 if (rhs->is_boz
9506 && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
9507 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9508 &code->loc) == FAILURE)
9509 return false;
9510
9511 /* Handle the case of a BOZ literal on the RHS. */
9512 if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
9513 {
9514 int rc;
9515 if (gfc_option.warn_surprising)
9516 gfc_warning ("BOZ literal at %L is bitwise transferred "
9517 "non-integer symbol '%s'", &code->loc,
9518 lhs->symtree->n.sym->name);
9519
9520 if (!gfc_convert_boz (rhs, &lhs->ts))
9521 return false;
9522 if ((rc = gfc_range_check (rhs)) != ARITH_OK)
9523 {
9524 if (rc == ARITH_UNDERFLOW)
9525 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9526 ". This check can be disabled with the option "
9527 "-fno-range-check", &rhs->where);
9528 else if (rc == ARITH_OVERFLOW)
9529 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9530 ". This check can be disabled with the option "
9531 "-fno-range-check", &rhs->where);
9532 else if (rc == ARITH_NAN)
9533 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9534 ". This check can be disabled with the option "
9535 "-fno-range-check", &rhs->where);
9536 return false;
9537 }
9538 }
9539
9540 if (lhs->ts.type == BT_CHARACTER
9541 && gfc_option.warn_character_truncation)
9542 {
9543 if (lhs->ts.u.cl != NULL
9544 && lhs->ts.u.cl->length != NULL
9545 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9546 llen = mpz_get_si (lhs->ts.u.cl->length->value.integer);
9547
9548 if (rhs->expr_type == EXPR_CONSTANT)
9549 rlen = rhs->value.character.length;
9550
9551 else if (rhs->ts.u.cl != NULL
9552 && rhs->ts.u.cl->length != NULL
9553 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9554 rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
9555
9556 if (rlen && llen && rlen > llen)
9557 gfc_warning_now ("CHARACTER expression will be truncated "
9558 "in assignment (%d/%d) at %L",
9559 llen, rlen, &code->loc);
9560 }
9561
9562 /* Ensure that a vector index expression for the lvalue is evaluated
9563 to a temporary if the lvalue symbol is referenced in it. */
9564 if (lhs->rank)
9565 {
9566 for (ref = lhs->ref; ref; ref= ref->next)
9567 if (ref->type == REF_ARRAY)
9568 {
9569 for (n = 0; n < ref->u.ar.dimen; n++)
9570 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
9571 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
9572 ref->u.ar.start[n]))
9573 ref->u.ar.start[n]
9574 = gfc_get_parentheses (ref->u.ar.start[n]);
9575 }
9576 }
9577
9578 if (gfc_pure (NULL))
9579 {
9580 if (lhs->ts.type == BT_DERIVED
9581 && lhs->expr_type == EXPR_VARIABLE
9582 && lhs->ts.u.derived->attr.pointer_comp
9583 && rhs->expr_type == EXPR_VARIABLE
9584 && (gfc_impure_variable (rhs->symtree->n.sym)
9585 || gfc_is_coindexed (rhs)))
9586 {
9587 /* F2008, C1283. */
9588 if (gfc_is_coindexed (rhs))
9589 gfc_error ("Coindexed expression at %L is assigned to "
9590 "a derived type variable with a POINTER "
9591 "component in a PURE procedure",
9592 &rhs->where);
9593 else
9594 gfc_error ("The impure variable at %L is assigned to "
9595 "a derived type variable with a POINTER "
9596 "component in a PURE procedure (12.6)",
9597 &rhs->where);
9598 return rval;
9599 }
9600
9601 /* Fortran 2008, C1283. */
9602 if (gfc_is_coindexed (lhs))
9603 {
9604 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9605 "procedure", &rhs->where);
9606 return rval;
9607 }
9608 }
9609
9610 if (gfc_implicit_pure (NULL))
9611 {
9612 if (lhs->expr_type == EXPR_VARIABLE
9613 && lhs->symtree->n.sym != gfc_current_ns->proc_name
9614 && lhs->symtree->n.sym->ns != gfc_current_ns)
9615 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9616
9617 if (lhs->ts.type == BT_DERIVED
9618 && lhs->expr_type == EXPR_VARIABLE
9619 && lhs->ts.u.derived->attr.pointer_comp
9620 && rhs->expr_type == EXPR_VARIABLE
9621 && (gfc_impure_variable (rhs->symtree->n.sym)
9622 || gfc_is_coindexed (rhs)))
9623 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9624
9625 /* Fortran 2008, C1283. */
9626 if (gfc_is_coindexed (lhs))
9627 gfc_current_ns->proc_name->attr.implicit_pure = 0;
9628 }
9629
9630 /* F03:7.4.1.2. */
9631 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9632 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9633 if (lhs->ts.type == BT_CLASS)
9634 {
9635 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9636 "%L - check that there is a matching specific subroutine "
9637 "for '=' operator", &lhs->where);
9638 return false;
9639 }
9640
9641 /* F2008, Section 7.2.1.2. */
9642 if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
9643 {
9644 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9645 "component in assignment at %L", &lhs->where);
9646 return false;
9647 }
9648
9649 gfc_check_assign (lhs, rhs, 1);
9650 return false;
9651 }
9652
9653
9654 /* Add a component reference onto an expression. */
9655
9656 static void
add_comp_ref(gfc_expr * e,gfc_component * c)9657 add_comp_ref (gfc_expr *e, gfc_component *c)
9658 {
9659 gfc_ref **ref;
9660 ref = &(e->ref);
9661 while (*ref)
9662 ref = &((*ref)->next);
9663 *ref = gfc_get_ref ();
9664 (*ref)->type = REF_COMPONENT;
9665 (*ref)->u.c.sym = e->ts.u.derived;
9666 (*ref)->u.c.component = c;
9667 e->ts = c->ts;
9668
9669 /* Add a full array ref, as necessary. */
9670 if (c->as)
9671 {
9672 gfc_add_full_array_ref (e, c->as);
9673 e->rank = c->as->rank;
9674 }
9675 }
9676
9677
9678 /* Build an assignment. Keep the argument 'op' for future use, so that
9679 pointer assignments can be made. */
9680
9681 static gfc_code *
build_assignment(gfc_exec_op op,gfc_expr * expr1,gfc_expr * expr2,gfc_component * comp1,gfc_component * comp2,locus loc)9682 build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
9683 gfc_component *comp1, gfc_component *comp2, locus loc)
9684 {
9685 gfc_code *this_code;
9686
9687 this_code = gfc_get_code ();
9688 this_code->op = op;
9689 this_code->next = NULL;
9690 this_code->expr1 = gfc_copy_expr (expr1);
9691 this_code->expr2 = gfc_copy_expr (expr2);
9692 this_code->loc = loc;
9693 if (comp1 && comp2)
9694 {
9695 add_comp_ref (this_code->expr1, comp1);
9696 add_comp_ref (this_code->expr2, comp2);
9697 }
9698
9699 return this_code;
9700 }
9701
9702
9703 /* Makes a temporary variable expression based on the characteristics of
9704 a given variable expression. */
9705
9706 static gfc_expr*
get_temp_from_expr(gfc_expr * e,gfc_namespace * ns)9707 get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
9708 {
9709 static int serial = 0;
9710 char name[GFC_MAX_SYMBOL_LEN];
9711 gfc_symtree *tmp;
9712 gfc_array_spec *as;
9713 gfc_array_ref *aref;
9714 gfc_ref *ref;
9715
9716 sprintf (name, "DA@%d", serial++);
9717 gfc_get_sym_tree (name, ns, &tmp, false);
9718 gfc_add_type (tmp->n.sym, &e->ts, NULL);
9719
9720 as = NULL;
9721 ref = NULL;
9722 aref = NULL;
9723
9724 /* This function could be expanded to support other expression type
9725 but this is not needed here. */
9726 gcc_assert (e->expr_type == EXPR_VARIABLE);
9727
9728 /* Obtain the arrayspec for the temporary. */
9729 if (e->rank)
9730 {
9731 aref = gfc_find_array_ref (e);
9732 if (e->expr_type == EXPR_VARIABLE
9733 && e->symtree->n.sym->as == aref->as)
9734 as = aref->as;
9735 else
9736 {
9737 for (ref = e->ref; ref; ref = ref->next)
9738 if (ref->type == REF_COMPONENT
9739 && ref->u.c.component->as == aref->as)
9740 {
9741 as = aref->as;
9742 break;
9743 }
9744 }
9745 }
9746
9747 /* Add the attributes and the arrayspec to the temporary. */
9748 tmp->n.sym->attr = gfc_expr_attr (e);
9749 if (as)
9750 {
9751 tmp->n.sym->as = gfc_copy_array_spec (as);
9752 if (!ref)
9753 ref = e->ref;
9754 if (as->type == AS_DEFERRED)
9755 tmp->n.sym->attr.allocatable = 1;
9756 }
9757 else
9758 tmp->n.sym->attr.dimension = 0;
9759
9760 gfc_set_sym_referenced (tmp->n.sym);
9761 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
9762 e = gfc_lval_expr_from_sym (tmp->n.sym);
9763
9764 /* Should the lhs be a section, use its array ref for the
9765 temporary expression. */
9766 if (aref && aref->type != AR_FULL)
9767 {
9768 gfc_free_ref_list (e->ref);
9769 e->ref = gfc_copy_ref (ref);
9770 }
9771 return e;
9772 }
9773
9774
9775 /* Add one line of code to the code chain, making sure that 'head' and
9776 'tail' are appropriately updated. */
9777
9778 static void
add_code_to_chain(gfc_code ** this_code,gfc_code ** head,gfc_code ** tail)9779 add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
9780 {
9781 gcc_assert (this_code);
9782 if (*head == NULL)
9783 *head = *tail = *this_code;
9784 else
9785 *tail = gfc_append_code (*tail, *this_code);
9786 *this_code = NULL;
9787 }
9788
9789
9790 /* Counts the potential number of part array references that would
9791 result from resolution of typebound defined assignments. */
9792
9793 static int
nonscalar_typebound_assign(gfc_symbol * derived,int depth)9794 nonscalar_typebound_assign (gfc_symbol *derived, int depth)
9795 {
9796 gfc_component *c;
9797 int c_depth = 0, t_depth;
9798
9799 for (c= derived->components; c; c = c->next)
9800 {
9801 if ((c->ts.type != BT_DERIVED
9802 || c->attr.pointer
9803 || c->attr.allocatable
9804 || c->attr.proc_pointer_comp
9805 || c->attr.class_pointer
9806 || c->attr.proc_pointer)
9807 && !c->attr.defined_assign_comp)
9808 continue;
9809
9810 if (c->as && c_depth == 0)
9811 c_depth = 1;
9812
9813 if (c->ts.u.derived->attr.defined_assign_comp)
9814 t_depth = nonscalar_typebound_assign (c->ts.u.derived,
9815 c->as ? 1 : 0);
9816 else
9817 t_depth = 0;
9818
9819 c_depth = t_depth > c_depth ? t_depth : c_depth;
9820 }
9821 return depth + c_depth;
9822 }
9823
9824
9825 /* Implement 7.2.1.3 of the F08 standard:
9826 "An intrinsic assignment where the variable is of derived type is
9827 performed as if each component of the variable were assigned from the
9828 corresponding component of expr using pointer assignment (7.2.2) for
9829 each pointer component, defined assignment for each nonpointer
9830 nonallocatable component of a type that has a type-bound defined
9831 assignment consistent with the component, intrinsic assignment for
9832 each other nonpointer nonallocatable component, ..."
9833
9834 The pointer assignments are taken care of by the intrinsic
9835 assignment of the structure itself. This function recursively adds
9836 defined assignments where required. The recursion is accomplished
9837 by calling resolve_code.
9838
9839 When the lhs in a defined assignment has intent INOUT, we need a
9840 temporary for the lhs. In pseudo-code:
9841
9842 ! Only call function lhs once.
9843 if (lhs is not a constant or an variable)
9844 temp_x = expr2
9845 expr2 => temp_x
9846 ! Do the intrinsic assignment
9847 expr1 = expr2
9848 ! Now do the defined assignments
9849 do over components with typebound defined assignment [%cmp]
9850 #if one component's assignment procedure is INOUT
9851 t1 = expr1
9852 #if expr2 non-variable
9853 temp_x = expr2
9854 expr2 => temp_x
9855 # endif
9856 expr1 = expr2
9857 # for each cmp
9858 t1%cmp {defined=} expr2%cmp
9859 expr1%cmp = t1%cmp
9860 #else
9861 expr1 = expr2
9862
9863 # for each cmp
9864 expr1%cmp {defined=} expr2%cmp
9865 #endif
9866 */
9867
9868 /* The temporary assignments have to be put on top of the additional
9869 code to avoid the result being changed by the intrinsic assignment.
9870 */
9871 static int component_assignment_level = 0;
9872 static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
9873
9874 static void
generate_component_assignments(gfc_code ** code,gfc_namespace * ns)9875 generate_component_assignments (gfc_code **code, gfc_namespace *ns)
9876 {
9877 gfc_component *comp1, *comp2;
9878 gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
9879 gfc_expr *t1;
9880 int error_count, depth;
9881
9882 gfc_get_errors (NULL, &error_count);
9883
9884 /* Filter out continuing processing after an error. */
9885 if (error_count
9886 || (*code)->expr1->ts.type != BT_DERIVED
9887 || (*code)->expr2->ts.type != BT_DERIVED)
9888 return;
9889
9890 /* TODO: Handle more than one part array reference in assignments. */
9891 depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
9892 (*code)->expr1->rank ? 1 : 0);
9893 if (depth > 1)
9894 {
9895 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9896 "done because multiple part array references would "
9897 "occur in intermediate expressions.", &(*code)->loc);
9898 return;
9899 }
9900
9901 component_assignment_level++;
9902
9903 /* Create a temporary so that functions get called only once. */
9904 if ((*code)->expr2->expr_type != EXPR_VARIABLE
9905 && (*code)->expr2->expr_type != EXPR_CONSTANT)
9906 {
9907 gfc_expr *tmp_expr;
9908
9909 /* Assign the rhs to the temporary. */
9910 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
9911 this_code = build_assignment (EXEC_ASSIGN,
9912 tmp_expr, (*code)->expr2,
9913 NULL, NULL, (*code)->loc);
9914 /* Add the code and substitute the rhs expression. */
9915 add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
9916 gfc_free_expr ((*code)->expr2);
9917 (*code)->expr2 = tmp_expr;
9918 }
9919
9920 /* Do the intrinsic assignment. This is not needed if the lhs is one
9921 of the temporaries generated here, since the intrinsic assignment
9922 to the final result already does this. */
9923 if ((*code)->expr1->symtree->n.sym->name[2] != '@')
9924 {
9925 this_code = build_assignment (EXEC_ASSIGN,
9926 (*code)->expr1, (*code)->expr2,
9927 NULL, NULL, (*code)->loc);
9928 add_code_to_chain (&this_code, &head, &tail);
9929 }
9930
9931 comp1 = (*code)->expr1->ts.u.derived->components;
9932 comp2 = (*code)->expr2->ts.u.derived->components;
9933
9934 t1 = NULL;
9935 for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
9936 {
9937 bool inout = false;
9938
9939 /* The intrinsic assignment does the right thing for pointers
9940 of all kinds and allocatable components. */
9941 if (comp1->ts.type != BT_DERIVED
9942 || comp1->attr.pointer
9943 || comp1->attr.allocatable
9944 || comp1->attr.proc_pointer_comp
9945 || comp1->attr.class_pointer
9946 || comp1->attr.proc_pointer)
9947 continue;
9948
9949 /* Make an assigment for this component. */
9950 this_code = build_assignment (EXEC_ASSIGN,
9951 (*code)->expr1, (*code)->expr2,
9952 comp1, comp2, (*code)->loc);
9953
9954 /* Convert the assignment if there is a defined assignment for
9955 this type. Otherwise, using the call from resolve_code,
9956 recurse into its components. */
9957 resolve_code (this_code, ns);
9958
9959 if (this_code->op == EXEC_ASSIGN_CALL)
9960 {
9961 gfc_formal_arglist *dummy_args;
9962 gfc_symbol *rsym;
9963 /* Check that there is a typebound defined assignment. If not,
9964 then this must be a module defined assignment. We cannot
9965 use the defined_assign_comp attribute here because it must
9966 be this derived type that has the defined assignment and not
9967 a parent type. */
9968 if (!(comp1->ts.u.derived->f2k_derived
9969 && comp1->ts.u.derived->f2k_derived
9970 ->tb_op[INTRINSIC_ASSIGN]))
9971 {
9972 gfc_free_statements (this_code);
9973 this_code = NULL;
9974 continue;
9975 }
9976
9977 /* If the first argument of the subroutine has intent INOUT
9978 a temporary must be generated and used instead. */
9979 rsym = this_code->resolved_sym;
9980 dummy_args = gfc_sym_get_dummy_args (rsym);
9981 if (dummy_args
9982 && dummy_args->sym->attr.intent == INTENT_INOUT)
9983 {
9984 gfc_code *temp_code;
9985 inout = true;
9986
9987 /* Build the temporary required for the assignment and put
9988 it at the head of the generated code. */
9989 if (!t1)
9990 {
9991 t1 = get_temp_from_expr ((*code)->expr1, ns);
9992 temp_code = build_assignment (EXEC_ASSIGN,
9993 t1, (*code)->expr1,
9994 NULL, NULL, (*code)->loc);
9995 add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
9996 }
9997
9998 /* Replace the first actual arg with the component of the
9999 temporary. */
10000 gfc_free_expr (this_code->ext.actual->expr);
10001 this_code->ext.actual->expr = gfc_copy_expr (t1);
10002 add_comp_ref (this_code->ext.actual->expr, comp1);
10003 }
10004 }
10005 else if (this_code->op == EXEC_ASSIGN && !this_code->next)
10006 {
10007 /* Don't add intrinsic assignments since they are already
10008 effected by the intrinsic assignment of the structure. */
10009 gfc_free_statements (this_code);
10010 this_code = NULL;
10011 continue;
10012 }
10013
10014 add_code_to_chain (&this_code, &head, &tail);
10015
10016 if (t1 && inout)
10017 {
10018 /* Transfer the value to the final result. */
10019 this_code = build_assignment (EXEC_ASSIGN,
10020 (*code)->expr1, t1,
10021 comp1, comp2, (*code)->loc);
10022 add_code_to_chain (&this_code, &head, &tail);
10023 }
10024 }
10025
10026 /* This is probably not necessary. */
10027 if (this_code)
10028 {
10029 gfc_free_statements (this_code);
10030 this_code = NULL;
10031 }
10032
10033 /* Put the temporary assignments at the top of the generated code. */
10034 if (tmp_head && component_assignment_level == 1)
10035 {
10036 gfc_append_code (tmp_head, head);
10037 head = tmp_head;
10038 tmp_head = tmp_tail = NULL;
10039 }
10040
10041 /* Now attach the remaining code chain to the input code. Step on
10042 to the end of the new code since resolution is complete. */
10043 gcc_assert ((*code)->op == EXEC_ASSIGN);
10044 tail->next = (*code)->next;
10045 /* Overwrite 'code' because this would place the intrinsic assignment
10046 before the temporary for the lhs is created. */
10047 gfc_free_expr ((*code)->expr1);
10048 gfc_free_expr ((*code)->expr2);
10049 **code = *head;
10050 free (head);
10051 *code = tail;
10052
10053 component_assignment_level--;
10054 }
10055
10056
10057 /* Given a block of code, recursively resolve everything pointed to by this
10058 code block. */
10059
10060 static void
resolve_code(gfc_code * code,gfc_namespace * ns)10061 resolve_code (gfc_code *code, gfc_namespace *ns)
10062 {
10063 int omp_workshare_save;
10064 int forall_save, do_concurrent_save;
10065 code_stack frame;
10066 gfc_try t;
10067
10068 frame.prev = cs_base;
10069 frame.head = code;
10070 cs_base = &frame;
10071
10072 find_reachable_labels (code);
10073
10074 for (; code; code = code->next)
10075 {
10076 frame.current = code;
10077 forall_save = forall_flag;
10078 do_concurrent_save = do_concurrent_flag;
10079
10080 if (code->op == EXEC_FORALL)
10081 {
10082 forall_flag = 1;
10083 gfc_resolve_forall (code, ns, forall_save);
10084 forall_flag = 2;
10085 }
10086 else if (code->block)
10087 {
10088 omp_workshare_save = -1;
10089 switch (code->op)
10090 {
10091 case EXEC_OMP_PARALLEL_WORKSHARE:
10092 omp_workshare_save = omp_workshare_flag;
10093 omp_workshare_flag = 1;
10094 gfc_resolve_omp_parallel_blocks (code, ns);
10095 break;
10096 case EXEC_OMP_PARALLEL:
10097 case EXEC_OMP_PARALLEL_DO:
10098 case EXEC_OMP_PARALLEL_SECTIONS:
10099 case EXEC_OMP_TASK:
10100 omp_workshare_save = omp_workshare_flag;
10101 omp_workshare_flag = 0;
10102 gfc_resolve_omp_parallel_blocks (code, ns);
10103 break;
10104 case EXEC_OMP_DO:
10105 gfc_resolve_omp_do_blocks (code, ns);
10106 break;
10107 case EXEC_SELECT_TYPE:
10108 /* Blocks are handled in resolve_select_type because we have
10109 to transform the SELECT TYPE into ASSOCIATE first. */
10110 break;
10111 case EXEC_DO_CONCURRENT:
10112 do_concurrent_flag = 1;
10113 gfc_resolve_blocks (code->block, ns);
10114 do_concurrent_flag = 2;
10115 break;
10116 case EXEC_OMP_WORKSHARE:
10117 omp_workshare_save = omp_workshare_flag;
10118 omp_workshare_flag = 1;
10119 /* FALL THROUGH */
10120 default:
10121 gfc_resolve_blocks (code->block, ns);
10122 break;
10123 }
10124
10125 if (omp_workshare_save != -1)
10126 omp_workshare_flag = omp_workshare_save;
10127 }
10128
10129 t = SUCCESS;
10130 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
10131 t = gfc_resolve_expr (code->expr1);
10132 forall_flag = forall_save;
10133 do_concurrent_flag = do_concurrent_save;
10134
10135 if (gfc_resolve_expr (code->expr2) == FAILURE)
10136 t = FAILURE;
10137
10138 if (code->op == EXEC_ALLOCATE
10139 && gfc_resolve_expr (code->expr3) == FAILURE)
10140 t = FAILURE;
10141
10142 switch (code->op)
10143 {
10144 case EXEC_NOP:
10145 case EXEC_END_BLOCK:
10146 case EXEC_END_NESTED_BLOCK:
10147 case EXEC_CYCLE:
10148 case EXEC_PAUSE:
10149 case EXEC_STOP:
10150 case EXEC_ERROR_STOP:
10151 case EXEC_EXIT:
10152 case EXEC_CONTINUE:
10153 case EXEC_DT_END:
10154 case EXEC_ASSIGN_CALL:
10155 case EXEC_CRITICAL:
10156 break;
10157
10158 case EXEC_SYNC_ALL:
10159 case EXEC_SYNC_IMAGES:
10160 case EXEC_SYNC_MEMORY:
10161 resolve_sync (code);
10162 break;
10163
10164 case EXEC_LOCK:
10165 case EXEC_UNLOCK:
10166 resolve_lock_unlock (code);
10167 break;
10168
10169 case EXEC_ENTRY:
10170 /* Keep track of which entry we are up to. */
10171 current_entry_id = code->ext.entry->id;
10172 break;
10173
10174 case EXEC_WHERE:
10175 resolve_where (code, NULL);
10176 break;
10177
10178 case EXEC_GOTO:
10179 if (code->expr1 != NULL)
10180 {
10181 if (code->expr1->ts.type != BT_INTEGER)
10182 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10183 "INTEGER variable", &code->expr1->where);
10184 else if (code->expr1->symtree->n.sym->attr.assign != 1)
10185 gfc_error ("Variable '%s' has not been assigned a target "
10186 "label at %L", code->expr1->symtree->n.sym->name,
10187 &code->expr1->where);
10188 }
10189 else
10190 resolve_branch (code->label1, code);
10191 break;
10192
10193 case EXEC_RETURN:
10194 if (code->expr1 != NULL
10195 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
10196 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10197 "INTEGER return specifier", &code->expr1->where);
10198 break;
10199
10200 case EXEC_INIT_ASSIGN:
10201 case EXEC_END_PROCEDURE:
10202 break;
10203
10204 case EXEC_ASSIGN:
10205 if (t == FAILURE)
10206 break;
10207
10208 if (gfc_check_vardef_context (code->expr1, false, false, false,
10209 _("assignment")) == FAILURE)
10210 break;
10211
10212 if (resolve_ordinary_assign (code, ns))
10213 {
10214 if (code->op == EXEC_COMPCALL)
10215 goto compcall;
10216 else
10217 goto call;
10218 }
10219
10220 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10221 if (code->expr1->ts.type == BT_DERIVED
10222 && code->expr1->ts.u.derived->attr.defined_assign_comp)
10223 generate_component_assignments (&code, ns);
10224
10225 break;
10226
10227 case EXEC_LABEL_ASSIGN:
10228 if (code->label1->defined == ST_LABEL_UNKNOWN)
10229 gfc_error ("Label %d referenced at %L is never defined",
10230 code->label1->value, &code->label1->where);
10231 if (t == SUCCESS
10232 && (code->expr1->expr_type != EXPR_VARIABLE
10233 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
10234 || code->expr1->symtree->n.sym->ts.kind
10235 != gfc_default_integer_kind
10236 || code->expr1->symtree->n.sym->as != NULL))
10237 gfc_error ("ASSIGN statement at %L requires a scalar "
10238 "default INTEGER variable", &code->expr1->where);
10239 break;
10240
10241 case EXEC_POINTER_ASSIGN:
10242 {
10243 gfc_expr* e;
10244
10245 if (t == FAILURE)
10246 break;
10247
10248 /* This is both a variable definition and pointer assignment
10249 context, so check both of them. For rank remapping, a final
10250 array ref may be present on the LHS and fool gfc_expr_attr
10251 used in gfc_check_vardef_context. Remove it. */
10252 e = remove_last_array_ref (code->expr1);
10253 t = gfc_check_vardef_context (e, true, false, false,
10254 _("pointer assignment"));
10255 if (t == SUCCESS)
10256 t = gfc_check_vardef_context (e, false, false, false,
10257 _("pointer assignment"));
10258 gfc_free_expr (e);
10259 if (t == FAILURE)
10260 break;
10261
10262 gfc_check_pointer_assign (code->expr1, code->expr2);
10263 break;
10264 }
10265
10266 case EXEC_ARITHMETIC_IF:
10267 if (t == SUCCESS
10268 && code->expr1->ts.type != BT_INTEGER
10269 && code->expr1->ts.type != BT_REAL)
10270 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10271 "expression", &code->expr1->where);
10272
10273 resolve_branch (code->label1, code);
10274 resolve_branch (code->label2, code);
10275 resolve_branch (code->label3, code);
10276 break;
10277
10278 case EXEC_IF:
10279 if (t == SUCCESS && code->expr1 != NULL
10280 && (code->expr1->ts.type != BT_LOGICAL
10281 || code->expr1->rank != 0))
10282 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10283 &code->expr1->where);
10284 break;
10285
10286 case EXEC_CALL:
10287 call:
10288 resolve_call (code);
10289 break;
10290
10291 case EXEC_COMPCALL:
10292 compcall:
10293 resolve_typebound_subroutine (code);
10294 break;
10295
10296 case EXEC_CALL_PPC:
10297 resolve_ppc_call (code);
10298 break;
10299
10300 case EXEC_SELECT:
10301 /* Select is complicated. Also, a SELECT construct could be
10302 a transformed computed GOTO. */
10303 resolve_select (code, false);
10304 break;
10305
10306 case EXEC_SELECT_TYPE:
10307 resolve_select_type (code, ns);
10308 break;
10309
10310 case EXEC_BLOCK:
10311 resolve_block_construct (code);
10312 break;
10313
10314 case EXEC_DO:
10315 if (code->ext.iterator != NULL)
10316 {
10317 gfc_iterator *iter = code->ext.iterator;
10318 if (gfc_resolve_iterator (iter, true, false) != FAILURE)
10319 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
10320 }
10321 break;
10322
10323 case EXEC_DO_WHILE:
10324 if (code->expr1 == NULL)
10325 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
10326 if (t == SUCCESS
10327 && (code->expr1->rank != 0
10328 || code->expr1->ts.type != BT_LOGICAL))
10329 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10330 "a scalar LOGICAL expression", &code->expr1->where);
10331 break;
10332
10333 case EXEC_ALLOCATE:
10334 if (t == SUCCESS)
10335 resolve_allocate_deallocate (code, "ALLOCATE");
10336
10337 break;
10338
10339 case EXEC_DEALLOCATE:
10340 if (t == SUCCESS)
10341 resolve_allocate_deallocate (code, "DEALLOCATE");
10342
10343 break;
10344
10345 case EXEC_OPEN:
10346 if (gfc_resolve_open (code->ext.open) == FAILURE)
10347 break;
10348
10349 resolve_branch (code->ext.open->err, code);
10350 break;
10351
10352 case EXEC_CLOSE:
10353 if (gfc_resolve_close (code->ext.close) == FAILURE)
10354 break;
10355
10356 resolve_branch (code->ext.close->err, code);
10357 break;
10358
10359 case EXEC_BACKSPACE:
10360 case EXEC_ENDFILE:
10361 case EXEC_REWIND:
10362 case EXEC_FLUSH:
10363 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
10364 break;
10365
10366 resolve_branch (code->ext.filepos->err, code);
10367 break;
10368
10369 case EXEC_INQUIRE:
10370 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
10371 break;
10372
10373 resolve_branch (code->ext.inquire->err, code);
10374 break;
10375
10376 case EXEC_IOLENGTH:
10377 gcc_assert (code->ext.inquire != NULL);
10378 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
10379 break;
10380
10381 resolve_branch (code->ext.inquire->err, code);
10382 break;
10383
10384 case EXEC_WAIT:
10385 if (gfc_resolve_wait (code->ext.wait) == FAILURE)
10386 break;
10387
10388 resolve_branch (code->ext.wait->err, code);
10389 resolve_branch (code->ext.wait->end, code);
10390 resolve_branch (code->ext.wait->eor, code);
10391 break;
10392
10393 case EXEC_READ:
10394 case EXEC_WRITE:
10395 if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
10396 break;
10397
10398 resolve_branch (code->ext.dt->err, code);
10399 resolve_branch (code->ext.dt->end, code);
10400 resolve_branch (code->ext.dt->eor, code);
10401 break;
10402
10403 case EXEC_TRANSFER:
10404 resolve_transfer (code);
10405 break;
10406
10407 case EXEC_DO_CONCURRENT:
10408 case EXEC_FORALL:
10409 resolve_forall_iterators (code->ext.forall_iterator);
10410
10411 if (code->expr1 != NULL
10412 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
10413 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10414 "expression", &code->expr1->where);
10415 break;
10416
10417 case EXEC_OMP_ATOMIC:
10418 case EXEC_OMP_BARRIER:
10419 case EXEC_OMP_CRITICAL:
10420 case EXEC_OMP_FLUSH:
10421 case EXEC_OMP_DO:
10422 case EXEC_OMP_MASTER:
10423 case EXEC_OMP_ORDERED:
10424 case EXEC_OMP_SECTIONS:
10425 case EXEC_OMP_SINGLE:
10426 case EXEC_OMP_TASKWAIT:
10427 case EXEC_OMP_TASKYIELD:
10428 case EXEC_OMP_WORKSHARE:
10429 gfc_resolve_omp_directive (code, ns);
10430 break;
10431
10432 case EXEC_OMP_PARALLEL:
10433 case EXEC_OMP_PARALLEL_DO:
10434 case EXEC_OMP_PARALLEL_SECTIONS:
10435 case EXEC_OMP_PARALLEL_WORKSHARE:
10436 case EXEC_OMP_TASK:
10437 omp_workshare_save = omp_workshare_flag;
10438 omp_workshare_flag = 0;
10439 gfc_resolve_omp_directive (code, ns);
10440 omp_workshare_flag = omp_workshare_save;
10441 break;
10442
10443 default:
10444 gfc_internal_error ("resolve_code(): Bad statement code");
10445 }
10446 }
10447
10448 cs_base = frame.prev;
10449 }
10450
10451
10452 /* Resolve initial values and make sure they are compatible with
10453 the variable. */
10454
10455 static void
resolve_values(gfc_symbol * sym)10456 resolve_values (gfc_symbol *sym)
10457 {
10458 gfc_try t;
10459
10460 if (sym->value == NULL)
10461 return;
10462
10463 if (sym->value->expr_type == EXPR_STRUCTURE)
10464 t= resolve_structure_cons (sym->value, 1);
10465 else
10466 t = gfc_resolve_expr (sym->value);
10467
10468 if (t == FAILURE)
10469 return;
10470
10471 gfc_check_assign_symbol (sym, NULL, sym->value);
10472 }
10473
10474
10475 /* Verify the binding labels for common blocks that are BIND(C). The label
10476 for a BIND(C) common block must be identical in all scoping units in which
10477 the common block is declared. Further, the binding label can not collide
10478 with any other global entity in the program. */
10479
10480 static void
resolve_bind_c_comms(gfc_symtree * comm_block_tree)10481 resolve_bind_c_comms (gfc_symtree *comm_block_tree)
10482 {
10483 if (comm_block_tree->n.common->is_bind_c == 1)
10484 {
10485 gfc_gsymbol *binding_label_gsym;
10486 gfc_gsymbol *comm_name_gsym;
10487 const char * bind_label = comm_block_tree->n.common->binding_label
10488 ? comm_block_tree->n.common->binding_label : "";
10489
10490 /* See if a global symbol exists by the common block's name. It may
10491 be NULL if the common block is use-associated. */
10492 comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
10493 comm_block_tree->n.common->name);
10494 if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
10495 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
10496 "with the global entity '%s' at %L",
10497 bind_label,
10498 comm_block_tree->n.common->name,
10499 &(comm_block_tree->n.common->where),
10500 comm_name_gsym->name, &(comm_name_gsym->where));
10501 else if (comm_name_gsym != NULL
10502 && strcmp (comm_name_gsym->name,
10503 comm_block_tree->n.common->name) == 0)
10504 {
10505 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
10506 as expected. */
10507 if (comm_name_gsym->binding_label == NULL)
10508 /* No binding label for common block stored yet; save this one. */
10509 comm_name_gsym->binding_label = bind_label;
10510 else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
10511 {
10512 /* Common block names match but binding labels do not. */
10513 gfc_error ("Binding label '%s' for common block '%s' at %L "
10514 "does not match the binding label '%s' for common "
10515 "block '%s' at %L",
10516 bind_label,
10517 comm_block_tree->n.common->name,
10518 &(comm_block_tree->n.common->where),
10519 comm_name_gsym->binding_label,
10520 comm_name_gsym->name,
10521 &(comm_name_gsym->where));
10522 return;
10523 }
10524 }
10525
10526 /* There is no binding label (NAME="") so we have nothing further to
10527 check and nothing to add as a global symbol for the label. */
10528 if (!comm_block_tree->n.common->binding_label)
10529 return;
10530
10531 binding_label_gsym =
10532 gfc_find_gsymbol (gfc_gsym_root,
10533 comm_block_tree->n.common->binding_label);
10534 if (binding_label_gsym == NULL)
10535 {
10536 /* Need to make a global symbol for the binding label to prevent
10537 it from colliding with another. */
10538 binding_label_gsym =
10539 gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
10540 binding_label_gsym->sym_name = comm_block_tree->n.common->name;
10541 binding_label_gsym->type = GSYM_COMMON;
10542 }
10543 else
10544 {
10545 /* If comm_name_gsym is NULL, the name common block is use
10546 associated and the name could be colliding. */
10547 if (binding_label_gsym->type != GSYM_COMMON)
10548 gfc_error ("Binding label '%s' for common block '%s' at %L "
10549 "collides with the global entity '%s' at %L",
10550 comm_block_tree->n.common->binding_label,
10551 comm_block_tree->n.common->name,
10552 &(comm_block_tree->n.common->where),
10553 binding_label_gsym->name,
10554 &(binding_label_gsym->where));
10555 else if (comm_name_gsym != NULL
10556 && (strcmp (binding_label_gsym->name,
10557 comm_name_gsym->binding_label) != 0)
10558 && (strcmp (binding_label_gsym->sym_name,
10559 comm_name_gsym->name) != 0))
10560 gfc_error ("Binding label '%s' for common block '%s' at %L "
10561 "collides with global entity '%s' at %L",
10562 binding_label_gsym->name, binding_label_gsym->sym_name,
10563 &(comm_block_tree->n.common->where),
10564 comm_name_gsym->name, &(comm_name_gsym->where));
10565 }
10566 }
10567
10568 return;
10569 }
10570
10571
10572 /* Verify any BIND(C) derived types in the namespace so we can report errors
10573 for them once, rather than for each variable declared of that type. */
10574
10575 static void
resolve_bind_c_derived_types(gfc_symbol * derived_sym)10576 resolve_bind_c_derived_types (gfc_symbol *derived_sym)
10577 {
10578 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
10579 && derived_sym->attr.is_bind_c == 1)
10580 verify_bind_c_derived_type (derived_sym);
10581
10582 return;
10583 }
10584
10585
10586 /* Verify that any binding labels used in a given namespace do not collide
10587 with the names or binding labels of any global symbols. */
10588
10589 static void
gfc_verify_binding_labels(gfc_symbol * sym)10590 gfc_verify_binding_labels (gfc_symbol *sym)
10591 {
10592 int has_error = 0;
10593
10594 if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
10595 && sym->attr.flavor != FL_DERIVED && sym->binding_label)
10596 {
10597 gfc_gsymbol *bind_c_sym;
10598
10599 bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
10600 if (bind_c_sym != NULL
10601 && strcmp (bind_c_sym->name, sym->binding_label) == 0)
10602 {
10603 if (sym->attr.if_source == IFSRC_DECL
10604 && (bind_c_sym->type != GSYM_SUBROUTINE
10605 && bind_c_sym->type != GSYM_FUNCTION)
10606 && ((sym->attr.contained == 1
10607 && strcmp (bind_c_sym->sym_name, sym->name) != 0)
10608 || (sym->attr.use_assoc == 1
10609 && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
10610 {
10611 /* Make sure global procedures don't collide with anything. */
10612 gfc_error ("Binding label '%s' at %L collides with the global "
10613 "entity '%s' at %L", sym->binding_label,
10614 &(sym->declared_at), bind_c_sym->name,
10615 &(bind_c_sym->where));
10616 has_error = 1;
10617 }
10618 else if (sym->attr.contained == 0
10619 && (sym->attr.if_source == IFSRC_IFBODY
10620 && sym->attr.flavor == FL_PROCEDURE)
10621 && (bind_c_sym->sym_name != NULL
10622 && strcmp (bind_c_sym->sym_name, sym->name) != 0))
10623 {
10624 /* Make sure procedures in interface bodies don't collide. */
10625 gfc_error ("Binding label '%s' in interface body at %L collides "
10626 "with the global entity '%s' at %L",
10627 sym->binding_label,
10628 &(sym->declared_at), bind_c_sym->name,
10629 &(bind_c_sym->where));
10630 has_error = 1;
10631 }
10632 else if (sym->attr.contained == 0
10633 && sym->attr.if_source == IFSRC_UNKNOWN)
10634 if ((sym->attr.use_assoc && bind_c_sym->mod_name
10635 && strcmp (bind_c_sym->mod_name, sym->module) != 0)
10636 || sym->attr.use_assoc == 0)
10637 {
10638 gfc_error ("Binding label '%s' at %L collides with global "
10639 "entity '%s' at %L", sym->binding_label,
10640 &(sym->declared_at), bind_c_sym->name,
10641 &(bind_c_sym->where));
10642 has_error = 1;
10643 }
10644
10645 if (has_error != 0)
10646 /* Clear the binding label to prevent checking multiple times. */
10647 sym->binding_label = NULL;
10648 }
10649 else if (bind_c_sym == NULL)
10650 {
10651 bind_c_sym = gfc_get_gsymbol (sym->binding_label);
10652 bind_c_sym->where = sym->declared_at;
10653 bind_c_sym->sym_name = sym->name;
10654
10655 if (sym->attr.use_assoc == 1)
10656 bind_c_sym->mod_name = sym->module;
10657 else
10658 if (sym->ns->proc_name != NULL)
10659 bind_c_sym->mod_name = sym->ns->proc_name->name;
10660
10661 if (sym->attr.contained == 0)
10662 {
10663 if (sym->attr.subroutine)
10664 bind_c_sym->type = GSYM_SUBROUTINE;
10665 else if (sym->attr.function)
10666 bind_c_sym->type = GSYM_FUNCTION;
10667 }
10668 }
10669 }
10670 return;
10671 }
10672
10673
10674 /* Resolve an index expression. */
10675
10676 static gfc_try
resolve_index_expr(gfc_expr * e)10677 resolve_index_expr (gfc_expr *e)
10678 {
10679 if (gfc_resolve_expr (e) == FAILURE)
10680 return FAILURE;
10681
10682 if (gfc_simplify_expr (e, 0) == FAILURE)
10683 return FAILURE;
10684
10685 if (gfc_specification_expr (e) == FAILURE)
10686 return FAILURE;
10687
10688 return SUCCESS;
10689 }
10690
10691
10692 /* Resolve a charlen structure. */
10693
10694 static gfc_try
resolve_charlen(gfc_charlen * cl)10695 resolve_charlen (gfc_charlen *cl)
10696 {
10697 int i, k;
10698 bool saved_specification_expr;
10699
10700 if (cl->resolved)
10701 return SUCCESS;
10702
10703 cl->resolved = 1;
10704 saved_specification_expr = specification_expr;
10705 specification_expr = true;
10706
10707 if (cl->length_from_typespec)
10708 {
10709 if (gfc_resolve_expr (cl->length) == FAILURE)
10710 {
10711 specification_expr = saved_specification_expr;
10712 return FAILURE;
10713 }
10714
10715 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
10716 {
10717 specification_expr = saved_specification_expr;
10718 return FAILURE;
10719 }
10720 }
10721 else
10722 {
10723
10724 if (resolve_index_expr (cl->length) == FAILURE)
10725 {
10726 specification_expr = saved_specification_expr;
10727 return FAILURE;
10728 }
10729 }
10730
10731 /* "If the character length parameter value evaluates to a negative
10732 value, the length of character entities declared is zero." */
10733 if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
10734 {
10735 if (gfc_option.warn_surprising)
10736 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10737 " the length has been set to zero",
10738 &cl->length->where, i);
10739 gfc_replace_expr (cl->length,
10740 gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
10741 }
10742
10743 /* Check that the character length is not too large. */
10744 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
10745 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
10746 && cl->length->ts.type == BT_INTEGER
10747 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
10748 {
10749 gfc_error ("String length at %L is too large", &cl->length->where);
10750 specification_expr = saved_specification_expr;
10751 return FAILURE;
10752 }
10753
10754 specification_expr = saved_specification_expr;
10755 return SUCCESS;
10756 }
10757
10758
10759 /* Test for non-constant shape arrays. */
10760
10761 static bool
is_non_constant_shape_array(gfc_symbol * sym)10762 is_non_constant_shape_array (gfc_symbol *sym)
10763 {
10764 gfc_expr *e;
10765 int i;
10766 bool not_constant;
10767
10768 not_constant = false;
10769 if (sym->as != NULL)
10770 {
10771 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10772 has not been simplified; parameter array references. Do the
10773 simplification now. */
10774 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
10775 {
10776 e = sym->as->lower[i];
10777 if (e && (resolve_index_expr (e) == FAILURE
10778 || !gfc_is_constant_expr (e)))
10779 not_constant = true;
10780 e = sym->as->upper[i];
10781 if (e && (resolve_index_expr (e) == FAILURE
10782 || !gfc_is_constant_expr (e)))
10783 not_constant = true;
10784 }
10785 }
10786 return not_constant;
10787 }
10788
10789 /* Given a symbol and an initialization expression, add code to initialize
10790 the symbol to the function entry. */
10791 static void
build_init_assign(gfc_symbol * sym,gfc_expr * init)10792 build_init_assign (gfc_symbol *sym, gfc_expr *init)
10793 {
10794 gfc_expr *lval;
10795 gfc_code *init_st;
10796 gfc_namespace *ns = sym->ns;
10797
10798 /* Search for the function namespace if this is a contained
10799 function without an explicit result. */
10800 if (sym->attr.function && sym == sym->result
10801 && sym->name != sym->ns->proc_name->name)
10802 {
10803 ns = ns->contained;
10804 for (;ns; ns = ns->sibling)
10805 if (strcmp (ns->proc_name->name, sym->name) == 0)
10806 break;
10807 }
10808
10809 if (ns == NULL)
10810 {
10811 gfc_free_expr (init);
10812 return;
10813 }
10814
10815 /* Build an l-value expression for the result. */
10816 lval = gfc_lval_expr_from_sym (sym);
10817
10818 /* Add the code at scope entry. */
10819 init_st = gfc_get_code ();
10820 init_st->next = ns->code;
10821 ns->code = init_st;
10822
10823 /* Assign the default initializer to the l-value. */
10824 init_st->loc = sym->declared_at;
10825 init_st->op = EXEC_INIT_ASSIGN;
10826 init_st->expr1 = lval;
10827 init_st->expr2 = init;
10828 }
10829
10830 /* Assign the default initializer to a derived type variable or result. */
10831
10832 static void
apply_default_init(gfc_symbol * sym)10833 apply_default_init (gfc_symbol *sym)
10834 {
10835 gfc_expr *init = NULL;
10836
10837 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
10838 return;
10839
10840 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
10841 init = gfc_default_initializer (&sym->ts);
10842
10843 if (init == NULL && sym->ts.type != BT_CLASS)
10844 return;
10845
10846 build_init_assign (sym, init);
10847 sym->attr.referenced = 1;
10848 }
10849
10850 /* Build an initializer for a local integer, real, complex, logical, or
10851 character variable, based on the command line flags finit-local-zero,
10852 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10853 null if the symbol should not have a default initialization. */
10854 static gfc_expr *
build_default_init_expr(gfc_symbol * sym)10855 build_default_init_expr (gfc_symbol *sym)
10856 {
10857 int char_len;
10858 gfc_expr *init_expr;
10859 int i;
10860
10861 /* These symbols should never have a default initialization. */
10862 if (sym->attr.allocatable
10863 || sym->attr.external
10864 || sym->attr.dummy
10865 || sym->attr.pointer
10866 || sym->attr.in_equivalence
10867 || sym->attr.in_common
10868 || sym->attr.data
10869 || sym->module
10870 || sym->attr.cray_pointee
10871 || sym->attr.cray_pointer
10872 || sym->assoc)
10873 return NULL;
10874
10875 /* Now we'll try to build an initializer expression. */
10876 init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
10877 &sym->declared_at);
10878
10879 /* We will only initialize integers, reals, complex, logicals, and
10880 characters, and only if the corresponding command-line flags
10881 were set. Otherwise, we free init_expr and return null. */
10882 switch (sym->ts.type)
10883 {
10884 case BT_INTEGER:
10885 if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
10886 mpz_set_si (init_expr->value.integer,
10887 gfc_option.flag_init_integer_value);
10888 else
10889 {
10890 gfc_free_expr (init_expr);
10891 init_expr = NULL;
10892 }
10893 break;
10894
10895 case BT_REAL:
10896 switch (gfc_option.flag_init_real)
10897 {
10898 case GFC_INIT_REAL_SNAN:
10899 init_expr->is_snan = 1;
10900 /* Fall through. */
10901 case GFC_INIT_REAL_NAN:
10902 mpfr_set_nan (init_expr->value.real);
10903 break;
10904
10905 case GFC_INIT_REAL_INF:
10906 mpfr_set_inf (init_expr->value.real, 1);
10907 break;
10908
10909 case GFC_INIT_REAL_NEG_INF:
10910 mpfr_set_inf (init_expr->value.real, -1);
10911 break;
10912
10913 case GFC_INIT_REAL_ZERO:
10914 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
10915 break;
10916
10917 default:
10918 gfc_free_expr (init_expr);
10919 init_expr = NULL;
10920 break;
10921 }
10922 break;
10923
10924 case BT_COMPLEX:
10925 switch (gfc_option.flag_init_real)
10926 {
10927 case GFC_INIT_REAL_SNAN:
10928 init_expr->is_snan = 1;
10929 /* Fall through. */
10930 case GFC_INIT_REAL_NAN:
10931 mpfr_set_nan (mpc_realref (init_expr->value.complex));
10932 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
10933 break;
10934
10935 case GFC_INIT_REAL_INF:
10936 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
10937 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
10938 break;
10939
10940 case GFC_INIT_REAL_NEG_INF:
10941 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
10942 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
10943 break;
10944
10945 case GFC_INIT_REAL_ZERO:
10946 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
10947 break;
10948
10949 default:
10950 gfc_free_expr (init_expr);
10951 init_expr = NULL;
10952 break;
10953 }
10954 break;
10955
10956 case BT_LOGICAL:
10957 if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
10958 init_expr->value.logical = 0;
10959 else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
10960 init_expr->value.logical = 1;
10961 else
10962 {
10963 gfc_free_expr (init_expr);
10964 init_expr = NULL;
10965 }
10966 break;
10967
10968 case BT_CHARACTER:
10969 /* For characters, the length must be constant in order to
10970 create a default initializer. */
10971 if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10972 && sym->ts.u.cl->length
10973 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
10974 {
10975 char_len = mpz_get_si (sym->ts.u.cl->length->value.integer);
10976 init_expr->value.character.length = char_len;
10977 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
10978 for (i = 0; i < char_len; i++)
10979 init_expr->value.character.string[i]
10980 = (unsigned char) gfc_option.flag_init_character_value;
10981 }
10982 else
10983 {
10984 gfc_free_expr (init_expr);
10985 init_expr = NULL;
10986 }
10987 if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
10988 && sym->ts.u.cl->length)
10989 {
10990 gfc_actual_arglist *arg;
10991 init_expr = gfc_get_expr ();
10992 init_expr->where = sym->declared_at;
10993 init_expr->ts = sym->ts;
10994 init_expr->expr_type = EXPR_FUNCTION;
10995 init_expr->value.function.isym =
10996 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
10997 init_expr->value.function.name = "repeat";
10998 arg = gfc_get_actual_arglist ();
10999 arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at,
11000 NULL, 1);
11001 arg->expr->value.character.string[0]
11002 = gfc_option.flag_init_character_value;
11003 arg->next = gfc_get_actual_arglist ();
11004 arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length);
11005 init_expr->value.function.actual = arg;
11006 }
11007 break;
11008
11009 default:
11010 gfc_free_expr (init_expr);
11011 init_expr = NULL;
11012 }
11013 return init_expr;
11014 }
11015
11016 /* Add an initialization expression to a local variable. */
11017 static void
apply_default_init_local(gfc_symbol * sym)11018 apply_default_init_local (gfc_symbol *sym)
11019 {
11020 gfc_expr *init = NULL;
11021
11022 /* The symbol should be a variable or a function return value. */
11023 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
11024 || (sym->attr.function && sym->result != sym))
11025 return;
11026
11027 /* Try to build the initializer expression. If we can't initialize
11028 this symbol, then init will be NULL. */
11029 init = build_default_init_expr (sym);
11030 if (init == NULL)
11031 return;
11032
11033 /* For saved variables, we don't want to add an initializer at function
11034 entry, so we just add a static initializer. Note that automatic variables
11035 are stack allocated even with -fno-automatic; we have also to exclude
11036 result variable, which are also nonstatic. */
11037 if (sym->attr.save || sym->ns->save_all
11038 || (gfc_option.flag_max_stack_var_size == 0 && !sym->attr.result
11039 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
11040 {
11041 /* Don't clobber an existing initializer! */
11042 gcc_assert (sym->value == NULL);
11043 sym->value = init;
11044 return;
11045 }
11046
11047 build_init_assign (sym, init);
11048 }
11049
11050
11051 /* Resolution of common features of flavors variable and procedure. */
11052
11053 static gfc_try
resolve_fl_var_and_proc(gfc_symbol * sym,int mp_flag)11054 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
11055 {
11056 gfc_array_spec *as;
11057
11058 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
11059 as = CLASS_DATA (sym)->as;
11060 else
11061 as = sym->as;
11062
11063 /* Constraints on deferred shape variable. */
11064 if (as == NULL || as->type != AS_DEFERRED)
11065 {
11066 bool pointer, allocatable, dimension;
11067
11068 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
11069 {
11070 pointer = CLASS_DATA (sym)->attr.class_pointer;
11071 allocatable = CLASS_DATA (sym)->attr.allocatable;
11072 dimension = CLASS_DATA (sym)->attr.dimension;
11073 }
11074 else
11075 {
11076 pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
11077 allocatable = sym->attr.allocatable;
11078 dimension = sym->attr.dimension;
11079 }
11080
11081 if (allocatable)
11082 {
11083 if (dimension && as->type != AS_ASSUMED_RANK)
11084 {
11085 gfc_error ("Allocatable array '%s' at %L must have a deferred "
11086 "shape or assumed rank", sym->name, &sym->declared_at);
11087 return FAILURE;
11088 }
11089 else if (gfc_notify_std (GFC_STD_F2003, "Scalar object "
11090 "'%s' at %L may not be ALLOCATABLE",
11091 sym->name, &sym->declared_at) == FAILURE)
11092 return FAILURE;
11093 }
11094
11095 if (pointer && dimension && as->type != AS_ASSUMED_RANK)
11096 {
11097 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
11098 "assumed rank", sym->name, &sym->declared_at);
11099 return FAILURE;
11100 }
11101 }
11102 else
11103 {
11104 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
11105 && sym->ts.type != BT_CLASS && !sym->assoc)
11106 {
11107 gfc_error ("Array '%s' at %L cannot have a deferred shape",
11108 sym->name, &sym->declared_at);
11109 return FAILURE;
11110 }
11111 }
11112
11113 /* Constraints on polymorphic variables. */
11114 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
11115 {
11116 /* F03:C502. */
11117 if (sym->attr.class_ok
11118 && !sym->attr.select_type_temporary
11119 && !UNLIMITED_POLY(sym)
11120 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
11121 {
11122 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
11123 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
11124 &sym->declared_at);
11125 return FAILURE;
11126 }
11127
11128 /* F03:C509. */
11129 /* Assume that use associated symbols were checked in the module ns.
11130 Class-variables that are associate-names are also something special
11131 and excepted from the test. */
11132 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
11133 {
11134 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
11135 "or pointer", sym->name, &sym->declared_at);
11136 return FAILURE;
11137 }
11138 }
11139
11140 return SUCCESS;
11141 }
11142
11143
11144 /* Additional checks for symbols with flavor variable and derived
11145 type. To be called from resolve_fl_variable. */
11146
11147 static gfc_try
resolve_fl_variable_derived(gfc_symbol * sym,int no_init_flag)11148 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
11149 {
11150 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
11151
11152 /* Check to see if a derived type is blocked from being host
11153 associated by the presence of another class I symbol in the same
11154 namespace. 14.6.1.3 of the standard and the discussion on
11155 comp.lang.fortran. */
11156 if (sym->ns != sym->ts.u.derived->ns
11157 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
11158 {
11159 gfc_symbol *s;
11160 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
11161 if (s && s->attr.generic)
11162 s = gfc_find_dt_in_generic (s);
11163 if (s && s->attr.flavor != FL_DERIVED)
11164 {
11165 gfc_error ("The type '%s' cannot be host associated at %L "
11166 "because it is blocked by an incompatible object "
11167 "of the same name declared at %L",
11168 sym->ts.u.derived->name, &sym->declared_at,
11169 &s->declared_at);
11170 return FAILURE;
11171 }
11172 }
11173
11174 /* 4th constraint in section 11.3: "If an object of a type for which
11175 component-initialization is specified (R429) appears in the
11176 specification-part of a module and does not have the ALLOCATABLE
11177 or POINTER attribute, the object shall have the SAVE attribute."
11178
11179 The check for initializers is performed with
11180 gfc_has_default_initializer because gfc_default_initializer generates
11181 a hidden default for allocatable components. */
11182 if (!(sym->value || no_init_flag) && sym->ns->proc_name
11183 && sym->ns->proc_name->attr.flavor == FL_MODULE
11184 && !sym->ns->save_all && !sym->attr.save
11185 && !sym->attr.pointer && !sym->attr.allocatable
11186 && gfc_has_default_initializer (sym->ts.u.derived)
11187 && gfc_notify_std (GFC_STD_F2008, "Implied SAVE for "
11188 "module variable '%s' at %L, needed due to "
11189 "the default initialization", sym->name,
11190 &sym->declared_at) == FAILURE)
11191 return FAILURE;
11192
11193 /* Assign default initializer. */
11194 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
11195 && (!no_init_flag || sym->attr.intent == INTENT_OUT))
11196 {
11197 sym->value = gfc_default_initializer (&sym->ts);
11198 }
11199
11200 return SUCCESS;
11201 }
11202
11203
11204 /* Resolve symbols with flavor variable. */
11205
11206 static gfc_try
resolve_fl_variable(gfc_symbol * sym,int mp_flag)11207 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
11208 {
11209 int no_init_flag, automatic_flag;
11210 gfc_expr *e;
11211 const char *auto_save_msg;
11212 bool saved_specification_expr;
11213
11214 auto_save_msg = "Automatic object '%s' at %L cannot have the "
11215 "SAVE attribute";
11216
11217 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
11218 return FAILURE;
11219
11220 /* Set this flag to check that variables are parameters of all entries.
11221 This check is effected by the call to gfc_resolve_expr through
11222 is_non_constant_shape_array. */
11223 saved_specification_expr = specification_expr;
11224 specification_expr = true;
11225
11226 if (sym->ns->proc_name
11227 && (sym->ns->proc_name->attr.flavor == FL_MODULE
11228 || sym->ns->proc_name->attr.is_main_program)
11229 && !sym->attr.use_assoc
11230 && !sym->attr.allocatable
11231 && !sym->attr.pointer
11232 && is_non_constant_shape_array (sym))
11233 {
11234 /* The shape of a main program or module array needs to be
11235 constant. */
11236 gfc_error ("The module or main program array '%s' at %L must "
11237 "have constant shape", sym->name, &sym->declared_at);
11238 specification_expr = saved_specification_expr;
11239 return FAILURE;
11240 }
11241
11242 /* Constraints on deferred type parameter. */
11243 if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
11244 {
11245 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
11246 "requires either the pointer or allocatable attribute",
11247 sym->name, &sym->declared_at);
11248 specification_expr = saved_specification_expr;
11249 return FAILURE;
11250 }
11251
11252 if (sym->ts.type == BT_CHARACTER)
11253 {
11254 /* Make sure that character string variables with assumed length are
11255 dummy arguments. */
11256 e = sym->ts.u.cl->length;
11257 if (e == NULL && !sym->attr.dummy && !sym->attr.result
11258 && !sym->ts.deferred && !sym->attr.select_type_temporary)
11259 {
11260 gfc_error ("Entity with assumed character length at %L must be a "
11261 "dummy argument or a PARAMETER", &sym->declared_at);
11262 specification_expr = saved_specification_expr;
11263 return FAILURE;
11264 }
11265
11266 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
11267 {
11268 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
11269 specification_expr = saved_specification_expr;
11270 return FAILURE;
11271 }
11272
11273 if (!gfc_is_constant_expr (e)
11274 && !(e->expr_type == EXPR_VARIABLE
11275 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
11276 {
11277 if (!sym->attr.use_assoc && sym->ns->proc_name
11278 && (sym->ns->proc_name->attr.flavor == FL_MODULE
11279 || sym->ns->proc_name->attr.is_main_program))
11280 {
11281 gfc_error ("'%s' at %L must have constant character length "
11282 "in this context", sym->name, &sym->declared_at);
11283 specification_expr = saved_specification_expr;
11284 return FAILURE;
11285 }
11286 if (sym->attr.in_common)
11287 {
11288 gfc_error ("COMMON variable '%s' at %L must have constant "
11289 "character length", sym->name, &sym->declared_at);
11290 specification_expr = saved_specification_expr;
11291 return FAILURE;
11292 }
11293 }
11294 }
11295
11296 if (sym->value == NULL && sym->attr.referenced)
11297 apply_default_init_local (sym); /* Try to apply a default initialization. */
11298
11299 /* Determine if the symbol may not have an initializer. */
11300 no_init_flag = automatic_flag = 0;
11301 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
11302 || sym->attr.intrinsic || sym->attr.result)
11303 no_init_flag = 1;
11304 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
11305 && is_non_constant_shape_array (sym))
11306 {
11307 no_init_flag = automatic_flag = 1;
11308
11309 /* Also, they must not have the SAVE attribute.
11310 SAVE_IMPLICIT is checked below. */
11311 if (sym->as && sym->attr.codimension)
11312 {
11313 int corank = sym->as->corank;
11314 sym->as->corank = 0;
11315 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
11316 sym->as->corank = corank;
11317 }
11318 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
11319 {
11320 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
11321 specification_expr = saved_specification_expr;
11322 return FAILURE;
11323 }
11324 }
11325
11326 /* Ensure that any initializer is simplified. */
11327 if (sym->value)
11328 gfc_simplify_expr (sym->value, 1);
11329
11330 /* Reject illegal initializers. */
11331 if (!sym->mark && sym->value)
11332 {
11333 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
11334 && CLASS_DATA (sym)->attr.allocatable))
11335 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
11336 sym->name, &sym->declared_at);
11337 else if (sym->attr.external)
11338 gfc_error ("External '%s' at %L cannot have an initializer",
11339 sym->name, &sym->declared_at);
11340 else if (sym->attr.dummy
11341 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
11342 gfc_error ("Dummy '%s' at %L cannot have an initializer",
11343 sym->name, &sym->declared_at);
11344 else if (sym->attr.intrinsic)
11345 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
11346 sym->name, &sym->declared_at);
11347 else if (sym->attr.result)
11348 gfc_error ("Function result '%s' at %L cannot have an initializer",
11349 sym->name, &sym->declared_at);
11350 else if (automatic_flag)
11351 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
11352 sym->name, &sym->declared_at);
11353 else
11354 goto no_init_error;
11355 specification_expr = saved_specification_expr;
11356 return FAILURE;
11357 }
11358
11359 no_init_error:
11360 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
11361 {
11362 gfc_try res = resolve_fl_variable_derived (sym, no_init_flag);
11363 specification_expr = saved_specification_expr;
11364 return res;
11365 }
11366
11367 specification_expr = saved_specification_expr;
11368 return SUCCESS;
11369 }
11370
11371
11372 /* Resolve a procedure. */
11373
11374 static gfc_try
resolve_fl_procedure(gfc_symbol * sym,int mp_flag)11375 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
11376 {
11377 gfc_formal_arglist *arg;
11378
11379 if (sym->attr.function
11380 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
11381 return FAILURE;
11382
11383 if (sym->ts.type == BT_CHARACTER)
11384 {
11385 gfc_charlen *cl = sym->ts.u.cl;
11386
11387 if (cl && cl->length && gfc_is_constant_expr (cl->length)
11388 && resolve_charlen (cl) == FAILURE)
11389 return FAILURE;
11390
11391 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
11392 && sym->attr.proc == PROC_ST_FUNCTION)
11393 {
11394 gfc_error ("Character-valued statement function '%s' at %L must "
11395 "have constant length", sym->name, &sym->declared_at);
11396 return FAILURE;
11397 }
11398 }
11399
11400 /* Ensure that derived type for are not of a private type. Internal
11401 module procedures are excluded by 2.2.3.3 - i.e., they are not
11402 externally accessible and can access all the objects accessible in
11403 the host. */
11404 if (!(sym->ns->parent
11405 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
11406 && gfc_check_symbol_access (sym))
11407 {
11408 gfc_interface *iface;
11409
11410 for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
11411 {
11412 if (arg->sym
11413 && arg->sym->ts.type == BT_DERIVED
11414 && !arg->sym->ts.u.derived->attr.use_assoc
11415 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11416 && gfc_notify_std (GFC_STD_F2003, "'%s' is of a "
11417 "PRIVATE type and cannot be a dummy argument"
11418 " of '%s', which is PUBLIC at %L",
11419 arg->sym->name, sym->name, &sym->declared_at)
11420 == FAILURE)
11421 {
11422 /* Stop this message from recurring. */
11423 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11424 return FAILURE;
11425 }
11426 }
11427
11428 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11429 PRIVATE to the containing module. */
11430 for (iface = sym->generic; iface; iface = iface->next)
11431 {
11432 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
11433 {
11434 if (arg->sym
11435 && arg->sym->ts.type == BT_DERIVED
11436 && !arg->sym->ts.u.derived->attr.use_assoc
11437 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11438 && gfc_notify_std (GFC_STD_F2003, "Procedure "
11439 "'%s' in PUBLIC interface '%s' at %L "
11440 "takes dummy arguments of '%s' which is "
11441 "PRIVATE", iface->sym->name, sym->name,
11442 &iface->sym->declared_at,
11443 gfc_typename (&arg->sym->ts)) == FAILURE)
11444 {
11445 /* Stop this message from recurring. */
11446 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11447 return FAILURE;
11448 }
11449 }
11450 }
11451
11452 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11453 PRIVATE to the containing module. */
11454 for (iface = sym->generic; iface; iface = iface->next)
11455 {
11456 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
11457 {
11458 if (arg->sym
11459 && arg->sym->ts.type == BT_DERIVED
11460 && !arg->sym->ts.u.derived->attr.use_assoc
11461 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
11462 && gfc_notify_std (GFC_STD_F2003, "Procedure "
11463 "'%s' in PUBLIC interface '%s' at %L "
11464 "takes dummy arguments of '%s' which is "
11465 "PRIVATE", iface->sym->name, sym->name,
11466 &iface->sym->declared_at,
11467 gfc_typename (&arg->sym->ts)) == FAILURE)
11468 {
11469 /* Stop this message from recurring. */
11470 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
11471 return FAILURE;
11472 }
11473 }
11474 }
11475 }
11476
11477 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
11478 && !sym->attr.proc_pointer)
11479 {
11480 gfc_error ("Function '%s' at %L cannot have an initializer",
11481 sym->name, &sym->declared_at);
11482 return FAILURE;
11483 }
11484
11485 /* An external symbol may not have an initializer because it is taken to be
11486 a procedure. Exception: Procedure Pointers. */
11487 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
11488 {
11489 gfc_error ("External object '%s' at %L may not have an initializer",
11490 sym->name, &sym->declared_at);
11491 return FAILURE;
11492 }
11493
11494 /* An elemental function is required to return a scalar 12.7.1 */
11495 if (sym->attr.elemental && sym->attr.function && sym->as)
11496 {
11497 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11498 "result", sym->name, &sym->declared_at);
11499 /* Reset so that the error only occurs once. */
11500 sym->attr.elemental = 0;
11501 return FAILURE;
11502 }
11503
11504 if (sym->attr.proc == PROC_ST_FUNCTION
11505 && (sym->attr.allocatable || sym->attr.pointer))
11506 {
11507 gfc_error ("Statement function '%s' at %L may not have pointer or "
11508 "allocatable attribute", sym->name, &sym->declared_at);
11509 return FAILURE;
11510 }
11511
11512 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11513 char-len-param shall not be array-valued, pointer-valued, recursive
11514 or pure. ....snip... A character value of * may only be used in the
11515 following ways: (i) Dummy arg of procedure - dummy associates with
11516 actual length; (ii) To declare a named constant; or (iii) External
11517 function - but length must be declared in calling scoping unit. */
11518 if (sym->attr.function
11519 && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
11520 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
11521 {
11522 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
11523 || (sym->attr.recursive) || (sym->attr.pure))
11524 {
11525 if (sym->as && sym->as->rank)
11526 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11527 "array-valued", sym->name, &sym->declared_at);
11528
11529 if (sym->attr.pointer)
11530 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11531 "pointer-valued", sym->name, &sym->declared_at);
11532
11533 if (sym->attr.pure)
11534 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11535 "pure", sym->name, &sym->declared_at);
11536
11537 if (sym->attr.recursive)
11538 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11539 "recursive", sym->name, &sym->declared_at);
11540
11541 return FAILURE;
11542 }
11543
11544 /* Appendix B.2 of the standard. Contained functions give an
11545 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11546 character length is an F2003 feature. */
11547 if (!sym->attr.contained
11548 && gfc_current_form != FORM_FIXED
11549 && !sym->ts.deferred)
11550 gfc_notify_std (GFC_STD_F95_OBS,
11551 "CHARACTER(*) function '%s' at %L",
11552 sym->name, &sym->declared_at);
11553 }
11554
11555 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
11556 {
11557 gfc_formal_arglist *curr_arg;
11558 int has_non_interop_arg = 0;
11559
11560 if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
11561 sym->common_block) == FAILURE)
11562 {
11563 /* Clear these to prevent looking at them again if there was an
11564 error. */
11565 sym->attr.is_bind_c = 0;
11566 sym->attr.is_c_interop = 0;
11567 sym->ts.is_c_interop = 0;
11568 }
11569 else
11570 {
11571 /* So far, no errors have been found. */
11572 sym->attr.is_c_interop = 1;
11573 sym->ts.is_c_interop = 1;
11574 }
11575
11576 curr_arg = gfc_sym_get_dummy_args (sym);
11577 while (curr_arg != NULL)
11578 {
11579 /* Skip implicitly typed dummy args here. */
11580 if (curr_arg->sym->attr.implicit_type == 0)
11581 if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE)
11582 /* If something is found to fail, record the fact so we
11583 can mark the symbol for the procedure as not being
11584 BIND(C) to try and prevent multiple errors being
11585 reported. */
11586 has_non_interop_arg = 1;
11587
11588 curr_arg = curr_arg->next;
11589 }
11590
11591 /* See if any of the arguments were not interoperable and if so, clear
11592 the procedure symbol to prevent duplicate error messages. */
11593 if (has_non_interop_arg != 0)
11594 {
11595 sym->attr.is_c_interop = 0;
11596 sym->ts.is_c_interop = 0;
11597 sym->attr.is_bind_c = 0;
11598 }
11599 }
11600
11601 if (!sym->attr.proc_pointer)
11602 {
11603 if (sym->attr.save == SAVE_EXPLICIT)
11604 {
11605 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11606 "in '%s' at %L", sym->name, &sym->declared_at);
11607 return FAILURE;
11608 }
11609 if (sym->attr.intent)
11610 {
11611 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11612 "in '%s' at %L", sym->name, &sym->declared_at);
11613 return FAILURE;
11614 }
11615 if (sym->attr.subroutine && sym->attr.result)
11616 {
11617 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11618 "in '%s' at %L", sym->name, &sym->declared_at);
11619 return FAILURE;
11620 }
11621 if (sym->attr.external && sym->attr.function
11622 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
11623 || sym->attr.contained))
11624 {
11625 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11626 "in '%s' at %L", sym->name, &sym->declared_at);
11627 return FAILURE;
11628 }
11629 if (strcmp ("ppr@", sym->name) == 0)
11630 {
11631 gfc_error ("Procedure pointer result '%s' at %L "
11632 "is missing the pointer attribute",
11633 sym->ns->proc_name->name, &sym->declared_at);
11634 return FAILURE;
11635 }
11636 }
11637
11638 return SUCCESS;
11639 }
11640
11641
11642 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11643 been defined and we now know their defined arguments, check that they fulfill
11644 the requirements of the standard for procedures used as finalizers. */
11645
11646 static gfc_try
gfc_resolve_finalizers(gfc_symbol * derived)11647 gfc_resolve_finalizers (gfc_symbol* derived)
11648 {
11649 gfc_finalizer* list;
11650 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
11651 gfc_try result = SUCCESS;
11652 bool seen_scalar = false;
11653
11654 if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
11655 return SUCCESS;
11656
11657 /* Walk over the list of finalizer-procedures, check them, and if any one
11658 does not fit in with the standard's definition, print an error and remove
11659 it from the list. */
11660 prev_link = &derived->f2k_derived->finalizers;
11661 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
11662 {
11663 gfc_formal_arglist *dummy_args;
11664 gfc_symbol* arg;
11665 gfc_finalizer* i;
11666 int my_rank;
11667
11668 /* Skip this finalizer if we already resolved it. */
11669 if (list->proc_tree)
11670 {
11671 prev_link = &(list->next);
11672 continue;
11673 }
11674
11675 /* Check this exists and is a SUBROUTINE. */
11676 if (!list->proc_sym->attr.subroutine)
11677 {
11678 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11679 list->proc_sym->name, &list->where);
11680 goto error;
11681 }
11682
11683 /* We should have exactly one argument. */
11684 dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
11685 if (!dummy_args || dummy_args->next)
11686 {
11687 gfc_error ("FINAL procedure at %L must have exactly one argument",
11688 &list->where);
11689 goto error;
11690 }
11691 arg = dummy_args->sym;
11692
11693 /* This argument must be of our type. */
11694 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
11695 {
11696 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11697 &arg->declared_at, derived->name);
11698 goto error;
11699 }
11700
11701 /* It must neither be a pointer nor allocatable nor optional. */
11702 if (arg->attr.pointer)
11703 {
11704 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11705 &arg->declared_at);
11706 goto error;
11707 }
11708 if (arg->attr.allocatable)
11709 {
11710 gfc_error ("Argument of FINAL procedure at %L must not be"
11711 " ALLOCATABLE", &arg->declared_at);
11712 goto error;
11713 }
11714 if (arg->attr.optional)
11715 {
11716 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11717 &arg->declared_at);
11718 goto error;
11719 }
11720
11721 /* It must not be INTENT(OUT). */
11722 if (arg->attr.intent == INTENT_OUT)
11723 {
11724 gfc_error ("Argument of FINAL procedure at %L must not be"
11725 " INTENT(OUT)", &arg->declared_at);
11726 goto error;
11727 }
11728
11729 /* Warn if the procedure is non-scalar and not assumed shape. */
11730 if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
11731 && arg->as->type != AS_ASSUMED_SHAPE)
11732 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11733 " shape argument", &arg->declared_at);
11734
11735 /* Check that it does not match in kind and rank with a FINAL procedure
11736 defined earlier. To really loop over the *earlier* declarations,
11737 we need to walk the tail of the list as new ones were pushed at the
11738 front. */
11739 /* TODO: Handle kind parameters once they are implemented. */
11740 my_rank = (arg->as ? arg->as->rank : 0);
11741 for (i = list->next; i; i = i->next)
11742 {
11743 gfc_formal_arglist *dummy_args;
11744
11745 /* Argument list might be empty; that is an error signalled earlier,
11746 but we nevertheless continued resolving. */
11747 dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
11748 if (dummy_args)
11749 {
11750 gfc_symbol* i_arg = dummy_args->sym;
11751 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
11752 if (i_rank == my_rank)
11753 {
11754 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11755 " rank (%d) as '%s'",
11756 list->proc_sym->name, &list->where, my_rank,
11757 i->proc_sym->name);
11758 goto error;
11759 }
11760 }
11761 }
11762
11763 /* Is this the/a scalar finalizer procedure? */
11764 if (!arg->as || arg->as->rank == 0)
11765 seen_scalar = true;
11766
11767 /* Find the symtree for this procedure. */
11768 gcc_assert (!list->proc_tree);
11769 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
11770
11771 prev_link = &list->next;
11772 continue;
11773
11774 /* Remove wrong nodes immediately from the list so we don't risk any
11775 troubles in the future when they might fail later expectations. */
11776 error:
11777 result = FAILURE;
11778 i = list;
11779 *prev_link = list->next;
11780 gfc_free_finalizer (i);
11781 }
11782
11783 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11784 were nodes in the list, must have been for arrays. It is surely a good
11785 idea to have a scalar version there if there's something to finalize. */
11786 if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
11787 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11788 " defined at %L, suggest also scalar one",
11789 derived->name, &derived->declared_at);
11790
11791 /* TODO: Remove this error when finalization is finished. */
11792 gfc_error ("Finalization at %L is not yet implemented",
11793 &derived->declared_at);
11794
11795 gfc_find_derived_vtab (derived);
11796 return result;
11797 }
11798
11799
11800 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11801
11802 static gfc_try
check_generic_tbp_ambiguity(gfc_tbp_generic * t1,gfc_tbp_generic * t2,const char * generic_name,locus where)11803 check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
11804 const char* generic_name, locus where)
11805 {
11806 gfc_symbol *sym1, *sym2;
11807 const char *pass1, *pass2;
11808
11809 gcc_assert (t1->specific && t2->specific);
11810 gcc_assert (!t1->specific->is_generic);
11811 gcc_assert (!t2->specific->is_generic);
11812 gcc_assert (t1->is_operator == t2->is_operator);
11813
11814 sym1 = t1->specific->u.specific->n.sym;
11815 sym2 = t2->specific->u.specific->n.sym;
11816
11817 if (sym1 == sym2)
11818 return SUCCESS;
11819
11820 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11821 if (sym1->attr.subroutine != sym2->attr.subroutine
11822 || sym1->attr.function != sym2->attr.function)
11823 {
11824 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11825 " GENERIC '%s' at %L",
11826 sym1->name, sym2->name, generic_name, &where);
11827 return FAILURE;
11828 }
11829
11830 /* Compare the interfaces. */
11831 if (t1->specific->nopass)
11832 pass1 = NULL;
11833 else if (t1->specific->pass_arg)
11834 pass1 = t1->specific->pass_arg;
11835 else
11836 pass1 = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym)->sym->name;
11837 if (t2->specific->nopass)
11838 pass2 = NULL;
11839 else if (t2->specific->pass_arg)
11840 pass2 = t2->specific->pass_arg;
11841 else
11842 pass2 = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym)->sym->name;
11843 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
11844 NULL, 0, pass1, pass2))
11845 {
11846 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11847 sym1->name, sym2->name, generic_name, &where);
11848 return FAILURE;
11849 }
11850
11851 return SUCCESS;
11852 }
11853
11854
11855 /* Worker function for resolving a generic procedure binding; this is used to
11856 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11857
11858 The difference between those cases is finding possible inherited bindings
11859 that are overridden, as one has to look for them in tb_sym_root,
11860 tb_uop_root or tb_op, respectively. Thus the caller must already find
11861 the super-type and set p->overridden correctly. */
11862
11863 static gfc_try
resolve_tb_generic_targets(gfc_symbol * super_type,gfc_typebound_proc * p,const char * name)11864 resolve_tb_generic_targets (gfc_symbol* super_type,
11865 gfc_typebound_proc* p, const char* name)
11866 {
11867 gfc_tbp_generic* target;
11868 gfc_symtree* first_target;
11869 gfc_symtree* inherited;
11870
11871 gcc_assert (p && p->is_generic);
11872
11873 /* Try to find the specific bindings for the symtrees in our target-list. */
11874 gcc_assert (p->u.generic);
11875 for (target = p->u.generic; target; target = target->next)
11876 if (!target->specific)
11877 {
11878 gfc_typebound_proc* overridden_tbp;
11879 gfc_tbp_generic* g;
11880 const char* target_name;
11881
11882 target_name = target->specific_st->name;
11883
11884 /* Defined for this type directly. */
11885 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
11886 {
11887 target->specific = target->specific_st->n.tb;
11888 goto specific_found;
11889 }
11890
11891 /* Look for an inherited specific binding. */
11892 if (super_type)
11893 {
11894 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
11895 true, NULL);
11896
11897 if (inherited)
11898 {
11899 gcc_assert (inherited->n.tb);
11900 target->specific = inherited->n.tb;
11901 goto specific_found;
11902 }
11903 }
11904
11905 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11906 " at %L", target_name, name, &p->where);
11907 return FAILURE;
11908
11909 /* Once we've found the specific binding, check it is not ambiguous with
11910 other specifics already found or inherited for the same GENERIC. */
11911 specific_found:
11912 gcc_assert (target->specific);
11913
11914 /* This must really be a specific binding! */
11915 if (target->specific->is_generic)
11916 {
11917 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11918 " '%s' is GENERIC, too", name, &p->where, target_name);
11919 return FAILURE;
11920 }
11921
11922 /* Check those already resolved on this type directly. */
11923 for (g = p->u.generic; g; g = g->next)
11924 if (g != target && g->specific
11925 && check_generic_tbp_ambiguity (target, g, name, p->where)
11926 == FAILURE)
11927 return FAILURE;
11928
11929 /* Check for ambiguity with inherited specific targets. */
11930 for (overridden_tbp = p->overridden; overridden_tbp;
11931 overridden_tbp = overridden_tbp->overridden)
11932 if (overridden_tbp->is_generic)
11933 {
11934 for (g = overridden_tbp->u.generic; g; g = g->next)
11935 {
11936 gcc_assert (g->specific);
11937 if (check_generic_tbp_ambiguity (target, g,
11938 name, p->where) == FAILURE)
11939 return FAILURE;
11940 }
11941 }
11942 }
11943
11944 /* If we attempt to "overwrite" a specific binding, this is an error. */
11945 if (p->overridden && !p->overridden->is_generic)
11946 {
11947 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11948 " the same name", name, &p->where);
11949 return FAILURE;
11950 }
11951
11952 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11953 all must have the same attributes here. */
11954 first_target = p->u.generic->specific->u.specific;
11955 gcc_assert (first_target);
11956 p->subroutine = first_target->n.sym->attr.subroutine;
11957 p->function = first_target->n.sym->attr.function;
11958
11959 return SUCCESS;
11960 }
11961
11962
11963 /* Resolve a GENERIC procedure binding for a derived type. */
11964
11965 static gfc_try
resolve_typebound_generic(gfc_symbol * derived,gfc_symtree * st)11966 resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
11967 {
11968 gfc_symbol* super_type;
11969
11970 /* Find the overridden binding if any. */
11971 st->n.tb->overridden = NULL;
11972 super_type = gfc_get_derived_super_type (derived);
11973 if (super_type)
11974 {
11975 gfc_symtree* overridden;
11976 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
11977 true, NULL);
11978
11979 if (overridden && overridden->n.tb)
11980 st->n.tb->overridden = overridden->n.tb;
11981 }
11982
11983 /* Resolve using worker function. */
11984 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
11985 }
11986
11987
11988 /* Retrieve the target-procedure of an operator binding and do some checks in
11989 common for intrinsic and user-defined type-bound operators. */
11990
11991 static gfc_symbol*
get_checked_tb_operator_target(gfc_tbp_generic * target,locus where)11992 get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
11993 {
11994 gfc_symbol* target_proc;
11995
11996 gcc_assert (target->specific && !target->specific->is_generic);
11997 target_proc = target->specific->u.specific->n.sym;
11998 gcc_assert (target_proc);
11999
12000 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12001 if (target->specific->nopass)
12002 {
12003 gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
12004 return NULL;
12005 }
12006
12007 return target_proc;
12008 }
12009
12010
12011 /* Resolve a type-bound intrinsic operator. */
12012
12013 static gfc_try
resolve_typebound_intrinsic_op(gfc_symbol * derived,gfc_intrinsic_op op,gfc_typebound_proc * p)12014 resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
12015 gfc_typebound_proc* p)
12016 {
12017 gfc_symbol* super_type;
12018 gfc_tbp_generic* target;
12019
12020 /* If there's already an error here, do nothing (but don't fail again). */
12021 if (p->error)
12022 return SUCCESS;
12023
12024 /* Operators should always be GENERIC bindings. */
12025 gcc_assert (p->is_generic);
12026
12027 /* Look for an overridden binding. */
12028 super_type = gfc_get_derived_super_type (derived);
12029 if (super_type && super_type->f2k_derived)
12030 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
12031 op, true, NULL);
12032 else
12033 p->overridden = NULL;
12034
12035 /* Resolve general GENERIC properties using worker function. */
12036 if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
12037 goto error;
12038
12039 /* Check the targets to be procedures of correct interface. */
12040 for (target = p->u.generic; target; target = target->next)
12041 {
12042 gfc_symbol* target_proc;
12043
12044 target_proc = get_checked_tb_operator_target (target, p->where);
12045 if (!target_proc)
12046 goto error;
12047
12048 if (!gfc_check_operator_interface (target_proc, op, p->where))
12049 goto error;
12050
12051 /* Add target to non-typebound operator list. */
12052 if (!target->specific->deferred && !derived->attr.use_assoc
12053 && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
12054 {
12055 gfc_interface *head, *intr;
12056 if (gfc_check_new_interface (derived->ns->op[op], target_proc,
12057 p->where) == FAILURE)
12058 return FAILURE;
12059 head = derived->ns->op[op];
12060 intr = gfc_get_interface ();
12061 intr->sym = target_proc;
12062 intr->where = p->where;
12063 intr->next = head;
12064 derived->ns->op[op] = intr;
12065 }
12066 }
12067
12068 return SUCCESS;
12069
12070 error:
12071 p->error = 1;
12072 return FAILURE;
12073 }
12074
12075
12076 /* Resolve a type-bound user operator (tree-walker callback). */
12077
12078 static gfc_symbol* resolve_bindings_derived;
12079 static gfc_try resolve_bindings_result;
12080
12081 static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
12082
12083 static void
resolve_typebound_user_op(gfc_symtree * stree)12084 resolve_typebound_user_op (gfc_symtree* stree)
12085 {
12086 gfc_symbol* super_type;
12087 gfc_tbp_generic* target;
12088
12089 gcc_assert (stree && stree->n.tb);
12090
12091 if (stree->n.tb->error)
12092 return;
12093
12094 /* Operators should always be GENERIC bindings. */
12095 gcc_assert (stree->n.tb->is_generic);
12096
12097 /* Find overridden procedure, if any. */
12098 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
12099 if (super_type && super_type->f2k_derived)
12100 {
12101 gfc_symtree* overridden;
12102 overridden = gfc_find_typebound_user_op (super_type, NULL,
12103 stree->name, true, NULL);
12104
12105 if (overridden && overridden->n.tb)
12106 stree->n.tb->overridden = overridden->n.tb;
12107 }
12108 else
12109 stree->n.tb->overridden = NULL;
12110
12111 /* Resolve basically using worker function. */
12112 if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
12113 == FAILURE)
12114 goto error;
12115
12116 /* Check the targets to be functions of correct interface. */
12117 for (target = stree->n.tb->u.generic; target; target = target->next)
12118 {
12119 gfc_symbol* target_proc;
12120
12121 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
12122 if (!target_proc)
12123 goto error;
12124
12125 if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
12126 goto error;
12127 }
12128
12129 return;
12130
12131 error:
12132 resolve_bindings_result = FAILURE;
12133 stree->n.tb->error = 1;
12134 }
12135
12136
12137 /* Resolve the type-bound procedures for a derived type. */
12138
12139 static void
resolve_typebound_procedure(gfc_symtree * stree)12140 resolve_typebound_procedure (gfc_symtree* stree)
12141 {
12142 gfc_symbol* proc;
12143 locus where;
12144 gfc_symbol* me_arg;
12145 gfc_symbol* super_type;
12146 gfc_component* comp;
12147
12148 gcc_assert (stree);
12149
12150 /* Undefined specific symbol from GENERIC target definition. */
12151 if (!stree->n.tb)
12152 return;
12153
12154 if (stree->n.tb->error)
12155 return;
12156
12157 /* If this is a GENERIC binding, use that routine. */
12158 if (stree->n.tb->is_generic)
12159 {
12160 if (resolve_typebound_generic (resolve_bindings_derived, stree)
12161 == FAILURE)
12162 goto error;
12163 return;
12164 }
12165
12166 /* Get the target-procedure to check it. */
12167 gcc_assert (!stree->n.tb->is_generic);
12168 gcc_assert (stree->n.tb->u.specific);
12169 proc = stree->n.tb->u.specific->n.sym;
12170 where = stree->n.tb->where;
12171
12172 /* Default access should already be resolved from the parser. */
12173 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
12174
12175 if (stree->n.tb->deferred)
12176 {
12177 if (check_proc_interface (proc, &where) == FAILURE)
12178 goto error;
12179 }
12180 else
12181 {
12182 /* Check for F08:C465. */
12183 if ((!proc->attr.subroutine && !proc->attr.function)
12184 || (proc->attr.proc != PROC_MODULE
12185 && proc->attr.if_source != IFSRC_IFBODY)
12186 || proc->attr.abstract)
12187 {
12188 gfc_error ("'%s' must be a module procedure or an external procedure with"
12189 " an explicit interface at %L", proc->name, &where);
12190 goto error;
12191 }
12192 }
12193
12194 stree->n.tb->subroutine = proc->attr.subroutine;
12195 stree->n.tb->function = proc->attr.function;
12196
12197 /* Find the super-type of the current derived type. We could do this once and
12198 store in a global if speed is needed, but as long as not I believe this is
12199 more readable and clearer. */
12200 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
12201
12202 /* If PASS, resolve and check arguments if not already resolved / loaded
12203 from a .mod file. */
12204 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
12205 {
12206 gfc_formal_arglist *dummy_args;
12207
12208 dummy_args = gfc_sym_get_dummy_args (proc);
12209 if (stree->n.tb->pass_arg)
12210 {
12211 gfc_formal_arglist *i;
12212
12213 /* If an explicit passing argument name is given, walk the arg-list
12214 and look for it. */
12215
12216 me_arg = NULL;
12217 stree->n.tb->pass_arg_num = 1;
12218 for (i = dummy_args; i; i = i->next)
12219 {
12220 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
12221 {
12222 me_arg = i->sym;
12223 break;
12224 }
12225 ++stree->n.tb->pass_arg_num;
12226 }
12227
12228 if (!me_arg)
12229 {
12230 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
12231 " argument '%s'",
12232 proc->name, stree->n.tb->pass_arg, &where,
12233 stree->n.tb->pass_arg);
12234 goto error;
12235 }
12236 }
12237 else
12238 {
12239 /* Otherwise, take the first one; there should in fact be at least
12240 one. */
12241 stree->n.tb->pass_arg_num = 1;
12242 if (!dummy_args)
12243 {
12244 gfc_error ("Procedure '%s' with PASS at %L must have at"
12245 " least one argument", proc->name, &where);
12246 goto error;
12247 }
12248 me_arg = dummy_args->sym;
12249 }
12250
12251 /* Now check that the argument-type matches and the passed-object
12252 dummy argument is generally fine. */
12253
12254 gcc_assert (me_arg);
12255
12256 if (me_arg->ts.type != BT_CLASS)
12257 {
12258 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12259 " at %L", proc->name, &where);
12260 goto error;
12261 }
12262
12263 if (CLASS_DATA (me_arg)->ts.u.derived
12264 != resolve_bindings_derived)
12265 {
12266 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12267 " the derived-type '%s'", me_arg->name, proc->name,
12268 me_arg->name, &where, resolve_bindings_derived->name);
12269 goto error;
12270 }
12271
12272 gcc_assert (me_arg->ts.type == BT_CLASS);
12273 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
12274 {
12275 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
12276 " scalar", proc->name, &where);
12277 goto error;
12278 }
12279 if (CLASS_DATA (me_arg)->attr.allocatable)
12280 {
12281 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12282 " be ALLOCATABLE", proc->name, &where);
12283 goto error;
12284 }
12285 if (CLASS_DATA (me_arg)->attr.class_pointer)
12286 {
12287 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12288 " be POINTER", proc->name, &where);
12289 goto error;
12290 }
12291 }
12292
12293 /* If we are extending some type, check that we don't override a procedure
12294 flagged NON_OVERRIDABLE. */
12295 stree->n.tb->overridden = NULL;
12296 if (super_type)
12297 {
12298 gfc_symtree* overridden;
12299 overridden = gfc_find_typebound_proc (super_type, NULL,
12300 stree->name, true, NULL);
12301
12302 if (overridden)
12303 {
12304 if (overridden->n.tb)
12305 stree->n.tb->overridden = overridden->n.tb;
12306
12307 if (gfc_check_typebound_override (stree, overridden) == FAILURE)
12308 goto error;
12309 }
12310 }
12311
12312 /* See if there's a name collision with a component directly in this type. */
12313 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
12314 if (!strcmp (comp->name, stree->name))
12315 {
12316 gfc_error ("Procedure '%s' at %L has the same name as a component of"
12317 " '%s'",
12318 stree->name, &where, resolve_bindings_derived->name);
12319 goto error;
12320 }
12321
12322 /* Try to find a name collision with an inherited component. */
12323 if (super_type && gfc_find_component (super_type, stree->name, true, true))
12324 {
12325 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
12326 " component of '%s'",
12327 stree->name, &where, resolve_bindings_derived->name);
12328 goto error;
12329 }
12330
12331 stree->n.tb->error = 0;
12332 return;
12333
12334 error:
12335 resolve_bindings_result = FAILURE;
12336 stree->n.tb->error = 1;
12337 }
12338
12339
12340 static gfc_try
resolve_typebound_procedures(gfc_symbol * derived)12341 resolve_typebound_procedures (gfc_symbol* derived)
12342 {
12343 int op;
12344 gfc_symbol* super_type;
12345
12346 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
12347 return SUCCESS;
12348
12349 super_type = gfc_get_derived_super_type (derived);
12350 if (super_type)
12351 resolve_symbol (super_type);
12352
12353 resolve_bindings_derived = derived;
12354 resolve_bindings_result = SUCCESS;
12355
12356 /* Make sure the vtab has been generated. */
12357 gfc_find_derived_vtab (derived);
12358
12359 if (derived->f2k_derived->tb_sym_root)
12360 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
12361 &resolve_typebound_procedure);
12362
12363 if (derived->f2k_derived->tb_uop_root)
12364 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
12365 &resolve_typebound_user_op);
12366
12367 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
12368 {
12369 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
12370 if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
12371 p) == FAILURE)
12372 resolve_bindings_result = FAILURE;
12373 }
12374
12375 return resolve_bindings_result;
12376 }
12377
12378
12379 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12380 to give all identical derived types the same backend_decl. */
12381 static void
add_dt_to_dt_list(gfc_symbol * derived)12382 add_dt_to_dt_list (gfc_symbol *derived)
12383 {
12384 gfc_dt_list *dt_list;
12385
12386 for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
12387 if (derived == dt_list->derived)
12388 return;
12389
12390 dt_list = gfc_get_dt_list ();
12391 dt_list->next = gfc_derived_types;
12392 dt_list->derived = derived;
12393 gfc_derived_types = dt_list;
12394 }
12395
12396
12397 /* Ensure that a derived-type is really not abstract, meaning that every
12398 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12399
12400 static gfc_try
ensure_not_abstract_walker(gfc_symbol * sub,gfc_symtree * st)12401 ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
12402 {
12403 if (!st)
12404 return SUCCESS;
12405
12406 if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
12407 return FAILURE;
12408 if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
12409 return FAILURE;
12410
12411 if (st->n.tb && st->n.tb->deferred)
12412 {
12413 gfc_symtree* overriding;
12414 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
12415 if (!overriding)
12416 return FAILURE;
12417 gcc_assert (overriding->n.tb);
12418 if (overriding->n.tb->deferred)
12419 {
12420 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
12421 " '%s' is DEFERRED and not overridden",
12422 sub->name, &sub->declared_at, st->name);
12423 return FAILURE;
12424 }
12425 }
12426
12427 return SUCCESS;
12428 }
12429
12430 static gfc_try
ensure_not_abstract(gfc_symbol * sub,gfc_symbol * ancestor)12431 ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
12432 {
12433 /* The algorithm used here is to recursively travel up the ancestry of sub
12434 and for each ancestor-type, check all bindings. If any of them is
12435 DEFERRED, look it up starting from sub and see if the found (overriding)
12436 binding is not DEFERRED.
12437 This is not the most efficient way to do this, but it should be ok and is
12438 clearer than something sophisticated. */
12439
12440 gcc_assert (ancestor && !sub->attr.abstract);
12441
12442 if (!ancestor->attr.abstract)
12443 return SUCCESS;
12444
12445 /* Walk bindings of this ancestor. */
12446 if (ancestor->f2k_derived)
12447 {
12448 gfc_try t;
12449 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
12450 if (t == FAILURE)
12451 return FAILURE;
12452 }
12453
12454 /* Find next ancestor type and recurse on it. */
12455 ancestor = gfc_get_derived_super_type (ancestor);
12456 if (ancestor)
12457 return ensure_not_abstract (sub, ancestor);
12458
12459 return SUCCESS;
12460 }
12461
12462
12463 /* This check for typebound defined assignments is done recursively
12464 since the order in which derived types are resolved is not always in
12465 order of the declarations. */
12466
12467 static void
check_defined_assignments(gfc_symbol * derived)12468 check_defined_assignments (gfc_symbol *derived)
12469 {
12470 gfc_component *c;
12471
12472 for (c = derived->components; c; c = c->next)
12473 {
12474 if (c->ts.type != BT_DERIVED
12475 || c->attr.pointer
12476 || c->attr.allocatable
12477 || c->attr.proc_pointer_comp
12478 || c->attr.class_pointer
12479 || c->attr.proc_pointer)
12480 continue;
12481
12482 if (c->ts.u.derived->attr.defined_assign_comp
12483 || (c->ts.u.derived->f2k_derived
12484 && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
12485 {
12486 derived->attr.defined_assign_comp = 1;
12487 return;
12488 }
12489
12490 check_defined_assignments (c->ts.u.derived);
12491 if (c->ts.u.derived->attr.defined_assign_comp)
12492 {
12493 derived->attr.defined_assign_comp = 1;
12494 return;
12495 }
12496 }
12497 }
12498
12499
12500 /* Resolve the components of a derived type. This does not have to wait until
12501 resolution stage, but can be done as soon as the dt declaration has been
12502 parsed. */
12503
12504 static gfc_try
resolve_fl_derived0(gfc_symbol * sym)12505 resolve_fl_derived0 (gfc_symbol *sym)
12506 {
12507 gfc_symbol* super_type;
12508 gfc_component *c;
12509
12510 if (sym->attr.unlimited_polymorphic)
12511 return SUCCESS;
12512
12513 super_type = gfc_get_derived_super_type (sym);
12514
12515 /* F2008, C432. */
12516 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
12517 {
12518 gfc_error ("As extending type '%s' at %L has a coarray component, "
12519 "parent type '%s' shall also have one", sym->name,
12520 &sym->declared_at, super_type->name);
12521 return FAILURE;
12522 }
12523
12524 /* Ensure the extended type gets resolved before we do. */
12525 if (super_type && resolve_fl_derived0 (super_type) == FAILURE)
12526 return FAILURE;
12527
12528 /* An ABSTRACT type must be extensible. */
12529 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
12530 {
12531 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12532 sym->name, &sym->declared_at);
12533 return FAILURE;
12534 }
12535
12536 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
12537 : sym->components;
12538
12539 for ( ; c != NULL; c = c->next)
12540 {
12541 if (c->attr.artificial)
12542 continue;
12543
12544 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12545 if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
12546 {
12547 gfc_error ("Deferred-length character component '%s' at %L is not "
12548 "yet supported", c->name, &c->loc);
12549 return FAILURE;
12550 }
12551
12552 /* F2008, C442. */
12553 if ((!sym->attr.is_class || c != sym->components)
12554 && c->attr.codimension
12555 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
12556 {
12557 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12558 "deferred shape", c->name, &c->loc);
12559 return FAILURE;
12560 }
12561
12562 /* F2008, C443. */
12563 if (c->attr.codimension && c->ts.type == BT_DERIVED
12564 && c->ts.u.derived->ts.is_iso_c)
12565 {
12566 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12567 "shall not be a coarray", c->name, &c->loc);
12568 return FAILURE;
12569 }
12570
12571 /* F2008, C444. */
12572 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
12573 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
12574 || c->attr.allocatable))
12575 {
12576 gfc_error ("Component '%s' at %L with coarray component "
12577 "shall be a nonpointer, nonallocatable scalar",
12578 c->name, &c->loc);
12579 return FAILURE;
12580 }
12581
12582 /* F2008, C448. */
12583 if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
12584 {
12585 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12586 "is not an array pointer", c->name, &c->loc);
12587 return FAILURE;
12588 }
12589
12590 if (c->attr.proc_pointer && c->ts.interface)
12591 {
12592 gfc_symbol *ifc = c->ts.interface;
12593
12594 if (!sym->attr.vtype
12595 && check_proc_interface (ifc, &c->loc) == FAILURE)
12596 return FAILURE;
12597
12598 if (ifc->attr.if_source || ifc->attr.intrinsic)
12599 {
12600 /* Resolve interface and copy attributes. */
12601 if (ifc->formal && !ifc->formal_ns)
12602 resolve_symbol (ifc);
12603 if (ifc->attr.intrinsic)
12604 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
12605
12606 if (ifc->result)
12607 {
12608 c->ts = ifc->result->ts;
12609 c->attr.allocatable = ifc->result->attr.allocatable;
12610 c->attr.pointer = ifc->result->attr.pointer;
12611 c->attr.dimension = ifc->result->attr.dimension;
12612 c->as = gfc_copy_array_spec (ifc->result->as);
12613 c->attr.class_ok = ifc->result->attr.class_ok;
12614 }
12615 else
12616 {
12617 c->ts = ifc->ts;
12618 c->attr.allocatable = ifc->attr.allocatable;
12619 c->attr.pointer = ifc->attr.pointer;
12620 c->attr.dimension = ifc->attr.dimension;
12621 c->as = gfc_copy_array_spec (ifc->as);
12622 c->attr.class_ok = ifc->attr.class_ok;
12623 }
12624 c->ts.interface = ifc;
12625 c->attr.function = ifc->attr.function;
12626 c->attr.subroutine = ifc->attr.subroutine;
12627
12628 c->attr.pure = ifc->attr.pure;
12629 c->attr.elemental = ifc->attr.elemental;
12630 c->attr.recursive = ifc->attr.recursive;
12631 c->attr.always_explicit = ifc->attr.always_explicit;
12632 c->attr.ext_attr |= ifc->attr.ext_attr;
12633 /* Copy char length. */
12634 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
12635 {
12636 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
12637 if (cl->length && !cl->resolved
12638 && gfc_resolve_expr (cl->length) == FAILURE)
12639 return FAILURE;
12640 c->ts.u.cl = cl;
12641 }
12642 }
12643 }
12644 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
12645 {
12646 /* Since PPCs are not implicitly typed, a PPC without an explicit
12647 interface must be a subroutine. */
12648 gfc_add_subroutine (&c->attr, c->name, &c->loc);
12649 }
12650
12651 /* Procedure pointer components: Check PASS arg. */
12652 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
12653 && !sym->attr.vtype)
12654 {
12655 gfc_symbol* me_arg;
12656
12657 if (c->tb->pass_arg)
12658 {
12659 gfc_formal_arglist* i;
12660
12661 /* If an explicit passing argument name is given, walk the arg-list
12662 and look for it. */
12663
12664 me_arg = NULL;
12665 c->tb->pass_arg_num = 1;
12666 for (i = c->ts.interface->formal; i; i = i->next)
12667 {
12668 if (!strcmp (i->sym->name, c->tb->pass_arg))
12669 {
12670 me_arg = i->sym;
12671 break;
12672 }
12673 c->tb->pass_arg_num++;
12674 }
12675
12676 if (!me_arg)
12677 {
12678 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12679 "at %L has no argument '%s'", c->name,
12680 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
12681 c->tb->error = 1;
12682 return FAILURE;
12683 }
12684 }
12685 else
12686 {
12687 /* Otherwise, take the first one; there should in fact be at least
12688 one. */
12689 c->tb->pass_arg_num = 1;
12690 if (!c->ts.interface->formal)
12691 {
12692 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12693 "must have at least one argument",
12694 c->name, &c->loc);
12695 c->tb->error = 1;
12696 return FAILURE;
12697 }
12698 me_arg = c->ts.interface->formal->sym;
12699 }
12700
12701 /* Now check that the argument-type matches. */
12702 gcc_assert (me_arg);
12703 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
12704 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
12705 || (me_arg->ts.type == BT_CLASS
12706 && CLASS_DATA (me_arg)->ts.u.derived != sym))
12707 {
12708 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12709 " the derived type '%s'", me_arg->name, c->name,
12710 me_arg->name, &c->loc, sym->name);
12711 c->tb->error = 1;
12712 return FAILURE;
12713 }
12714
12715 /* Check for C453. */
12716 if (me_arg->attr.dimension)
12717 {
12718 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12719 "must be scalar", me_arg->name, c->name, me_arg->name,
12720 &c->loc);
12721 c->tb->error = 1;
12722 return FAILURE;
12723 }
12724
12725 if (me_arg->attr.pointer)
12726 {
12727 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12728 "may not have the POINTER attribute", me_arg->name,
12729 c->name, me_arg->name, &c->loc);
12730 c->tb->error = 1;
12731 return FAILURE;
12732 }
12733
12734 if (me_arg->attr.allocatable)
12735 {
12736 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12737 "may not be ALLOCATABLE", me_arg->name, c->name,
12738 me_arg->name, &c->loc);
12739 c->tb->error = 1;
12740 return FAILURE;
12741 }
12742
12743 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
12744 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12745 " at %L", c->name, &c->loc);
12746
12747 }
12748
12749 /* Check type-spec if this is not the parent-type component. */
12750 if (((sym->attr.is_class
12751 && (!sym->components->ts.u.derived->attr.extension
12752 || c != sym->components->ts.u.derived->components))
12753 || (!sym->attr.is_class
12754 && (!sym->attr.extension || c != sym->components)))
12755 && !sym->attr.vtype
12756 && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
12757 return FAILURE;
12758
12759 /* If this type is an extension, set the accessibility of the parent
12760 component. */
12761 if (super_type
12762 && ((sym->attr.is_class
12763 && c == sym->components->ts.u.derived->components)
12764 || (!sym->attr.is_class && c == sym->components))
12765 && strcmp (super_type->name, c->name) == 0)
12766 c->attr.access = super_type->attr.access;
12767
12768 /* If this type is an extension, see if this component has the same name
12769 as an inherited type-bound procedure. */
12770 if (super_type && !sym->attr.is_class
12771 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
12772 {
12773 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12774 " inherited type-bound procedure",
12775 c->name, sym->name, &c->loc);
12776 return FAILURE;
12777 }
12778
12779 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
12780 && !c->ts.deferred)
12781 {
12782 if (c->ts.u.cl->length == NULL
12783 || (resolve_charlen (c->ts.u.cl) == FAILURE)
12784 || !gfc_is_constant_expr (c->ts.u.cl->length))
12785 {
12786 gfc_error ("Character length of component '%s' needs to "
12787 "be a constant specification expression at %L",
12788 c->name,
12789 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
12790 return FAILURE;
12791 }
12792 }
12793
12794 if (c->ts.type == BT_CHARACTER && c->ts.deferred
12795 && !c->attr.pointer && !c->attr.allocatable)
12796 {
12797 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12798 "length must be a POINTER or ALLOCATABLE",
12799 c->name, sym->name, &c->loc);
12800 return FAILURE;
12801 }
12802
12803 if (c->ts.type == BT_DERIVED
12804 && sym->component_access != ACCESS_PRIVATE
12805 && gfc_check_symbol_access (sym)
12806 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
12807 && !c->ts.u.derived->attr.use_assoc
12808 && !gfc_check_symbol_access (c->ts.u.derived)
12809 && gfc_notify_std (GFC_STD_F2003, "the component '%s' "
12810 "is a PRIVATE type and cannot be a component of "
12811 "'%s', which is PUBLIC at %L", c->name,
12812 sym->name, &sym->declared_at) == FAILURE)
12813 return FAILURE;
12814
12815 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
12816 {
12817 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12818 "type %s", c->name, &c->loc, sym->name);
12819 return FAILURE;
12820 }
12821
12822 if (sym->attr.sequence)
12823 {
12824 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
12825 {
12826 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12827 "not have the SEQUENCE attribute",
12828 c->ts.u.derived->name, &sym->declared_at);
12829 return FAILURE;
12830 }
12831 }
12832
12833 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
12834 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
12835 else if (c->ts.type == BT_CLASS && c->attr.class_ok
12836 && CLASS_DATA (c)->ts.u.derived->attr.generic)
12837 CLASS_DATA (c)->ts.u.derived
12838 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
12839
12840 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
12841 && c->attr.pointer && c->ts.u.derived->components == NULL
12842 && !c->ts.u.derived->attr.zero_comp)
12843 {
12844 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12845 "that has not been declared", c->name, sym->name,
12846 &c->loc);
12847 return FAILURE;
12848 }
12849
12850 if (c->ts.type == BT_CLASS && c->attr.class_ok
12851 && CLASS_DATA (c)->attr.class_pointer
12852 && CLASS_DATA (c)->ts.u.derived->components == NULL
12853 && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
12854 && !UNLIMITED_POLY (c))
12855 {
12856 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12857 "that has not been declared", c->name, sym->name,
12858 &c->loc);
12859 return FAILURE;
12860 }
12861
12862 /* C437. */
12863 if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
12864 && (!c->attr.class_ok
12865 || !(CLASS_DATA (c)->attr.class_pointer
12866 || CLASS_DATA (c)->attr.allocatable)))
12867 {
12868 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12869 "or pointer", c->name, &c->loc);
12870 /* Prevent a recurrence of the error. */
12871 c->ts.type = BT_UNKNOWN;
12872 return FAILURE;
12873 }
12874
12875 /* Ensure that all the derived type components are put on the
12876 derived type list; even in formal namespaces, where derived type
12877 pointer components might not have been declared. */
12878 if (c->ts.type == BT_DERIVED
12879 && c->ts.u.derived
12880 && c->ts.u.derived->components
12881 && c->attr.pointer
12882 && sym != c->ts.u.derived)
12883 add_dt_to_dt_list (c->ts.u.derived);
12884
12885 if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
12886 || c->attr.proc_pointer
12887 || c->attr.allocatable)) == FAILURE)
12888 return FAILURE;
12889
12890 if (c->initializer && !sym->attr.vtype
12891 && gfc_check_assign_symbol (sym, c, c->initializer) == FAILURE)
12892 return FAILURE;
12893 }
12894
12895 check_defined_assignments (sym);
12896
12897 if (!sym->attr.defined_assign_comp && super_type)
12898 sym->attr.defined_assign_comp
12899 = super_type->attr.defined_assign_comp;
12900
12901 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12902 all DEFERRED bindings are overridden. */
12903 if (super_type && super_type->attr.abstract && !sym->attr.abstract
12904 && !sym->attr.is_class
12905 && ensure_not_abstract (sym, super_type) == FAILURE)
12906 return FAILURE;
12907
12908 /* Add derived type to the derived type list. */
12909 add_dt_to_dt_list (sym);
12910
12911 /* Check if the type is finalizable. This is done in order to ensure that the
12912 finalization wrapper is generated early enough. */
12913 gfc_is_finalizable (sym, NULL);
12914
12915 return SUCCESS;
12916 }
12917
12918
12919 /* The following procedure does the full resolution of a derived type,
12920 including resolution of all type-bound procedures (if present). In contrast
12921 to 'resolve_fl_derived0' this can only be done after the module has been
12922 parsed completely. */
12923
12924 static gfc_try
resolve_fl_derived(gfc_symbol * sym)12925 resolve_fl_derived (gfc_symbol *sym)
12926 {
12927 gfc_symbol *gen_dt = NULL;
12928
12929 if (sym->attr.unlimited_polymorphic)
12930 return SUCCESS;
12931
12932 if (!sym->attr.is_class)
12933 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
12934 if (gen_dt && gen_dt->generic && gen_dt->generic->next
12935 && (!gen_dt->generic->sym->attr.use_assoc
12936 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
12937 && gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of "
12938 "function '%s' at %L being the same name as derived "
12939 "type at %L", sym->name,
12940 gen_dt->generic->sym == sym
12941 ? gen_dt->generic->next->sym->name
12942 : gen_dt->generic->sym->name,
12943 gen_dt->generic->sym == sym
12944 ? &gen_dt->generic->next->sym->declared_at
12945 : &gen_dt->generic->sym->declared_at,
12946 &sym->declared_at) == FAILURE)
12947 return FAILURE;
12948
12949 /* Resolve the finalizer procedures. */
12950 if (gfc_resolve_finalizers (sym) == FAILURE)
12951 return FAILURE;
12952
12953 if (sym->attr.is_class && sym->ts.u.derived == NULL)
12954 {
12955 /* Fix up incomplete CLASS symbols. */
12956 gfc_component *data = gfc_find_component (sym, "_data", true, true);
12957 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
12958
12959 /* Nothing more to do for unlimited polymorphic entities. */
12960 if (data->ts.u.derived->attr.unlimited_polymorphic)
12961 return SUCCESS;
12962 else if (vptr->ts.u.derived == NULL)
12963 {
12964 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
12965 gcc_assert (vtab);
12966 vptr->ts.u.derived = vtab->ts.u.derived;
12967 }
12968 }
12969
12970 if (resolve_fl_derived0 (sym) == FAILURE)
12971 return FAILURE;
12972
12973 /* Resolve the type-bound procedures. */
12974 if (resolve_typebound_procedures (sym) == FAILURE)
12975 return FAILURE;
12976
12977 return SUCCESS;
12978 }
12979
12980
12981 static gfc_try
resolve_fl_namelist(gfc_symbol * sym)12982 resolve_fl_namelist (gfc_symbol *sym)
12983 {
12984 gfc_namelist *nl;
12985 gfc_symbol *nlsym;
12986
12987 for (nl = sym->namelist; nl; nl = nl->next)
12988 {
12989 /* Check again, the check in match only works if NAMELIST comes
12990 after the decl. */
12991 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
12992 {
12993 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12994 "allowed", nl->sym->name, sym->name, &sym->declared_at);
12995 return FAILURE;
12996 }
12997
12998 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
12999 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array "
13000 "object '%s' with assumed shape in namelist "
13001 "'%s' at %L", nl->sym->name, sym->name,
13002 &sym->declared_at) == FAILURE)
13003 return FAILURE;
13004
13005 if (is_non_constant_shape_array (nl->sym)
13006 && gfc_notify_std (GFC_STD_F2003, "NAMELIST array "
13007 "object '%s' with nonconstant shape in namelist "
13008 "'%s' at %L", nl->sym->name, sym->name,
13009 &sym->declared_at) == FAILURE)
13010 return FAILURE;
13011
13012 if (nl->sym->ts.type == BT_CHARACTER
13013 && (nl->sym->ts.u.cl->length == NULL
13014 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
13015 && gfc_notify_std (GFC_STD_F2003, "NAMELIST object "
13016 "'%s' with nonconstant character length in "
13017 "namelist '%s' at %L", nl->sym->name, sym->name,
13018 &sym->declared_at) == FAILURE)
13019 return FAILURE;
13020
13021 /* FIXME: Once UDDTIO is implemented, the following can be
13022 removed. */
13023 if (nl->sym->ts.type == BT_CLASS)
13024 {
13025 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
13026 "polymorphic and requires a defined input/output "
13027 "procedure", nl->sym->name, sym->name, &sym->declared_at);
13028 return FAILURE;
13029 }
13030
13031 if (nl->sym->ts.type == BT_DERIVED
13032 && (nl->sym->ts.u.derived->attr.alloc_comp
13033 || nl->sym->ts.u.derived->attr.pointer_comp))
13034 {
13035 if (gfc_notify_std (GFC_STD_F2003, "NAMELIST object "
13036 "'%s' in namelist '%s' at %L with ALLOCATABLE "
13037 "or POINTER components", nl->sym->name,
13038 sym->name, &sym->declared_at) == FAILURE)
13039 return FAILURE;
13040
13041 /* FIXME: Once UDDTIO is implemented, the following can be
13042 removed. */
13043 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
13044 "ALLOCATABLE or POINTER components and thus requires "
13045 "a defined input/output procedure", nl->sym->name,
13046 sym->name, &sym->declared_at);
13047 return FAILURE;
13048 }
13049 }
13050
13051 /* Reject PRIVATE objects in a PUBLIC namelist. */
13052 if (gfc_check_symbol_access (sym))
13053 {
13054 for (nl = sym->namelist; nl; nl = nl->next)
13055 {
13056 if (!nl->sym->attr.use_assoc
13057 && !is_sym_host_assoc (nl->sym, sym->ns)
13058 && !gfc_check_symbol_access (nl->sym))
13059 {
13060 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
13061 "cannot be member of PUBLIC namelist '%s' at %L",
13062 nl->sym->name, sym->name, &sym->declared_at);
13063 return FAILURE;
13064 }
13065
13066 /* Types with private components that came here by USE-association. */
13067 if (nl->sym->ts.type == BT_DERIVED
13068 && derived_inaccessible (nl->sym->ts.u.derived))
13069 {
13070 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
13071 "components and cannot be member of namelist '%s' at %L",
13072 nl->sym->name, sym->name, &sym->declared_at);
13073 return FAILURE;
13074 }
13075
13076 /* Types with private components that are defined in the same module. */
13077 if (nl->sym->ts.type == BT_DERIVED
13078 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
13079 && nl->sym->ts.u.derived->attr.private_comp)
13080 {
13081 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
13082 "cannot be a member of PUBLIC namelist '%s' at %L",
13083 nl->sym->name, sym->name, &sym->declared_at);
13084 return FAILURE;
13085 }
13086 }
13087 }
13088
13089
13090 /* 14.1.2 A module or internal procedure represent local entities
13091 of the same type as a namelist member and so are not allowed. */
13092 for (nl = sym->namelist; nl; nl = nl->next)
13093 {
13094 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
13095 continue;
13096
13097 if (nl->sym->attr.function && nl->sym == nl->sym->result)
13098 if ((nl->sym == sym->ns->proc_name)
13099 ||
13100 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
13101 continue;
13102
13103 nlsym = NULL;
13104 if (nl->sym->name)
13105 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
13106 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
13107 {
13108 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13109 "attribute in '%s' at %L", nlsym->name,
13110 &sym->declared_at);
13111 return FAILURE;
13112 }
13113 }
13114
13115 return SUCCESS;
13116 }
13117
13118
13119 static gfc_try
resolve_fl_parameter(gfc_symbol * sym)13120 resolve_fl_parameter (gfc_symbol *sym)
13121 {
13122 /* A parameter array's shape needs to be constant. */
13123 if (sym->as != NULL
13124 && (sym->as->type == AS_DEFERRED
13125 || is_non_constant_shape_array (sym)))
13126 {
13127 gfc_error ("Parameter array '%s' at %L cannot be automatic "
13128 "or of deferred shape", sym->name, &sym->declared_at);
13129 return FAILURE;
13130 }
13131
13132 /* Make sure a parameter that has been implicitly typed still
13133 matches the implicit type, since PARAMETER statements can precede
13134 IMPLICIT statements. */
13135 if (sym->attr.implicit_type
13136 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
13137 sym->ns)))
13138 {
13139 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
13140 "later IMPLICIT type", sym->name, &sym->declared_at);
13141 return FAILURE;
13142 }
13143
13144 /* Make sure the types of derived parameters are consistent. This
13145 type checking is deferred until resolution because the type may
13146 refer to a derived type from the host. */
13147 if (sym->ts.type == BT_DERIVED
13148 && !gfc_compare_types (&sym->ts, &sym->value->ts))
13149 {
13150 gfc_error ("Incompatible derived type in PARAMETER at %L",
13151 &sym->value->where);
13152 return FAILURE;
13153 }
13154 return SUCCESS;
13155 }
13156
13157
13158 /* Do anything necessary to resolve a symbol. Right now, we just
13159 assume that an otherwise unknown symbol is a variable. This sort
13160 of thing commonly happens for symbols in module. */
13161
13162 static void
resolve_symbol(gfc_symbol * sym)13163 resolve_symbol (gfc_symbol *sym)
13164 {
13165 int check_constant, mp_flag;
13166 gfc_symtree *symtree;
13167 gfc_symtree *this_symtree;
13168 gfc_namespace *ns;
13169 gfc_component *c;
13170 symbol_attribute class_attr;
13171 gfc_array_spec *as;
13172 bool saved_specification_expr;
13173
13174 if (sym->resolved)
13175 return;
13176 sym->resolved = 1;
13177
13178 if (sym->attr.artificial)
13179 return;
13180
13181 if (sym->attr.unlimited_polymorphic)
13182 return;
13183
13184 if (sym->attr.flavor == FL_UNKNOWN
13185 || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
13186 && !sym->attr.generic && !sym->attr.external
13187 && sym->attr.if_source == IFSRC_UNKNOWN))
13188 {
13189
13190 /* If we find that a flavorless symbol is an interface in one of the
13191 parent namespaces, find its symtree in this namespace, free the
13192 symbol and set the symtree to point to the interface symbol. */
13193 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
13194 {
13195 symtree = gfc_find_symtree (ns->sym_root, sym->name);
13196 if (symtree && (symtree->n.sym->generic ||
13197 (symtree->n.sym->attr.flavor == FL_PROCEDURE
13198 && sym->ns->construct_entities)))
13199 {
13200 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
13201 sym->name);
13202 gfc_release_symbol (sym);
13203 symtree->n.sym->refs++;
13204 this_symtree->n.sym = symtree->n.sym;
13205 return;
13206 }
13207 }
13208
13209 /* Otherwise give it a flavor according to such attributes as
13210 it has. */
13211 if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
13212 && sym->attr.intrinsic == 0)
13213 sym->attr.flavor = FL_VARIABLE;
13214 else if (sym->attr.flavor == FL_UNKNOWN)
13215 {
13216 sym->attr.flavor = FL_PROCEDURE;
13217 if (sym->attr.dimension)
13218 sym->attr.function = 1;
13219 }
13220 }
13221
13222 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
13223 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
13224
13225 if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
13226 && resolve_procedure_interface (sym) == FAILURE)
13227 return;
13228
13229 if (sym->attr.is_protected && !sym->attr.proc_pointer
13230 && (sym->attr.procedure || sym->attr.external))
13231 {
13232 if (sym->attr.external)
13233 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13234 "at %L", &sym->declared_at);
13235 else
13236 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13237 "at %L", &sym->declared_at);
13238
13239 return;
13240 }
13241
13242 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
13243 return;
13244
13245 /* Symbols that are module procedures with results (functions) have
13246 the types and array specification copied for type checking in
13247 procedures that call them, as well as for saving to a module
13248 file. These symbols can't stand the scrutiny that their results
13249 can. */
13250 mp_flag = (sym->result != NULL && sym->result != sym);
13251
13252 /* Make sure that the intrinsic is consistent with its internal
13253 representation. This needs to be done before assigning a default
13254 type to avoid spurious warnings. */
13255 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
13256 && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
13257 return;
13258
13259 /* Resolve associate names. */
13260 if (sym->assoc)
13261 resolve_assoc_var (sym, true);
13262
13263 /* Assign default type to symbols that need one and don't have one. */
13264 if (sym->ts.type == BT_UNKNOWN)
13265 {
13266 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
13267 {
13268 gfc_set_default_type (sym, 1, NULL);
13269 }
13270
13271 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
13272 && !sym->attr.function && !sym->attr.subroutine
13273 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
13274 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
13275
13276 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
13277 {
13278 /* The specific case of an external procedure should emit an error
13279 in the case that there is no implicit type. */
13280 if (!mp_flag)
13281 gfc_set_default_type (sym, sym->attr.external, NULL);
13282 else
13283 {
13284 /* Result may be in another namespace. */
13285 resolve_symbol (sym->result);
13286
13287 if (!sym->result->attr.proc_pointer)
13288 {
13289 sym->ts = sym->result->ts;
13290 sym->as = gfc_copy_array_spec (sym->result->as);
13291 sym->attr.dimension = sym->result->attr.dimension;
13292 sym->attr.pointer = sym->result->attr.pointer;
13293 sym->attr.allocatable = sym->result->attr.allocatable;
13294 sym->attr.contiguous = sym->result->attr.contiguous;
13295 }
13296 }
13297 }
13298 }
13299 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
13300 {
13301 bool saved_specification_expr = specification_expr;
13302 specification_expr = true;
13303 gfc_resolve_array_spec (sym->result->as, false);
13304 specification_expr = saved_specification_expr;
13305 }
13306
13307 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
13308 {
13309 as = CLASS_DATA (sym)->as;
13310 class_attr = CLASS_DATA (sym)->attr;
13311 class_attr.pointer = class_attr.class_pointer;
13312 }
13313 else
13314 {
13315 class_attr = sym->attr;
13316 as = sym->as;
13317 }
13318
13319 /* F2008, C530. */
13320 if (sym->attr.contiguous
13321 && (!class_attr.dimension
13322 || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
13323 && !class_attr.pointer)))
13324 {
13325 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
13326 "array pointer or an assumed-shape or assumed-rank array",
13327 sym->name, &sym->declared_at);
13328 return;
13329 }
13330
13331 /* Assumed size arrays and assumed shape arrays must be dummy
13332 arguments. Array-spec's of implied-shape should have been resolved to
13333 AS_EXPLICIT already. */
13334
13335 if (as)
13336 {
13337 gcc_assert (as->type != AS_IMPLIED_SHAPE);
13338 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
13339 || as->type == AS_ASSUMED_SHAPE)
13340 && !sym->attr.dummy && !sym->attr.select_type_temporary)
13341 {
13342 if (as->type == AS_ASSUMED_SIZE)
13343 gfc_error ("Assumed size array at %L must be a dummy argument",
13344 &sym->declared_at);
13345 else
13346 gfc_error ("Assumed shape array at %L must be a dummy argument",
13347 &sym->declared_at);
13348 return;
13349 }
13350 /* TS 29113, C535a. */
13351 if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
13352 && !sym->attr.select_type_temporary)
13353 {
13354 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13355 &sym->declared_at);
13356 return;
13357 }
13358 if (as->type == AS_ASSUMED_RANK
13359 && (sym->attr.codimension || sym->attr.value))
13360 {
13361 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13362 "CODIMENSION attribute", &sym->declared_at);
13363 return;
13364 }
13365 }
13366
13367 /* Make sure symbols with known intent or optional are really dummy
13368 variable. Because of ENTRY statement, this has to be deferred
13369 until resolution time. */
13370
13371 if (!sym->attr.dummy
13372 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
13373 {
13374 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
13375 return;
13376 }
13377
13378 if (sym->attr.value && !sym->attr.dummy)
13379 {
13380 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
13381 "it is not a dummy argument", sym->name, &sym->declared_at);
13382 return;
13383 }
13384
13385 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
13386 {
13387 gfc_charlen *cl = sym->ts.u.cl;
13388 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
13389 {
13390 gfc_error ("Character dummy variable '%s' at %L with VALUE "
13391 "attribute must have constant length",
13392 sym->name, &sym->declared_at);
13393 return;
13394 }
13395
13396 if (sym->ts.is_c_interop
13397 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
13398 {
13399 gfc_error ("C interoperable character dummy variable '%s' at %L "
13400 "with VALUE attribute must have length one",
13401 sym->name, &sym->declared_at);
13402 return;
13403 }
13404 }
13405
13406 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
13407 && sym->ts.u.derived->attr.generic)
13408 {
13409 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
13410 if (!sym->ts.u.derived)
13411 {
13412 gfc_error ("The derived type '%s' at %L is of type '%s', "
13413 "which has not been defined", sym->name,
13414 &sym->declared_at, sym->ts.u.derived->name);
13415 sym->ts.type = BT_UNKNOWN;
13416 return;
13417 }
13418 }
13419
13420 if (sym->ts.type == BT_ASSUMED)
13421 {
13422 /* TS 29113, C407a. */
13423 if (!sym->attr.dummy)
13424 {
13425 gfc_error ("Assumed type of variable %s at %L is only permitted "
13426 "for dummy variables", sym->name, &sym->declared_at);
13427 return;
13428 }
13429 if (sym->attr.allocatable || sym->attr.codimension
13430 || sym->attr.pointer || sym->attr.value)
13431 {
13432 gfc_error ("Assumed-type variable %s at %L may not have the "
13433 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13434 sym->name, &sym->declared_at);
13435 return;
13436 }
13437 if (sym->attr.intent == INTENT_OUT)
13438 {
13439 gfc_error ("Assumed-type variable %s at %L may not have the "
13440 "INTENT(OUT) attribute",
13441 sym->name, &sym->declared_at);
13442 return;
13443 }
13444 if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
13445 {
13446 gfc_error ("Assumed-type variable %s at %L shall not be an "
13447 "explicit-shape array", sym->name, &sym->declared_at);
13448 return;
13449 }
13450 }
13451
13452 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13453 do this for something that was implicitly typed because that is handled
13454 in gfc_set_default_type. Handle dummy arguments and procedure
13455 definitions separately. Also, anything that is use associated is not
13456 handled here but instead is handled in the module it is declared in.
13457 Finally, derived type definitions are allowed to be BIND(C) since that
13458 only implies that they're interoperable, and they are checked fully for
13459 interoperability when a variable is declared of that type. */
13460 if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
13461 sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
13462 sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
13463 {
13464 gfc_try t = SUCCESS;
13465
13466 /* First, make sure the variable is declared at the
13467 module-level scope (J3/04-007, Section 15.3). */
13468 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
13469 sym->attr.in_common == 0)
13470 {
13471 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13472 "is neither a COMMON block nor declared at the "
13473 "module level scope", sym->name, &(sym->declared_at));
13474 t = FAILURE;
13475 }
13476 else if (sym->common_head != NULL)
13477 {
13478 t = verify_com_block_vars_c_interop (sym->common_head);
13479 }
13480 else
13481 {
13482 /* If type() declaration, we need to verify that the components
13483 of the given type are all C interoperable, etc. */
13484 if (sym->ts.type == BT_DERIVED &&
13485 sym->ts.u.derived->attr.is_c_interop != 1)
13486 {
13487 /* Make sure the user marked the derived type as BIND(C). If
13488 not, call the verify routine. This could print an error
13489 for the derived type more than once if multiple variables
13490 of that type are declared. */
13491 if (sym->ts.u.derived->attr.is_bind_c != 1)
13492 verify_bind_c_derived_type (sym->ts.u.derived);
13493 t = FAILURE;
13494 }
13495
13496 /* Verify the variable itself as C interoperable if it
13497 is BIND(C). It is not possible for this to succeed if
13498 the verify_bind_c_derived_type failed, so don't have to handle
13499 any error returned by verify_bind_c_derived_type. */
13500 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
13501 sym->common_block);
13502 }
13503
13504 if (t == FAILURE)
13505 {
13506 /* clear the is_bind_c flag to prevent reporting errors more than
13507 once if something failed. */
13508 sym->attr.is_bind_c = 0;
13509 return;
13510 }
13511 }
13512
13513 /* If a derived type symbol has reached this point, without its
13514 type being declared, we have an error. Notice that most
13515 conditions that produce undefined derived types have already
13516 been dealt with. However, the likes of:
13517 implicit type(t) (t) ..... call foo (t) will get us here if
13518 the type is not declared in the scope of the implicit
13519 statement. Change the type to BT_UNKNOWN, both because it is so
13520 and to prevent an ICE. */
13521 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
13522 && sym->ts.u.derived->components == NULL
13523 && !sym->ts.u.derived->attr.zero_comp)
13524 {
13525 gfc_error ("The derived type '%s' at %L is of type '%s', "
13526 "which has not been defined", sym->name,
13527 &sym->declared_at, sym->ts.u.derived->name);
13528 sym->ts.type = BT_UNKNOWN;
13529 return;
13530 }
13531
13532 /* Make sure that the derived type has been resolved and that the
13533 derived type is visible in the symbol's namespace, if it is a
13534 module function and is not PRIVATE. */
13535 if (sym->ts.type == BT_DERIVED
13536 && sym->ts.u.derived->attr.use_assoc
13537 && sym->ns->proc_name
13538 && sym->ns->proc_name->attr.flavor == FL_MODULE
13539 && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
13540 return;
13541
13542 /* Unless the derived-type declaration is use associated, Fortran 95
13543 does not allow public entries of private derived types.
13544 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13545 161 in 95-006r3. */
13546 if (sym->ts.type == BT_DERIVED
13547 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
13548 && !sym->ts.u.derived->attr.use_assoc
13549 && gfc_check_symbol_access (sym)
13550 && !gfc_check_symbol_access (sym->ts.u.derived)
13551 && gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L "
13552 "of PRIVATE derived type '%s'",
13553 (sym->attr.flavor == FL_PARAMETER) ? "parameter"
13554 : "variable", sym->name, &sym->declared_at,
13555 sym->ts.u.derived->name) == FAILURE)
13556 return;
13557
13558 /* F2008, C1302. */
13559 if (sym->ts.type == BT_DERIVED
13560 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
13561 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
13562 || sym->ts.u.derived->attr.lock_comp)
13563 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
13564 {
13565 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13566 "type LOCK_TYPE must be a coarray", sym->name,
13567 &sym->declared_at);
13568 return;
13569 }
13570
13571 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13572 default initialization is defined (5.1.2.4.4). */
13573 if (sym->ts.type == BT_DERIVED
13574 && sym->attr.dummy
13575 && sym->attr.intent == INTENT_OUT
13576 && sym->as
13577 && sym->as->type == AS_ASSUMED_SIZE)
13578 {
13579 for (c = sym->ts.u.derived->components; c; c = c->next)
13580 {
13581 if (c->initializer)
13582 {
13583 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13584 "ASSUMED SIZE and so cannot have a default initializer",
13585 sym->name, &sym->declared_at);
13586 return;
13587 }
13588 }
13589 }
13590
13591 /* F2008, C542. */
13592 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
13593 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
13594 {
13595 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13596 "INTENT(OUT)", sym->name, &sym->declared_at);
13597 return;
13598 }
13599
13600 /* F2008, C525. */
13601 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
13602 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13603 && CLASS_DATA (sym)->attr.coarray_comp))
13604 || class_attr.codimension)
13605 && (sym->attr.result || sym->result == sym))
13606 {
13607 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13608 "a coarray component", sym->name, &sym->declared_at);
13609 return;
13610 }
13611
13612 /* F2008, C524. */
13613 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
13614 && sym->ts.u.derived->ts.is_iso_c)
13615 {
13616 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13617 "shall not be a coarray", sym->name, &sym->declared_at);
13618 return;
13619 }
13620
13621 /* F2008, C525. */
13622 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
13623 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13624 && CLASS_DATA (sym)->attr.coarray_comp))
13625 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
13626 || class_attr.allocatable))
13627 {
13628 gfc_error ("Variable '%s' at %L with coarray component "
13629 "shall be a nonpointer, nonallocatable scalar",
13630 sym->name, &sym->declared_at);
13631 return;
13632 }
13633
13634 /* F2008, C526. The function-result case was handled above. */
13635 if (class_attr.codimension
13636 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
13637 || sym->attr.select_type_temporary
13638 || sym->ns->save_all
13639 || sym->ns->proc_name->attr.flavor == FL_MODULE
13640 || sym->ns->proc_name->attr.is_main_program
13641 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
13642 {
13643 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13644 "nor a dummy argument", sym->name, &sym->declared_at);
13645 return;
13646 }
13647 /* F2008, C528. */
13648 else if (class_attr.codimension && !sym->attr.select_type_temporary
13649 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
13650 {
13651 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13652 "deferred shape", sym->name, &sym->declared_at);
13653 return;
13654 }
13655 else if (class_attr.codimension && class_attr.allocatable && as
13656 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
13657 {
13658 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13659 "deferred shape", sym->name, &sym->declared_at);
13660 return;
13661 }
13662
13663 /* F2008, C541. */
13664 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
13665 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13666 && CLASS_DATA (sym)->attr.coarray_comp))
13667 || (class_attr.codimension && class_attr.allocatable))
13668 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
13669 {
13670 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13671 "allocatable coarray or have coarray components",
13672 sym->name, &sym->declared_at);
13673 return;
13674 }
13675
13676 if (class_attr.codimension && sym->attr.dummy
13677 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
13678 {
13679 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13680 "procedure '%s'", sym->name, &sym->declared_at,
13681 sym->ns->proc_name->name);
13682 return;
13683 }
13684
13685 if (sym->ts.type == BT_LOGICAL
13686 && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
13687 || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
13688 && sym->ns->proc_name->attr.is_bind_c)))
13689 {
13690 int i;
13691 for (i = 0; gfc_logical_kinds[i].kind; i++)
13692 if (gfc_logical_kinds[i].kind == sym->ts.kind)
13693 break;
13694 if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
13695 && gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at %L "
13696 "with non-C_Bool kind in BIND(C) procedure '%s'",
13697 sym->name, &sym->declared_at,
13698 sym->ns->proc_name->name) == FAILURE)
13699 return;
13700 else if (!gfc_logical_kinds[i].c_bool
13701 && gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable '%s' at"
13702 " %L with non-C_Bool kind in BIND(C) "
13703 "procedure '%s'", sym->name,
13704 &sym->declared_at,
13705 sym->attr.function ? sym->name
13706 : sym->ns->proc_name->name)
13707 == FAILURE)
13708 return;
13709 }
13710
13711 switch (sym->attr.flavor)
13712 {
13713 case FL_VARIABLE:
13714 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
13715 return;
13716 break;
13717
13718 case FL_PROCEDURE:
13719 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
13720 return;
13721 break;
13722
13723 case FL_NAMELIST:
13724 if (resolve_fl_namelist (sym) == FAILURE)
13725 return;
13726 break;
13727
13728 case FL_PARAMETER:
13729 if (resolve_fl_parameter (sym) == FAILURE)
13730 return;
13731 break;
13732
13733 default:
13734 break;
13735 }
13736
13737 /* Resolve array specifier. Check as well some constraints
13738 on COMMON blocks. */
13739
13740 check_constant = sym->attr.in_common && !sym->attr.pointer;
13741
13742 /* Set the formal_arg_flag so that check_conflict will not throw
13743 an error for host associated variables in the specification
13744 expression for an array_valued function. */
13745 if (sym->attr.function && sym->as)
13746 formal_arg_flag = 1;
13747
13748 saved_specification_expr = specification_expr;
13749 specification_expr = true;
13750 gfc_resolve_array_spec (sym->as, check_constant);
13751 specification_expr = saved_specification_expr;
13752
13753 formal_arg_flag = 0;
13754
13755 /* Resolve formal namespaces. */
13756 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
13757 && !sym->attr.contained && !sym->attr.intrinsic)
13758 gfc_resolve (sym->formal_ns);
13759
13760 /* Make sure the formal namespace is present. */
13761 if (sym->formal && !sym->formal_ns)
13762 {
13763 gfc_formal_arglist *formal = sym->formal;
13764 while (formal && !formal->sym)
13765 formal = formal->next;
13766
13767 if (formal)
13768 {
13769 sym->formal_ns = formal->sym->ns;
13770 if (sym->ns != formal->sym->ns)
13771 sym->formal_ns->refs++;
13772 }
13773 }
13774
13775 /* Check threadprivate restrictions. */
13776 if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
13777 && (!sym->attr.in_common
13778 && sym->module == NULL
13779 && (sym->ns->proc_name == NULL
13780 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
13781 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
13782
13783 /* If we have come this far we can apply default-initializers, as
13784 described in 14.7.5, to those variables that have not already
13785 been assigned one. */
13786 if (sym->ts.type == BT_DERIVED
13787 && !sym->value
13788 && !sym->attr.allocatable
13789 && !sym->attr.alloc_comp)
13790 {
13791 symbol_attribute *a = &sym->attr;
13792
13793 if ((!a->save && !a->dummy && !a->pointer
13794 && !a->in_common && !a->use_assoc
13795 && (a->referenced || a->result)
13796 && !(a->function && sym != sym->result))
13797 || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
13798 apply_default_init (sym);
13799 }
13800
13801 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
13802 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
13803 && !CLASS_DATA (sym)->attr.class_pointer
13804 && !CLASS_DATA (sym)->attr.allocatable)
13805 apply_default_init (sym);
13806
13807 /* If this symbol has a type-spec, check it. */
13808 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
13809 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
13810 if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
13811 == FAILURE)
13812 return;
13813 }
13814
13815
13816 /************* Resolve DATA statements *************/
13817
13818 static struct
13819 {
13820 gfc_data_value *vnode;
13821 mpz_t left;
13822 }
13823 values;
13824
13825
13826 /* Advance the values structure to point to the next value in the data list. */
13827
13828 static gfc_try
next_data_value(void)13829 next_data_value (void)
13830 {
13831 while (mpz_cmp_ui (values.left, 0) == 0)
13832 {
13833
13834 if (values.vnode->next == NULL)
13835 return FAILURE;
13836
13837 values.vnode = values.vnode->next;
13838 mpz_set (values.left, values.vnode->repeat);
13839 }
13840
13841 return SUCCESS;
13842 }
13843
13844
13845 static gfc_try
check_data_variable(gfc_data_variable * var,locus * where)13846 check_data_variable (gfc_data_variable *var, locus *where)
13847 {
13848 gfc_expr *e;
13849 mpz_t size;
13850 mpz_t offset;
13851 gfc_try t;
13852 ar_type mark = AR_UNKNOWN;
13853 int i;
13854 mpz_t section_index[GFC_MAX_DIMENSIONS];
13855 gfc_ref *ref;
13856 gfc_array_ref *ar;
13857 gfc_symbol *sym;
13858 int has_pointer;
13859
13860 if (gfc_resolve_expr (var->expr) == FAILURE)
13861 return FAILURE;
13862
13863 ar = NULL;
13864 mpz_init_set_si (offset, 0);
13865 e = var->expr;
13866
13867 if (e->expr_type != EXPR_VARIABLE)
13868 gfc_internal_error ("check_data_variable(): Bad expression");
13869
13870 sym = e->symtree->n.sym;
13871
13872 if (sym->ns->is_block_data && !sym->attr.in_common)
13873 {
13874 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13875 sym->name, &sym->declared_at);
13876 }
13877
13878 if (e->ref == NULL && sym->as)
13879 {
13880 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13881 " declaration", sym->name, where);
13882 return FAILURE;
13883 }
13884
13885 has_pointer = sym->attr.pointer;
13886
13887 if (gfc_is_coindexed (e))
13888 {
13889 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
13890 where);
13891 return FAILURE;
13892 }
13893
13894 for (ref = e->ref; ref; ref = ref->next)
13895 {
13896 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
13897 has_pointer = 1;
13898
13899 if (has_pointer
13900 && ref->type == REF_ARRAY
13901 && ref->u.ar.type != AR_FULL)
13902 {
13903 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13904 "be a full array", sym->name, where);
13905 return FAILURE;
13906 }
13907 }
13908
13909 if (e->rank == 0 || has_pointer)
13910 {
13911 mpz_init_set_ui (size, 1);
13912 ref = NULL;
13913 }
13914 else
13915 {
13916 ref = e->ref;
13917
13918 /* Find the array section reference. */
13919 for (ref = e->ref; ref; ref = ref->next)
13920 {
13921 if (ref->type != REF_ARRAY)
13922 continue;
13923 if (ref->u.ar.type == AR_ELEMENT)
13924 continue;
13925 break;
13926 }
13927 gcc_assert (ref);
13928
13929 /* Set marks according to the reference pattern. */
13930 switch (ref->u.ar.type)
13931 {
13932 case AR_FULL:
13933 mark = AR_FULL;
13934 break;
13935
13936 case AR_SECTION:
13937 ar = &ref->u.ar;
13938 /* Get the start position of array section. */
13939 gfc_get_section_index (ar, section_index, &offset);
13940 mark = AR_SECTION;
13941 break;
13942
13943 default:
13944 gcc_unreachable ();
13945 }
13946
13947 if (gfc_array_size (e, &size) == FAILURE)
13948 {
13949 gfc_error ("Nonconstant array section at %L in DATA statement",
13950 &e->where);
13951 mpz_clear (offset);
13952 return FAILURE;
13953 }
13954 }
13955
13956 t = SUCCESS;
13957
13958 while (mpz_cmp_ui (size, 0) > 0)
13959 {
13960 if (next_data_value () == FAILURE)
13961 {
13962 gfc_error ("DATA statement at %L has more variables than values",
13963 where);
13964 t = FAILURE;
13965 break;
13966 }
13967
13968 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
13969 if (t == FAILURE)
13970 break;
13971
13972 /* If we have more than one element left in the repeat count,
13973 and we have more than one element left in the target variable,
13974 then create a range assignment. */
13975 /* FIXME: Only done for full arrays for now, since array sections
13976 seem tricky. */
13977 if (mark == AR_FULL && ref && ref->next == NULL
13978 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
13979 {
13980 mpz_t range;
13981
13982 if (mpz_cmp (size, values.left) >= 0)
13983 {
13984 mpz_init_set (range, values.left);
13985 mpz_sub (size, size, values.left);
13986 mpz_set_ui (values.left, 0);
13987 }
13988 else
13989 {
13990 mpz_init_set (range, size);
13991 mpz_sub (values.left, values.left, size);
13992 mpz_set_ui (size, 0);
13993 }
13994
13995 t = gfc_assign_data_value (var->expr, values.vnode->expr,
13996 offset, &range);
13997
13998 mpz_add (offset, offset, range);
13999 mpz_clear (range);
14000
14001 if (t == FAILURE)
14002 break;
14003 }
14004
14005 /* Assign initial value to symbol. */
14006 else
14007 {
14008 mpz_sub_ui (values.left, values.left, 1);
14009 mpz_sub_ui (size, size, 1);
14010
14011 t = gfc_assign_data_value (var->expr, values.vnode->expr,
14012 offset, NULL);
14013 if (t == FAILURE)
14014 break;
14015
14016 if (mark == AR_FULL)
14017 mpz_add_ui (offset, offset, 1);
14018
14019 /* Modify the array section indexes and recalculate the offset
14020 for next element. */
14021 else if (mark == AR_SECTION)
14022 gfc_advance_section (section_index, ar, &offset);
14023 }
14024 }
14025
14026 if (mark == AR_SECTION)
14027 {
14028 for (i = 0; i < ar->dimen; i++)
14029 mpz_clear (section_index[i]);
14030 }
14031
14032 mpz_clear (size);
14033 mpz_clear (offset);
14034
14035 return t;
14036 }
14037
14038
14039 static gfc_try traverse_data_var (gfc_data_variable *, locus *);
14040
14041 /* Iterate over a list of elements in a DATA statement. */
14042
14043 static gfc_try
traverse_data_list(gfc_data_variable * var,locus * where)14044 traverse_data_list (gfc_data_variable *var, locus *where)
14045 {
14046 mpz_t trip;
14047 iterator_stack frame;
14048 gfc_expr *e, *start, *end, *step;
14049 gfc_try retval = SUCCESS;
14050
14051 mpz_init (frame.value);
14052 mpz_init (trip);
14053
14054 start = gfc_copy_expr (var->iter.start);
14055 end = gfc_copy_expr (var->iter.end);
14056 step = gfc_copy_expr (var->iter.step);
14057
14058 if (gfc_simplify_expr (start, 1) == FAILURE
14059 || start->expr_type != EXPR_CONSTANT)
14060 {
14061 gfc_error ("start of implied-do loop at %L could not be "
14062 "simplified to a constant value", &start->where);
14063 retval = FAILURE;
14064 goto cleanup;
14065 }
14066 if (gfc_simplify_expr (end, 1) == FAILURE
14067 || end->expr_type != EXPR_CONSTANT)
14068 {
14069 gfc_error ("end of implied-do loop at %L could not be "
14070 "simplified to a constant value", &start->where);
14071 retval = FAILURE;
14072 goto cleanup;
14073 }
14074 if (gfc_simplify_expr (step, 1) == FAILURE
14075 || step->expr_type != EXPR_CONSTANT)
14076 {
14077 gfc_error ("step of implied-do loop at %L could not be "
14078 "simplified to a constant value", &start->where);
14079 retval = FAILURE;
14080 goto cleanup;
14081 }
14082
14083 mpz_set (trip, end->value.integer);
14084 mpz_sub (trip, trip, start->value.integer);
14085 mpz_add (trip, trip, step->value.integer);
14086
14087 mpz_div (trip, trip, step->value.integer);
14088
14089 mpz_set (frame.value, start->value.integer);
14090
14091 frame.prev = iter_stack;
14092 frame.variable = var->iter.var->symtree;
14093 iter_stack = &frame;
14094
14095 while (mpz_cmp_ui (trip, 0) > 0)
14096 {
14097 if (traverse_data_var (var->list, where) == FAILURE)
14098 {
14099 retval = FAILURE;
14100 goto cleanup;
14101 }
14102
14103 e = gfc_copy_expr (var->expr);
14104 if (gfc_simplify_expr (e, 1) == FAILURE)
14105 {
14106 gfc_free_expr (e);
14107 retval = FAILURE;
14108 goto cleanup;
14109 }
14110
14111 mpz_add (frame.value, frame.value, step->value.integer);
14112
14113 mpz_sub_ui (trip, trip, 1);
14114 }
14115
14116 cleanup:
14117 mpz_clear (frame.value);
14118 mpz_clear (trip);
14119
14120 gfc_free_expr (start);
14121 gfc_free_expr (end);
14122 gfc_free_expr (step);
14123
14124 iter_stack = frame.prev;
14125 return retval;
14126 }
14127
14128
14129 /* Type resolve variables in the variable list of a DATA statement. */
14130
14131 static gfc_try
traverse_data_var(gfc_data_variable * var,locus * where)14132 traverse_data_var (gfc_data_variable *var, locus *where)
14133 {
14134 gfc_try t;
14135
14136 for (; var; var = var->next)
14137 {
14138 if (var->expr == NULL)
14139 t = traverse_data_list (var, where);
14140 else
14141 t = check_data_variable (var, where);
14142
14143 if (t == FAILURE)
14144 return FAILURE;
14145 }
14146
14147 return SUCCESS;
14148 }
14149
14150
14151 /* Resolve the expressions and iterators associated with a data statement.
14152 This is separate from the assignment checking because data lists should
14153 only be resolved once. */
14154
14155 static gfc_try
resolve_data_variables(gfc_data_variable * d)14156 resolve_data_variables (gfc_data_variable *d)
14157 {
14158 for (; d; d = d->next)
14159 {
14160 if (d->list == NULL)
14161 {
14162 if (gfc_resolve_expr (d->expr) == FAILURE)
14163 return FAILURE;
14164 }
14165 else
14166 {
14167 if (gfc_resolve_iterator (&d->iter, false, true) == FAILURE)
14168 return FAILURE;
14169
14170 if (resolve_data_variables (d->list) == FAILURE)
14171 return FAILURE;
14172 }
14173 }
14174
14175 return SUCCESS;
14176 }
14177
14178
14179 /* Resolve a single DATA statement. We implement this by storing a pointer to
14180 the value list into static variables, and then recursively traversing the
14181 variables list, expanding iterators and such. */
14182
14183 static void
resolve_data(gfc_data * d)14184 resolve_data (gfc_data *d)
14185 {
14186
14187 if (resolve_data_variables (d->var) == FAILURE)
14188 return;
14189
14190 values.vnode = d->value;
14191 if (d->value == NULL)
14192 mpz_set_ui (values.left, 0);
14193 else
14194 mpz_set (values.left, d->value->repeat);
14195
14196 if (traverse_data_var (d->var, &d->where) == FAILURE)
14197 return;
14198
14199 /* At this point, we better not have any values left. */
14200
14201 if (next_data_value () == SUCCESS)
14202 gfc_error ("DATA statement at %L has more values than variables",
14203 &d->where);
14204 }
14205
14206
14207 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14208 accessed by host or use association, is a dummy argument to a pure function,
14209 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14210 is storage associated with any such variable, shall not be used in the
14211 following contexts: (clients of this function). */
14212
14213 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14214 procedure. Returns zero if assignment is OK, nonzero if there is a
14215 problem. */
14216 int
gfc_impure_variable(gfc_symbol * sym)14217 gfc_impure_variable (gfc_symbol *sym)
14218 {
14219 gfc_symbol *proc;
14220 gfc_namespace *ns;
14221
14222 if (sym->attr.use_assoc || sym->attr.in_common)
14223 return 1;
14224
14225 /* Check if the symbol's ns is inside the pure procedure. */
14226 for (ns = gfc_current_ns; ns; ns = ns->parent)
14227 {
14228 if (ns == sym->ns)
14229 break;
14230 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
14231 return 1;
14232 }
14233
14234 proc = sym->ns->proc_name;
14235 if (sym->attr.dummy
14236 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
14237 || proc->attr.function))
14238 return 1;
14239
14240 /* TODO: Sort out what can be storage associated, if anything, and include
14241 it here. In principle equivalences should be scanned but it does not
14242 seem to be possible to storage associate an impure variable this way. */
14243 return 0;
14244 }
14245
14246
14247 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14248 current namespace is inside a pure procedure. */
14249
14250 int
gfc_pure(gfc_symbol * sym)14251 gfc_pure (gfc_symbol *sym)
14252 {
14253 symbol_attribute attr;
14254 gfc_namespace *ns;
14255
14256 if (sym == NULL)
14257 {
14258 /* Check if the current namespace or one of its parents
14259 belongs to a pure procedure. */
14260 for (ns = gfc_current_ns; ns; ns = ns->parent)
14261 {
14262 sym = ns->proc_name;
14263 if (sym == NULL)
14264 return 0;
14265 attr = sym->attr;
14266 if (attr.flavor == FL_PROCEDURE && attr.pure)
14267 return 1;
14268 }
14269 return 0;
14270 }
14271
14272 attr = sym->attr;
14273
14274 return attr.flavor == FL_PROCEDURE && attr.pure;
14275 }
14276
14277
14278 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14279 checks if the current namespace is implicitly pure. Note that this
14280 function returns false for a PURE procedure. */
14281
14282 int
gfc_implicit_pure(gfc_symbol * sym)14283 gfc_implicit_pure (gfc_symbol *sym)
14284 {
14285 gfc_namespace *ns;
14286
14287 if (sym == NULL)
14288 {
14289 /* Check if the current procedure is implicit_pure. Walk up
14290 the procedure list until we find a procedure. */
14291 for (ns = gfc_current_ns; ns; ns = ns->parent)
14292 {
14293 sym = ns->proc_name;
14294 if (sym == NULL)
14295 return 0;
14296
14297 if (sym->attr.flavor == FL_PROCEDURE)
14298 break;
14299 }
14300 }
14301
14302 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
14303 && !sym->attr.pure;
14304 }
14305
14306
14307 /* Test whether the current procedure is elemental or not. */
14308
14309 int
gfc_elemental(gfc_symbol * sym)14310 gfc_elemental (gfc_symbol *sym)
14311 {
14312 symbol_attribute attr;
14313
14314 if (sym == NULL)
14315 sym = gfc_current_ns->proc_name;
14316 if (sym == NULL)
14317 return 0;
14318 attr = sym->attr;
14319
14320 return attr.flavor == FL_PROCEDURE && attr.elemental;
14321 }
14322
14323
14324 /* Warn about unused labels. */
14325
14326 static void
warn_unused_fortran_label(gfc_st_label * label)14327 warn_unused_fortran_label (gfc_st_label *label)
14328 {
14329 if (label == NULL)
14330 return;
14331
14332 warn_unused_fortran_label (label->left);
14333
14334 if (label->defined == ST_LABEL_UNKNOWN)
14335 return;
14336
14337 switch (label->referenced)
14338 {
14339 case ST_LABEL_UNKNOWN:
14340 gfc_warning ("Label %d at %L defined but not used", label->value,
14341 &label->where);
14342 break;
14343
14344 case ST_LABEL_BAD_TARGET:
14345 gfc_warning ("Label %d at %L defined but cannot be used",
14346 label->value, &label->where);
14347 break;
14348
14349 default:
14350 break;
14351 }
14352
14353 warn_unused_fortran_label (label->right);
14354 }
14355
14356
14357 /* Returns the sequence type of a symbol or sequence. */
14358
14359 static seq_type
sequence_type(gfc_typespec ts)14360 sequence_type (gfc_typespec ts)
14361 {
14362 seq_type result;
14363 gfc_component *c;
14364
14365 switch (ts.type)
14366 {
14367 case BT_DERIVED:
14368
14369 if (ts.u.derived->components == NULL)
14370 return SEQ_NONDEFAULT;
14371
14372 result = sequence_type (ts.u.derived->components->ts);
14373 for (c = ts.u.derived->components->next; c; c = c->next)
14374 if (sequence_type (c->ts) != result)
14375 return SEQ_MIXED;
14376
14377 return result;
14378
14379 case BT_CHARACTER:
14380 if (ts.kind != gfc_default_character_kind)
14381 return SEQ_NONDEFAULT;
14382
14383 return SEQ_CHARACTER;
14384
14385 case BT_INTEGER:
14386 if (ts.kind != gfc_default_integer_kind)
14387 return SEQ_NONDEFAULT;
14388
14389 return SEQ_NUMERIC;
14390
14391 case BT_REAL:
14392 if (!(ts.kind == gfc_default_real_kind
14393 || ts.kind == gfc_default_double_kind))
14394 return SEQ_NONDEFAULT;
14395
14396 return SEQ_NUMERIC;
14397
14398 case BT_COMPLEX:
14399 if (ts.kind != gfc_default_complex_kind)
14400 return SEQ_NONDEFAULT;
14401
14402 return SEQ_NUMERIC;
14403
14404 case BT_LOGICAL:
14405 if (ts.kind != gfc_default_logical_kind)
14406 return SEQ_NONDEFAULT;
14407
14408 return SEQ_NUMERIC;
14409
14410 default:
14411 return SEQ_NONDEFAULT;
14412 }
14413 }
14414
14415
14416 /* Resolve derived type EQUIVALENCE object. */
14417
14418 static gfc_try
resolve_equivalence_derived(gfc_symbol * derived,gfc_symbol * sym,gfc_expr * e)14419 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
14420 {
14421 gfc_component *c = derived->components;
14422
14423 if (!derived)
14424 return SUCCESS;
14425
14426 /* Shall not be an object of nonsequence derived type. */
14427 if (!derived->attr.sequence)
14428 {
14429 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14430 "attribute to be an EQUIVALENCE object", sym->name,
14431 &e->where);
14432 return FAILURE;
14433 }
14434
14435 /* Shall not have allocatable components. */
14436 if (derived->attr.alloc_comp)
14437 {
14438 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14439 "components to be an EQUIVALENCE object",sym->name,
14440 &e->where);
14441 return FAILURE;
14442 }
14443
14444 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
14445 {
14446 gfc_error ("Derived type variable '%s' at %L with default "
14447 "initialization cannot be in EQUIVALENCE with a variable "
14448 "in COMMON", sym->name, &e->where);
14449 return FAILURE;
14450 }
14451
14452 for (; c ; c = c->next)
14453 {
14454 if (c->ts.type == BT_DERIVED
14455 && (resolve_equivalence_derived (c->ts.u.derived, sym, e) == FAILURE))
14456 return FAILURE;
14457
14458 /* Shall not be an object of sequence derived type containing a pointer
14459 in the structure. */
14460 if (c->attr.pointer)
14461 {
14462 gfc_error ("Derived type variable '%s' at %L with pointer "
14463 "component(s) cannot be an EQUIVALENCE object",
14464 sym->name, &e->where);
14465 return FAILURE;
14466 }
14467 }
14468 return SUCCESS;
14469 }
14470
14471
14472 /* Resolve equivalence object.
14473 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14474 an allocatable array, an object of nonsequence derived type, an object of
14475 sequence derived type containing a pointer at any level of component
14476 selection, an automatic object, a function name, an entry name, a result
14477 name, a named constant, a structure component, or a subobject of any of
14478 the preceding objects. A substring shall not have length zero. A
14479 derived type shall not have components with default initialization nor
14480 shall two objects of an equivalence group be initialized.
14481 Either all or none of the objects shall have an protected attribute.
14482 The simple constraints are done in symbol.c(check_conflict) and the rest
14483 are implemented here. */
14484
14485 static void
resolve_equivalence(gfc_equiv * eq)14486 resolve_equivalence (gfc_equiv *eq)
14487 {
14488 gfc_symbol *sym;
14489 gfc_symbol *first_sym;
14490 gfc_expr *e;
14491 gfc_ref *r;
14492 locus *last_where = NULL;
14493 seq_type eq_type, last_eq_type;
14494 gfc_typespec *last_ts;
14495 int object, cnt_protected;
14496 const char *msg;
14497
14498 last_ts = &eq->expr->symtree->n.sym->ts;
14499
14500 first_sym = eq->expr->symtree->n.sym;
14501
14502 cnt_protected = 0;
14503
14504 for (object = 1; eq; eq = eq->eq, object++)
14505 {
14506 e = eq->expr;
14507
14508 e->ts = e->symtree->n.sym->ts;
14509 /* match_varspec might not know yet if it is seeing
14510 array reference or substring reference, as it doesn't
14511 know the types. */
14512 if (e->ref && e->ref->type == REF_ARRAY)
14513 {
14514 gfc_ref *ref = e->ref;
14515 sym = e->symtree->n.sym;
14516
14517 if (sym->attr.dimension)
14518 {
14519 ref->u.ar.as = sym->as;
14520 ref = ref->next;
14521 }
14522
14523 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14524 if (e->ts.type == BT_CHARACTER
14525 && ref
14526 && ref->type == REF_ARRAY
14527 && ref->u.ar.dimen == 1
14528 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
14529 && ref->u.ar.stride[0] == NULL)
14530 {
14531 gfc_expr *start = ref->u.ar.start[0];
14532 gfc_expr *end = ref->u.ar.end[0];
14533 void *mem = NULL;
14534
14535 /* Optimize away the (:) reference. */
14536 if (start == NULL && end == NULL)
14537 {
14538 if (e->ref == ref)
14539 e->ref = ref->next;
14540 else
14541 e->ref->next = ref->next;
14542 mem = ref;
14543 }
14544 else
14545 {
14546 ref->type = REF_SUBSTRING;
14547 if (start == NULL)
14548 start = gfc_get_int_expr (gfc_default_integer_kind,
14549 NULL, 1);
14550 ref->u.ss.start = start;
14551 if (end == NULL && e->ts.u.cl)
14552 end = gfc_copy_expr (e->ts.u.cl->length);
14553 ref->u.ss.end = end;
14554 ref->u.ss.length = e->ts.u.cl;
14555 e->ts.u.cl = NULL;
14556 }
14557 ref = ref->next;
14558 free (mem);
14559 }
14560
14561 /* Any further ref is an error. */
14562 if (ref)
14563 {
14564 gcc_assert (ref->type == REF_ARRAY);
14565 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14566 &ref->u.ar.where);
14567 continue;
14568 }
14569 }
14570
14571 if (gfc_resolve_expr (e) == FAILURE)
14572 continue;
14573
14574 sym = e->symtree->n.sym;
14575
14576 if (sym->attr.is_protected)
14577 cnt_protected++;
14578 if (cnt_protected > 0 && cnt_protected != object)
14579 {
14580 gfc_error ("Either all or none of the objects in the "
14581 "EQUIVALENCE set at %L shall have the "
14582 "PROTECTED attribute",
14583 &e->where);
14584 break;
14585 }
14586
14587 /* Shall not equivalence common block variables in a PURE procedure. */
14588 if (sym->ns->proc_name
14589 && sym->ns->proc_name->attr.pure
14590 && sym->attr.in_common)
14591 {
14592 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14593 "object in the pure procedure '%s'",
14594 sym->name, &e->where, sym->ns->proc_name->name);
14595 break;
14596 }
14597
14598 /* Shall not be a named constant. */
14599 if (e->expr_type == EXPR_CONSTANT)
14600 {
14601 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14602 "object", sym->name, &e->where);
14603 continue;
14604 }
14605
14606 if (e->ts.type == BT_DERIVED
14607 && resolve_equivalence_derived (e->ts.u.derived, sym, e) == FAILURE)
14608 continue;
14609
14610 /* Check that the types correspond correctly:
14611 Note 5.28:
14612 A numeric sequence structure may be equivalenced to another sequence
14613 structure, an object of default integer type, default real type, double
14614 precision real type, default logical type such that components of the
14615 structure ultimately only become associated to objects of the same
14616 kind. A character sequence structure may be equivalenced to an object
14617 of default character kind or another character sequence structure.
14618 Other objects may be equivalenced only to objects of the same type and
14619 kind parameters. */
14620
14621 /* Identical types are unconditionally OK. */
14622 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
14623 goto identical_types;
14624
14625 last_eq_type = sequence_type (*last_ts);
14626 eq_type = sequence_type (sym->ts);
14627
14628 /* Since the pair of objects is not of the same type, mixed or
14629 non-default sequences can be rejected. */
14630
14631 msg = "Sequence %s with mixed components in EQUIVALENCE "
14632 "statement at %L with different type objects";
14633 if ((object ==2
14634 && last_eq_type == SEQ_MIXED
14635 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
14636 == FAILURE)
14637 || (eq_type == SEQ_MIXED
14638 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14639 &e->where) == FAILURE))
14640 continue;
14641
14642 msg = "Non-default type object or sequence %s in EQUIVALENCE "
14643 "statement at %L with objects of different type";
14644 if ((object ==2
14645 && last_eq_type == SEQ_NONDEFAULT
14646 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
14647 last_where) == FAILURE)
14648 || (eq_type == SEQ_NONDEFAULT
14649 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14650 &e->where) == FAILURE))
14651 continue;
14652
14653 msg ="Non-CHARACTER object '%s' in default CHARACTER "
14654 "EQUIVALENCE statement at %L";
14655 if (last_eq_type == SEQ_CHARACTER
14656 && eq_type != SEQ_CHARACTER
14657 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14658 &e->where) == FAILURE)
14659 continue;
14660
14661 msg ="Non-NUMERIC object '%s' in default NUMERIC "
14662 "EQUIVALENCE statement at %L";
14663 if (last_eq_type == SEQ_NUMERIC
14664 && eq_type != SEQ_NUMERIC
14665 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
14666 &e->where) == FAILURE)
14667 continue;
14668
14669 identical_types:
14670 last_ts =&sym->ts;
14671 last_where = &e->where;
14672
14673 if (!e->ref)
14674 continue;
14675
14676 /* Shall not be an automatic array. */
14677 if (e->ref->type == REF_ARRAY
14678 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
14679 {
14680 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14681 "an EQUIVALENCE object", sym->name, &e->where);
14682 continue;
14683 }
14684
14685 r = e->ref;
14686 while (r)
14687 {
14688 /* Shall not be a structure component. */
14689 if (r->type == REF_COMPONENT)
14690 {
14691 gfc_error ("Structure component '%s' at %L cannot be an "
14692 "EQUIVALENCE object",
14693 r->u.c.component->name, &e->where);
14694 break;
14695 }
14696
14697 /* A substring shall not have length zero. */
14698 if (r->type == REF_SUBSTRING)
14699 {
14700 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
14701 {
14702 gfc_error ("Substring at %L has length zero",
14703 &r->u.ss.start->where);
14704 break;
14705 }
14706 }
14707 r = r->next;
14708 }
14709 }
14710 }
14711
14712
14713 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14714
14715 static void
resolve_fntype(gfc_namespace * ns)14716 resolve_fntype (gfc_namespace *ns)
14717 {
14718 gfc_entry_list *el;
14719 gfc_symbol *sym;
14720
14721 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
14722 return;
14723
14724 /* If there are any entries, ns->proc_name is the entry master
14725 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14726 if (ns->entries)
14727 sym = ns->entries->sym;
14728 else
14729 sym = ns->proc_name;
14730 if (sym->result == sym
14731 && sym->ts.type == BT_UNKNOWN
14732 && gfc_set_default_type (sym, 0, NULL) == FAILURE
14733 && !sym->attr.untyped)
14734 {
14735 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14736 sym->name, &sym->declared_at);
14737 sym->attr.untyped = 1;
14738 }
14739
14740 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
14741 && !sym->attr.contained
14742 && !gfc_check_symbol_access (sym->ts.u.derived)
14743 && gfc_check_symbol_access (sym))
14744 {
14745 gfc_notify_std (GFC_STD_F2003, "PUBLIC function '%s' at "
14746 "%L of PRIVATE type '%s'", sym->name,
14747 &sym->declared_at, sym->ts.u.derived->name);
14748 }
14749
14750 if (ns->entries)
14751 for (el = ns->entries->next; el; el = el->next)
14752 {
14753 if (el->sym->result == el->sym
14754 && el->sym->ts.type == BT_UNKNOWN
14755 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
14756 && !el->sym->attr.untyped)
14757 {
14758 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14759 el->sym->name, &el->sym->declared_at);
14760 el->sym->attr.untyped = 1;
14761 }
14762 }
14763 }
14764
14765
14766 /* 12.3.2.1.1 Defined operators. */
14767
14768 static gfc_try
check_uop_procedure(gfc_symbol * sym,locus where)14769 check_uop_procedure (gfc_symbol *sym, locus where)
14770 {
14771 gfc_formal_arglist *formal;
14772
14773 if (!sym->attr.function)
14774 {
14775 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14776 sym->name, &where);
14777 return FAILURE;
14778 }
14779
14780 if (sym->ts.type == BT_CHARACTER
14781 && !(sym->ts.u.cl && sym->ts.u.cl->length)
14782 && !(sym->result && sym->result->ts.u.cl
14783 && sym->result->ts.u.cl->length))
14784 {
14785 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14786 "character length", sym->name, &where);
14787 return FAILURE;
14788 }
14789
14790 formal = gfc_sym_get_dummy_args (sym);
14791 if (!formal || !formal->sym)
14792 {
14793 gfc_error ("User operator procedure '%s' at %L must have at least "
14794 "one argument", sym->name, &where);
14795 return FAILURE;
14796 }
14797
14798 if (formal->sym->attr.intent != INTENT_IN)
14799 {
14800 gfc_error ("First argument of operator interface at %L must be "
14801 "INTENT(IN)", &where);
14802 return FAILURE;
14803 }
14804
14805 if (formal->sym->attr.optional)
14806 {
14807 gfc_error ("First argument of operator interface at %L cannot be "
14808 "optional", &where);
14809 return FAILURE;
14810 }
14811
14812 formal = formal->next;
14813 if (!formal || !formal->sym)
14814 return SUCCESS;
14815
14816 if (formal->sym->attr.intent != INTENT_IN)
14817 {
14818 gfc_error ("Second argument of operator interface at %L must be "
14819 "INTENT(IN)", &where);
14820 return FAILURE;
14821 }
14822
14823 if (formal->sym->attr.optional)
14824 {
14825 gfc_error ("Second argument of operator interface at %L cannot be "
14826 "optional", &where);
14827 return FAILURE;
14828 }
14829
14830 if (formal->next)
14831 {
14832 gfc_error ("Operator interface at %L must have, at most, two "
14833 "arguments", &where);
14834 return FAILURE;
14835 }
14836
14837 return SUCCESS;
14838 }
14839
14840 static void
gfc_resolve_uops(gfc_symtree * symtree)14841 gfc_resolve_uops (gfc_symtree *symtree)
14842 {
14843 gfc_interface *itr;
14844
14845 if (symtree == NULL)
14846 return;
14847
14848 gfc_resolve_uops (symtree->left);
14849 gfc_resolve_uops (symtree->right);
14850
14851 for (itr = symtree->n.uop->op; itr; itr = itr->next)
14852 check_uop_procedure (itr->sym, itr->sym->declared_at);
14853 }
14854
14855
14856 /* Examine all of the expressions associated with a program unit,
14857 assign types to all intermediate expressions, make sure that all
14858 assignments are to compatible types and figure out which names
14859 refer to which functions or subroutines. It doesn't check code
14860 block, which is handled by resolve_code. */
14861
14862 static void
resolve_types(gfc_namespace * ns)14863 resolve_types (gfc_namespace *ns)
14864 {
14865 gfc_namespace *n;
14866 gfc_charlen *cl;
14867 gfc_data *d;
14868 gfc_equiv *eq;
14869 gfc_namespace* old_ns = gfc_current_ns;
14870
14871 /* Check that all IMPLICIT types are ok. */
14872 if (!ns->seen_implicit_none)
14873 {
14874 unsigned letter;
14875 for (letter = 0; letter != GFC_LETTERS; ++letter)
14876 if (ns->set_flag[letter]
14877 && resolve_typespec_used (&ns->default_type[letter],
14878 &ns->implicit_loc[letter],
14879 NULL) == FAILURE)
14880 return;
14881 }
14882
14883 gfc_current_ns = ns;
14884
14885 resolve_entries (ns);
14886
14887 resolve_common_vars (ns->blank_common.head, false);
14888 resolve_common_blocks (ns->common_root);
14889
14890 resolve_contained_functions (ns);
14891
14892 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
14893 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
14894 resolve_formal_arglist (ns->proc_name);
14895
14896 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
14897
14898 for (cl = ns->cl_list; cl; cl = cl->next)
14899 resolve_charlen (cl);
14900
14901 gfc_traverse_ns (ns, resolve_symbol);
14902
14903 resolve_fntype (ns);
14904
14905 for (n = ns->contained; n; n = n->sibling)
14906 {
14907 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
14908 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14909 "also be PURE", n->proc_name->name,
14910 &n->proc_name->declared_at);
14911
14912 resolve_types (n);
14913 }
14914
14915 forall_flag = 0;
14916 do_concurrent_flag = 0;
14917 gfc_check_interfaces (ns);
14918
14919 gfc_traverse_ns (ns, resolve_values);
14920
14921 if (ns->save_all)
14922 gfc_save_all (ns);
14923
14924 iter_stack = NULL;
14925 for (d = ns->data; d; d = d->next)
14926 resolve_data (d);
14927
14928 iter_stack = NULL;
14929 gfc_traverse_ns (ns, gfc_formalize_init_value);
14930
14931 gfc_traverse_ns (ns, gfc_verify_binding_labels);
14932
14933 if (ns->common_root != NULL)
14934 gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
14935
14936 for (eq = ns->equiv; eq; eq = eq->next)
14937 resolve_equivalence (eq);
14938
14939 /* Warn about unused labels. */
14940 if (warn_unused_label)
14941 warn_unused_fortran_label (ns->st_labels);
14942
14943 gfc_resolve_uops (ns->uop_root);
14944
14945 gfc_current_ns = old_ns;
14946 }
14947
14948
14949 /* Call resolve_code recursively. */
14950
14951 static void
resolve_codes(gfc_namespace * ns)14952 resolve_codes (gfc_namespace *ns)
14953 {
14954 gfc_namespace *n;
14955 bitmap_obstack old_obstack;
14956
14957 if (ns->resolved == 1)
14958 return;
14959
14960 for (n = ns->contained; n; n = n->sibling)
14961 resolve_codes (n);
14962
14963 gfc_current_ns = ns;
14964
14965 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14966 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
14967 cs_base = NULL;
14968
14969 /* Set to an out of range value. */
14970 current_entry_id = -1;
14971
14972 old_obstack = labels_obstack;
14973 bitmap_obstack_initialize (&labels_obstack);
14974
14975 resolve_code (ns->code, ns);
14976
14977 bitmap_obstack_release (&labels_obstack);
14978 labels_obstack = old_obstack;
14979 }
14980
14981
14982 /* This function is called after a complete program unit has been compiled.
14983 Its purpose is to examine all of the expressions associated with a program
14984 unit, assign types to all intermediate expressions, make sure that all
14985 assignments are to compatible types and figure out which names refer to
14986 which functions or subroutines. */
14987
14988 void
gfc_resolve(gfc_namespace * ns)14989 gfc_resolve (gfc_namespace *ns)
14990 {
14991 gfc_namespace *old_ns;
14992 code_stack *old_cs_base;
14993
14994 if (ns->resolved)
14995 return;
14996
14997 ns->resolved = -1;
14998 old_ns = gfc_current_ns;
14999 old_cs_base = cs_base;
15000
15001 resolve_types (ns);
15002 component_assignment_level = 0;
15003 resolve_codes (ns);
15004
15005 gfc_current_ns = old_ns;
15006 cs_base = old_cs_base;
15007 ns->resolved = 1;
15008
15009 gfc_run_passes (ns);
15010 }
15011