Bug Summary

File:build/gcc/fortran/resolve.c
Warning:line 15848, column 15
Value stored to 't' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name resolve.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/13.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11/backward -internal-isystem /usr/lib64/clang/13.0.0/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-11-20-133755-20252-1/report-nyNRIN.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c
1/* Perform type resolution on the various structures.
2 Copyright (C) 2001-2021 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
20
21#include "config.h"
22#include "system.h"
23#include "coretypes.h"
24#include "options.h"
25#include "bitmap.h"
26#include "gfortran.h"
27#include "arith.h" /* For gfc_compare_expr(). */
28#include "dependency.h"
29#include "data.h"
30#include "target-memory.h" /* for gfc_simplify_transfer */
31#include "constructor.h"
32
33/* Types used in equivalence statements. */
34
35enum seq_type
36{
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
38};
39
40/* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and gfc_resolve_code(). */
42
43typedef struct code_stack
44{
45 struct gfc_code *head, *current;
46 struct code_stack *prev;
47
48 /* This bitmap keeps track of the targets valid for a branch from
49 inside this block except for END {IF|SELECT}s of enclosing
50 blocks. */
51 bitmap reachable_labels;
52}
53code_stack;
54
55static code_stack *cs_base = NULL__null;
56
57
58/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
59
60static int forall_flag;
61int gfc_do_concurrent_flag;
62
63/* True when we are resolving an expression that is an actual argument to
64 a procedure. */
65static bool actual_arg = false;
66/* True when we are resolving an expression that is the first actual argument
67 to a procedure. */
68static bool first_actual_arg = false;
69
70
71/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
72
73static int omp_workshare_flag;
74
75/* True if we are processing a formal arglist. The corresponding function
76 resets the flag each time that it is read. */
77static bool formal_arg_flag = false;
78
79/* True if we are resolving a specification expression. */
80static bool specification_expr = false;
81
82/* The id of the last entry seen. */
83static int current_entry_id;
84
85/* We use bitmaps to determine if a branch target is valid. */
86static bitmap_obstack labels_obstack;
87
88/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89static bool inquiry_argument = false;
90
91
92bool
93gfc_is_formal_arg (void)
94{
95 return formal_arg_flag;
96}
97
98/* Is the symbol host associated? */
99static bool
100is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
101{
102 for (ns = ns->parent; ns; ns = ns->parent)
103 {
104 if (sym->ns == ns)
105 return true;
106 }
107
108 return false;
109}
110
111/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
114
115static bool
116resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
117{
118 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
119 {
120 if (where)
121 {
122 if (name)
123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
124 name, where, ts->u.derived->name);
125 else
126 gfc_error ("ABSTRACT type %qs used at %L",
127 ts->u.derived->name, where);
128 }
129
130 return false;
131 }
132
133 return true;
134}
135
136
137static bool
138check_proc_interface (gfc_symbol *ifc, locus *where)
139{
140 /* Several checks for F08:C1216. */
141 if (ifc->attr.procedure)
142 {
143 gfc_error ("Interface %qs at %L is declared "
144 "in a later PROCEDURE statement", ifc->name, where);
145 return false;
146 }
147 if (ifc->generic)
148 {
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface *gen = ifc->generic;
152 while (gen && strcmp (gen->sym->name, ifc->name) != 0)
153 gen = gen->next;
154 if (!gen)
155 {
156 gfc_error ("Interface %qs at %L may not be generic",
157 ifc->name, where);
158 return false;
159 }
160 }
161 if (ifc->attr.proc == PROC_ST_FUNCTION)
162 {
163 gfc_error ("Interface %qs at %L may not be a statement function",
164 ifc->name, where);
165 return false;
166 }
167 if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
168 || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
169 ifc->attr.intrinsic = 1;
170 if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
171 {
172 gfc_error ("Intrinsic procedure %qs not allowed in "
173 "PROCEDURE statement at %L", ifc->name, where);
174 return false;
175 }
176 if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
177 {
178 gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
179 return false;
180 }
181 return true;
182}
183
184
185static void resolve_symbol (gfc_symbol *sym);
186
187
188/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
189
190static bool
191resolve_procedure_interface (gfc_symbol *sym)
192{
193 gfc_symbol *ifc = sym->ts.interface;
194
195 if (!ifc)
196 return true;
197
198 if (ifc == sym)
199 {
200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
201 sym->name, &sym->declared_at);
202 return false;
203 }
204 if (!check_proc_interface (ifc, &sym->declared_at))
205 return false;
206
207 if (ifc->attr.if_source || ifc->attr.intrinsic)
208 {
209 /* Resolve interface and copy attributes. */
210 resolve_symbol (ifc);
211 if (ifc->attr.intrinsic)
212 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
213
214 if (ifc->result)
215 {
216 sym->ts = ifc->result->ts;
217 sym->attr.allocatable = ifc->result->attr.allocatable;
218 sym->attr.pointer = ifc->result->attr.pointer;
219 sym->attr.dimension = ifc->result->attr.dimension;
220 sym->attr.class_ok = ifc->result->attr.class_ok;
221 sym->as = gfc_copy_array_spec (ifc->result->as);
222 sym->result = sym;
223 }
224 else
225 {
226 sym->ts = ifc->ts;
227 sym->attr.allocatable = ifc->attr.allocatable;
228 sym->attr.pointer = ifc->attr.pointer;
229 sym->attr.dimension = ifc->attr.dimension;
230 sym->attr.class_ok = ifc->attr.class_ok;
231 sym->as = gfc_copy_array_spec (ifc->as);
232 }
233 sym->ts.interface = ifc;
234 sym->attr.function = ifc->attr.function;
235 sym->attr.subroutine = ifc->attr.subroutine;
236
237 sym->attr.pure = ifc->attr.pure;
238 sym->attr.elemental = ifc->attr.elemental;
239 sym->attr.contiguous = ifc->attr.contiguous;
240 sym->attr.recursive = ifc->attr.recursive;
241 sym->attr.always_explicit = ifc->attr.always_explicit;
242 sym->attr.ext_attr |= ifc->attr.ext_attr;
243 sym->attr.is_bind_c = ifc->attr.is_bind_c;
244 /* Copy char length. */
245 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
246 {
247 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
248 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
249 && !gfc_resolve_expr (sym->ts.u.cl->length))
250 return false;
251 }
252 }
253
254 return true;
255}
256
257
258/* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
263
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
266
267void
268gfc_resolve_formal_arglist (gfc_symbol *proc)
269{
270 gfc_formal_arglist *f;
271 gfc_symbol *sym;
272 bool saved_specification_expr;
273 int i;
274
275 if (proc->result != NULL__null)
276 sym = proc->result;
277 else
278 sym = proc;
279
280 if (gfc_elemental (proc)
281 || sym->attr.pointer || sym->attr.allocatable
282 || (sym->as && sym->as->rank != 0))
283 {
284 proc->attr.always_explicit = 1;
285 sym->attr.always_explicit = 1;
286 }
287
288 formal_arg_flag = true;
289
290 for (f = proc->formal; f; f = f->next)
291 {
292 gfc_array_spec *as;
293
294 sym = f->sym;
295
296 if (sym == NULL__null)
297 {
298 /* Alternate return placeholder. */
299 if (gfc_elemental (proc))
300 gfc_error ("Alternate return specifier in elemental subroutine "
301 "%qs at %L is not allowed", proc->name,
302 &proc->declared_at);
303 if (proc->attr.function)
304 gfc_error ("Alternate return specifier in function "
305 "%qs at %L is not allowed", proc->name,
306 &proc->declared_at);
307 continue;
308 }
309 else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
310 && !resolve_procedure_interface (sym))
311 return;
312
313 if (strcmp (proc->name, sym->name) == 0)
314 {
315 gfc_error ("Self-referential argument "
316 "%qs at %L is not allowed", sym->name,
317 &proc->declared_at);
318 return;
319 }
320
321 if (sym->attr.if_source != IFSRC_UNKNOWN)
322 gfc_resolve_formal_arglist (sym);
323
324 if (sym->attr.subroutine || sym->attr.external)
325 {
326 if (sym->attr.flavor == FL_UNKNOWN)
327 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
328 }
329 else
330 {
331 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
332 && (!sym->attr.function || sym->result == sym))
333 gfc_set_default_type (sym, 1, sym->ns);
334 }
335
336 as = sym->ts.type == BT_CLASS && sym->attr.class_ok
337 ? CLASS_DATA (sym)sym->ts.u.derived->components->as : sym->as;
338
339 saved_specification_expr = specification_expr;
340 specification_expr = true;
341 gfc_resolve_array_spec (as, 0);
342 specification_expr = saved_specification_expr;
343
344 /* We can't tell if an array with dimension (:) is assumed or deferred
345 shape until we know if it has the pointer or allocatable attributes.
346 */
347 if (as && as->rank > 0 && as->type == AS_DEFERRED
348 && ((sym->ts.type != BT_CLASS
349 && !(sym->attr.pointer || sym->attr.allocatable))
350 || (sym->ts.type == BT_CLASS
351 && !(CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer
352 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable)))
353 && sym->attr.flavor != FL_PROCEDURE)
354 {
355 as->type = AS_ASSUMED_SHAPE;
356 for (i = 0; i < as->rank; i++)
357 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 1);
358 }
359
360 if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
361 || (as && as->type == AS_ASSUMED_RANK)
362 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
363 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
364 && (CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer
365 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable
366 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.target))
367 || sym->attr.optional)
368 {
369 proc->attr.always_explicit = 1;
370 if (proc->result)
371 proc->result->attr.always_explicit = 1;
372 }
373
374 /* If the flavor is unknown at this point, it has to be a variable.
375 A procedure specification would have already set the type. */
376
377 if (sym->attr.flavor == FL_UNKNOWN)
378 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
379
380 if (gfc_pure (proc))
381 {
382 if (sym->attr.flavor == FL_PROCEDURE)
383 {
384 /* F08:C1279. */
385 if (!gfc_pure (sym))
386 {
387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
388 "also be PURE", sym->name, &sym->declared_at);
389 continue;
390 }
391 }
392 else if (!sym->attr.pointer)
393 {
394 if (proc->attr.function && sym->attr.intent != INTENT_IN)
395 {
396 if (sym->attr.value)
397 gfc_notify_std (GFC_STD_F2008(1<<7), "Argument %qs"
398 " of pure function %qs at %L with VALUE "
399 "attribute but without INTENT(IN)",
400 sym->name, proc->name, &sym->declared_at);
401 else
402 gfc_error ("Argument %qs of pure function %qs at %L must "
403 "be INTENT(IN) or VALUE", sym->name, proc->name,
404 &sym->declared_at);
405 }
406
407 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
408 {
409 if (sym->attr.value)
410 gfc_notify_std (GFC_STD_F2008(1<<7), "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
412 "attribute but without INTENT", sym->name,
413 proc->name, &sym->declared_at);
414 else
415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym->name, proc->name,
418 &sym->declared_at);
419 }
420 }
421
422 /* F08:C1278a. */
423 if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
424 {
425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
426 " may not be polymorphic", sym->name, proc->name,
427 &sym->declared_at);
428 continue;
429 }
430 }
431
432 if (proc->attr.implicit_pure)
433 {
434 if (sym->attr.flavor == FL_PROCEDURE)
435 {
436 if (!gfc_pure (sym))
437 proc->attr.implicit_pure = 0;
438 }
439 else if (!sym->attr.pointer)
440 {
441 if (proc->attr.function && sym->attr.intent != INTENT_IN
442 && !sym->value)
443 proc->attr.implicit_pure = 0;
444
445 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
446 && !sym->value)
447 proc->attr.implicit_pure = 0;
448 }
449 }
450
451 if (gfc_elemental (proc))
452 {
453 /* F08:C1289. */
454 if (sym->attr.codimension
455 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
456 && CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension))
457 {
458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
459 "procedure", sym->name, &sym->declared_at);
460 continue;
461 }
462
463 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
464 && CLASS_DATA (sym)sym->ts.u.derived->components->as))
465 {
466 gfc_error ("Argument %qs of elemental procedure at %L must "
467 "be scalar", sym->name, &sym->declared_at);
468 continue;
469 }
470
471 if (sym->attr.allocatable
472 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
473 && CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable))
474 {
475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
476 "have the ALLOCATABLE attribute", sym->name,
477 &sym->declared_at);
478 continue;
479 }
480
481 if (sym->attr.pointer
482 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
483 && CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer))
484 {
485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
486 "have the POINTER attribute", sym->name,
487 &sym->declared_at);
488 continue;
489 }
490
491 if (sym->attr.flavor == FL_PROCEDURE)
492 {
493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym->name, proc->name,
495 &sym->declared_at);
496 continue;
497 }
498
499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
501 {
502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
503 "have its INTENT specified or have the VALUE "
504 "attribute", sym->name, proc->name,
505 &sym->declared_at);
506 continue;
507 }
508 }
509
510 /* Each dummy shall be specified to be scalar. */
511 if (proc->attr.proc == PROC_ST_FUNCTION)
512 {
513 if (sym->as != NULL__null)
514 {
515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 shall be specified, explicitly or implicitly, to be scalar. */
517 gfc_error ("Argument '%s' of statement function '%s' at %L "
518 "must be scalar", sym->name, proc->name,
519 &proc->declared_at);
520 continue;
521 }
522
523 if (sym->ts.type == BT_CHARACTER)
524 {
525 gfc_charlen *cl = sym->ts.u.cl;
526 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
527 {
528 gfc_error ("Character-valued argument %qs of statement "
529 "function at %L must have constant length",
530 sym->name, &sym->declared_at);
531 continue;
532 }
533 }
534 }
535 }
536 formal_arg_flag = false;
537}
538
539
540/* Work function called when searching for symbols that have argument lists
541 associated with them. */
542
543static void
544find_arglists (gfc_symbol *sym)
545{
546 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
547 || gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
== FL_UNION || (sym->attr.flavor) == FL_STRUCT)
|| sym->attr.intrinsic)
548 return;
549
550 gfc_resolve_formal_arglist (sym);
551}
552
553
554/* Given a namespace, resolve all formal argument lists within the namespace.
555 */
556
557static void
558resolve_formal_arglists (gfc_namespace *ns)
559{
560 if (ns == NULL__null)
561 return;
562
563 gfc_traverse_ns (ns, find_arglists);
564}
565
566
567static void
568resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
569{
570 bool t;
571
572 if (sym && sym->attr.flavor == FL_PROCEDURE
573 && sym->ns->parent
574 && sym->ns->parent->proc_name
575 && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
576 && !strcmp (sym->name, sym->ns->parent->proc_name->name))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym->name, &sym->declared_at);
579
580 /* If this namespace is not a function or an entry master function,
581 ignore it. */
582 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
583 || sym->attr.entry_master)
584 return;
585
586 if (!sym->result)
587 return;
588
589 /* Try to find out of what the return type is. */
590 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL__null)
591 {
592 t = gfc_set_default_type (sym->result, 0, ns);
593
594 if (!t && !sym->result->attr.untyped)
595 {
596 if (sym->result == sym)
597 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
598 sym->name, &sym->declared_at);
599 else if (!sym->result->attr.proc_pointer)
600 gfc_error ("Result %qs of contained function %qs at %L has "
601 "no IMPLICIT type", sym->result->name, sym->name,
602 &sym->result->declared_at);
603 sym->result->attr.untyped = 1;
604 }
605 }
606
607 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
608 type, lists the only ways a character length value of * can be used:
609 dummy arguments of procedures, named constants, function results and
610 in allocate statements if the allocate_object is an assumed length dummy
611 in external functions. Internal function results and results of module
612 procedures are not on this list, ergo, not permitted. */
613
614 if (sym->result->ts.type == BT_CHARACTER)
615 {
616 gfc_charlen *cl = sym->result->ts.u.cl;
617 if ((!cl || !cl->length) && !sym->result->ts.deferred)
618 {
619 /* See if this is a module-procedure and adapt error message
620 accordingly. */
621 bool module_proc;
622 gcc_assert (ns->parent && ns->parent->proc_name)((void)(!(ns->parent && ns->parent->proc_name
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 622, __FUNCTION__), 0 : 0))
;
623 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
624
625 gfc_error (module_proc
626 ? G_("Character-valued module procedure %qs at %L""Character-valued module procedure %qs at %L" " must not be assumed length"
627 " must not be assumed length")"Character-valued module procedure %qs at %L" " must not be assumed length"
628 : G_("Character-valued internal function %qs at %L""Character-valued internal function %qs at %L" " must not be assumed length"
629 " must not be assumed length")"Character-valued internal function %qs at %L" " must not be assumed length",
630 sym->name, &sym->declared_at);
631 }
632 }
633}
634
635
636/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
637 introduce duplicates. */
638
639static void
640merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
641{
642 gfc_formal_arglist *f, *new_arglist;
643 gfc_symbol *new_sym;
644
645 for (; new_args != NULL__null; new_args = new_args->next)
646 {
647 new_sym = new_args->sym;
648 /* See if this arg is already in the formal argument list. */
649 for (f = proc->formal; f; f = f->next)
650 {
651 if (new_sym == f->sym)
652 break;
653 }
654
655 if (f)
656 continue;
657
658 /* Add a new argument. Argument order is not important. */
659 new_arglist = gfc_get_formal_arglist ()((gfc_formal_arglist *) xcalloc (1, sizeof (gfc_formal_arglist
)))
;
660 new_arglist->sym = new_sym;
661 new_arglist->next = proc->formal;
662 proc->formal = new_arglist;
663 }
664}
665
666
667/* Flag the arguments that are not present in all entries. */
668
669static void
670check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
671{
672 gfc_formal_arglist *f, *head;
673 head = new_args;
674
675 for (f = proc->formal; f; f = f->next)
676 {
677 if (f->sym == NULL__null)
678 continue;
679
680 for (new_args = head; new_args; new_args = new_args->next)
681 {
682 if (new_args->sym == f->sym)
683 break;
684 }
685
686 if (new_args)
687 continue;
688
689 f->sym->attr.not_always_present = 1;
690 }
691}
692
693
694/* Resolve alternate entry points. If a symbol has multiple entry points we
695 create a new master symbol for the main routine, and turn the existing
696 symbol into an entry point. */
697
698static void
699resolve_entries (gfc_namespace *ns)
700{
701 gfc_namespace *old_ns;
702 gfc_code *c;
703 gfc_symbol *proc;
704 gfc_entry_list *el;
705 char name[GFC_MAX_SYMBOL_LEN63 + 1];
706 static int master_count = 0;
707
708 if (ns->proc_name == NULL__null)
709 return;
710
711 /* No need to do anything if this procedure doesn't have alternate entry
712 points. */
713 if (!ns->entries)
714 return;
715
716 /* We may already have resolved alternate entry points. */
717 if (ns->proc_name->attr.entry_master)
718 return;
719
720 /* If this isn't a procedure something has gone horribly wrong. */
721 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE)((void)(!(ns->proc_name->attr.flavor == FL_PROCEDURE) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 721, __FUNCTION__), 0 : 0))
;
722
723 /* Remember the current namespace. */
724 old_ns = gfc_current_ns;
725
726 gfc_current_ns = ns;
727
728 /* Add the main entry point to the list of entry points. */
729 el = gfc_get_entry_list ()((gfc_entry_list *) xcalloc (1, sizeof (gfc_entry_list)));
730 el->sym = ns->proc_name;
731 el->id = 0;
732 el->next = ns->entries;
733 ns->entries = el;
734 ns->proc_name->attr.entry = 1;
735
736 /* If it is a module function, it needs to be in the right namespace
737 so that gfc_get_fake_result_decl can gather up the results. The
738 need for this arose in get_proc_name, where these beasts were
739 left in their own namespace, to keep prior references linked to
740 the entry declaration.*/
741 if (ns->proc_name->attr.function
742 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
743 el->sym->ns = ns;
744
745 /* Do the same for entries where the master is not a module
746 procedure. These are retained in the module namespace because
747 of the module procedure declaration. */
748 for (el = el->next; el; el = el->next)
749 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
750 && el->sym->attr.mod_proc)
751 el->sym->ns = ns;
752 el = ns->entries;
753
754 /* Add an entry statement for it. */
755 c = gfc_get_code (EXEC_ENTRY);
756 c->ext.entry = el;
757 c->next = ns->code;
758 ns->code = c;
759
760 /* Create a new symbol for the master function. */
761 /* Give the internal function a unique name (within this file).
762 Also include the function name so the user has some hope of figuring
763 out what is going on. */
764 snprintf (name, GFC_MAX_SYMBOL_LEN63, "master.%d.%s",
765 master_count++, ns->proc_name->name);
766 gfc_get_ha_symbol (name, &proc);
767 gcc_assert (proc != NULL)((void)(!(proc != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 767, __FUNCTION__), 0 : 0))
;
768
769 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL__null);
770 if (ns->proc_name->attr.subroutine)
771 gfc_add_subroutine (&proc->attr, proc->name, NULL__null);
772 else
773 {
774 gfc_symbol *sym;
775 gfc_typespec *ts, *fts;
776 gfc_array_spec *as, *fas;
777 gfc_add_function (&proc->attr, proc->name, NULL__null);
778 proc->result = proc;
779 fas = ns->entries->sym->as;
780 fas = fas ? fas : ns->entries->sym->result->as;
781 fts = &ns->entries->sym->result->ts;
782 if (fts->type == BT_UNKNOWN)
783 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL__null);
784 for (el = ns->entries->next; el; el = el->next)
785 {
786 ts = &el->sym->result->ts;
787 as = el->sym->as;
788 as = as ? as : el->sym->result->as;
789 if (ts->type == BT_UNKNOWN)
790 ts = gfc_get_default_type (el->sym->result->name, NULL__null);
791
792 if (! gfc_compare_types (ts, fts)
793 || (el->sym->result->attr.dimension
794 != ns->entries->sym->result->attr.dimension)
795 || (el->sym->result->attr.pointer
796 != ns->entries->sym->result->attr.pointer))
797 break;
798 else if (as && fas && ns->entries->sym->result != el->sym->result
799 && gfc_compare_array_spec (as, fas) == 0)
800 gfc_error ("Function %s at %L has entries with mismatched "
801 "array specifications", ns->entries->sym->name,
802 &ns->entries->sym->declared_at);
803 /* The characteristics need to match and thus both need to have
804 the same string length, i.e. both len=*, or both len=4.
805 Having both len=<variable> is also possible, but difficult to
806 check at compile time. */
807 else if (ts->type == BT_CHARACTER
808 && (el->sym->result->attr.allocatable
809 != ns->entries->sym->result->attr.allocatable))
810 {
811 gfc_error ("Function %s at %L has entry %s with mismatched "
812 "characteristics", ns->entries->sym->name,
813 &ns->entries->sym->declared_at, el->sym->name);
814 goto cleanup;
815 }
816 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
817 && (((ts->u.cl->length && !fts->u.cl->length)
818 ||(!ts->u.cl->length && fts->u.cl->length))
819 || (ts->u.cl->length
820 && ts->u.cl->length->expr_type
821 != fts->u.cl->length->expr_type)
822 || (ts->u.cl->length
823 && ts->u.cl->length->expr_type == EXPR_CONSTANT
824 && mpz_cmp__gmpz_cmp (ts->u.cl->length->value.integer,
825 fts->u.cl->length->value.integer) != 0)))
826 gfc_notify_std (GFC_STD_GNU(1<<5), "Function %s at %L with "
827 "entries returning variables of different "
828 "string lengths", ns->entries->sym->name,
829 &ns->entries->sym->declared_at);
830 }
831
832 if (el == NULL__null)
833 {
834 sym = ns->entries->sym->result;
835 /* All result types the same. */
836 proc->ts = *fts;
837 if (sym->attr.dimension)
838 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL__null);
839 if (sym->attr.pointer)
840 gfc_add_pointer (&proc->attr, NULL__null);
841 }
842 else
843 {
844 /* Otherwise the result will be passed through a union by
845 reference. */
846 proc->attr.mixed_entry_master = 1;
847 for (el = ns->entries; el; el = el->next)
848 {
849 sym = el->sym->result;
850 if (sym->attr.dimension)
851 {
852 if (el == ns->entries)
853 gfc_error ("FUNCTION result %s cannot be an array in "
854 "FUNCTION %s at %L", sym->name,
855 ns->entries->sym->name, &sym->declared_at);
856 else
857 gfc_error ("ENTRY result %s cannot be an array in "
858 "FUNCTION %s at %L", sym->name,
859 ns->entries->sym->name, &sym->declared_at);
860 }
861 else if (sym->attr.pointer)
862 {
863 if (el == ns->entries)
864 gfc_error ("FUNCTION result %s cannot be a POINTER in "
865 "FUNCTION %s at %L", sym->name,
866 ns->entries->sym->name, &sym->declared_at);
867 else
868 gfc_error ("ENTRY result %s cannot be a POINTER in "
869 "FUNCTION %s at %L", sym->name,
870 ns->entries->sym->name, &sym->declared_at);
871 }
872 else
873 {
874 ts = &sym->ts;
875 if (ts->type == BT_UNKNOWN)
876 ts = gfc_get_default_type (sym->name, NULL__null);
877 switch (ts->type)
878 {
879 case BT_INTEGER:
880 if (ts->kind == gfc_default_integer_kind)
881 sym = NULL__null;
882 break;
883 case BT_REAL:
884 if (ts->kind == gfc_default_real_kind
885 || ts->kind == gfc_default_double_kind)
886 sym = NULL__null;
887 break;
888 case BT_COMPLEX:
889 if (ts->kind == gfc_default_complex_kind)
890 sym = NULL__null;
891 break;
892 case BT_LOGICAL:
893 if (ts->kind == gfc_default_logical_kind)
894 sym = NULL__null;
895 break;
896 case BT_UNKNOWN:
897 /* We will issue error elsewhere. */
898 sym = NULL__null;
899 break;
900 default:
901 break;
902 }
903 if (sym)
904 {
905 if (el == ns->entries)
906 gfc_error ("FUNCTION result %s cannot be of type %s "
907 "in FUNCTION %s at %L", sym->name,
908 gfc_typename (ts), ns->entries->sym->name,
909 &sym->declared_at);
910 else
911 gfc_error ("ENTRY result %s cannot be of type %s "
912 "in FUNCTION %s at %L", sym->name,
913 gfc_typename (ts), ns->entries->sym->name,
914 &sym->declared_at);
915 }
916 }
917 }
918 }
919 }
920
921cleanup:
922 proc->attr.access = ACCESS_PRIVATE;
923 proc->attr.entry_master = 1;
924
925 /* Merge all the entry point arguments. */
926 for (el = ns->entries; el; el = el->next)
927 merge_argument_lists (proc, el->sym->formal);
928
929 /* Check the master formal arguments for any that are not
930 present in all entry points. */
931 for (el = ns->entries; el; el = el->next)
932 check_argument_lists (proc, el->sym->formal);
933
934 /* Use the master function for the function body. */
935 ns->proc_name = proc;
936
937 /* Finalize the new symbols. */
938 gfc_commit_symbols ();
939
940 /* Restore the original namespace. */
941 gfc_current_ns = old_ns;
942}
943
944
945/* Resolve common variables. */
946static void
947resolve_common_vars (gfc_common_head *common_block, bool named_common)
948{
949 gfc_symbol *csym = common_block->head;
950 gfc_gsymbol *gsym;
951
952 for (; csym; csym = csym->common_next)
953 {
954 gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
955 if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
956 gfc_error_now ("Global entity %qs at %L cannot appear in a "
957 "COMMON block at %L", gsym->name,
958 &gsym->where, &csym->common_block->where);
959
960 /* gfc_add_in_common may have been called before, but the reported errors
961 have been ignored to continue parsing.
962 We do the checks again here. */
963 if (!csym->attr.use_assoc)
964 {
965 gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
966 gfc_notify_std (GFC_STD_F2018_OBS(1<<10), "COMMON block at %L",
967 &common_block->where);
968 }
969
970 if (csym->value || csym->attr.data)
971 {
972 if (!csym->ns->is_block_data)
973 gfc_notify_std (GFC_STD_GNU(1<<5), "Variable %qs at %L is in COMMON "
974 "but only in BLOCK DATA initialization is "
975 "allowed", csym->name, &csym->declared_at);
976 else if (!named_common)
977 gfc_notify_std (GFC_STD_GNU(1<<5), "Initialized variable %qs at %L is "
978 "in a blank COMMON but initialization is only "
979 "allowed in named common blocks", csym->name,
980 &csym->declared_at);
981 }
982
983 if (UNLIMITED_POLY (csym)(csym != __null && csym->ts.type == BT_CLASS &&
csym->ts.u.derived->components && csym->ts.
u.derived->components->ts.u.derived && csym->
ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)
)
984 gfc_error_now ("%qs at %L cannot appear in COMMON "
985 "[F2008:C5100]", csym->name, &csym->declared_at);
986
987 if (csym->ts.type != BT_DERIVED)
988 continue;
989
990 if (!(csym->ts.u.derived->attr.sequence
991 || csym->ts.u.derived->attr.is_bind_c))
992 gfc_error_now ("Derived type variable %qs in COMMON at %L "
993 "has neither the SEQUENCE nor the BIND(C) "
994 "attribute", csym->name, &csym->declared_at);
995 if (csym->ts.u.derived->attr.alloc_comp)
996 gfc_error_now ("Derived type variable %qs in COMMON at %L "
997 "has an ultimate component that is "
998 "allocatable", csym->name, &csym->declared_at);
999 if (gfc_has_default_initializer (csym->ts.u.derived))
1000 gfc_error_now ("Derived type variable %qs in COMMON at %L "
1001 "may not have default initializer", csym->name,
1002 &csym->declared_at);
1003
1004 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1005 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
1006 }
1007}
1008
1009/* Resolve common blocks. */
1010static void
1011resolve_common_blocks (gfc_symtree *common_root)
1012{
1013 gfc_symbol *sym;
1014 gfc_gsymbol * gsym;
1015
1016 if (common_root == NULL__null)
1017 return;
1018
1019 if (common_root->left)
1020 resolve_common_blocks (common_root->left);
1021 if (common_root->right)
1022 resolve_common_blocks (common_root->right);
1023
1024 resolve_common_vars (common_root->n.common, true);
1025
1026 /* The common name is a global name - in Fortran 2003 also if it has a
1027 C binding name, since Fortran 2008 only the C binding name is a global
1028 identifier. */
1029 if (!common_root->n.common->binding_label
1030 || gfc_notification_std (GFC_STD_F2008(1<<7)))
1031 {
1032 gsym = gfc_find_gsymbol (gfc_gsym_root,
1033 common_root->n.common->name);
1034
1035 if (gsym && gfc_notification_std (GFC_STD_F2008(1<<7))
1036 && gsym->type == GSYM_COMMON
1037 && ((common_root->n.common->binding_label
1038 && (!gsym->binding_label
1039 || strcmp (common_root->n.common->binding_label,
1040 gsym->binding_label) != 0))
1041 || (!common_root->n.common->binding_label
1042 && gsym->binding_label)))
1043 {
1044 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
1045 "identifier and must thus have the same binding name "
1046 "as the same-named COMMON block at %L: %s vs %s",
1047 common_root->n.common->name, &common_root->n.common->where,
1048 &gsym->where,
1049 common_root->n.common->binding_label
1050 ? common_root->n.common->binding_label : "(blank)",
1051 gsym->binding_label ? gsym->binding_label : "(blank)");
1052 return;
1053 }
1054
1055 if (gsym && gsym->type != GSYM_COMMON
1056 && !common_root->n.common->binding_label)
1057 {
1058 gfc_error ("COMMON block %qs at %L uses the same global identifier "
1059 "as entity at %L",
1060 common_root->n.common->name, &common_root->n.common->where,
1061 &gsym->where);
1062 return;
1063 }
1064 if (gsym && gsym->type != GSYM_COMMON)
1065 {
1066 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
1067 "%L sharing the identifier with global non-COMMON-block "
1068 "entity at %L", common_root->n.common->name,
1069 &common_root->n.common->where, &gsym->where);
1070 return;
1071 }
1072 if (!gsym)
1073 {
1074 gsym = gfc_get_gsymbol (common_root->n.common->name, false);
1075 gsym->type = GSYM_COMMON;
1076 gsym->where = common_root->n.common->where;
1077 gsym->defined = 1;
1078 }
1079 gsym->used = 1;
1080 }
1081
1082 if (common_root->n.common->binding_label)
1083 {
1084 gsym = gfc_find_gsymbol (gfc_gsym_root,
1085 common_root->n.common->binding_label);
1086 if (gsym && gsym->type != GSYM_COMMON)
1087 {
1088 gfc_error ("COMMON block at %L with binding label %qs uses the same "
1089 "global identifier as entity at %L",
1090 &common_root->n.common->where,
1091 common_root->n.common->binding_label, &gsym->where);
1092 return;
1093 }
1094 if (!gsym)
1095 {
1096 gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
1097 gsym->type = GSYM_COMMON;
1098 gsym->where = common_root->n.common->where;
1099 gsym->defined = 1;
1100 }
1101 gsym->used = 1;
1102 }
1103
1104 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1105 if (sym == NULL__null)
1106 return;
1107
1108 if (sym->attr.flavor == FL_PARAMETER)
1109 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
1110 sym->name, &common_root->n.common->where, &sym->declared_at);
1111
1112 if (sym->attr.external)
1113 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
1114 sym->name, &common_root->n.common->where);
1115
1116 if (sym->attr.intrinsic)
1117 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1118 sym->name, &common_root->n.common->where);
1119 else if (sym->attr.result
1120 || gfc_is_function_return_value (sym, gfc_current_ns))
1121 gfc_notify_std (GFC_STD_F2003(1<<4), "COMMON block %qs at %L "
1122 "that is also a function result", sym->name,
1123 &common_root->n.common->where);
1124 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1125 && sym->attr.proc != PROC_ST_FUNCTION)
1126 gfc_notify_std (GFC_STD_F2003(1<<4), "COMMON block %qs at %L "
1127 "that is also a global procedure", sym->name,
1128 &common_root->n.common->where);
1129}
1130
1131
1132/* Resolve contained function types. Because contained functions can call one
1133 another, they have to be worked out before any of the contained procedures
1134 can be resolved.
1135
1136 The good news is that if a function doesn't already have a type, the only
1137 way it can get one is through an IMPLICIT type or a RESULT variable, because
1138 by definition contained functions are contained namespace they're contained
1139 in, not in a sibling or parent namespace. */
1140
1141static void
1142resolve_contained_functions (gfc_namespace *ns)
1143{
1144 gfc_namespace *child;
1145 gfc_entry_list *el;
1146
1147 resolve_formal_arglists (ns);
1148
1149 for (child = ns->contained; child; child = child->sibling)
1150 {
1151 /* Resolve alternate entry points first. */
1152 resolve_entries (child);
1153
1154 /* Then check function return types. */
1155 resolve_contained_fntype (child->proc_name, child);
1156 for (el = child->entries; el; el = el->next)
1157 resolve_contained_fntype (el->sym, child);
1158 }
1159}
1160
1161
1162
1163/* A Parameterized Derived Type constructor must contain values for
1164 the PDT KIND parameters or they must have a default initializer.
1165 Go through the constructor picking out the KIND expressions,
1166 storing them in 'param_list' and then call gfc_get_pdt_instance
1167 to obtain the PDT instance. */
1168
1169static gfc_actual_arglist *param_list, *param_tail, *param;
1170
1171static bool
1172get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1173{
1174 param = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
1175 if (!param_list)
1176 param_list = param_tail = param;
1177 else
1178 {
1179 param_tail->next = param;
1180 param_tail = param_tail->next;
1181 }
1182
1183 param_tail->name = c->name;
1184 if (expr)
1185 param_tail->expr = gfc_copy_expr (expr);
1186 else if (c->initializer)
1187 param_tail->expr = gfc_copy_expr (c->initializer);
1188 else
1189 {
1190 param_tail->spec_type = SPEC_ASSUMED;
1191 if (c->attr.pdt_kind)
1192 {
1193 gfc_error ("The KIND parameter %qs in the PDT constructor "
1194 "at %C has no value", param->name);
1195 return false;
1196 }
1197 }
1198
1199 return true;
1200}
1201
1202static bool
1203get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1204 gfc_symbol *derived)
1205{
1206 gfc_constructor *cons = NULL__null;
1207 gfc_component *comp;
1208 bool t = true;
1209
1210 if (expr && expr->expr_type == EXPR_STRUCTURE)
1211 cons = gfc_constructor_first (expr->value.constructor);
1212 else if (constr)
1213 cons = *constr;
1214 gcc_assert (cons)((void)(!(cons) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 1214, __FUNCTION__), 0 : 0))
;
1215
1216 comp = derived->components;
1217
1218 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1219 {
1220 if (cons->expr
1221 && cons->expr->expr_type == EXPR_STRUCTURE
1222 && comp->ts.type == BT_DERIVED)
1223 {
1224 t = get_pdt_constructor (cons->expr, NULL__null, comp->ts.u.derived);
1225 if (!t)
1226 return t;
1227 }
1228 else if (comp->ts.type == BT_DERIVED)
1229 {
1230 t = get_pdt_constructor (NULL__null, &cons, comp->ts.u.derived);
1231 if (!t)
1232 return t;
1233 }
1234 else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1235 && derived->attr.pdt_template)
1236 {
1237 t = get_pdt_spec_expr (comp, cons->expr);
1238 if (!t)
1239 return t;
1240 }
1241 }
1242 return t;
1243}
1244
1245
1246static bool resolve_fl_derived0 (gfc_symbol *sym);
1247static bool resolve_fl_struct (gfc_symbol *sym);
1248
1249
1250/* Resolve all of the elements of a structure constructor and make sure that
1251 the types are correct. The 'init' flag indicates that the given
1252 constructor is an initializer. */
1253
1254static bool
1255resolve_structure_cons (gfc_expr *expr, int init)
1256{
1257 gfc_constructor *cons;
1258 gfc_component *comp;
1259 bool t;
1260 symbol_attribute a;
1261
1262 t = true;
1263
1264 if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1265 {
1266 if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1267 resolve_fl_derived0 (expr->ts.u.derived);
1268 else
1269 resolve_fl_struct (expr->ts.u.derived);
1270
1271 /* If this is a Parameterized Derived Type template, find the
1272 instance corresponding to the PDT kind parameters. */
1273 if (expr->ts.u.derived->attr.pdt_template)
1274 {
1275 param_list = NULL__null;
1276 t = get_pdt_constructor (expr, NULL__null, expr->ts.u.derived);
1277 if (!t)
1278 return t;
1279 gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL__null);
1280
1281 expr->param_list = gfc_copy_actual_arglist (param_list);
1282
1283 if (param_list)
1284 gfc_free_actual_arglist (param_list);
1285
1286 if (!expr->ts.u.derived->attr.pdt_type)
1287 return false;
1288 }
1289 }
1290
1291 cons = gfc_constructor_first (expr->value.constructor);
1292
1293 /* A constructor may have references if it is the result of substituting a
1294 parameter variable. In this case we just pull out the component we
1295 want. */
1296 if (expr->ref)
1297 comp = expr->ref->u.c.sym->components;
1298 else
1299 comp = expr->ts.u.derived->components;
1300
1301 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1302 {
1303 int rank;
1304
1305 if (!cons->expr)
1306 continue;
1307
1308 /* Unions use an EXPR_NULL contrived expression to tell the translation
1309 phase to generate an initializer of the appropriate length.
1310 Ignore it here. */
1311 if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1312 continue;
1313
1314 if (!gfc_resolve_expr (cons->expr))
1315 {
1316 t = false;
1317 continue;
1318 }
1319
1320 rank = comp->as ? comp->as->rank : 0;
1321 if (comp->ts.type == BT_CLASS
1322 && !comp->ts.u.derived->attr.unlimited_polymorphic
1323 && CLASS_DATA (comp)comp->ts.u.derived->components->as)
1324 rank = CLASS_DATA (comp)comp->ts.u.derived->components->as->rank;
1325
1326 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
1327 && (comp->attr.allocatable || cons->expr->rank))
1328 {
1329 gfc_error ("The rank of the element in the structure "
1330 "constructor at %L does not match that of the "
1331 "component (%d/%d)", &cons->expr->where,
1332 cons->expr->rank, rank);
1333 t = false;
1334 }
1335
1336 /* If we don't have the right type, try to convert it. */
1337
1338 if (!comp->attr.proc_pointer &&
1339 !gfc_compare_types (&cons->expr->ts, &comp->ts))
1340 {
1341 if (strcmp (comp->name, "_extends") == 0)
1342 {
1343 /* Can afford to be brutal with the _extends initializer.
1344 The derived type can get lost because it is PRIVATE
1345 but it is not usage constrained by the standard. */
1346 cons->expr->ts = comp->ts;
1347 }
1348 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
1349 {
1350 gfc_error ("The element in the structure constructor at %L, "
1351 "for pointer component %qs, is %s but should be %s",
1352 &cons->expr->where, comp->name,
1353 gfc_basic_typename (cons->expr->ts.type),
1354 gfc_basic_typename (comp->ts.type));
1355 t = false;
1356 }
1357 else
1358 {
1359 bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1360 if (t)
1361 t = t2;
1362 }
1363 }
1364
1365 /* For strings, the length of the constructor should be the same as
1366 the one of the structure, ensure this if the lengths are known at
1367 compile time and when we are dealing with PARAMETER or structure
1368 constructors. */
1369 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1370 && comp->ts.u.cl->length
1371 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1372 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1373 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1374 && cons->expr->rank != 0
1375 && mpz_cmp__gmpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1376 comp->ts.u.cl->length->value.integer) != 0)
1377 {
1378 if (cons->expr->expr_type == EXPR_VARIABLE
1379 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1380 {
1381 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1382 to make use of the gfc_resolve_character_array_constructor
1383 machinery. The expression is later simplified away to
1384 an array of string literals. */
1385 gfc_expr *para = cons->expr;
1386 cons->expr = gfc_get_expr ();
1387 cons->expr->ts = para->ts;
1388 cons->expr->where = para->where;
1389 cons->expr->expr_type = EXPR_ARRAY;
1390 cons->expr->rank = para->rank;
1391 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1392 gfc_constructor_append_expr (&cons->expr->value.constructor,
1393 para, &cons->expr->where);
1394 }
1395
1396 if (cons->expr->expr_type == EXPR_ARRAY)
1397 {
1398 /* Rely on the cleanup of the namespace to deal correctly with
1399 the old charlen. (There was a block here that attempted to
1400 remove the charlen but broke the chain in so doing.) */
1401 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
1402 cons->expr->ts.u.cl->length_from_typespec = true;
1403 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1404 gfc_resolve_character_array_constructor (cons->expr);
1405 }
1406 }
1407
1408 if (cons->expr->expr_type == EXPR_NULL
1409 && !(comp->attr.pointer || comp->attr.allocatable
1410 || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
1411 || (comp->ts.type == BT_CLASS
1412 && (CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer
1413 || CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable))))
1414 {
1415 t = false;
1416 gfc_error ("The NULL in the structure constructor at %L is "
1417 "being applied to component %qs, which is neither "
1418 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1419 comp->name);
1420 }
1421
1422 if (comp->attr.proc_pointer && comp->ts.interface)
1423 {
1424 /* Check procedure pointer interface. */
1425 gfc_symbol *s2 = NULL__null;
1426 gfc_component *c2;
1427 const char *name;
1428 char err[200];
1429
1430 c2 = gfc_get_proc_ptr_comp (cons->expr);
1431 if (c2)
1432 {
1433 s2 = c2->ts.interface;
1434 name = c2->name;
1435 }
1436 else if (cons->expr->expr_type == EXPR_FUNCTION)
1437 {
1438 s2 = cons->expr->symtree->n.sym->result;
1439 name = cons->expr->symtree->n.sym->result->name;
1440 }
1441 else if (cons->expr->expr_type != EXPR_NULL)
1442 {
1443 s2 = cons->expr->symtree->n.sym;
1444 name = cons->expr->symtree->n.sym->name;
1445 }
1446
1447 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
1448 err, sizeof (err), NULL__null, NULL__null))
1449 {
1450 gfc_error_opt (0, "Interface mismatch for procedure-pointer "
1451 "component %qs in structure constructor at %L:"
1452 " %s", comp->name, &cons->expr->where, err);
1453 return false;
1454 }
1455 }
1456
1457 /* Validate shape, except for dynamic or PDT arrays. */
1458 if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1459 && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1460 && !comp->attr.pdt_array)
1461 {
1462 mpz_t len;
1463 mpz_init__gmpz_init (len);
1464 for (int n = 0; n < rank; n++)
1465 {
1466 if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1467 || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1468 {
1469 gfc_error ("Bad array spec of component %qs referenced in "
1470 "structure constructor at %L",
1471 comp->name, &cons->expr->where);
1472 t = false;
1473 break;
1474 };
1475 mpz_set_ui__gmpz_set_ui (len, 1);
1476 mpz_add__gmpz_add (len, len, comp->as->upper[n]->value.integer);
1477 mpz_sub__gmpz_sub (len, len, comp->as->lower[n]->value.integer);
1478 if (mpz_cmp__gmpz_cmp (cons->expr->shape[n], len) != 0)
1479 {
1480 gfc_error ("The shape of component %qs in the structure "
1481 "constructor at %L differs from the shape of the "
1482 "declared component for dimension %d (%ld/%ld)",
1483 comp->name, &cons->expr->where, n+1,
1484 mpz_get_si__gmpz_get_si (cons->expr->shape[n]),
1485 mpz_get_si__gmpz_get_si (len));
1486 t = false;
1487 }
1488 }
1489 mpz_clear__gmpz_clear (len);
1490 }
1491
1492 if (!comp->attr.pointer || comp->attr.proc_pointer
1493 || cons->expr->expr_type == EXPR_NULL)
1494 continue;
1495
1496 a = gfc_expr_attr (cons->expr);
1497
1498 if (!a.pointer && !a.target)
1499 {
1500 t = false;
1501 gfc_error ("The element in the structure constructor at %L, "
1502 "for pointer component %qs should be a POINTER or "
1503 "a TARGET", &cons->expr->where, comp->name);
1504 }
1505
1506 if (init)
1507 {
1508 /* F08:C461. Additional checks for pointer initialization. */
1509 if (a.allocatable)
1510 {
1511 t = false;
1512 gfc_error ("Pointer initialization target at %L "
1513 "must not be ALLOCATABLE", &cons->expr->where);
1514 }
1515 if (!a.save)
1516 {
1517 t = false;
1518 gfc_error ("Pointer initialization target at %L "
1519 "must have the SAVE attribute", &cons->expr->where);
1520 }
1521 }
1522
1523 /* F2003, C1272 (3). */
1524 bool impure = cons->expr->expr_type == EXPR_VARIABLE
1525 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1526 || gfc_is_coindexed (cons->expr));
1527 if (impure && gfc_pure (NULL__null))
1528 {
1529 t = false;
1530 gfc_error ("Invalid expression in the structure constructor for "
1531 "pointer component %qs at %L in PURE procedure",
1532 comp->name, &cons->expr->where);
1533 }
1534
1535 if (impure)
1536 gfc_unset_implicit_pure (NULL__null);
1537 }
1538
1539 return t;
1540}
1541
1542
1543/****************** Expression name resolution ******************/
1544
1545/* Returns 0 if a symbol was not declared with a type or
1546 attribute declaration statement, nonzero otherwise. */
1547
1548static int
1549was_declared (gfc_symbol *sym)
1550{
1551 symbol_attribute a;
1552
1553 a = sym->attr;
1554
1555 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1556 return 1;
1557
1558 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
1559 || a.optional || a.pointer || a.save || a.target || a.volatile_
1560 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
1561 || a.asynchronous || a.codimension)
1562 return 1;
1563
1564 return 0;
1565}
1566
1567
1568/* Determine if a symbol is generic or not. */
1569
1570static int
1571generic_sym (gfc_symbol *sym)
1572{
1573 gfc_symbol *s;
1574
1575 if (sym->attr.generic ||
1576 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1577 return 1;
1578
1579 if (was_declared (sym) || sym->ns->parent == NULL__null)
1580 return 0;
1581
1582 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1583
1584 if (s != NULL__null)
1585 {
1586 if (s == sym)
1587 return 0;
1588 else
1589 return generic_sym (s);
1590 }
1591
1592 return 0;
1593}
1594
1595
1596/* Determine if a symbol is specific or not. */
1597
1598static int
1599specific_sym (gfc_symbol *sym)
1600{
1601 gfc_symbol *s;
1602
1603 if (sym->attr.if_source == IFSRC_IFBODY
1604 || sym->attr.proc == PROC_MODULE
1605 || sym->attr.proc == PROC_INTERNAL
1606 || sym->attr.proc == PROC_ST_FUNCTION
1607 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
1608 || sym->attr.external)
1609 return 1;
1610
1611 if (was_declared (sym) || sym->ns->parent == NULL__null)
1612 return 0;
1613
1614 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1615
1616 return (s == NULL__null) ? 0 : specific_sym (s);
1617}
1618
1619
1620/* Figure out if the procedure is specific, generic or unknown. */
1621
1622enum proc_type
1623{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
1624
1625static proc_type
1626procedure_kind (gfc_symbol *sym)
1627{
1628 if (generic_sym (sym))
1629 return PTYPE_GENERIC;
1630
1631 if (specific_sym (sym))
1632 return PTYPE_SPECIFIC;
1633
1634 return PTYPE_UNKNOWN;
1635}
1636
1637/* Check references to assumed size arrays. The flag need_full_assumed_size
1638 is nonzero when matching actual arguments. */
1639
1640static int need_full_assumed_size = 0;
1641
1642static bool
1643check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
1644{
1645 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
1646 return false;
1647
1648 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1649 What should it be? */
1650 if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL__null)
1651 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
1652 && (e->ref->u.ar.type == AR_FULL))
1653 {
1654 gfc_error ("The upper bound in the last dimension must "
1655 "appear in the reference to the assumed size "
1656 "array %qs at %L", sym->name, &e->where);
1657 return true;
1658 }
1659 return false;
1660}
1661
1662
1663/* Look for bad assumed size array references in argument expressions
1664 of elemental and array valued intrinsic procedures. Since this is
1665 called from procedure resolution functions, it only recurses at
1666 operators. */
1667
1668static bool
1669resolve_assumed_size_actual (gfc_expr *e)
1670{
1671 if (e == NULL__null)
1672 return false;
1673
1674 switch (e->expr_type)
1675 {
1676 case EXPR_VARIABLE:
1677 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
1678 return true;
1679 break;
1680
1681 case EXPR_OP:
1682 if (resolve_assumed_size_actual (e->value.op.op1)
1683 || resolve_assumed_size_actual (e->value.op.op2))
1684 return true;
1685 break;
1686
1687 default:
1688 break;
1689 }
1690 return false;
1691}
1692
1693
1694/* Check a generic procedure, passed as an actual argument, to see if
1695 there is a matching specific name. If none, it is an error, and if
1696 more than one, the reference is ambiguous. */
1697static int
1698count_specific_procs (gfc_expr *e)
1699{
1700 int n;
1701 gfc_interface *p;
1702 gfc_symbol *sym;
1703
1704 n = 0;
1705 sym = e->symtree->n.sym;
1706
1707 for (p = sym->generic; p; p = p->next)
1708 if (strcmp (sym->name, p->sym->name) == 0)
1709 {
1710 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1711 sym->name);
1712 n++;
1713 }
1714
1715 if (n > 1)
1716 gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
1717 &e->where);
1718
1719 if (n == 0)
1720 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1721 "argument at %L", sym->name, &e->where);
1722
1723 return n;
1724}
1725
1726
1727/* See if a call to sym could possibly be a not allowed RECURSION because of
1728 a missing RECURSIVE declaration. This means that either sym is the current
1729 context itself, or sym is the parent of a contained procedure calling its
1730 non-RECURSIVE containing procedure.
1731 This also works if sym is an ENTRY. */
1732
1733static bool
1734is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1735{
1736 gfc_symbol* proc_sym;
1737 gfc_symbol* context_proc;
1738 gfc_namespace* real_context;
1739
1740 if (sym->attr.flavor == FL_PROGRAM
1741 || gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
== FL_UNION || (sym->attr.flavor) == FL_STRUCT)
)
1742 return false;
1743
1744 /* If we've got an ENTRY, find real procedure. */
1745 if (sym->attr.entry && sym->ns->entries)
1746 proc_sym = sym->ns->entries->sym;
1747 else
1748 proc_sym = sym;
1749
1750 /* If sym is RECURSIVE, all is well of course. */
1751 if (proc_sym->attr.recursive || flag_recursiveglobal_options.x_flag_recursive)
1752 return false;
1753
1754 /* Find the context procedure's "real" symbol if it has entries.
1755 We look for a procedure symbol, so recurse on the parents if we don't
1756 find one (like in case of a BLOCK construct). */
1757 for (real_context = context; ; real_context = real_context->parent)
1758 {
1759 /* We should find something, eventually! */
1760 gcc_assert (real_context)((void)(!(real_context) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 1760, __FUNCTION__), 0 : 0))
;
1761
1762 context_proc = (real_context->entries ? real_context->entries->sym
1763 : real_context->proc_name);
1764
1765 /* In some special cases, there may not be a proc_name, like for this
1766 invalid code:
1767 real(bad_kind()) function foo () ...
1768 when checking the call to bad_kind ().
1769 In these cases, we simply return here and assume that the
1770 call is ok. */
1771 if (!context_proc)
1772 return false;
1773
1774 if (context_proc->attr.flavor != FL_LABEL)
1775 break;
1776 }
1777
1778 /* A call from sym's body to itself is recursion, of course. */
1779 if (context_proc == proc_sym)
1780 return true;
1781
1782 /* The same is true if context is a contained procedure and sym the
1783 containing one. */
1784 if (context_proc->attr.contained)
1785 {
1786 gfc_symbol* parent_proc;
1787
1788 gcc_assert (context->parent)((void)(!(context->parent) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 1788, __FUNCTION__), 0 : 0))
;
1789 parent_proc = (context->parent->entries ? context->parent->entries->sym
1790 : context->parent->proc_name);
1791
1792 if (parent_proc == proc_sym)
1793 return true;
1794 }
1795
1796 return false;
1797}
1798
1799
1800/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1801 its typespec and formal argument list. */
1802
1803bool
1804gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
1805{
1806 gfc_intrinsic_sym* isym = NULL__null;
1807 const char* symstd;
1808
1809 if (sym->resolve_symbol_called >= 2)
1810 return true;
1811
1812 sym->resolve_symbol_called = 2;
1813
1814 /* Already resolved. */
1815 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
1816 return true;
1817
1818 /* We already know this one is an intrinsic, so we don't call
1819 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1820 gfc_find_subroutine directly to check whether it is a function or
1821 subroutine. */
1822
1823 if (sym->intmod_sym_id && sym->attr.subroutine)
1824 {
1825 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1826 isym = gfc_intrinsic_subroutine_by_id (id);
1827 }
1828 else if (sym->intmod_sym_id)
1829 {
1830 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1831 isym = gfc_intrinsic_function_by_id (id);
1832 }
1833 else if (!sym->attr.subroutine)
1834 isym = gfc_find_function (sym->name);
1835
1836 if (isym && !sym->attr.subroutine)
1837 {
1838 if (sym->ts.type != BT_UNKNOWN && warn_surprisingglobal_options.x_warn_surprising
1839 && !sym->attr.implicit_type)
1840 gfc_warning (OPT_Wsurprising,
1841 "Type specified for intrinsic function %qs at %L is"
1842 " ignored", sym->name, &sym->declared_at);
1843
1844 if (!sym->attr.function &&
1845 !gfc_add_function(&sym->attr, sym->name, loc))
1846 return false;
1847
1848 sym->ts = isym->ts;
1849 }
1850 else if (isym || (isym = gfc_find_subroutine (sym->name)))
1851 {
1852 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1853 {
1854 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1855 " specifier", sym->name, &sym->declared_at);
1856 return false;
1857 }
1858
1859 if (!sym->attr.subroutine &&
1860 !gfc_add_subroutine(&sym->attr, sym->name, loc))
1861 return false;
1862 }
1863 else
1864 {
1865 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
1866 &sym->declared_at);
1867 return false;
1868 }
1869
1870 gfc_copy_formal_args_intr (sym, isym, NULL__null);
1871
1872 sym->attr.pure = isym->pure;
1873 sym->attr.elemental = isym->elemental;
1874
1875 /* Check it is actually available in the standard settings. */
1876 if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
1877 {
1878 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1879 "available in the current standard settings but %s. Use "
1880 "an appropriate %<-std=*%> option or enable "
1881 "%<-fall-intrinsics%> in order to use it.",
1882 sym->name, &sym->declared_at, symstd);
1883 return false;
1884 }
1885
1886 return true;
1887}
1888
1889
1890/* Resolve a procedure expression, like passing it to a called procedure or as
1891 RHS for a procedure pointer assignment. */
1892
1893static bool
1894resolve_procedure_expression (gfc_expr* expr)
1895{
1896 gfc_symbol* sym;
1897
1898 if (expr->expr_type != EXPR_VARIABLE)
1899 return true;
1900 gcc_assert (expr->symtree)((void)(!(expr->symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 1900, __FUNCTION__), 0 : 0))
;
1901
1902 sym = expr->symtree->n.sym;
1903
1904 if (sym->attr.intrinsic)
1905 gfc_resolve_intrinsic (sym, &expr->where);
1906
1907 if (sym->attr.flavor != FL_PROCEDURE
1908 || (sym->attr.function && sym->result == sym))
1909 return true;
1910
1911 /* A non-RECURSIVE procedure that is used as procedure expression within its
1912 own body is in danger of being called recursively. */
1913 if (is_illegal_recursion (sym, gfc_current_ns))
1914 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1915 " itself recursively. Declare it RECURSIVE or use"
1916 " %<-frecursive%>", sym->name, &expr->where);
1917
1918 return true;
1919}
1920
1921
1922/* Check that name is not a derived type. */
1923
1924static bool
1925is_dt_name (const char *name)
1926{
1927 gfc_symbol *dt_list, *dt_first;
1928
1929 dt_list = dt_first = gfc_derived_types;
1930 for (; dt_list; dt_list = dt_list->dt_next)
1931 {
1932 if (strcmp(dt_list->name, name) == 0)
1933 return true;
1934 if (dt_first == dt_list->dt_next)
1935 break;
1936 }
1937 return false;
1938}
1939
1940
1941/* Resolve an actual argument list. Most of the time, this is just
1942 resolving the expressions in the list.
1943 The exception is that we sometimes have to decide whether arguments
1944 that look like procedure arguments are really simple variable
1945 references. */
1946
1947static bool
1948resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1949 bool no_formal_args)
1950{
1951 gfc_symbol *sym;
1952 gfc_symtree *parent_st;
1953 gfc_expr *e;
1954 gfc_component *comp;
1955 int save_need_full_assumed_size;
1956 bool return_value = false;
1957 bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
1958
1959 actual_arg = true;
1960 first_actual_arg = true;
1961
1962 for (; arg; arg = arg->next)
1963 {
1964 e = arg->expr;
1965 if (e == NULL__null)
1966 {
1967 /* Check the label is a valid branching target. */
1968 if (arg->label)
1969 {
1970 if (arg->label->defined == ST_LABEL_UNKNOWN)
1971 {
1972 gfc_error ("Label %d referenced at %L is never defined",
1973 arg->label->value, &arg->label->where);
1974 goto cleanup;
1975 }
1976 }
1977 first_actual_arg = false;
1978 continue;
1979 }
1980
1981 if (e->expr_type == EXPR_VARIABLE
1982 && e->symtree->n.sym->attr.generic
1983 && no_formal_args
1984 && count_specific_procs (e) != 1)
1985 goto cleanup;
1986
1987 if (e->ts.type != BT_PROCEDURE)
1988 {
1989 save_need_full_assumed_size = need_full_assumed_size;
1990 if (e->expr_type != EXPR_VARIABLE)
1991 need_full_assumed_size = 0;
1992 if (!gfc_resolve_expr (e))
1993 goto cleanup;
1994 need_full_assumed_size = save_need_full_assumed_size;
1995 goto argument_list;
1996 }
1997
1998 /* See if the expression node should really be a variable reference. */
1999
2000 sym = e->symtree->n.sym;
2001
2002 if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2003 {
2004 gfc_error ("Derived type %qs is used as an actual "
2005 "argument at %L", sym->name, &e->where);
2006 goto cleanup;
2007 }
2008
2009 if (sym->attr.flavor == FL_PROCEDURE
2010 || sym->attr.intrinsic
2011 || sym->attr.external)
2012 {
2013 int actual_ok;
2014
2015 /* If a procedure is not already determined to be something else
2016 check if it is intrinsic. */
2017 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
2018 sym->attr.intrinsic = 1;
2019
2020 if (sym->attr.proc == PROC_ST_FUNCTION)
2021 {
2022 gfc_error ("Statement function %qs at %L is not allowed as an "
2023 "actual argument", sym->name, &e->where);
2024 }
2025
2026 actual_ok = gfc_intrinsic_actual_ok (sym->name,
2027 sym->attr.subroutine);
2028 if (sym->attr.intrinsic && actual_ok == 0)
2029 {
2030 gfc_error ("Intrinsic %qs at %L is not allowed as an "
2031 "actual argument", sym->name, &e->where);
2032 }
2033
2034 if (sym->attr.contained && !sym->attr.use_assoc
2035 && sym->ns->proc_name->attr.flavor != FL_MODULE)
2036 {
2037 if (!gfc_notify_std (GFC_STD_F2008(1<<7), "Internal procedure %qs is"
2038 " used as actual argument at %L",
2039 sym->name, &e->where))
2040 goto cleanup;
2041 }
2042
2043 if (sym->attr.elemental && !sym->attr.intrinsic)
2044 {
2045 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
2046 "allowed as an actual argument at %L", sym->name,
2047 &e->where);
2048 }
2049
2050 /* Check if a generic interface has a specific procedure
2051 with the same name before emitting an error. */
2052 if (sym->attr.generic && count_specific_procs (e) != 1)
2053 goto cleanup;
2054
2055 /* Just in case a specific was found for the expression. */
2056 sym = e->symtree->n.sym;
2057
2058 /* If the symbol is the function that names the current (or
2059 parent) scope, then we really have a variable reference. */
2060
2061 if (gfc_is_function_return_value (sym, sym->ns))
2062 goto got_variable;
2063
2064 /* If all else fails, see if we have a specific intrinsic. */
2065 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
2066 {
2067 gfc_intrinsic_sym *isym;
2068
2069 isym = gfc_find_function (sym->name);
2070 if (isym == NULL__null || !isym->specific)
2071 {
2072 gfc_error ("Unable to find a specific INTRINSIC procedure "
2073 "for the reference %qs at %L", sym->name,
2074 &e->where);
2075 goto cleanup;
2076 }
2077 sym->ts = isym->ts;
2078 sym->attr.intrinsic = 1;
2079 sym->attr.function = 1;
2080 }
2081
2082 if (!gfc_resolve_expr (e))
2083 goto cleanup;
2084 goto argument_list;
2085 }
2086
2087 /* See if the name is a module procedure in a parent unit. */
2088
2089 if (was_declared (sym) || sym->ns->parent == NULL__null)
2090 goto got_variable;
2091
2092 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2093 {
2094 gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
2095 goto cleanup;
2096 }
2097
2098 if (parent_st == NULL__null)
2099 goto got_variable;
2100
2101 sym = parent_st->n.sym;
2102 e->symtree = parent_st; /* Point to the right thing. */
2103
2104 if (sym->attr.flavor == FL_PROCEDURE
2105 || sym->attr.intrinsic
2106 || sym->attr.external)
2107 {
2108 if (!gfc_resolve_expr (e))
2109 goto cleanup;
2110 goto argument_list;
2111 }
2112
2113 got_variable:
2114 e->expr_type = EXPR_VARIABLE;
2115 e->ts = sym->ts;
2116 if ((sym->as != NULL__null && sym->ts.type != BT_CLASS)
2117 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2118 && CLASS_DATA (sym)sym->ts.u.derived->components->as))
2119 {
2120 e->rank = sym->ts.type == BT_CLASS
2121 ? CLASS_DATA (sym)sym->ts.u.derived->components->as->rank : sym->as->rank;
2122 e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
2123 e->ref->type = REF_ARRAY;
2124 e->ref->u.ar.type = AR_FULL;
2125 e->ref->u.ar.as = sym->ts.type == BT_CLASS
2126 ? CLASS_DATA (sym)sym->ts.u.derived->components->as : sym->as;
2127 }
2128
2129 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
2130 primary.c (match_actual_arg). If above code determines that it
2131 is a variable instead, it needs to be resolved as it was not
2132 done at the beginning of this function. */
2133 save_need_full_assumed_size = need_full_assumed_size;
2134 if (e->expr_type != EXPR_VARIABLE)
2135 need_full_assumed_size = 0;
2136 if (!gfc_resolve_expr (e))
2137 goto cleanup;
2138 need_full_assumed_size = save_need_full_assumed_size;
2139
2140 argument_list:
2141 /* Check argument list functions %VAL, %LOC and %REF. There is
2142 nothing to do for %REF. */
2143 if (arg->name && arg->name[0] == '%')
2144 {
2145 if (strcmp ("%VAL", arg->name) == 0)
2146 {
2147 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2148 {
2149 gfc_error ("By-value argument at %L is not of numeric "
2150 "type", &e->where);
2151 goto cleanup;
2152 }
2153
2154 if (e->rank)
2155 {
2156 gfc_error ("By-value argument at %L cannot be an array or "
2157 "an array section", &e->where);
2158 goto cleanup;
2159 }
2160
2161 /* Intrinsics are still PROC_UNKNOWN here. However,
2162 since same file external procedures are not resolvable
2163 in gfortran, it is a good deal easier to leave them to
2164 intrinsic.c. */
2165 if (ptype != PROC_UNKNOWN
2166 && ptype != PROC_DUMMY
2167 && ptype != PROC_EXTERNAL
2168 && ptype != PROC_MODULE)
2169 {
2170 gfc_error ("By-value argument at %L is not allowed "
2171 "in this context", &e->where);
2172 goto cleanup;
2173 }
2174 }
2175
2176 /* Statement functions have already been excluded above. */
2177 else if (strcmp ("%LOC", arg->name) == 0
2178 && e->ts.type == BT_PROCEDURE)
2179 {
2180 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2181 {
2182 gfc_error ("Passing internal procedure at %L by location "
2183 "not allowed", &e->where);
2184 goto cleanup;
2185 }
2186 }
2187 }
2188
2189 comp = gfc_get_proc_ptr_comp(e);
2190 if (e->expr_type == EXPR_VARIABLE
2191 && comp && comp->attr.elemental)
2192 {
2193 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2194 "allowed as an actual argument at %L", comp->name,
2195 &e->where);
2196 }
2197
2198 /* Fortran 2008, C1237. */
2199 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
2200 && gfc_has_ultimate_pointer (e))
2201 {
2202 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
2203 "component", &e->where);
2204 goto cleanup;
2205 }
2206
2207 first_actual_arg = false;
2208 }
2209
2210 return_value = true;
2211
2212cleanup:
2213 actual_arg = actual_arg_sav;
2214 first_actual_arg = first_actual_arg_sav;
2215
2216 return return_value;
2217}
2218
2219
2220/* Do the checks of the actual argument list that are specific to elemental
2221 procedures. If called with c == NULL, we have a function, otherwise if
2222 expr == NULL, we have a subroutine. */
2223
2224static bool
2225resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2226{
2227 gfc_actual_arglist *arg0;
2228 gfc_actual_arglist *arg;
2229 gfc_symbol *esym = NULL__null;
2230 gfc_intrinsic_sym *isym = NULL__null;
2231 gfc_expr *e = NULL__null;
2232 gfc_intrinsic_arg *iformal = NULL__null;
2233 gfc_formal_arglist *eformal = NULL__null;
2234 bool formal_optional = false;
2235 bool set_by_optional = false;
2236 int i;
2237 int rank = 0;
2238
2239 /* Is this an elemental procedure? */
2240 if (expr && expr->value.function.actual != NULL__null)
2241 {
2242 if (expr->value.function.esym != NULL__null
2243 && expr->value.function.esym->attr.elemental)
2244 {
2245 arg0 = expr->value.function.actual;
2246 esym = expr->value.function.esym;
2247 }
2248 else if (expr->value.function.isym != NULL__null
2249 && expr->value.function.isym->elemental)
2250 {
2251 arg0 = expr->value.function.actual;
2252 isym = expr->value.function.isym;
2253 }
2254 else
2255 return true;
2256 }
2257 else if (c && c->ext.actual != NULL__null)
2258 {
2259 arg0 = c->ext.actual;
2260
2261 if (c->resolved_sym)
2262 esym = c->resolved_sym;
2263 else
2264 esym = c->symtree->n.sym;
2265 gcc_assert (esym)((void)(!(esym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 2265, __FUNCTION__), 0 : 0))
;
2266
2267 if (!esym->attr.elemental)
2268 return true;
2269 }
2270 else
2271 return true;
2272
2273 /* The rank of an elemental is the rank of its array argument(s). */
2274 for (arg = arg0; arg; arg = arg->next)
2275 {
2276 if (arg->expr != NULL__null && arg->expr->rank != 0)
2277 {
2278 rank = arg->expr->rank;
2279 if (arg->expr->expr_type == EXPR_VARIABLE
2280 && arg->expr->symtree->n.sym->attr.optional)
2281 set_by_optional = true;
2282
2283 /* Function specific; set the result rank and shape. */
2284 if (expr)
2285 {
2286 expr->rank = rank;
2287 if (!expr->shape && arg->expr->shape)
2288 {
2289 expr->shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
2290 for (i = 0; i < rank; i++)
2291 mpz_init_set__gmpz_init_set (expr->shape[i], arg->expr->shape[i]);
2292 }
2293 }
2294 break;
2295 }
2296 }
2297
2298 /* If it is an array, it shall not be supplied as an actual argument
2299 to an elemental procedure unless an array of the same rank is supplied
2300 as an actual argument corresponding to a nonoptional dummy argument of
2301 that elemental procedure(12.4.1.5). */
2302 formal_optional = false;
2303 if (isym)
2304 iformal = isym->formal;
2305 else
2306 eformal = esym->formal;
2307
2308 for (arg = arg0; arg; arg = arg->next)
2309 {
2310 if (eformal)
2311 {
2312 if (eformal->sym && eformal->sym->attr.optional)
2313 formal_optional = true;
2314 eformal = eformal->next;
2315 }
2316 else if (isym && iformal)
2317 {
2318 if (iformal->optional)
2319 formal_optional = true;
2320 iformal = iformal->next;
2321 }
2322 else if (isym)
2323 formal_optional = true;
2324
2325 if (pedanticglobal_options.x_pedantic && arg->expr != NULL__null
2326 && arg->expr->expr_type == EXPR_VARIABLE
2327 && arg->expr->symtree->n.sym->attr.optional
2328 && formal_optional
2329 && arg->expr->rank
2330 && (set_by_optional || arg->expr->rank != rank)
2331 && !(isym && isym->id == GFC_ISYM_CONVERSION))
2332 {
2333 bool t = false;
2334 gfc_actual_arglist *a;
2335
2336 /* Scan the argument list for a non-optional argument with the
2337 same rank as arg. */
2338 for (a = arg0; a; a = a->next)
2339 if (a != arg
2340 && a->expr->rank == arg->expr->rank
2341 && !a->expr->symtree->n.sym->attr.optional)
2342 {
2343 t = true;
2344 break;
2345 }
2346
2347 if (!t)
2348 gfc_warning (OPT_Wpedantic,
2349 "%qs at %L is an array and OPTIONAL; If it is not "
2350 "present, then it cannot be the actual argument of "
2351 "an ELEMENTAL procedure unless there is a non-optional"
2352 " argument with the same rank "
2353 "(Fortran 2018, 15.5.2.12)",
2354 arg->expr->symtree->n.sym->name, &arg->expr->where);
2355 }
2356 }
2357
2358 for (arg = arg0; arg; arg = arg->next)
2359 {
2360 if (arg->expr == NULL__null || arg->expr->rank == 0)
2361 continue;
2362
2363 /* Being elemental, the last upper bound of an assumed size array
2364 argument must be present. */
2365 if (resolve_assumed_size_actual (arg->expr))
2366 return false;
2367
2368 /* Elemental procedure's array actual arguments must conform. */
2369 if (e != NULL__null)
2370 {
2371 if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")gettext ("elemental procedure")))
2372 return false;
2373 }
2374 else
2375 e = arg->expr;
2376 }
2377
2378 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2379 is an array, the intent inout/out variable needs to be also an array. */
2380 if (rank > 0 && esym && expr == NULL__null)
2381 for (eformal = esym->formal, arg = arg0; arg && eformal;
2382 arg = arg->next, eformal = eformal->next)
2383 if ((eformal->sym->attr.intent == INTENT_OUT
2384 || eformal->sym->attr.intent == INTENT_INOUT)
2385 && arg->expr && arg->expr->rank == 0)
2386 {
2387 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2388 "ELEMENTAL subroutine %qs is a scalar, but another "
2389 "actual argument is an array", &arg->expr->where,
2390 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2391 : "INOUT", eformal->sym->name, esym->name);
2392 return false;
2393 }
2394 return true;
2395}
2396
2397
2398/* This function does the checking of references to global procedures
2399 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2400 77 and 95 standards. It checks for a gsymbol for the name, making
2401 one if it does not already exist. If it already exists, then the
2402 reference being resolved must correspond to the type of gsymbol.
2403 Otherwise, the new symbol is equipped with the attributes of the
2404 reference. The corresponding code that is called in creating
2405 global entities is parse.c.
2406
2407 In addition, for all but -std=legacy, the gsymbols are used to
2408 check the interfaces of external procedures from the same file.
2409 The namespace of the gsymbol is resolved and then, once this is
2410 done the interface is checked. */
2411
2412
2413static bool
2414not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2415{
2416 if (!gsym_ns->proc_name->attr.recursive)
2417 return true;
2418
2419 if (sym->ns == gsym_ns)
2420 return false;
2421
2422 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2423 return false;
2424
2425 return true;
2426}
2427
2428static bool
2429not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2430{
2431 if (gsym_ns->entries)
2432 {
2433 gfc_entry_list *entry = gsym_ns->entries;
2434
2435 for (; entry; entry = entry->next)
2436 {
2437 if (strcmp (sym->name, entry->sym->name) == 0)
2438 {
2439 if (strcmp (gsym_ns->proc_name->name,
2440 sym->ns->proc_name->name) == 0)
2441 return false;
2442
2443 if (sym->ns->parent
2444 && strcmp (gsym_ns->proc_name->name,
2445 sym->ns->parent->proc_name->name) == 0)
2446 return false;
2447 }
2448 }
2449 }
2450 return true;
2451}
2452
2453
2454/* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2455
2456bool
2457gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2458{
2459 gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2460
2461 for ( ; arg; arg = arg->next)
2462 {
2463 if (!arg->sym)
2464 continue;
2465
2466 if (arg->sym->attr.allocatable) /* (2a) */
2467 {
2468 strncpy (errmsg, _("allocatable argument")gettext ("allocatable argument"), err_len);
2469 return true;
2470 }
2471 else if (arg->sym->attr.asynchronous)
2472 {
2473 strncpy (errmsg, _("asynchronous argument")gettext ("asynchronous argument"), err_len);
2474 return true;
2475 }
2476 else if (arg->sym->attr.optional)
2477 {
2478 strncpy (errmsg, _("optional argument")gettext ("optional argument"), err_len);
2479 return true;
2480 }
2481 else if (arg->sym->attr.pointer)
2482 {
2483 strncpy (errmsg, _("pointer argument")gettext ("pointer argument"), err_len);
2484 return true;
2485 }
2486 else if (arg->sym->attr.target)
2487 {
2488 strncpy (errmsg, _("target argument")gettext ("target argument"), err_len);
2489 return true;
2490 }
2491 else if (arg->sym->attr.value)
2492 {
2493 strncpy (errmsg, _("value argument")gettext ("value argument"), err_len);
2494 return true;
2495 }
2496 else if (arg->sym->attr.volatile_)
2497 {
2498 strncpy (errmsg, _("volatile argument")gettext ("volatile argument"), err_len);
2499 return true;
2500 }
2501 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2502 {
2503 strncpy (errmsg, _("assumed-shape argument")gettext ("assumed-shape argument"), err_len);
2504 return true;
2505 }
2506 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2507 {
2508 strncpy (errmsg, _("assumed-rank argument")gettext ("assumed-rank argument"), err_len);
2509 return true;
2510 }
2511 else if (arg->sym->attr.codimension) /* (2c) */
2512 {
2513 strncpy (errmsg, _("coarray argument")gettext ("coarray argument"), err_len);
2514 return true;
2515 }
2516 else if (false) /* (2d) TODO: parametrized derived type */
2517 {
2518 strncpy (errmsg, _("parametrized derived type argument")gettext ("parametrized derived type argument"), err_len);
2519 return true;
2520 }
2521 else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2522 {
2523 strncpy (errmsg, _("polymorphic argument")gettext ("polymorphic argument"), err_len);
2524 return true;
2525 }
2526 else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2527 {
2528 strncpy (errmsg, _("NO_ARG_CHECK attribute")gettext ("NO_ARG_CHECK attribute"), err_len);
2529 return true;
2530 }
2531 else if (arg->sym->ts.type == BT_ASSUMED)
2532 {
2533 /* As assumed-type is unlimited polymorphic (cf. above).
2534 See also TS 29113, Note 6.1. */
2535 strncpy (errmsg, _("assumed-type argument")gettext ("assumed-type argument"), err_len);
2536 return true;
2537 }
2538 }
2539
2540 if (sym->attr.function)
2541 {
2542 gfc_symbol *res = sym->result ? sym->result : sym;
2543
2544 if (res->attr.dimension) /* (3a) */
2545 {
2546 strncpy (errmsg, _("array result")gettext ("array result"), err_len);
2547 return true;
2548 }
2549 else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2550 {
2551 strncpy (errmsg, _("pointer or allocatable result")gettext ("pointer or allocatable result"), err_len);
2552 return true;
2553 }
2554 else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2555 && res->ts.u.cl->length
2556 && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2557 {
2558 strncpy (errmsg, _("result with non-constant character length")gettext ("result with non-constant character length"), err_len);
2559 return true;
2560 }
2561 }
2562
2563 if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
2564 {
2565 strncpy (errmsg, _("elemental procedure")gettext ("elemental procedure"), err_len);
2566 return true;
2567 }
2568 else if (sym->attr.is_bind_c) /* (5) */
2569 {
2570 strncpy (errmsg, _("bind(c) procedure")gettext ("bind(c) procedure"), err_len);
2571 return true;
2572 }
2573
2574 return false;
2575}
2576
2577
2578static void
2579resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
2580{
2581 gfc_gsymbol * gsym;
2582 gfc_namespace *ns;
2583 enum gfc_symbol_type type;
2584 char reason[200];
2585
2586 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2587
2588 gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2589 sym->binding_label != NULL__null);
2590
2591 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
2592 gfc_global_used (gsym, where);
2593
2594 if ((sym->attr.if_source == IFSRC_UNKNOWN
2595 || sym->attr.if_source == IFSRC_IFBODY)
2596 && gsym->type != GSYM_UNKNOWN
2597 && !gsym->binding_label
2598 && gsym->ns
2599 && gsym->ns->proc_name
2600 && not_in_recursive (sym, gsym->ns)
2601 && not_entry_self_reference (sym, gsym->ns))
2602 {
2603 gfc_symbol *def_sym;
2604 def_sym = gsym->ns->proc_name;
2605
2606 if (gsym->ns->resolved != -1)
2607 {
2608
2609 /* Resolve the gsymbol namespace if needed. */
2610 if (!gsym->ns->resolved)
2611 {
2612 gfc_symbol *old_dt_list;
2613
2614 /* Stash away derived types so that the backend_decls
2615 do not get mixed up. */
2616 old_dt_list = gfc_derived_types;
2617 gfc_derived_types = NULL__null;
2618
2619 gfc_resolve (gsym->ns);
2620
2621 /* Store the new derived types with the global namespace. */
2622 if (gfc_derived_types)
2623 gsym->ns->derived_types = gfc_derived_types;
2624
2625 /* Restore the derived types of this namespace. */
2626 gfc_derived_types = old_dt_list;
2627 }
2628
2629 /* Make sure that translation for the gsymbol occurs before
2630 the procedure currently being resolved. */
2631 ns = gfc_global_ns_list;
2632 for (; ns && ns != gsym->ns; ns = ns->sibling)
2633 {
2634 if (ns->sibling == gsym->ns)
2635 {
2636 ns->sibling = gsym->ns->sibling;
2637 gsym->ns->sibling = gfc_global_ns_list;
2638 gfc_global_ns_list = gsym->ns;
2639 break;
2640 }
2641 }
2642
2643 /* This can happen if a binding name has been specified. */
2644 if (gsym->binding_label && gsym->sym_name != def_sym->name)
2645 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2646
2647 if (def_sym->attr.entry_master || def_sym->attr.entry)
2648 {
2649 gfc_entry_list *entry;
2650 for (entry = gsym->ns->entries; entry; entry = entry->next)
2651 if (strcmp (entry->sym->name, sym->name) == 0)
2652 {
2653 def_sym = entry->sym;
2654 break;
2655 }
2656 }
2657 }
2658
2659 if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
2660 {
2661 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2662 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2663 gfc_typename (&def_sym->ts));
2664 goto done;
2665 }
2666
2667 if (sym->attr.if_source == IFSRC_UNKNOWN
2668 && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
2669 {
2670 gfc_error ("Explicit interface required for %qs at %L: %s",
2671 sym->name, &sym->declared_at, reason);
2672 goto done;
2673 }
2674
2675 bool bad_result_characteristics;
2676 if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
2677 reason, sizeof(reason), NULL__null, NULL__null,
2678 &bad_result_characteristics))
2679 {
2680 /* Turn erros into warnings with -std=gnu and -std=legacy,
2681 unless a function returns a wrong type, which can lead
2682 to all kinds of ICEs and wrong code. */
2683
2684 if (!pedanticglobal_options.x_pedantic && (gfc_option.allow_std & GFC_STD_GNU(1<<5))
2685 && !bad_result_characteristics)
2686 gfc_errors_to_warnings (true);
2687
2688 gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2689 sym->name, &sym->declared_at, reason);
2690 sym->error = 1;
2691 gfc_errors_to_warnings (false);
2692 goto done;
2693 }
2694 }
2695
2696done:
2697
2698 if (gsym->type == GSYM_UNKNOWN)
2699 {
2700 gsym->type = type;
2701 gsym->where = *where;
2702 }
2703
2704 gsym->used = 1;
2705}
2706
2707
2708/************* Function resolution *************/
2709
2710/* Resolve a function call known to be generic.
2711 Section 14.1.2.4.1. */
2712
2713static match
2714resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
2715{
2716 gfc_symbol *s;
2717
2718 if (sym->attr.generic)
2719 {
2720 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
2721 if (s != NULL__null)
2722 {
2723 expr->value.function.name = s->name;
2724 expr->value.function.esym = s;
2725
2726 if (s->ts.type != BT_UNKNOWN)
2727 expr->ts = s->ts;
2728 else if (s->result != NULL__null && s->result->ts.type != BT_UNKNOWN)
2729 expr->ts = s->result->ts;
2730
2731 if (s->as != NULL__null)
2732 expr->rank = s->as->rank;
2733 else if (s->result != NULL__null && s->result->as != NULL__null)
2734 expr->rank = s->result->as->rank;
2735
2736 gfc_set_sym_referenced (expr->value.function.esym);
2737
2738 return MATCH_YES;
2739 }
2740
2741 /* TODO: Need to search for elemental references in generic
2742 interface. */
2743 }
2744
2745 if (sym->attr.intrinsic)
2746 return gfc_intrinsic_func_interface (expr, 0);
2747
2748 return MATCH_NO;
2749}
2750
2751
2752static bool
2753resolve_generic_f (gfc_expr *expr)
2754{
2755 gfc_symbol *sym;
2756 match m;
2757 gfc_interface *intr = NULL__null;
2758
2759 sym = expr->symtree->n.sym;
2760
2761 for (;;)
2762 {
2763 m = resolve_generic_f0 (expr, sym);
2764 if (m == MATCH_YES)
2765 return true;
2766 else if (m == MATCH_ERROR)
2767 return false;
2768
2769generic:
2770 if (!intr)
2771 for (intr = sym->generic; intr; intr = intr->next)
2772 if (gfc_fl_struct (intr->sym->attr.flavor)((intr->sym->attr.flavor) == FL_DERIVED || (intr->sym
->attr.flavor) == FL_UNION || (intr->sym->attr.flavor
) == FL_STRUCT)
)
2773 break;
2774
2775 if (sym->ns->parent == NULL__null)
2776 break;
2777 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2778
2779 if (sym == NULL__null)
2780 break;
2781 if (!generic_sym (sym))
2782 goto generic;
2783 }
2784
2785 /* Last ditch attempt. See if the reference is to an intrinsic
2786 that possesses a matching interface. 14.1.2.4 */
2787 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
2788 {
2789 if (gfc_init_expr_flag)
2790 gfc_error ("Function %qs in initialization expression at %L "
2791 "must be an intrinsic function",
2792 expr->symtree->n.sym->name, &expr->where);
2793 else
2794 gfc_error ("There is no specific function for the generic %qs "
2795 "at %L", expr->symtree->n.sym->name, &expr->where);
2796 return false;
2797 }
2798
2799 if (intr)
2800 {
2801 if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL__null,
2802 NULL__null, false))
2803 return false;
2804 if (!gfc_use_derived (expr->ts.u.derived))
2805 return false;
2806 return resolve_structure_cons (expr, 0);
2807 }
2808
2809 m = gfc_intrinsic_func_interface (expr, 0);
2810 if (m == MATCH_YES)
2811 return true;
2812
2813 if (m == MATCH_NO)
2814 gfc_error ("Generic function %qs at %L is not consistent with a "
2815 "specific intrinsic interface", expr->symtree->n.sym->name,
2816 &expr->where);
2817
2818 return false;
2819}
2820
2821
2822/* Resolve a function call known to be specific. */
2823
2824static match
2825resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
2826{
2827 match m;
2828
2829 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2830 {
2831 if (sym->attr.dummy)
2832 {
2833 sym->attr.proc = PROC_DUMMY;
2834 goto found;
2835 }
2836
2837 sym->attr.proc = PROC_EXTERNAL;
2838 goto found;
2839 }
2840
2841 if (sym->attr.proc == PROC_MODULE
2842 || sym->attr.proc == PROC_ST_FUNCTION
2843 || sym->attr.proc == PROC_INTERNAL)
2844 goto found;
2845
2846 if (sym->attr.intrinsic)
2847 {
2848 m = gfc_intrinsic_func_interface (expr, 1);
2849 if (m == MATCH_YES)
2850 return MATCH_YES;
2851 if (m == MATCH_NO)
2852 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2853 "with an intrinsic", sym->name, &expr->where);
2854
2855 return MATCH_ERROR;
2856 }
2857
2858 return MATCH_NO;
2859
2860found:
2861 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2862
2863 if (sym->result)
2864 expr->ts = sym->result->ts;
2865 else
2866 expr->ts = sym->ts;
2867 expr->value.function.name = sym->name;
2868 expr->value.function.esym = sym;
2869 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2870 error(s). */
2871 if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)sym->ts.u.derived->components)
2872 return MATCH_ERROR;
2873 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components->as)
2874 expr->rank = CLASS_DATA (sym)sym->ts.u.derived->components->as->rank;
2875 else if (sym->as != NULL__null)
2876 expr->rank = sym->as->rank;
2877
2878 return MATCH_YES;
2879}
2880
2881
2882static bool
2883resolve_specific_f (gfc_expr *expr)
2884{
2885 gfc_symbol *sym;
2886 match m;
2887
2888 sym = expr->symtree->n.sym;
2889
2890 for (;;)
2891 {
2892 m = resolve_specific_f0 (sym, expr);
2893 if (m == MATCH_YES)
2894 return true;
2895 if (m == MATCH_ERROR)
2896 return false;
2897
2898 if (sym->ns->parent == NULL__null)
2899 break;
2900
2901 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2902
2903 if (sym == NULL__null)
2904 break;
2905 }
2906
2907 gfc_error ("Unable to resolve the specific function %qs at %L",
2908 expr->symtree->n.sym->name, &expr->where);
2909
2910 return true;
2911}
2912
2913/* Recursively append candidate SYM to CANDIDATES. Store the number of
2914 candidates in CANDIDATES_LEN. */
2915
2916static void
2917lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
2918 char **&candidates,
2919 size_t &candidates_len)
2920{
2921 gfc_symtree *p;
2922
2923 if (sym == NULL__null)
2924 return;
2925 if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
2926 && sym->n.sym->attr.flavor == FL_PROCEDURE)
2927 vec_push (candidates, candidates_len, sym->name);
2928
2929 p = sym->left;
2930 if (p)
2931 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2932
2933 p = sym->right;
2934 if (p)
2935 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2936}
2937
2938
2939/* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2940
2941const char*
2942gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
2943{
2944 char **candidates = NULL__null;
2945 size_t candidates_len = 0;
2946 lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
2947 return gfc_closest_fuzzy_match (fn, candidates);
2948}
2949
2950
2951/* Resolve a procedure call not known to be generic nor specific. */
2952
2953static bool
2954resolve_unknown_f (gfc_expr *expr)
2955{
2956 gfc_symbol *sym;
2957 gfc_typespec *ts;
2958
2959 sym = expr->symtree->n.sym;
2960
2961 if (sym->attr.dummy)
2962 {
2963 sym->attr.proc = PROC_DUMMY;
2964 expr->value.function.name = sym->name;
2965 goto set_type;
2966 }
2967
2968 /* See if we have an intrinsic function reference. */
2969
2970 if (gfc_is_intrinsic (sym, 0, expr->where))
2971 {
2972 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
2973 return true;
2974 return false;
2975 }
2976
2977 /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
2978 /* Intrinsics were handled above, only non-intrinsics left here. */
2979 if (sym->attr.flavor == FL_PROCEDURE
2980 && sym->attr.implicit_type
2981 && sym->ns
2982 && sym->ns->has_implicit_none_export)
2983 {
2984 gfc_error ("Missing explicit declaration with EXTERNAL attribute "
2985 "for symbol %qs at %L", sym->name, &sym->declared_at);
2986 sym->error = 1;
2987 return false;
2988 }
2989
2990 /* The reference is to an external name. */
2991
2992 sym->attr.proc = PROC_EXTERNAL;
2993 expr->value.function.name = sym->name;
2994 expr->value.function.esym = expr->symtree->n.sym;
2995
2996 if (sym->as != NULL__null)
2997 expr->rank = sym->as->rank;
2998
2999 /* Type of the expression is either the type of the symbol or the
3000 default type of the symbol. */
3001
3002set_type:
3003 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3004
3005 if (sym->ts.type != BT_UNKNOWN)
3006 expr->ts = sym->ts;
3007 else
3008 {
3009 ts = gfc_get_default_type (sym->name, sym->ns);
3010
3011 if (ts->type == BT_UNKNOWN)
3012 {
3013 const char *guessed
3014 = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3015 if (guessed)
3016 gfc_error ("Function %qs at %L has no IMPLICIT type"
3017 "; did you mean %qs?",
3018 sym->name, &expr->where, guessed);
3019 else
3020 gfc_error ("Function %qs at %L has no IMPLICIT type",
3021 sym->name, &expr->where);
3022 return false;
3023 }
3024 else
3025 expr->ts = *ts;
3026 }
3027
3028 return true;
3029}
3030
3031
3032/* Return true, if the symbol is an external procedure. */
3033static bool
3034is_external_proc (gfc_symbol *sym)
3035{
3036 if (!sym->attr.dummy && !sym->attr.contained
3037 && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
3038 && sym->attr.proc != PROC_ST_FUNCTION
3039 && !sym->attr.proc_pointer
3040 && !sym->attr.use_assoc
3041 && sym->name)
3042 return true;
3043
3044 return false;
3045}
3046
3047
3048/* Figure out if a function reference is pure or not. Also set the name
3049 of the function for a potential error message. Return nonzero if the
3050 function is PURE, zero if not. */
3051static int
3052pure_stmt_function (gfc_expr *, gfc_symbol *);
3053
3054int
3055gfc_pure_function (gfc_expr *e, const char **name)
3056{
3057 int pure;
3058 gfc_component *comp;
3059
3060 *name = NULL__null;
3061
3062 if (e->symtree != NULL__null
3063 && e->symtree->n.sym != NULL__null
3064 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3065 return pure_stmt_function (e, e->symtree->n.sym);
3066
3067 comp = gfc_get_proc_ptr_comp (e);
3068 if (comp)
3069 {
3070 pure = gfc_pure (comp->ts.interface);
3071 *name = comp->name;
3072 }
3073 else if (e->value.function.esym)
3074 {
3075 pure = gfc_pure (e->value.function.esym);
3076 *name = e->value.function.esym->name;
3077 }
3078 else if (e->value.function.isym)
3079 {
3080 pure = e->value.function.isym->pure
3081 || e->value.function.isym->elemental;
3082 *name = e->value.function.isym->name;
3083 }
3084 else
3085 {
3086 /* Implicit functions are not pure. */
3087 pure = 0;
3088 *name = e->value.function.name;
3089 }
3090
3091 return pure;
3092}
3093
3094
3095/* Check if the expression is a reference to an implicitly pure function. */
3096
3097int
3098gfc_implicit_pure_function (gfc_expr *e)
3099{
3100 gfc_component *comp = gfc_get_proc_ptr_comp (e);
3101 if (comp)
3102 return gfc_implicit_pure (comp->ts.interface);
3103 else if (e->value.function.esym)
3104 return gfc_implicit_pure (e->value.function.esym);
3105 else
3106 return 0;
3107}
3108
3109
3110static bool
3111impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3112 int *f ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3113{
3114 const char *name;
3115
3116 /* Don't bother recursing into other statement functions
3117 since they will be checked individually for purity. */
3118 if (e->expr_type != EXPR_FUNCTION
3119 || !e->symtree
3120 || e->symtree->n.sym == sym
3121 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3122 return false;
3123
3124 return gfc_pure_function (e, &name) ? false : true;
3125}
3126
3127
3128static int
3129pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3130{
3131 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3132}
3133
3134
3135/* Check if an impure function is allowed in the current context. */
3136
3137static bool check_pure_function (gfc_expr *e)
3138{
3139 const char *name = NULL__null;
3140 if (!gfc_pure_function (e, &name) && name)
3141 {
3142 if (forall_flag)
3143 {
3144 gfc_error ("Reference to impure function %qs at %L inside a "
3145 "FORALL %s", name, &e->where,
3146 forall_flag == 2 ? "mask" : "block");
3147 return false;
3148 }
3149 else if (gfc_do_concurrent_flag)
3150 {
3151 gfc_error ("Reference to impure function %qs at %L inside a "
3152 "DO CONCURRENT %s", name, &e->where,
3153 gfc_do_concurrent_flag == 2 ? "mask" : "block");
3154 return false;
3155 }
3156 else if (gfc_pure (NULL__null))
3157 {
3158 gfc_error ("Reference to impure function %qs at %L "
3159 "within a PURE procedure", name, &e->where);
3160 return false;
3161 }
3162 if (!gfc_implicit_pure_function (e))
3163 gfc_unset_implicit_pure (NULL__null);
3164 }
3165 return true;
3166}
3167
3168
3169/* Update current procedure's array_outer_dependency flag, considering
3170 a call to procedure SYM. */
3171
3172static void
3173update_current_proc_array_outer_dependency (gfc_symbol *sym)
3174{
3175 /* Check to see if this is a sibling function that has not yet
3176 been resolved. */
3177 gfc_namespace *sibling = gfc_current_ns->sibling;
3178 for (; sibling; sibling = sibling->sibling)
3179 {
3180 if (sibling->proc_name == sym)
3181 {
3182 gfc_resolve (sibling);
3183 break;
3184 }
3185 }
3186
3187 /* If SYM has references to outer arrays, so has the procedure calling
3188 SYM. If SYM is a procedure pointer, we can assume the worst. */
3189 if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3190 && gfc_current_ns->proc_name)
3191 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3192}
3193
3194
3195/* Resolve a function call, which means resolving the arguments, then figuring
3196 out which entity the name refers to. */
3197
3198static bool
3199resolve_function (gfc_expr *expr)
3200{
3201 gfc_actual_arglist *arg;
3202 gfc_symbol *sym;
3203 bool t;
3204 int temp;
3205 procedure_type p = PROC_INTRINSIC;
3206 bool no_formal_args;
3207
3208 sym = NULL__null;
3209 if (expr->symtree)
3210 sym = expr->symtree->n.sym;
3211
3212 /* If this is a procedure pointer component, it has already been resolved. */
3213 if (gfc_is_proc_ptr_comp (expr))
3214 return true;
3215
3216 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3217 another caf_get. */
3218 if (sym && sym->attr.intrinsic
3219 && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3220 || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3221 return true;
3222
3223 if (expr->ref)
3224 {
3225 gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3226 &expr->where);
3227 return false;
3228 }
3229
3230 if (sym && sym->attr.intrinsic
3231 && !gfc_resolve_intrinsic (sym, &expr->where))
3232 return false;
3233
3234 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
3235 {
3236 gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
3237 return false;
3238 }
3239
3240 /* If this is a deferred TBP with an abstract interface (which may
3241 of course be referenced), expr->value.function.esym will be set. */
3242 if (sym && sym->attr.abstract && !expr->value.function.esym)
3243 {
3244 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3245 sym->name, &expr->where);
3246 return false;
3247 }
3248
3249 /* If this is a deferred TBP with an abstract interface, its result
3250 cannot be an assumed length character (F2003: C418). */
3251 if (sym && sym->attr.abstract && sym->attr.function
3252 && sym->result->ts.u.cl
3253 && sym->result->ts.u.cl->length == NULL__null
3254 && !sym->result->ts.deferred)
3255 {
3256 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
3257 "character length result (F2008: C418)", sym->name,
3258 &sym->declared_at);
3259 return false;
3260 }
3261
3262 /* Switch off assumed size checking and do this again for certain kinds
3263 of procedure, once the procedure itself is resolved. */
3264 need_full_assumed_size++;
3265
3266 if (expr->symtree && expr->symtree->n.sym)
3267 p = expr->symtree->n.sym->attr.proc;
3268
3269 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3270 inquiry_argument = true;
3271 no_formal_args = sym && is_external_proc (sym)
3272 && gfc_sym_get_dummy_args (sym) == NULL__null;
3273
3274 if (!resolve_actual_arglist (expr->value.function.actual,
3275 p, no_formal_args))
3276 {
3277 inquiry_argument = false;
3278 return false;
3279 }
3280
3281 inquiry_argument = false;
3282
3283 /* Resume assumed_size checking. */
3284 need_full_assumed_size--;
3285
3286 /* If the procedure is external, check for usage. */
3287 if (sym && is_external_proc (sym))
3288 resolve_global_procedure (sym, &expr->where, 0);
3289
3290 if (sym && sym->ts.type == BT_CHARACTER
3291 && sym->ts.u.cl
3292 && sym->ts.u.cl->length == NULL__null
3293 && !sym->attr.dummy
3294 && !sym->ts.deferred
3295 && expr->value.function.esym == NULL__null
3296 && !sym->attr.contained)
3297 {
3298 /* Internal procedures are taken care of in resolve_contained_fntype. */
3299 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
3300 "be used at %L since it is not a dummy argument",
3301 sym->name, &expr->where);
3302 return false;
3303 }
3304
3305 /* See if function is already resolved. */
3306
3307 if (expr->value.function.name != NULL__null
3308 || expr->value.function.isym != NULL__null)
3309 {
3310 if (expr->ts.type == BT_UNKNOWN)
3311 expr->ts = sym->ts;
3312 t = true;
3313 }
3314 else
3315 {
3316 /* Apply the rules of section 14.1.2. */
3317
3318 switch (procedure_kind (sym))
3319 {
3320 case PTYPE_GENERIC:
3321 t = resolve_generic_f (expr);
3322 break;
3323
3324 case PTYPE_SPECIFIC:
3325 t = resolve_specific_f (expr);
3326 break;
3327
3328 case PTYPE_UNKNOWN:
3329 t = resolve_unknown_f (expr);
3330 break;
3331
3332 default:
3333 gfc_internal_error ("resolve_function(): bad function type");
3334 }
3335 }
3336
3337 /* If the expression is still a function (it might have simplified),
3338 then we check to see if we are calling an elemental function. */
3339
3340 if (expr->expr_type != EXPR_FUNCTION)
3341 return t;
3342
3343 /* Walk the argument list looking for invalid BOZ. */
3344 for (arg = expr->value.function.actual; arg; arg = arg->next)
3345 if (arg->expr && arg->expr->ts.type == BT_BOZ)
3346 {
3347 gfc_error ("A BOZ literal constant at %L cannot appear as an "
3348 "actual argument in a function reference",
3349 &arg->expr->where);
3350 return false;
3351 }
3352
3353 temp = need_full_assumed_size;
3354 need_full_assumed_size = 0;
3355
3356 if (!resolve_elemental_actual (expr, NULL__null))
3357 return false;
3358
3359 if (omp_workshare_flag
3360 && expr->value.function.esym
3361 && ! gfc_elemental (expr->value.function.esym))
3362 {
3363 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3364 "in WORKSHARE construct", expr->value.function.esym->name,
3365 &expr->where);
3366 t = false;
3367 }
3368
3369#define GENERIC_ID expr->value.function.isym->id
3370 else if (expr->value.function.actual != NULL__null
3371 && expr->value.function.isym != NULL__null
3372 && GENERIC_ID != GFC_ISYM_LBOUND
3373 && GENERIC_ID != GFC_ISYM_LCOBOUND
3374 && GENERIC_ID != GFC_ISYM_UCOBOUND
3375 && GENERIC_ID != GFC_ISYM_LEN
3376 && GENERIC_ID != GFC_ISYM_LOC
3377 && GENERIC_ID != GFC_ISYM_C_LOC
3378 && GENERIC_ID != GFC_ISYM_PRESENT)
3379 {
3380 /* Array intrinsics must also have the last upper bound of an
3381 assumed size array argument. UBOUND and SIZE have to be
3382 excluded from the check if the second argument is anything
3383 than a constant. */
3384
3385 for (arg = expr->value.function.actual; arg; arg = arg->next)
3386 {
3387 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
3388 && arg == expr->value.function.actual
3389 && arg->next != NULL__null && arg->next->expr)
3390 {
3391 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3392 break;
3393
3394 if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
3395 break;
3396
3397 if ((int)mpz_get_si__gmpz_get_si (arg->next->expr->value.integer)
3398 < arg->expr->rank)
3399 break;
3400 }
3401
3402 if (arg->expr != NULL__null
3403 && arg->expr->rank > 0
3404 && resolve_assumed_size_actual (arg->expr))
3405 return false;
3406 }
3407 }
3408#undef GENERIC_ID
3409
3410 need_full_assumed_size = temp;
3411
3412 if (!check_pure_function(expr))
3413 t = false;
3414
3415 /* Functions without the RECURSIVE attribution are not allowed to
3416 * call themselves. */
3417 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3418 {
3419 gfc_symbol *esym;
3420 esym = expr->value.function.esym;
3421
3422 if (is_illegal_recursion (esym, gfc_current_ns))
3423 {
3424 if (esym->attr.entry && esym->ns->entries)
3425 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3426 " function %qs is not RECURSIVE",
3427 esym->name, &expr->where, esym->ns->entries->sym->name);
3428 else
3429 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3430 " is not RECURSIVE", esym->name, &expr->where);
3431
3432 t = false;
3433 }
3434 }
3435
3436 /* Character lengths of use associated functions may contains references to
3437 symbols not referenced from the current program unit otherwise. Make sure
3438 those symbols are marked as referenced. */
3439
3440 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
3441 && expr->value.function.esym->attr.use_assoc)
3442 {
3443 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
3444 }
3445
3446 /* Make sure that the expression has a typespec that works. */
3447 if (expr->ts.type == BT_UNKNOWN)
3448 {
3449 if (expr->symtree->n.sym->result
3450 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3451 && !expr->symtree->n.sym->result->attr.proc_pointer)
3452 expr->ts = expr->symtree->n.sym->result->ts;
3453 }
3454
3455 if (!expr->ref && !expr->value.function.isym)
3456 {
3457 if (expr->value.function.esym)
3458 update_current_proc_array_outer_dependency (expr->value.function.esym);
3459 else
3460 update_current_proc_array_outer_dependency (sym);
3461 }
3462 else if (expr->ref)
3463 /* typebound procedure: Assume the worst. */
3464 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3465
3466 if (expr->value.function.esym
3467 && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3468 gfc_warning (OPT_Wdeprecated_declarations,
3469 "Using function %qs at %L is deprecated",
3470 sym->name, &expr->where);
3471 return t;
3472}
3473
3474
3475/************* Subroutine resolution *************/
3476
3477static bool
3478pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
3479{
3480 if (gfc_pure (sym))
3481 return true;
3482
3483 if (forall_flag)
3484 {
3485 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3486 name, loc);
3487 return false;
3488 }
3489 else if (gfc_do_concurrent_flag)
3490 {
3491 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3492 "PURE", name, loc);
3493 return false;
3494 }
3495 else if (gfc_pure (NULL__null))
3496 {
3497 gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3498 return false;
3499 }
3500
3501 gfc_unset_implicit_pure (NULL__null);
3502 return true;
3503}
3504
3505
3506static match
3507resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
3508{
3509 gfc_symbol *s;
3510
3511 if (sym->attr.generic)
3512 {
3513 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3514 if (s != NULL__null)
3515 {
3516 c->resolved_sym = s;
3517 if (!pure_subroutine (s, s->name, &c->loc))
3518 return MATCH_ERROR;
3519 return MATCH_YES;
3520 }
3521
3522 /* TODO: Need to search for elemental references in generic interface. */
3523 }
3524
3525 if (sym->attr.intrinsic)
3526 return gfc_intrinsic_sub_interface (c, 0);
3527
3528 return MATCH_NO;
3529}
3530
3531
3532static bool
3533resolve_generic_s (gfc_code *c)
3534{
3535 gfc_symbol *sym;
3536 match m;
3537
3538 sym = c->symtree->n.sym;
3539
3540 for (;;)
3541 {
3542 m = resolve_generic_s0 (c, sym);
3543 if (m == MATCH_YES)
3544 return true;
3545 else if (m == MATCH_ERROR)
3546 return false;
3547
3548generic:
3549 if (sym->ns->parent == NULL__null)
3550 break;
3551 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3552
3553 if (sym == NULL__null)
3554 break;
3555 if (!generic_sym (sym))
3556 goto generic;
3557 }
3558
3559 /* Last ditch attempt. See if the reference is to an intrinsic
3560 that possesses a matching interface. 14.1.2.4 */
3561 sym = c->symtree->n.sym;
3562
3563 if (!gfc_is_intrinsic (sym, 1, c->loc))
3564 {
3565 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3566 sym->name, &c->loc);
3567 return false;
3568 }
3569
3570 m = gfc_intrinsic_sub_interface (c, 0);
3571 if (m == MATCH_YES)
3572 return true;
3573 if (m == MATCH_NO)
3574 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3575 "intrinsic subroutine interface", sym->name, &c->loc);
3576
3577 return false;
3578}
3579
3580
3581/* Resolve a subroutine call known to be specific. */
3582
3583static match
3584resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
3585{
3586 match m;
3587
3588 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3589 {
3590 if (sym->attr.dummy)
3591 {
3592 sym->attr.proc = PROC_DUMMY;
3593 goto found;
3594 }
3595
3596 sym->attr.proc = PROC_EXTERNAL;
3597 goto found;
3598 }
3599
3600 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3601 goto found;
3602
3603 if (sym->attr.intrinsic)
3604 {
3605 m = gfc_intrinsic_sub_interface (c, 1);
3606 if (m == MATCH_YES)
3607 return MATCH_YES;
3608 if (m == MATCH_NO)
3609 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3610 "with an intrinsic", sym->name, &c->loc);
3611
3612 return MATCH_ERROR;
3613 }
3614
3615 return MATCH_NO;
3616
3617found:
3618 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3619
3620 c->resolved_sym = sym;
3621 if (!pure_subroutine (sym, sym->name, &c->loc))
3622 return MATCH_ERROR;
3623
3624 return MATCH_YES;
3625}
3626
3627
3628static bool
3629resolve_specific_s (gfc_code *c)
3630{
3631 gfc_symbol *sym;
3632 match m;
3633
3634 sym = c->symtree->n.sym;
3635
3636 for (;;)
3637 {
3638 m = resolve_specific_s0 (c, sym);
3639 if (m == MATCH_YES)
3640 return true;
3641 if (m == MATCH_ERROR)
3642 return false;
3643
3644 if (sym->ns->parent == NULL__null)
3645 break;
3646
3647 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3648
3649 if (sym == NULL__null)
3650 break;
3651 }
3652
3653 sym = c->symtree->n.sym;
3654 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3655 sym->name, &c->loc);
3656
3657 return false;
3658}
3659
3660
3661/* Resolve a subroutine call not known to be generic nor specific. */
3662
3663static bool
3664resolve_unknown_s (gfc_code *c)
3665{
3666 gfc_symbol *sym;
3667
3668 sym = c->symtree->n.sym;
3669
3670 if (sym->attr.dummy)
3671 {
3672 sym->attr.proc = PROC_DUMMY;
3673 goto found;
3674 }
3675
3676 /* See if we have an intrinsic function reference. */
3677
3678 if (gfc_is_intrinsic (sym, 1, c->loc))
3679 {
3680 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
3681 return true;
3682 return false;
3683 }
3684
3685 /* The reference is to an external name. */
3686
3687found:
3688 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3689
3690 c->resolved_sym = sym;
3691
3692 return pure_subroutine (sym, sym->name, &c->loc);
3693}
3694
3695
3696/* Resolve a subroutine call. Although it was tempting to use the same code
3697 for functions, subroutines and functions are stored differently and this
3698 makes things awkward. */
3699
3700static bool
3701resolve_call (gfc_code *c)
3702{
3703 bool t;
3704 procedure_type ptype = PROC_INTRINSIC;
3705 gfc_symbol *csym, *sym;
3706 bool no_formal_args;
3707
3708 csym = c->symtree ? c->symtree->n.sym : NULL__null;
3709
3710 if (csym && csym->ts.type != BT_UNKNOWN)
3711 {
3712 gfc_error ("%qs at %L has a type, which is not consistent with "
3713 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
3714 return false;
3715 }
3716
3717 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3718 {
3719 gfc_symtree *st;
3720 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
3721 sym = st ? st->n.sym : NULL__null;
3722 if (sym && csym != sym
3723 && sym->ns == gfc_current_ns
3724 && sym->attr.flavor == FL_PROCEDURE
3725 && sym->attr.contained)
3726 {
3727 sym->refs++;
3728 if (csym->attr.generic)
3729 c->symtree->n.sym = sym;
3730 else
3731 c->symtree = st;
3732 csym = c->symtree->n.sym;
3733 }
3734 }
3735
3736 /* If this ia a deferred TBP, c->expr1 will be set. */
3737 if (!c->expr1 && csym)
3738 {
3739 if (csym->attr.abstract)
3740 {
3741 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3742 csym->name, &c->loc);
3743 return false;
3744 }
3745
3746 /* Subroutines without the RECURSIVE attribution are not allowed to
3747 call themselves. */
3748 if (is_illegal_recursion (csym, gfc_current_ns))
3749 {
3750 if (csym->attr.entry && csym->ns->entries)
3751 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3752 "as subroutine %qs is not RECURSIVE",
3753 csym->name, &c->loc, csym->ns->entries->sym->name);
3754 else
3755 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3756 "as it is not RECURSIVE", csym->name, &c->loc);
3757
3758 t = false;
3759 }
3760 }
3761
3762 /* Switch off assumed size checking and do this again for certain kinds
3763 of procedure, once the procedure itself is resolved. */
3764 need_full_assumed_size++;
3765
3766 if (csym)
3767 ptype = csym->attr.proc;
3768
3769 no_formal_args = csym && is_external_proc (csym)
3770 && gfc_sym_get_dummy_args (csym) == NULL__null;
3771 if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
3772 return false;
3773
3774 /* Resume assumed_size checking. */
3775 need_full_assumed_size--;
3776
3777 /* If external, check for usage. */
3778 if (csym && is_external_proc (csym))
3779 resolve_global_procedure (csym, &c->loc, 1);
3780
3781 t = true;
3782 if (c->resolved_sym == NULL__null)
3783 {
3784 c->resolved_isym = NULL__null;
3785 switch (procedure_kind (csym))
3786 {
3787 case PTYPE_GENERIC:
3788 t = resolve_generic_s (c);
3789 break;
3790
3791 case PTYPE_SPECIFIC:
3792 t = resolve_specific_s (c);
3793 break;
3794
3795 case PTYPE_UNKNOWN:
3796 t = resolve_unknown_s (c);
3797 break;
3798
3799 default:
3800 gfc_internal_error ("resolve_subroutine(): bad function type");
3801 }
3802 }
3803
3804 /* Some checks of elemental subroutine actual arguments. */
3805 if (!resolve_elemental_actual (NULL__null, c))
3806 return false;
3807
3808 if (!c->expr1)
3809 update_current_proc_array_outer_dependency (csym);
3810 else
3811 /* Typebound procedure: Assume the worst. */
3812 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3813
3814 if (c->resolved_sym
3815 && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3816 gfc_warning (OPT_Wdeprecated_declarations,
3817 "Using subroutine %qs at %L is deprecated",
3818 c->resolved_sym->name, &c->loc);
3819
3820 return t;
3821}
3822
3823
3824/* Compare the shapes of two arrays that have non-NULL shapes. If both
3825 op1->shape and op2->shape are non-NULL return true if their shapes
3826 match. If both op1->shape and op2->shape are non-NULL return false
3827 if their shapes do not match. If either op1->shape or op2->shape is
3828 NULL, return true. */
3829
3830static bool
3831compare_shapes (gfc_expr *op1, gfc_expr *op2)
3832{
3833 bool t;
3834 int i;
3835
3836 t = true;
3837
3838 if (op1->shape != NULL__null && op2->shape != NULL__null)
3839 {
3840 for (i = 0; i < op1->rank; i++)
3841 {
3842 if (mpz_cmp__gmpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3843 {
3844 gfc_error ("Shapes for operands at %L and %L are not conformable",
3845 &op1->where, &op2->where);
3846 t = false;
3847 break;
3848 }
3849 }
3850 }
3851
3852 return t;
3853}
3854
3855/* Convert a logical operator to the corresponding bitwise intrinsic call.
3856 For example A .AND. B becomes IAND(A, B). */
3857static gfc_expr *
3858logical_to_bitwise (gfc_expr *e)
3859{
3860 gfc_expr *tmp, *op1, *op2;
3861 gfc_isym_id isym;
3862 gfc_actual_arglist *args = NULL__null;
3863
3864 gcc_assert (e->expr_type == EXPR_OP)((void)(!(e->expr_type == EXPR_OP) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 3864, __FUNCTION__), 0 : 0))
;
3865
3866 isym = GFC_ISYM_NONE;
3867 op1 = e->value.op.op1;
3868 op2 = e->value.op.op2;
3869
3870 switch (e->value.op.op)
3871 {
3872 case INTRINSIC_NOT:
3873 isym = GFC_ISYM_NOT;
3874 break;
3875 case INTRINSIC_AND:
3876 isym = GFC_ISYM_IAND;
3877 break;
3878 case INTRINSIC_OR:
3879 isym = GFC_ISYM_IOR;
3880 break;
3881 case INTRINSIC_NEQV:
3882 isym = GFC_ISYM_IEOR;
3883 break;
3884 case INTRINSIC_EQV:
3885 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3886 Change the old expression to NEQV, which will get replaced by IEOR,
3887 and wrap it in NOT. */
3888 tmp = gfc_copy_expr (e);
3889 tmp->value.op.op = INTRINSIC_NEQV;
3890 tmp = logical_to_bitwise (tmp);
3891 isym = GFC_ISYM_NOT;
3892 op1 = tmp;
3893 op2 = NULL__null;
3894 break;
3895 default:
3896 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3897 }
3898
3899 /* Inherit the original operation's operands as arguments. */
3900 args = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
3901 args->expr = op1;
3902 if (op2)
3903 {
3904 args->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
3905 args->next->expr = op2;
3906 }
3907
3908 /* Convert the expression to a function call. */
3909 e->expr_type = EXPR_FUNCTION;
3910 e->value.function.actual = args;
3911 e->value.function.isym = gfc_intrinsic_function_by_id (isym);
3912 e->value.function.name = e->value.function.isym->name;
3913 e->value.function.esym = NULL__null;
3914
3915 /* Make up a pre-resolved function call symtree if we need to. */
3916 if (!e->symtree || !e->symtree->n.sym)
3917 {
3918 gfc_symbol *sym;
3919 gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
3920 sym = e->symtree->n.sym;
3921 sym->result = sym;
3922 sym->attr.flavor = FL_PROCEDURE;
3923 sym->attr.function = 1;
3924 sym->attr.elemental = 1;
3925 sym->attr.pure = 1;
3926 sym->attr.referenced = 1;
3927 gfc_intrinsic_symbol (sym)sym->module = gfc_get_string ("(intrinsic)");
3928 gfc_commit_symbol (sym);
3929 }
3930
3931 args->name = e->value.function.isym->formal->name;
3932 if (e->value.function.isym->formal->next)
3933 args->next->name = e->value.function.isym->formal->next->name;
3934
3935 return e;
3936}
3937
3938/* Recursively append candidate UOP to CANDIDATES. Store the number of
3939 candidates in CANDIDATES_LEN. */
3940static void
3941lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
3942 char **&candidates,
3943 size_t &candidates_len)
3944{
3945 gfc_symtree *p;
3946
3947 if (uop == NULL__null)
3948 return;
3949
3950 /* Not sure how to properly filter here. Use all for a start.
3951 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3952 these as i suppose they don't make terribly sense. */
3953
3954 if (uop->n.uop->op != NULL__null)
3955 vec_push (candidates, candidates_len, uop->name);
3956
3957 p = uop->left;
3958 if (p)
3959 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
3960
3961 p = uop->right;
3962 if (p)
3963 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
3964}
3965
3966/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3967
3968static const char*
3969lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
3970{
3971 char **candidates = NULL__null;
3972 size_t candidates_len = 0;
3973 lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
3974 return gfc_closest_fuzzy_match (op, candidates);
3975}
3976
3977
3978/* Callback finding an impure function as an operand to an .and. or
3979 .or. expression. Remember the last function warned about to
3980 avoid double warnings when recursing. */
3981
3982static int
3983impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
3984 void *data)
3985{
3986 gfc_expr *f = *e;
3987 const char *name;
3988 static gfc_expr *last = NULL__null;
3989 bool *found = (bool *) data;
3990
3991 if (f->expr_type == EXPR_FUNCTION)
3992 {
3993 *found = 1;
3994 if (f != last && !gfc_pure_function (f, &name)
3995 && !gfc_implicit_pure_function (f))
3996 {
3997 if (name)
3998 gfc_warning (OPT_Wfunction_elimination,
3999 "Impure function %qs at %L might not be evaluated",
4000 name, &f->where);
4001 else
4002 gfc_warning (OPT_Wfunction_elimination,
4003 "Impure function at %L might not be evaluated",
4004 &f->where);
4005 }
4006 last = f;
4007 }
4008
4009 return 0;
4010}
4011
4012/* Return true if TYPE is character based, false otherwise. */
4013
4014static int
4015is_character_based (bt type)
4016{
4017 return type == BT_CHARACTER || type == BT_HOLLERITH;
4018}
4019
4020
4021/* If expression is a hollerith, convert it to character and issue a warning
4022 for the conversion. */
4023
4024static void
4025convert_hollerith_to_character (gfc_expr *e)
4026{
4027 if (e->ts.type == BT_HOLLERITH)
4028 {
4029 gfc_typespec t;
4030 gfc_clear_ts (&t);
4031 t.type = BT_CHARACTER;
4032 t.kind = e->ts.kind;
4033 gfc_convert_type_warn (e, &t, 2, 1);
4034 }
4035}
4036
4037/* Convert to numeric and issue a warning for the conversion. */
4038
4039static void
4040convert_to_numeric (gfc_expr *a, gfc_expr *b)
4041{
4042 gfc_typespec t;
4043 gfc_clear_ts (&t);
4044 t.type = b->ts.type;
4045 t.kind = b->ts.kind;
4046 gfc_convert_type_warn (a, &t, 2, 1);
4047}
4048
4049/* Resolve an operator expression node. This can involve replacing the
4050 operation with a user defined function call. */
4051
4052static bool
4053resolve_operator (gfc_expr *e)
4054{
4055 gfc_expr *op1, *op2;
4056 /* One error uses 3 names; additional space for wording (also via gettext). */
4057 char msg[3*GFC_MAX_SYMBOL_LEN63 + 1 + 50];
4058 bool dual_locus_error;
4059 bool t = true;
4060
4061 /* Resolve all subnodes-- give them types. */
4062
4063 switch (e->value.op.op)
4064 {
4065 default:
4066 if (!gfc_resolve_expr (e->value.op.op2))
4067 t = false;
4068
4069 /* Fall through. */
4070
4071 case INTRINSIC_NOT:
4072 case INTRINSIC_UPLUS:
4073 case INTRINSIC_UMINUS:
4074 case INTRINSIC_PARENTHESES:
4075 if (!gfc_resolve_expr (e->value.op.op1))
4076 return false;
4077 if (e->value.op.op1
4078 && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4079 {
4080 gfc_error ("BOZ literal constant at %L cannot be an operand of "
4081 "unary operator %qs", &e->value.op.op1->where,
4082 gfc_op2string (e->value.op.op));
4083 return false;
4084 }
4085 break;
4086 }
4087
4088 /* Typecheck the new node. */
4089
4090 op1 = e->value.op.op1;
4091 op2 = e->value.op.op2;
4092 if (op1 == NULL__null && op2 == NULL__null)
4093 return false;
4094 /* Error out if op2 did not resolve. We already diagnosed op1. */
4095 if (t == false)
4096 return false;
4097
4098 dual_locus_error = false;
4099
4100 /* op1 and op2 cannot both be BOZ. */
4101 if (op1 && op1->ts.type == BT_BOZ
4102 && op2 && op2->ts.type == BT_BOZ)
4103 {
4104 gfc_error ("Operands at %L and %L cannot appear as operands of "
4105 "binary operator %qs", &op1->where, &op2->where,
4106 gfc_op2string (e->value.op.op));
4107 return false;
4108 }
4109
4110 if ((op1 && op1->expr_type == EXPR_NULL)
4111 || (op2 && op2->expr_type == EXPR_NULL))
4112 {
4113 snprintf (msg, sizeof (msg),
4114 _("Invalid context for NULL() pointer at %%L")gettext ("Invalid context for NULL() pointer at %%L"));
4115 goto bad_op;
4116 }
4117
4118 switch (e->value.op.op)
4119 {
4120 case INTRINSIC_UPLUS:
4121 case INTRINSIC_UMINUS:
4122 if (op1->ts.type == BT_INTEGER
4123 || op1->ts.type == BT_REAL
4124 || op1->ts.type == BT_COMPLEX)
4125 {
4126 e->ts = op1->ts;
4127 break;
4128 }
4129
4130 snprintf (msg, sizeof (msg),
4131 _("Operand of unary numeric operator %%<%s%%> at %%L is %s")gettext ("Operand of unary numeric operator %%<%s%%> at %%L is %s"
)
,
4132 gfc_op2string (e->value.op.op), gfc_typename (e));
4133 goto bad_op;
4134
4135 case INTRINSIC_PLUS:
4136 case INTRINSIC_MINUS:
4137 case INTRINSIC_TIMES:
4138 case INTRINSIC_DIVIDE:
4139 case INTRINSIC_POWER:
4140 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4141 {
4142 gfc_type_convert_binary (e, 1);
4143 break;
4144 }
4145
4146 if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
4147 snprintf (msg, sizeof (msg),
4148 _("Unexpected derived-type entities in binary intrinsic "gettext ("Unexpected derived-type entities in binary intrinsic "
"numeric operator %%<%s%%> at %%L")
4149 "numeric operator %%<%s%%> at %%L")gettext ("Unexpected derived-type entities in binary intrinsic "
"numeric operator %%<%s%%> at %%L")
,
4150 gfc_op2string (e->value.op.op));
4151 else
4152 snprintf (msg, sizeof(msg),
4153 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"
)
,
4154 gfc_op2string (e->value.op.op), gfc_typename (op1),
4155 gfc_typename (op2));
4156 goto bad_op;
4157
4158 case INTRINSIC_CONCAT:
4159 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4160 && op1->ts.kind == op2->ts.kind)
4161 {
4162 e->ts.type = BT_CHARACTER;
4163 e->ts.kind = op1->ts.kind;
4164 break;
4165 }
4166
4167 snprintf (msg, sizeof (msg),
4168 _("Operands of string concatenation operator at %%L are %s/%s")gettext ("Operands of string concatenation operator at %%L are %s/%s"
)
,
4169 gfc_typename (op1), gfc_typename (op2));
4170 goto bad_op;
4171
4172 case INTRINSIC_AND:
4173 case INTRINSIC_OR:
4174 case INTRINSIC_EQV:
4175 case INTRINSIC_NEQV:
4176 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4177 {
4178 e->ts.type = BT_LOGICAL;
4179 e->ts.kind = gfc_kind_max (op1, op2);
4180 if (op1->ts.kind < e->ts.kind)
4181 gfc_convert_type (op1, &e->ts, 2);
4182 else if (op2->ts.kind < e->ts.kind)
4183 gfc_convert_type (op2, &e->ts, 2);
4184
4185 if (flag_frontend_optimizeglobal_options.x_flag_frontend_optimize &&
4186 (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
4187 {
4188 /* Warn about short-circuiting
4189 with impure function as second operand. */
4190 bool op2_f = false;
4191 gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4192 }
4193 break;
4194 }
4195
4196 /* Logical ops on integers become bitwise ops with -fdec. */
4197 else if (flag_decglobal_options.x_flag_dec
4198 && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4199 {
4200 e->ts.type = BT_INTEGER;
4201 e->ts.kind = gfc_kind_max (op1, op2);
4202 if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4203 gfc_convert_type (op1, &e->ts, 1);
4204 if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4205 gfc_convert_type (op2, &e->ts, 1);
4206 e = logical_to_bitwise (e);
4207 goto simplify_op;
4208 }
4209
4210 snprintf (msg, sizeof (msg),
4211 _("Operands of logical operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of logical operator %%<%s%%> at %%L are %s/%s"
)
,
4212 gfc_op2string (e->value.op.op), gfc_typename (op1),
4213 gfc_typename (op2));
4214
4215 goto bad_op;
4216
4217 case INTRINSIC_NOT:
4218 /* Logical ops on integers become bitwise ops with -fdec. */
4219 if (flag_decglobal_options.x_flag_dec && op1->ts.type == BT_INTEGER)
4220 {
4221 e->ts.type = BT_INTEGER;
4222 e->ts.kind = op1->ts.kind;
4223 e = logical_to_bitwise (e);
4224 goto simplify_op;
4225 }
4226
4227 if (op1->ts.type == BT_LOGICAL)
4228 {
4229 e->ts.type = BT_LOGICAL;
4230 e->ts.kind = op1->ts.kind;
4231 break;
4232 }
4233
4234 snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s")gettext ("Operand of .not. operator at %%L is %s"),
4235 gfc_typename (op1));
4236 goto bad_op;
4237
4238 case INTRINSIC_GT:
4239 case INTRINSIC_GT_OS:
4240 case INTRINSIC_GE:
4241 case INTRINSIC_GE_OS:
4242 case INTRINSIC_LT:
4243 case INTRINSIC_LT_OS:
4244 case INTRINSIC_LE:
4245 case INTRINSIC_LE_OS:
4246 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4247 {
4248 strcpy (msg, _("COMPLEX quantities cannot be compared at %L")gettext ("COMPLEX quantities cannot be compared at %L"));
4249 goto bad_op;
4250 }
4251
4252 /* Fall through. */
4253
4254 case INTRINSIC_EQ:
4255 case INTRINSIC_EQ_OS:
4256 case INTRINSIC_NE:
4257 case INTRINSIC_NE_OS:
4258
4259 if (flag_decglobal_options.x_flag_dec
4260 && is_character_based (op1->ts.type)
4261 && is_character_based (op2->ts.type))
4262 {
4263 convert_hollerith_to_character (op1);
4264 convert_hollerith_to_character (op2);
4265 }
4266
4267 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4268 && op1->ts.kind == op2->ts.kind)
4269 {
4270 e->ts.type = BT_LOGICAL;
4271 e->ts.kind = gfc_default_logical_kind;
4272 break;
4273 }
4274
4275 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4276 if (op1->ts.type == BT_BOZ)
4277 {
4278 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear ""BOZ literal constant near %L cannot appear " "as an operand of a relational operator"
4279 "as an operand of a relational operator")"BOZ literal constant near %L cannot appear " "as an operand of a relational operator",
4280 &op1->where))
4281 return false;
4282
4283 if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4284 return false;
4285
4286 if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4287 return false;
4288 }
4289
4290 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4291 if (op2->ts.type == BT_BOZ)
4292 {
4293 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear""BOZ literal constant near %L cannot appear" " as an operand of a relational operator"
4294 " as an operand of a relational operator")"BOZ literal constant near %L cannot appear" " as an operand of a relational operator",
4295 &op2->where))
4296 return false;
4297
4298 if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4299 return false;
4300
4301 if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4302 return false;
4303 }
4304 if (flag_decglobal_options.x_flag_dec
4305 && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4306 convert_to_numeric (op1, op2);
4307
4308 if (flag_decglobal_options.x_flag_dec
4309 && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4310 convert_to_numeric (op2, op1);
4311
4312 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4313 {
4314 gfc_type_convert_binary (e, 1);
4315
4316 e->ts.type = BT_LOGICAL;
4317 e->ts.kind = gfc_default_logical_kind;
4318
4319 if (warn_compare_realsglobal_options.x_warn_compare_reals)
4320 {
4321 gfc_intrinsic_op op = e->value.op.op;
4322
4323 /* Type conversion has made sure that the types of op1 and op2
4324 agree, so it is only necessary to check the first one. */
4325 if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4326 && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4327 || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4328 {
4329 const char *msg;
4330
4331 if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
4332 msg = G_("Equality comparison for %s at %L")"Equality comparison for %s at %L";
4333 else
4334 msg = G_("Inequality comparison for %s at %L")"Inequality comparison for %s at %L";
4335
4336 gfc_warning (OPT_Wcompare_reals, msg,
4337 gfc_typename (op1), &op1->where);
4338 }
4339 }
4340
4341 break;
4342 }
4343
4344 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4345 snprintf (msg, sizeof (msg),
4346 _("Logicals at %%L must be compared with %s instead of %s")gettext ("Logicals at %%L must be compared with %s instead of %s"
)
,
4347 (e->value.op.op == INTRINSIC_EQ
4348 || e->value.op.op == INTRINSIC_EQ_OS)
4349 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
4350 else
4351 snprintf (msg, sizeof (msg),
4352 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of comparison operator %%<%s%%> at %%L are %s/%s"
)
,
4353 gfc_op2string (e->value.op.op), gfc_typename (op1),
4354 gfc_typename (op2));
4355
4356 goto bad_op;
4357
4358 case INTRINSIC_USER:
4359 if (e->value.op.uop->op == NULL__null)
4360 {
4361 const char *name = e->value.op.uop->name;
4362 const char *guessed;
4363 guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4364 if (guessed)
4365 snprintf (msg, sizeof (msg),
4366 _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?")gettext ("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"
)
,
4367 name, guessed);
4368 else
4369 snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L")gettext ("Unknown operator %%<%s%%> at %%L"),
4370 name);
4371 }
4372 else if (op2 == NULL__null)
4373 snprintf (msg, sizeof (msg),
4374 _("Operand of user operator %%<%s%%> at %%L is %s")gettext ("Operand of user operator %%<%s%%> at %%L is %s"
)
,
4375 e->value.op.uop->name, gfc_typename (op1));
4376 else
4377 {
4378 snprintf (msg, sizeof (msg),
4379 _("Operands of user operator %%<%s%%> at %%L are %s/%s")gettext ("Operands of user operator %%<%s%%> at %%L are %s/%s"
)
,
4380 e->value.op.uop->name, gfc_typename (op1),
4381 gfc_typename (op2));
4382 e->value.op.uop->op->sym->attr.referenced = 1;
4383 }
4384
4385 goto bad_op;
4386
4387 case INTRINSIC_PARENTHESES:
4388 e->ts = op1->ts;
4389 if (e->ts.type == BT_CHARACTER)
4390 e->ts.u.cl = op1->ts.u.cl;
4391 break;
4392
4393 default:
4394 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4395 }
4396
4397 /* Deal with arrayness of an operand through an operator. */
4398
4399 switch (e->value.op.op)
4400 {
4401 case INTRINSIC_PLUS:
4402 case INTRINSIC_MINUS:
4403 case INTRINSIC_TIMES:
4404 case INTRINSIC_DIVIDE:
4405 case INTRINSIC_POWER:
4406 case INTRINSIC_CONCAT:
4407 case INTRINSIC_AND:
4408 case INTRINSIC_OR:
4409 case INTRINSIC_EQV:
4410 case INTRINSIC_NEQV:
4411 case INTRINSIC_EQ:
4412 case INTRINSIC_EQ_OS:
4413 case INTRINSIC_NE:
4414 case INTRINSIC_NE_OS:
4415 case INTRINSIC_GT:
4416 case INTRINSIC_GT_OS:
4417 case INTRINSIC_GE:
4418 case INTRINSIC_GE_OS:
4419 case INTRINSIC_LT:
4420 case INTRINSIC_LT_OS:
4421 case INTRINSIC_LE:
4422 case INTRINSIC_LE_OS:
4423
4424 if (op1->rank == 0 && op2->rank == 0)
4425 e->rank = 0;
4426
4427 if (op1->rank == 0 && op2->rank != 0)
4428 {
4429 e->rank = op2->rank;
4430
4431 if (e->shape == NULL__null)
4432 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4433 }
4434
4435 if (op1->rank != 0 && op2->rank == 0)
4436 {
4437 e->rank = op1->rank;
4438
4439 if (e->shape == NULL__null)
4440 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4441 }
4442
4443 if (op1->rank != 0 && op2->rank != 0)
4444 {
4445 if (op1->rank == op2->rank)
4446 {
4447 e->rank = op1->rank;
4448 if (e->shape == NULL__null)
4449 {
4450 t = compare_shapes (op1, op2);
4451 if (!t)
4452 e->shape = NULL__null;
4453 else
4454 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4455 }
4456 }
4457 else
4458 {
4459 /* Allow higher level expressions to work. */
4460 e->rank = 0;
4461
4462 /* Try user-defined operators, and otherwise throw an error. */
4463 dual_locus_error = true;
4464 snprintf (msg, sizeof (msg),
4465 _("Inconsistent ranks for operator at %%L and %%L")gettext ("Inconsistent ranks for operator at %%L and %%L"));
4466 goto bad_op;
4467 }
4468 }
4469
4470 break;
4471
4472 case INTRINSIC_PARENTHESES:
4473 case INTRINSIC_NOT:
4474 case INTRINSIC_UPLUS:
4475 case INTRINSIC_UMINUS:
4476 /* Simply copy arrayness attribute */
4477 e->rank = op1->rank;
4478
4479 if (e->shape == NULL__null)
4480 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4481
4482 break;
4483
4484 default:
4485 break;
4486 }
4487
4488simplify_op:
4489
4490 /* Attempt to simplify the expression. */
4491 if (t)
4492 {
4493 t = gfc_simplify_expr (e, 0);
4494 /* Some calls do not succeed in simplification and return false
4495 even though there is no error; e.g. variable references to
4496 PARAMETER arrays. */
4497 if (!gfc_is_constant_expr (e))
4498 t = true;
4499 }
4500 return t;
4501
4502bad_op:
4503
4504 {
4505 match m = gfc_extend_expr (e);
4506 if (m == MATCH_YES)
4507 return true;
4508 if (m == MATCH_ERROR)
4509 return false;
4510 }
4511
4512 if (dual_locus_error)
4513 gfc_error (msg, &op1->where, &op2->where);
4514 else
4515 gfc_error (msg, &e->where);
4516
4517 return false;
4518}
4519
4520
4521/************** Array resolution subroutines **************/
4522
4523enum compare_result
4524{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
4525
4526/* Compare two integer expressions. */
4527
4528static compare_result
4529compare_bound (gfc_expr *a, gfc_expr *b)
4530{
4531 int i;
4532
4533 if (a == NULL__null || a->expr_type != EXPR_CONSTANT
4534 || b == NULL__null || b->expr_type != EXPR_CONSTANT)
4535 return CMP_UNKNOWN;
4536
4537 /* If either of the types isn't INTEGER, we must have
4538 raised an error earlier. */
4539
4540 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
4541 return CMP_UNKNOWN;
4542
4543 i = mpz_cmp__gmpz_cmp (a->value.integer, b->value.integer);
4544
4545 if (i < 0)
4546 return CMP_LT;
4547 if (i > 0)
4548 return CMP_GT;
4549 return CMP_EQ;
4550}
4551
4552
4553/* Compare an integer expression with an integer. */
4554
4555static compare_result
4556compare_bound_int (gfc_expr *a, int b)
4557{
4558 int i;
4559
4560 if (a == NULL__null || a->expr_type != EXPR_CONSTANT)
4561 return CMP_UNKNOWN;
4562
4563 if (a->ts.type != BT_INTEGER)
4564 gfc_internal_error ("compare_bound_int(): Bad expression");
4565
4566 i = mpz_cmp_si (a->value.integer, b)(__builtin_constant_p ((b) >= 0) && (b) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (b)))
&& ((static_cast<unsigned long> (b))) == 0 ? (
(a->value.integer)->_mp_size < 0 ? -1 : (a->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (a->value.integer
,(static_cast<unsigned long> (b)))) : __gmpz_cmp_si (a->
value.integer,b))
;
4567
4568 if (i < 0)
4569 return CMP_LT;
4570 if (i > 0)
4571 return CMP_GT;
4572 return CMP_EQ;
4573}
4574
4575
4576/* Compare an integer expression with a mpz_t. */
4577
4578static compare_result
4579compare_bound_mpz_t (gfc_expr *a, mpz_t b)
4580{
4581 int i;
4582
4583 if (a == NULL__null || a->expr_type != EXPR_CONSTANT)
4584 return CMP_UNKNOWN;
4585
4586 if (a->ts.type != BT_INTEGER)
4587 gfc_internal_error ("compare_bound_int(): Bad expression");
4588
4589 i = mpz_cmp__gmpz_cmp (a->value.integer, b);
4590
4591 if (i < 0)
4592 return CMP_LT;
4593 if (i > 0)
4594 return CMP_GT;
4595 return CMP_EQ;
4596}
4597
4598
4599/* Compute the last value of a sequence given by a triplet.
4600 Return 0 if it wasn't able to compute the last value, or if the
4601 sequence if empty, and 1 otherwise. */
4602
4603static int
4604compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4605 gfc_expr *stride, mpz_t last)
4606{
4607 mpz_t rem;
4608
4609 if (start == NULL__null || start->expr_type != EXPR_CONSTANT
4610 || end == NULL__null || end->expr_type != EXPR_CONSTANT
4611 || (stride != NULL__null && stride->expr_type != EXPR_CONSTANT))
4612 return 0;
4613
4614 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4615 || (stride != NULL__null && stride->ts.type != BT_INTEGER))
4616 return 0;
4617
4618 if (stride == NULL__null || compare_bound_int (stride, 1) == CMP_EQ)
4619 {
4620 if (compare_bound (start, end) == CMP_GT)
4621 return 0;
4622 mpz_set__gmpz_set (last, end->value.integer);
4623 return 1;
4624 }
4625
4626 if (compare_bound_int (stride, 0) == CMP_GT)
4627 {
4628 /* Stride is positive */
4629 if (mpz_cmp__gmpz_cmp (start->value.integer, end->value.integer) > 0)
4630 return 0;
4631 }
4632 else
4633 {
4634 /* Stride is negative */
4635 if (mpz_cmp__gmpz_cmp (start->value.integer, end->value.integer) < 0)
4636 return 0;
4637 }
4638
4639 mpz_init__gmpz_init (rem);
4640 mpz_sub__gmpz_sub (rem, end->value.integer, start->value.integer);
4641 mpz_tdiv_r__gmpz_tdiv_r (rem, rem, stride->value.integer);
4642 mpz_sub__gmpz_sub (last, end->value.integer, rem);
4643 mpz_clear__gmpz_clear (rem);
4644
4645 return 1;
4646}
4647
4648
4649/* Compare a single dimension of an array reference to the array
4650 specification. */
4651
4652static bool
4653check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
4654{
4655 mpz_t last_value;
4656
4657 if (ar->dimen_type[i] == DIMEN_STAR)
4658 {
4659 gcc_assert (ar->stride[i] == NULL)((void)(!(ar->stride[i] == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 4659, __FUNCTION__), 0 : 0))
;
4660 /* This implies [*] as [*:] and [*:3] are not possible. */
4661 if (ar->start[i] == NULL__null)
4662 {
4663 gcc_assert (ar->end[i] == NULL)((void)(!(ar->end[i] == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 4663, __FUNCTION__), 0 : 0))
;
4664 return true;
4665 }
4666 }
4667
4668/* Given start, end and stride values, calculate the minimum and
4669 maximum referenced indexes. */
4670
4671 switch (ar->dimen_type[i])
4672 {
4673 case DIMEN_VECTOR:
4674 case DIMEN_THIS_IMAGE:
4675 break;
4676
4677 case DIMEN_STAR:
4678 case DIMEN_ELEMENT:
4679 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
4680 {
4681 if (i < as->rank)
4682 gfc_warning (0, "Array reference at %L is out of bounds "
4683 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4684 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
4685 mpz_get_si__gmpz_get_si (as->lower[i]->value.integer), i+1);
4686 else
4687 gfc_warning (0, "Array reference at %L is out of bounds "
4688 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4689 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
4690 mpz_get_si__gmpz_get_si (as->lower[i]->value.integer),
4691 i + 1 - as->rank);
4692 return true;
4693 }
4694 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
4695 {
4696 if (i < as->rank)
4697 gfc_warning (0, "Array reference at %L is out of bounds "
4698 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4699 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
4700 mpz_get_si__gmpz_get_si (as->upper[i]->value.integer), i+1);
4701 else
4702 gfc_warning (0, "Array reference at %L is out of bounds "
4703 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4704 mpz_get_si__gmpz_get_si (ar->start[i]->value.integer),
4705 mpz_get_si__gmpz_get_si (as->upper[i]->value.integer),
4706 i + 1 - as->rank);
4707 return true;
4708 }
4709
4710 break;
4711
4712 case DIMEN_RANGE:
4713 {
4714#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4715#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4716
4717 compare_result comp_start_end = compare_bound (AR_START, AR_END);
4718
4719 /* Check for zero stride, which is not allowed. */
4720 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4721 {
4722 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
4723 return false;
4724 }
4725
4726 /* if start == len || (stride > 0 && start < len)
4727 || (stride < 0 && start > len),
4728 then the array section contains at least one element. In this
4729 case, there is an out-of-bounds access if
4730 (start < lower || start > upper). */
4731 if (compare_bound (AR_START, AR_END) == CMP_EQ
4732 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4733 || ar->stride[i] == NULL__null) && comp_start_end == CMP_LT)
4734 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4735 && comp_start_end == CMP_GT))
4736 {
4737 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4738 {
4739 gfc_warning (0, "Lower array reference at %L is out of bounds "
4740 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4741 mpz_get_si__gmpz_get_si (AR_START->value.integer),
4742 mpz_get_si__gmpz_get_si (as->lower[i]->value.integer), i+1);
4743 return true;
4744 }
4745 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4746 {
4747 gfc_warning (0, "Lower array reference at %L is out of bounds "
4748 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4749 mpz_get_si__gmpz_get_si (AR_START->value.integer),
4750 mpz_get_si__gmpz_get_si (as->upper[i]->value.integer), i+1);
4751 return true;
4752 }
4753 }
4754
4755 /* If we can compute the highest index of the array section,
4756 then it also has to be between lower and upper. */
4757 mpz_init__gmpz_init (last_value);
4758 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4759 last_value))
4760 {
4761 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
4762 {
4763 gfc_warning (0, "Upper array reference at %L is out of bounds "
4764 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4765 mpz_get_si__gmpz_get_si (last_value),
4766 mpz_get_si__gmpz_get_si (as->lower[i]->value.integer), i+1);
4767 mpz_clear__gmpz_clear (last_value);
4768 return true;
4769 }
4770 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4771 {
4772 gfc_warning (0, "Upper array reference at %L is out of bounds "
4773 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4774 mpz_get_si__gmpz_get_si (last_value),
4775 mpz_get_si__gmpz_get_si (as->upper[i]->value.integer), i+1);
4776 mpz_clear__gmpz_clear (last_value);
4777 return true;
4778 }
4779 }
4780 mpz_clear__gmpz_clear (last_value);
4781
4782#undef AR_START
4783#undef AR_END
4784 }
4785 break;
4786
4787 default:
4788 gfc_internal_error ("check_dimension(): Bad array reference");
4789 }
4790
4791 return true;
4792}
4793
4794
4795/* Compare an array reference with an array specification. */
4796
4797static bool
4798compare_spec_to_ref (gfc_array_ref *ar)
4799{
4800 gfc_array_spec *as;
4801 int i;
4802
4803 as = ar->as;
4804 i = as->rank - 1;
4805 /* TODO: Full array sections are only allowed as actual parameters. */
4806 if (as->type == AS_ASSUMED_SIZE
4807 && (/*ar->type == AR_FULL
4808 ||*/ (ar->type == AR_SECTION
4809 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL__null)))
4810 {
4811 gfc_error ("Rightmost upper bound of assumed size array section "
4812 "not specified at %L", &ar->where);
4813 return false;
4814 }
4815
4816 if (ar->type == AR_FULL)
4817 return true;
4818
4819 if (as->rank != ar->dimen)
4820 {
4821 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4822 &ar->where, ar->dimen, as->rank);
4823 return false;
4824 }
4825
4826 /* ar->codimen == 0 is a local array. */
4827 if (as->corank != ar->codimen && ar->codimen != 0)
4828 {
4829 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4830 &ar->where, ar->codimen, as->corank);
4831 return false;
4832 }
4833
4834 for (i = 0; i < as->rank; i++)
4835 if (!check_dimension (i, ar, as))
4836 return false;
4837
4838 /* Local access has no coarray spec. */
4839 if (ar->codimen != 0)
4840 for (i = as->rank; i < as->rank + as->corank; i++)
4841 {
4842 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4843 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
4844 {
4845 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4846 i + 1 - as->rank, &ar->where);
4847 return false;
4848 }
4849 if (!check_dimension (i, ar, as))
4850 return false;
4851 }
4852
4853 return true;
4854}
4855
4856
4857/* Resolve one part of an array index. */
4858
4859static bool
4860gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4861 int force_index_integer_kind)
4862{
4863 gfc_typespec ts;
4864
4865 if (index == NULL__null)
4866 return true;
4867
4868 if (!gfc_resolve_expr (index))
4869 return false;
4870
4871 if (check_scalar && index->rank != 0)
4872 {
4873 gfc_error ("Array index at %L must be scalar", &index->where);
4874 return false;
4875 }
4876
4877 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4878 {
4879 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4880 &index->where, gfc_basic_typename (index->ts.type));
4881 return false;
4882 }
4883
4884 if (index->ts.type == BT_REAL)
4885 if (!gfc_notify_std (GFC_STD_LEGACY(1<<6), "REAL array index at %L",
4886 &index->where))
4887 return false;
4888
4889 if ((index->ts.kind != gfc_index_integer_kind
4890 && force_index_integer_kind)
4891 || index->ts.type != BT_INTEGER)
4892 {
4893 gfc_clear_ts (&ts);
4894 ts.type = BT_INTEGER;
4895 ts.kind = gfc_index_integer_kind;
4896
4897 gfc_convert_type_warn (index, &ts, 2, 0);
4898 }
4899
4900 return true;
4901}
4902
4903/* Resolve one part of an array index. */
4904
4905bool
4906gfc_resolve_index (gfc_expr *index, int check_scalar)
4907{
4908 return gfc_resolve_index_1 (index, check_scalar, 1);
4909}
4910
4911/* Resolve a dim argument to an intrinsic function. */
4912
4913bool
4914gfc_resolve_dim_arg (gfc_expr *dim)
4915{
4916 if (dim == NULL__null)
4917 return true;
4918
4919 if (!gfc_resolve_expr (dim))
4920 return false;
4921
4922 if (dim->rank != 0)
4923 {
4924 gfc_error ("Argument dim at %L must be scalar", &dim->where);
4925 return false;
4926
4927 }
4928
4929 if (dim->ts.type != BT_INTEGER)
4930 {
4931 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
4932 return false;
4933 }
4934
4935 if (dim->ts.kind != gfc_index_integer_kind)
4936 {
4937 gfc_typespec ts;
4938
4939 gfc_clear_ts (&ts);
4940 ts.type = BT_INTEGER;
4941 ts.kind = gfc_index_integer_kind;
4942
4943 gfc_convert_type_warn (dim, &ts, 2, 0);
4944 }
4945
4946 return true;
4947}
4948
4949/* Given an expression that contains array references, update those array
4950 references to point to the right array specifications. While this is
4951 filled in during matching, this information is difficult to save and load
4952 in a module, so we take care of it here.
4953
4954 The idea here is that the original array reference comes from the
4955 base symbol. We traverse the list of reference structures, setting
4956 the stored reference to references. Component references can
4957 provide an additional array specification. */
4958static void
4959resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
4960
4961static void
4962find_array_spec (gfc_expr *e)
4963{
4964 gfc_array_spec *as;
4965 gfc_component *c;
4966 gfc_ref *ref;
4967 bool class_as = false;
4968
4969 if (e->symtree->n.sym->assoc)
4970 {
4971 if (e->symtree->n.sym->assoc->target)
4972 gfc_resolve_expr (e->symtree->n.sym->assoc->target);
4973 resolve_assoc_var (e->symtree->n.sym, false);
4974 }
4975
4976 if (e->symtree->n.sym->ts.type == BT_CLASS)
4977 {
4978 as = CLASS_DATA (e->symtree->n.sym)e->symtree->n.sym->ts.u.derived->components->as;
4979 class_as = true;
4980 }
4981 else
4982 as = e->symtree->n.sym->as;
4983
4984 for (ref = e->ref; ref; ref = ref->next)
4985 switch (ref->type)
4986 {
4987 case REF_ARRAY:
4988 if (as == NULL__null)
4989 gfc_internal_error ("find_array_spec(): Missing spec");
4990
4991 ref->u.ar.as = as;
4992 as = NULL__null;
4993 break;
4994
4995 case REF_COMPONENT:
4996 c = ref->u.c.component;
4997 if (c->attr.dimension)
4998 {
4999 if (as != NULL__null && !(class_as && as == c->as))
5000 gfc_internal_error ("find_array_spec(): unused as(1)");
5001 as = c->as;
5002 }
5003
5004 break;
5005
5006 case REF_SUBSTRING:
5007 case REF_INQUIRY:
5008 break;
5009 }
5010
5011 if (as != NULL__null)
5012 gfc_internal_error ("find_array_spec(): unused as(2)");
5013}
5014
5015
5016/* Resolve an array reference. */
5017
5018static bool
5019resolve_array_ref (gfc_array_ref *ar)
5020{
5021 int i, check_scalar;
5022 gfc_expr *e;
5023
5024 for (i = 0; i < ar->dimen + ar->codimen; i++)
5025 {
5026 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5027
5028 /* Do not force gfc_index_integer_kind for the start. We can
5029 do fine with any integer kind. This avoids temporary arrays
5030 created for indexing with a vector. */
5031 if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5032 return false;
5033 if (!gfc_resolve_index (ar->end[i], check_scalar))
5034 return false;
5035 if (!gfc_resolve_index (ar->stride[i], check_scalar))
5036 return false;
5037
5038 e = ar->start[i];
5039
5040 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
5041 switch (e->rank)
5042 {
5043 case 0:
5044 ar->dimen_type[i] = DIMEN_ELEMENT;
5045 break;
5046
5047 case 1:
5048 ar->dimen_type[i] = DIMEN_VECTOR;
5049 if (e->expr_type == EXPR_VARIABLE
5050 && e->symtree->n.sym->ts.type == BT_DERIVED)
5051 ar->start[i] = gfc_get_parentheses (e);
5052 break;
5053
5054 default:
5055 gfc_error ("Array index at %L is an array of rank %d",
5056 &ar->c_where[i], e->rank);
5057 return false;
5058 }
5059
5060 /* Fill in the upper bound, which may be lower than the
5061 specified one for something like a(2:10:5), which is
5062 identical to a(2:7:5). Only relevant for strides not equal
5063 to one. Don't try a division by zero. */
5064 if (ar->dimen_type[i] == DIMEN_RANGE
5065 && ar->stride[i] != NULL__null && ar->stride[i]->expr_type == EXPR_CONSTANT
5066 && mpz_cmp_si (ar->stride[i]->value.integer, 1L)(__builtin_constant_p ((1L) >= 0) && (1L) >= 0 ?
(__builtin_constant_p ((static_cast<unsigned long> (1L
))) && ((static_cast<unsigned long> (1L))) == 0
? ((ar->stride[i]->value.integer)->_mp_size < 0 ?
-1 : (ar->stride[i]->value.integer)->_mp_size > 0
) : __gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast
<unsigned long> (1L)))) : __gmpz_cmp_si (ar->stride[
i]->value.integer,1L))
!= 0
5067 && mpz_cmp_si (ar->stride[i]->value.integer, 0L)(__builtin_constant_p ((0L) >= 0) && (0L) >= 0 ?
(__builtin_constant_p ((static_cast<unsigned long> (0L
))) && ((static_cast<unsigned long> (0L))) == 0
? ((ar->stride[i]->value.integer)->_mp_size < 0 ?
-1 : (ar->stride[i]->value.integer)->_mp_size > 0
) : __gmpz_cmp_ui (ar->stride[i]->value.integer,(static_cast
<unsigned long> (0L)))) : __gmpz_cmp_si (ar->stride[
i]->value.integer,0L))
!= 0)
5068 {
5069 mpz_t size, end;
5070
5071 if (gfc_ref_dimen_size (ar, i, &size, &end))
5072 {
5073 if (ar->end[i] == NULL__null)
5074 {
5075 ar->end[i] =
5076 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5077 &ar->where);
5078 mpz_set__gmpz_set (ar->end[i]->value.integer, end);
5079 }
5080 else if (ar->end[i]->ts.type == BT_INTEGER
5081 && ar->end[i]->expr_type == EXPR_CONSTANT)
5082 {
5083 mpz_set__gmpz_set (ar->end[i]->value.integer, end);
5084 }
5085 else
5086 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5086, __FUNCTION__))
;
5087
5088 mpz_clear__gmpz_clear (size);
5089 mpz_clear__gmpz_clear (end);
5090 }
5091 }
5092 }
5093
5094 if (ar->type == AR_FULL)
5095 {
5096 if (ar->as->rank == 0)
5097 ar->type = AR_ELEMENT;
5098
5099 /* Make sure array is the same as array(:,:), this way
5100 we don't need to special case all the time. */
5101 ar->dimen = ar->as->rank;
5102 for (i = 0; i < ar->dimen; i++)
5103 {
5104 ar->dimen_type[i] = DIMEN_RANGE;
5105
5106 gcc_assert (ar->start[i] == NULL)((void)(!(ar->start[i] == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5106, __FUNCTION__), 0 : 0))
;
5107 gcc_assert (ar->end[i] == NULL)((void)(!(ar->end[i] == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5107, __FUNCTION__), 0 : 0))
;
5108 gcc_assert (ar->stride[i] == NULL)((void)(!(ar->stride[i] == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5108, __FUNCTION__), 0 : 0))
;
5109 }
5110 }
5111
5112 /* If the reference type is unknown, figure out what kind it is. */
5113
5114 if (ar->type == AR_UNKNOWN)
5115 {
5116 ar->type = AR_ELEMENT;
5117 for (i = 0; i < ar->dimen; i++)
5118 if (ar->dimen_type[i] == DIMEN_RANGE
5119 || ar->dimen_type[i] == DIMEN_VECTOR)
5120 {
5121 ar->type = AR_SECTION;
5122 break;
5123 }
5124 }
5125
5126 if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5127 return false;
5128
5129 if (ar->as->corank && ar->codimen == 0)
5130 {
5131 int n;
5132 ar->codimen = ar->as->corank;
5133 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5134 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5135 }
5136
5137 return true;
5138}
5139
5140
5141bool
5142gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
5143{
5144 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5145
5146 if (ref->u.ss.start != NULL__null)
5147 {
5148 if (!gfc_resolve_expr (ref->u.ss.start))
5149 return false;
5150
5151 if (ref->u.ss.start->ts.type != BT_INTEGER)
5152 {
5153 gfc_error ("Substring start index at %L must be of type INTEGER",
5154 &ref->u.ss.start->where);
5155 return false;
5156 }
5157
5158 if (ref->u.ss.start->rank != 0)
5159 {
5160 gfc_error ("Substring start index at %L must be scalar",
5161 &ref->u.ss.start->where);
5162 return false;
5163 }
5164
5165 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5166 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5167 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5168 {
5169 gfc_error ("Substring start index at %L is less than one",
5170 &ref->u.ss.start->where);
5171 return false;
5172 }
5173 }
5174
5175 if (ref->u.ss.end != NULL__null)
5176 {
5177 if (!gfc_resolve_expr (ref->u.ss.end))
5178 return false;
5179
5180 if (ref->u.ss.end->ts.type != BT_INTEGER)
5181 {
5182 gfc_error ("Substring end index at %L must be of type INTEGER",
5183 &ref->u.ss.end->where);
5184 return false;
5185 }
5186
5187 if (ref->u.ss.end->rank != 0)
5188 {
5189 gfc_error ("Substring end index at %L must be scalar",
5190 &ref->u.ss.end->where);
5191 return false;
5192 }
5193
5194 if (ref->u.ss.length != NULL__null
5195 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5196 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5197 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5198 {
5199 gfc_error ("Substring end index at %L exceeds the string length",
5200 &ref->u.ss.start->where);
5201 return false;
5202 }
5203
5204 if (compare_bound_mpz_t (ref->u.ss.end,
5205 gfc_integer_kinds[k].huge) == CMP_GT
5206 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5207 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5208 {
5209 gfc_error ("Substring end index at %L is too large",
5210 &ref->u.ss.end->where);
5211 return false;
5212 }
5213 /* If the substring has the same length as the original
5214 variable, the reference itself can be deleted. */
5215
5216 if (ref->u.ss.length != NULL__null
5217 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5218 && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5219 *equal_length = true;
5220 }
5221
5222 return true;
5223}
5224
5225
5226/* This function supplies missing substring charlens. */
5227
5228void
5229gfc_resolve_substring_charlen (gfc_expr *e)
5230{
5231 gfc_ref *char_ref;
5232 gfc_expr *start, *end;
5233 gfc_typespec *ts = NULL__null;
5234 mpz_t diff;
5235
5236 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
5237 {
5238 if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5239 break;
5240 if (char_ref->type == REF_COMPONENT)
5241 ts = &char_ref->u.c.component->ts;
5242 }
5243
5244 if (!char_ref || char_ref->type == REF_INQUIRY)
5245 return;
5246
5247 gcc_assert (char_ref->next == NULL)((void)(!(char_ref->next == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5247, __FUNCTION__), 0 : 0))
;
5248
5249 if (e->ts.u.cl)
5250 {
5251 if (e->ts.u.cl->length)
5252 gfc_free_expr (e->ts.u.cl->length);
5253 else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
5254 return;
5255 }
5256
5257 if (!e->ts.u.cl)
5258 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
5259
5260 if (char_ref->u.ss.start)
5261 start = gfc_copy_expr (char_ref->u.ss.start);
5262 else
5263 start = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null, 1);
5264
5265 if (char_ref->u.ss.end)
5266 end = gfc_copy_expr (char_ref->u.ss.end);
5267 else if (e->expr_type == EXPR_VARIABLE)
5268 {
5269 if (!ts)
5270 ts = &e->symtree->n.sym->ts;
5271 end = gfc_copy_expr (ts->u.cl->length);
5272 }
5273 else
5274 end = NULL__null;
5275
5276 if (!start || !end)
5277 {
5278 gfc_free_expr (start);
5279 gfc_free_expr (end);
5280 return;
5281 }
5282
5283 /* Length = (end - start + 1).
5284 Check first whether it has a constant length. */
5285 if (gfc_dep_difference (end, start, &diff))
5286 {
5287 gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5288 &e->where);
5289
5290 mpz_add_ui__gmpz_add_ui (len->value.integer, diff, 1);
5291 mpz_clear__gmpz_clear (diff);
5292 e->ts.u.cl->length = len;
5293 /* The check for length < 0 is handled below */
5294 }
5295 else
5296 {
5297 e->ts.u.cl->length = gfc_subtract (end, start);
5298 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5299 gfc_get_int_expr (gfc_charlen_int_kind,
5300 NULL__null, 1));
5301 }
5302
5303 /* F2008, 6.4.1: Both the starting point and the ending point shall
5304 be within the range 1, 2, ..., n unless the starting point exceeds
5305 the ending point, in which case the substring has length zero. */
5306
5307 if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
&& ((static_cast<unsigned long> (0))) == 0 ? (
(e->ts.u.cl->length->value.integer)->_mp_size <
0 ? -1 : (e->ts.u.cl->length->value.integer)->_mp_size
> 0) : __gmpz_cmp_ui (e->ts.u.cl->length->value.
integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si
(e->ts.u.cl->length->value.integer,0))
< 0)
5308 mpz_set_si__gmpz_set_si (e->ts.u.cl->length->value.integer, 0);
5309
5310 e->ts.u.cl->length->ts.type = BT_INTEGER;
5311 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
5312
5313 /* Make sure that the length is simplified. */
5314 gfc_simplify_expr (e->ts.u.cl->length, 1);
5315 gfc_resolve_expr (e->ts.u.cl->length);
5316}
5317
5318
5319/* Resolve subtype references. */
5320
5321bool
5322gfc_resolve_ref (gfc_expr *expr)
5323{
5324 int current_part_dimension, n_components, seen_part_dimension, dim;
5325 gfc_ref *ref, **prev, *array_ref;
5326 bool equal_length;
5327
5328 for (ref = expr->ref; ref; ref = ref->next)
5329 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL__null)
5330 {
5331 find_array_spec (expr);
5332 break;
5333 }
5334
5335 for (prev = &expr->ref; *prev != NULL__null;
5336 prev = *prev == NULL__null ? prev : &(*prev)->next)
5337 switch ((*prev)->type)
5338 {
5339 case REF_ARRAY:
5340 if (!resolve_array_ref (&(*prev)->u.ar))
5341 return false;
5342 break;
5343
5344 case REF_COMPONENT:
5345 case REF_INQUIRY:
5346 break;
5347
5348 case REF_SUBSTRING:
5349 equal_length = false;
5350 if (!gfc_resolve_substring (*prev, &equal_length))
5351 return false;
5352
5353 if (expr->expr_type != EXPR_SUBSTRING && equal_length)
5354 {
5355 /* Remove the reference and move the charlen, if any. */
5356 ref = *prev;
5357 *prev = ref->next;
5358 ref->next = NULL__null;
5359 expr->ts.u.cl = ref->u.ss.length;
5360 ref->u.ss.length = NULL__null;
5361 gfc_free_ref_list (ref);
5362 }
5363 break;
5364 }
5365
5366 /* Check constraints on part references. */
5367
5368 current_part_dimension = 0;
5369 seen_part_dimension = 0;
5370 n_components = 0;
5371 array_ref = NULL__null;
5372
5373 for (ref = expr->ref; ref; ref = ref->next)
5374 {
5375 switch (ref->type)
5376 {
5377 case REF_ARRAY:
5378 array_ref = ref;
5379 switch (ref->u.ar.type)
5380 {
5381 case AR_FULL:
5382 /* Coarray scalar. */
5383 if (ref->u.ar.as->rank == 0)
5384 {
5385 current_part_dimension = 0;
5386 break;
5387 }
5388 /* Fall through. */
5389 case AR_SECTION:
5390 current_part_dimension = 1;
5391 break;
5392
5393 case AR_ELEMENT:
5394 array_ref = NULL__null;
5395 current_part_dimension = 0;
5396 break;
5397
5398 case AR_UNKNOWN:
5399 gfc_internal_error ("resolve_ref(): Bad array reference");
5400 }
5401
5402 break;
5403
5404 case REF_COMPONENT:
5405 if (current_part_dimension || seen_part_dimension)
5406 {
5407 /* F03:C614. */
5408 if (ref->u.c.component->attr.pointer
5409 || ref->u.c.component->attr.proc_pointer
5410 || (ref->u.c.component->ts.type == BT_CLASS
5411 && CLASS_DATA (ref->u.c.component)ref->u.c.component->ts.u.derived->components->attr.pointer))
5412 {
5413 gfc_error ("Component to the right of a part reference "
5414 "with nonzero rank must not have the POINTER "
5415 "attribute at %L", &expr->where);
5416 return false;
5417 }
5418 else if (ref->u.c.component->attr.allocatable
5419 || (ref->u.c.component->ts.type == BT_CLASS
5420 && CLASS_DATA (ref->u.c.component)ref->u.c.component->ts.u.derived->components->attr.allocatable))
5421
5422 {
5423 gfc_error ("Component to the right of a part reference "
5424 "with nonzero rank must not have the ALLOCATABLE "
5425 "attribute at %L", &expr->where);
5426 return false;
5427 }
5428 }
5429
5430 n_components++;
5431 break;
5432
5433 case REF_SUBSTRING:
5434 break;
5435
5436 case REF_INQUIRY:
5437 /* Implement requirement in note 9.7 of F2018 that the result of the
5438 LEN inquiry be a scalar. */
5439 if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred)
5440 {
5441 array_ref->u.ar.type = AR_ELEMENT;
5442 expr->rank = 0;
5443 /* INQUIRY_LEN is not evaluated from the rest of the expr
5444 but directly from the string length. This means that setting
5445 the array indices to one does not matter but might trigger
5446 a runtime bounds error. Suppress the check. */
5447 expr->no_bounds_check = 1;
5448 for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
5449 {
5450 array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
5451 if (array_ref->u.ar.start[dim])
5452 gfc_free_expr (array_ref->u.ar.start[dim]);
5453 array_ref->u.ar.start[dim]
5454 = gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 1);
5455 if (array_ref->u.ar.end[dim])
5456 gfc_free_expr (array_ref->u.ar.end[dim]);
5457 if (array_ref->u.ar.stride[dim])
5458 gfc_free_expr (array_ref->u.ar.stride[dim]);
5459 }
5460 }
5461 break;
5462 }
5463
5464 if (((ref->type == REF_COMPONENT && n_components > 1)
5465 || ref->next == NULL__null)
5466 && current_part_dimension
5467 && seen_part_dimension)
5468 {
5469 gfc_error ("Two or more part references with nonzero rank must "
5470 "not be specified at %L", &expr->where);
5471 return false;
5472 }
5473
5474 if (ref->type == REF_COMPONENT)
5475 {
5476 if (current_part_dimension)
5477 seen_part_dimension = 1;
5478
5479 /* reset to make sure */
5480 current_part_dimension = 0;
5481 }
5482 }
5483
5484 return true;
5485}
5486
5487
5488/* Given an expression, determine its shape. This is easier than it sounds.
5489 Leaves the shape array NULL if it is not possible to determine the shape. */
5490
5491static void
5492expression_shape (gfc_expr *e)
5493{
5494 mpz_t array[GFC_MAX_DIMENSIONS15];
5495 int i;
5496
5497 if (e->rank <= 0 || e->shape != NULL__null)
5498 return;
5499
5500 for (i = 0; i < e->rank; i++)
5501 if (!gfc_array_dimen_size (e, i, &array[i]))
5502 goto fail;
5503
5504 e->shape = gfc_get_shape (e->rank)(((mpz_t *) xcalloc (((e->rank)), sizeof (mpz_t))));
5505
5506 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
5507
5508 return;
5509
5510fail:
5511 for (i--; i >= 0; i--)
5512 mpz_clear__gmpz_clear (array[i]);
5513}
5514
5515
5516/* Given a variable expression node, compute the rank of the expression by
5517 examining the base symbol and any reference structures it may have. */
5518
5519void
5520gfc_expression_rank (gfc_expr *e)
5521{
5522 gfc_ref *ref;
5523 int i, rank;
5524
5525 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5526 could lead to serious confusion... */
5527 gcc_assert (e->expr_type != EXPR_COMPCALL)((void)(!(e->expr_type != EXPR_COMPCALL) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5527, __FUNCTION__), 0 : 0))
;
5528
5529 if (e->ref == NULL__null)
5530 {
5531 if (e->expr_type == EXPR_ARRAY)
5532 goto done;
5533 /* Constructors can have a rank different from one via RESHAPE(). */
5534
5535 e->rank = ((e->symtree == NULL__null || e->symtree->n.sym->as == NULL__null)
5536 ? 0 : e->symtree->n.sym->as->rank);
5537 goto done;
5538 }
5539
5540 rank = 0;
5541
5542 for (ref = e->ref; ref; ref = ref->next)
5543 {
5544 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5545 && ref->u.c.component->attr.function && !ref->next)
5546 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5547
5548 if (ref->type != REF_ARRAY)
5549 continue;
5550
5551 if (ref->u.ar.type == AR_FULL)
5552 {
5553 rank = ref->u.ar.as->rank;
5554 break;
5555 }
5556
5557 if (ref->u.ar.type == AR_SECTION)
5558 {
5559 /* Figure out the rank of the section. */
5560 if (rank != 0)
5561 gfc_internal_error ("gfc_expression_rank(): Two array specs");
5562
5563 for (i = 0; i < ref->u.ar.dimen; i++)
5564 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5565 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5566 rank++;
5567
5568 break;
5569 }
5570 }
5571
5572 e->rank = rank;
5573
5574done:
5575 expression_shape (e);
5576}
5577
5578
5579static void
5580add_caf_get_intrinsic (gfc_expr *e)
5581{
5582 gfc_expr *wrapper, *tmp_expr;
5583 gfc_ref *ref;
5584 int n;
5585
5586 for (ref = e->ref; ref; ref = ref->next)
5587 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5588 break;
5589 if (ref == NULL__null)
5590 return;
5591
5592 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5593 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
5594 return;
5595
5596 tmp_expr = XCNEW (gfc_expr)((gfc_expr *) xcalloc (1, sizeof (gfc_expr)));
5597 *tmp_expr = *e;
5598 wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
5599 "caf_get", tmp_expr->where, 1, tmp_expr);
5600 wrapper->ts = e->ts;
5601 wrapper->rank = e->rank;
5602 if (e->rank)
5603 wrapper->shape = gfc_copy_shape (e->shape, e->rank);
5604 *e = *wrapper;
5605 free (wrapper);
5606}
5607
5608
5609static void
5610remove_caf_get_intrinsic (gfc_expr *e)
5611{
5612 gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym((void)(!(e->expr_type == EXPR_FUNCTION && e->value
.function.isym && e->value.function.isym->id ==
GFC_ISYM_CAF_GET) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5613, __FUNCTION__), 0 : 0))
5613 && e->value.function.isym->id == GFC_ISYM_CAF_GET)((void)(!(e->expr_type == EXPR_FUNCTION && e->value
.function.isym && e->value.function.isym->id ==
GFC_ISYM_CAF_GET) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 5613, __FUNCTION__), 0 : 0))
;
5614 gfc_expr *e2 = e->value.function.actual->expr;
5615 e->value.function.actual->expr = NULL__null;
5616 gfc_free_actual_arglist (e->value.function.actual);
5617 gfc_free_shape (&e->shape, e->rank);
5618 *e = *e2;
5619 free (e2);
5620}
5621
5622
5623/* Resolve a variable expression. */
5624
5625static bool
5626resolve_variable (gfc_expr *e)
5627{
5628 gfc_symbol *sym;
5629 bool t;
5630
5631 t = true;
5632
5633 if (e->symtree == NULL__null)
5634 return false;
5635 sym = e->symtree->n.sym;
5636
5637 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5638 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5639 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
5640 {
5641 if (!actual_arg || inquiry_argument)
5642 {
5643 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5644 "be used as actual argument", sym->name, &e->where);
5645 return false;
5646 }
5647 }
5648 /* TS 29113, 407b. */
5649 else if (e->ts.type == BT_ASSUMED)
5650 {
5651 if (!actual_arg)
5652 {
5653 gfc_error ("Assumed-type variable %s at %L may only be used "
5654 "as actual argument", sym->name, &e->where);
5655 return false;
5656 }
5657 else if (inquiry_argument && !first_actual_arg)
5658 {
5659 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5660 for all inquiry functions in resolve_function; the reason is
5661 that the function-name resolution happens too late in that
5662 function. */
5663 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5664 "an inquiry function shall be the first argument",
5665 sym->name, &e->where);
5666 return false;
5667 }
5668 }
5669 /* TS 29113, C535b. */
5670 else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5671 && sym->ts.u.derived && CLASS_DATA (sym)sym->ts.u.derived->components
5672 && CLASS_DATA (sym)sym->ts.u.derived->components->as
5673 && CLASS_DATA (sym)sym->ts.u.derived->components->as->type == AS_ASSUMED_RANK)
5674 || (sym->ts.type != BT_CLASS && sym->as
5675 && sym->as->type == AS_ASSUMED_RANK))
5676 && !sym->attr.select_rank_temporary)
5677 {
5678 if (!actual_arg
5679 && !(cs_base && cs_base->current
5680 && cs_base->current->op == EXEC_SELECT_RANK))
5681 {
5682 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5683 "actual argument", sym->name, &e->where);
5684 return false;
5685 }
5686 else if (inquiry_argument && !first_actual_arg)
5687 {
5688 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5689 for all inquiry functions in resolve_function; the reason is
5690 that the function-name resolution happens too late in that
5691 function. */
5692 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5693 "to an inquiry function shall be the first argument",
5694 sym->name, &e->where);
5695 return false;
5696 }
5697 }
5698
5699 if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
5700 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5701 && e->ref->next == NULL__null))
5702 {
5703 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5704 "a subobject reference", sym->name, &e->ref->u.ar.where);
5705 return false;
5706 }
5707 /* TS 29113, 407b. */
5708 else if (e->ts.type == BT_ASSUMED && e->ref
5709 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5710 && e->ref->next == NULL__null))
5711 {
5712 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5713 "reference", sym->name, &e->ref->u.ar.where);
5714 return false;
5715 }
5716
5717 /* TS 29113, C535b. */
5718 if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
5719 && sym->ts.u.derived && CLASS_DATA (sym)sym->ts.u.derived->components
5720 && CLASS_DATA (sym)sym->ts.u.derived->components->as
5721 && CLASS_DATA (sym)sym->ts.u.derived->components->as->type == AS_ASSUMED_RANK)
5722 || (sym->ts.type != BT_CLASS && sym->as
5723 && sym->as->type == AS_ASSUMED_RANK))
5724 && e->ref
5725 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5726 && e->ref->next == NULL__null))
5727 {
5728 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5729 "reference", sym->name, &e->ref->u.ar.where);
5730 return false;
5731 }
5732
5733 /* For variables that are used in an associate (target => object) where
5734 the object's basetype is array valued while the target is scalar,
5735 the ts' type of the component refs is still array valued, which
5736 can't be translated that way. */
5737 if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
5738 && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
5739 && CLASS_DATA (sym->assoc->target)sym->assoc->target->ts.u.derived->components->as)
5740 {
5741 gfc_ref *ref = e->ref;
5742 while (ref)
5743 {
5744 switch (ref->type)
5745 {
5746 case REF_COMPONENT:
5747 ref->u.c.sym = sym->ts.u.derived;
5748 /* Stop the loop. */
5749 ref = NULL__null;
5750 break;
5751 default:
5752 ref = ref->next;
5753 break;
5754 }
5755 }
5756 }
5757
5758 /* If this is an associate-name, it may be parsed with an array reference
5759 in error even though the target is scalar. Fail directly in this case.
5760 TODO Understand why class scalar expressions must be excluded. */
5761 if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5762 {
5763 if (sym->ts.type == BT_CLASS)
5764 gfc_fix_class_refs (e);
5765 if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
5766 return false;
5767 else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
5768 {
5769 /* This can happen because the parser did not detect that the
5770 associate name is an array and the expression had no array
5771 part_ref. */
5772 gfc_ref *ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
5773 ref->type = REF_ARRAY;
5774 ref->u.ar.type = AR_FULL;
5775 if (sym->as)
5776 {
5777 ref->u.ar.as = sym->as;
5778 ref->u.ar.dimen = sym->as->rank;
5779 }
5780 ref->next = e->ref;
5781 e->ref = ref;
5782
5783 }
5784 }
5785
5786 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5787 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5788
5789 /* On the other hand, the parser may not have known this is an array;
5790 in this case, we have to add a FULL reference. */
5791 if (sym->assoc && sym->attr.dimension && !e->ref)
5792 {
5793 e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
5794 e->ref->type = REF_ARRAY;
5795 e->ref->u.ar.type = AR_FULL;
5796 e->ref->u.ar.dimen = 0;
5797 }
5798
5799 /* Like above, but for class types, where the checking whether an array
5800 ref is present is more complicated. Furthermore make sure not to add
5801 the full array ref to _vptr or _len refs. */
5802 if (sym->assoc && sym->ts.type == BT_CLASS
5803 && CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
5804 && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
5805 {
5806 gfc_ref *ref, *newref;
5807
5808 newref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
5809 newref->type = REF_ARRAY;
5810 newref->u.ar.type = AR_FULL;
5811 newref->u.ar.dimen = 0;
5812 /* Because this is an associate var and the first ref either is a ref to
5813 the _data component or not, no traversal of the ref chain is
5814 needed. The array ref needs to be inserted after the _data ref,
5815 or when that is not present, which may happend for polymorphic
5816 types, then at the first position. */
5817 ref = e->ref;
5818 if (!ref)
5819 e->ref = newref;
5820 else if (ref->type == REF_COMPONENT
5821 && strcmp ("_data", ref->u.c.component->name) == 0)
5822 {
5823 if (!ref->next || ref->next->type != REF_ARRAY)
5824 {
5825 newref->next = ref->next;
5826 ref->next = newref;
5827 }
5828 else
5829 /* Array ref present already. */
5830 gfc_free_ref_list (newref);
5831 }
5832 else if (ref->type == REF_ARRAY)
5833 /* Array ref present already. */
5834 gfc_free_ref_list (newref);
5835 else
5836 {
5837 newref->next = ref;
5838 e->ref = newref;
5839 }
5840 }
5841
5842 if (e->ref && !gfc_resolve_ref (e))
5843 return false;
5844
5845 if (sym->attr.flavor == FL_PROCEDURE
5846 && (!sym->attr.function
5847 || (sym->attr.function && sym->result
5848 && sym->result->attr.proc_pointer
5849 && !sym->result->attr.function)))
5850 {
5851 e->ts.type = BT_PROCEDURE;
5852 goto resolve_procedure;
5853 }
5854
5855 if (sym->ts.type != BT_UNKNOWN)
5856 gfc_variable_attr (e, &e->ts);
5857 else if (sym->attr.flavor == FL_PROCEDURE
5858 && sym->attr.function && sym->result
5859 && sym->result->ts.type != BT_UNKNOWN
5860 && sym->result->attr.proc_pointer)
5861 e->ts = sym->result->ts;
5862 else
5863 {
5864 /* Must be a simple variable reference. */
5865 if (!gfc_set_default_type (sym, 1, sym->ns))
5866 return false;
5867 e->ts = sym->ts;
5868 }
5869
5870 if (check_assumed_size_reference (sym, e))
5871 return false;
5872
5873 /* Deal with forward references to entries during gfc_resolve_code, to
5874 satisfy, at least partially, 12.5.2.5. */
5875 if (gfc_current_ns->entries
5876 && current_entry_id == sym->entry_id
5877 && cs_base
5878 && cs_base->current
5879 && cs_base->current->op != EXEC_ENTRY)
5880 {
5881 gfc_entry_list *entry;
5882 gfc_formal_arglist *formal;
5883 int n;
5884 bool seen, saved_specification_expr;
5885
5886 /* If the symbol is a dummy... */
5887 if (sym->attr.dummy && sym->ns == gfc_current_ns)
5888 {
5889 entry = gfc_current_ns->entries;
5890 seen = false;
5891
5892 /* ...test if the symbol is a parameter of previous entries. */
5893 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5894 for (formal = entry->sym->formal; formal; formal = formal->next)
5895 {
5896 if (formal->sym && sym->name == formal->sym->name)
5897 {
5898 seen = true;
5899 break;
5900 }
5901 }
5902
5903 /* If it has not been seen as a dummy, this is an error. */
5904 if (!seen)
5905 {
5906 if (specification_expr)
5907 gfc_error ("Variable %qs, used in a specification expression"
5908 ", is referenced at %L before the ENTRY statement "
5909 "in which it is a parameter",
5910 sym->name, &cs_base->current->loc);
5911 else
5912 gfc_error ("Variable %qs is used at %L before the ENTRY "
5913 "statement in which it is a parameter",
5914 sym->name, &cs_base->current->loc);
5915 t = false;
5916 }
5917 }
5918
5919 /* Now do the same check on the specification expressions. */
5920 saved_specification_expr = specification_expr;
5921 specification_expr = true;
5922 if (sym->ts.type == BT_CHARACTER
5923 && !gfc_resolve_expr (sym->ts.u.cl->length))
5924 t = false;
5925
5926 if (sym->as)
5927 for (n = 0; n < sym->as->rank; n++)
5928 {
5929 if (!gfc_resolve_expr (sym->as->lower[n]))
5930 t = false;
5931 if (!gfc_resolve_expr (sym->as->upper[n]))
5932 t = false;
5933 }
5934 specification_expr = saved_specification_expr;
5935
5936 if (t)
5937 /* Update the symbol's entry level. */
5938 sym->entry_id = current_entry_id + 1;
5939 }
5940
5941 /* If a symbol has been host_associated mark it. This is used latter,
5942 to identify if aliasing is possible via host association. */
5943 if (sym->attr.flavor == FL_VARIABLE
5944 && gfc_current_ns->parent
5945 && (gfc_current_ns->parent == sym->ns
5946 || (gfc_current_ns->parent->parent
5947 && gfc_current_ns->parent->parent == sym->ns)))
5948 sym->attr.host_assoc = 1;
5949
5950 if (gfc_current_ns->proc_name
5951 && sym->attr.dimension
5952 && (sym->ns != gfc_current_ns
5953 || sym->attr.use_assoc
5954 || sym->attr.in_common))
5955 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
5956
5957resolve_procedure:
5958 if (t && !resolve_procedure_expression (e))
5959 t = false;
5960
5961 /* F2008, C617 and C1229. */
5962 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5963 && gfc_is_coindexed (e))
5964 {
5965 gfc_ref *ref, *ref2 = NULL__null;
5966
5967 for (ref = e->ref; ref; ref = ref->next)
5968 {
5969 if (ref->type == REF_COMPONENT)
5970 ref2 = ref;
5971 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5972 break;
5973 }
5974
5975 for ( ; ref; ref = ref->next)
5976 if (ref->type == REF_COMPONENT)
5977 break;
5978
5979 /* Expression itself is not coindexed object. */
5980 if (ref && e->ts.type == BT_CLASS)
5981 {
5982 gfc_error ("Polymorphic subobject of coindexed object at %L",
5983 &e->where);
5984 t = false;
5985 }
5986
5987 /* Expression itself is coindexed object. */
5988 if (ref == NULL__null)
5989 {
5990 gfc_component *c;
5991 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
5992 for ( ; c; c = c->next)
5993 if (c->attr.allocatable && c->ts.type == BT_CLASS)
5994 {
5995 gfc_error ("Coindexed object with polymorphic allocatable "
5996 "subcomponent at %L", &e->where);
5997 t = false;
5998 break;
5999 }
6000 }
6001 }
6002
6003 if (t)
6004 gfc_expression_rank (e);
6005
6006 if (t && flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
6007 add_caf_get_intrinsic (e);
6008
6009 if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6010 gfc_warning (OPT_Wdeprecated_declarations,
6011 "Using variable %qs at %L is deprecated",
6012 sym->name, &e->where);
6013 /* Simplify cases where access to a parameter array results in a
6014 single constant. Suppress errors since those will have been
6015 issued before, as warnings. */
6016 if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6017 {
6018 gfc_push_suppress_errors ();
6019 gfc_simplify_expr (e, 1);
6020 gfc_pop_suppress_errors ();
6021 }
6022
6023 return t;
6024}
6025
6026
6027/* Checks to see that the correct symbol has been host associated.
6028 The only situation where this arises is that in which a twice
6029 contained function is parsed after the host association is made.
6030 Therefore, on detecting this, change the symbol in the expression
6031 and convert the array reference into an actual arglist if the old
6032 symbol is a variable. */
6033static bool
6034check_host_association (gfc_expr *e)
6035{
6036 gfc_symbol *sym, *old_sym;
6037 gfc_symtree *st;
6038 int n;
6039 gfc_ref *ref;
6040 gfc_actual_arglist *arg, *tail = NULL__null;
6041 bool retval = e->expr_type == EXPR_FUNCTION;
6042
6043 /* If the expression is the result of substitution in
6044 interface.c(gfc_extend_expr) because there is no way in
6045 which the host association can be wrong. */
6046 if (e->symtree == NULL__null
6047 || e->symtree->n.sym == NULL__null
6048 || e->user_operator)
6049 return retval;
6050
6051 old_sym = e->symtree->n.sym;
6052
6053 if (gfc_current_ns->parent
6054 && old_sym->ns != gfc_current_ns)
6055 {
6056 /* Use the 'USE' name so that renamed module symbols are
6057 correctly handled. */
6058 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
6059
6060 if (sym && old_sym != sym
6061 && sym->ts.type == old_sym->ts.type
6062 && sym->attr.flavor == FL_PROCEDURE
6063 && sym->attr.contained)
6064 {
6065 /* Clear the shape, since it might not be valid. */
6066 gfc_free_shape (&e->shape, e->rank);
6067
6068 /* Give the expression the right symtree! */
6069 gfc_find_sym_tree (e->symtree->name, NULL__null, 1, &st);
6070 gcc_assert (st != NULL)((void)(!(st != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6070, __FUNCTION__), 0 : 0))
;
6071
6072 if (old_sym->attr.flavor == FL_PROCEDURE
6073 || e->expr_type == EXPR_FUNCTION)
6074 {
6075 /* Original was function so point to the new symbol, since
6076 the actual argument list is already attached to the
6077 expression. */
6078 e->value.function.esym = NULL__null;
6079 e->symtree = st;
6080 }
6081 else
6082 {
6083 /* Original was variable so convert array references into
6084 an actual arglist. This does not need any checking now
6085 since resolve_function will take care of it. */
6086 e->value.function.actual = NULL__null;
6087 e->expr_type = EXPR_FUNCTION;
6088 e->symtree = st;
6089
6090 /* Ambiguity will not arise if the array reference is not
6091 the last reference. */
6092 for (ref = e->ref; ref; ref = ref->next)
6093 if (ref->type == REF_ARRAY && ref->next == NULL__null)
6094 break;
6095
6096 if ((ref == NULL__null || ref->type != REF_ARRAY)
6097 && sym->attr.proc == PROC_INTERNAL)
6098 {
6099 gfc_error ("%qs at %L is host associated at %L into "
6100 "a contained procedure with an internal "
6101 "procedure of the same name", sym->name,
6102 &old_sym->declared_at, &e->where);
6103 return false;
6104 }
6105
6106 gcc_assert (ref->type == REF_ARRAY)((void)(!(ref->type == REF_ARRAY) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6106, __FUNCTION__), 0 : 0))
;
6107
6108 /* Grab the start expressions from the array ref and
6109 copy them into actual arguments. */
6110 for (n = 0; n < ref->u.ar.dimen; n++)
6111 {
6112 arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
6113 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
6114 if (e->value.function.actual == NULL__null)
6115 tail = e->value.function.actual = arg;
6116 else
6117 {
6118 tail->next = arg;
6119 tail = arg;
6120 }
6121 }
6122
6123 /* Dump the reference list and set the rank. */
6124 gfc_free_ref_list (e->ref);
6125 e->ref = NULL__null;
6126 e->rank = sym->as ? sym->as->rank : 0;
6127 }
6128
6129 gfc_resolve_expr (e);
6130 sym->refs++;
6131 }
6132 }
6133 /* This might have changed! */
6134 return e->expr_type == EXPR_FUNCTION;
6135}
6136
6137
6138static void
6139gfc_resolve_character_operator (gfc_expr *e)
6140{
6141 gfc_expr *op1 = e->value.op.op1;
6142 gfc_expr *op2 = e->value.op.op2;
6143 gfc_expr *e1 = NULL__null;
6144 gfc_expr *e2 = NULL__null;
6145
6146 gcc_assert (e->value.op.op == INTRINSIC_CONCAT)((void)(!(e->value.op.op == INTRINSIC_CONCAT) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6146, __FUNCTION__), 0 : 0))
;
6147
6148 if (op1->ts.u.cl && op1->ts.u.cl->length)
6149 e1 = gfc_copy_expr (op1->ts.u.cl->length);
6150 else if (op1->expr_type == EXPR_CONSTANT)
6151 e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null,
6152 op1->value.character.length);
6153
6154 if (op2->ts.u.cl && op2->ts.u.cl->length)
6155 e2 = gfc_copy_expr (op2->ts.u.cl->length);
6156 else if (op2->expr_type == EXPR_CONSTANT)
6157 e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null,
6158 op2->value.character.length);
6159
6160 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
6161
6162 if (!e1 || !e2)
6163 {
6164 gfc_free_expr (e1);
6165 gfc_free_expr (e2);
6166
6167 return;
6168 }
6169
6170 e->ts.u.cl->length = gfc_add (e1, e2);
6171 e->ts.u.cl->length->ts.type = BT_INTEGER;
6172 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
6173 gfc_simplify_expr (e->ts.u.cl->length, 0);
6174 gfc_resolve_expr (e->ts.u.cl->length);
6175
6176 return;
6177}
6178
6179
6180/* Ensure that an character expression has a charlen and, if possible, a
6181 length expression. */
6182
6183static void
6184fixup_charlen (gfc_expr *e)
6185{
6186 /* The cases fall through so that changes in expression type and the need
6187 for multiple fixes are picked up. In all circumstances, a charlen should
6188 be available for the middle end to hang a backend_decl on. */
6189 switch (e->expr_type)
6190 {
6191 case EXPR_OP:
6192 gfc_resolve_character_operator (e);
6193 /* FALLTHRU */
6194
6195 case EXPR_ARRAY:
6196 if (e->expr_type == EXPR_ARRAY)
6197 gfc_resolve_character_array_constructor (e);
6198 /* FALLTHRU */
6199
6200 case EXPR_SUBSTRING:
6201 if (!e->ts.u.cl && e->ref)
6202 gfc_resolve_substring_charlen (e);
6203 /* FALLTHRU */
6204
6205 default:
6206 if (!e->ts.u.cl)
6207 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
6208
6209 break;
6210 }
6211}
6212
6213
6214/* Update an actual argument to include the passed-object for type-bound
6215 procedures at the right position. */
6216
6217static gfc_actual_arglist*
6218update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
6219 const char *name)
6220{
6221 gcc_assert (argpos > 0)((void)(!(argpos > 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6221, __FUNCTION__), 0 : 0))
;
6222
6223 if (argpos == 1)
6224 {
6225 gfc_actual_arglist* result;
6226
6227 result = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
6228 result->expr = po;
6229 result->next = lst;
6230 if (name)
6231 result->name = name;
6232
6233 return result;
6234 }
6235
6236 if (lst)
6237 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
6238 else
6239 lst = update_arglist_pass (NULL__null, po, argpos - 1, name);
6240 return lst;
6241}
6242
6243
6244/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6245
6246static gfc_expr*
6247extract_compcall_passed_object (gfc_expr* e)
6248{
6249 gfc_expr* po;
6250
6251 if (e->expr_type == EXPR_UNKNOWN)
6252 {
6253 gfc_error ("Error in typebound call at %L",
6254 &e->where);
6255 return NULL__null;
6256 }
6257
6258 gcc_assert (e->expr_type == EXPR_COMPCALL)((void)(!(e->expr_type == EXPR_COMPCALL) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6258, __FUNCTION__), 0 : 0))
;
6259
6260 if (e->value.compcall.base_object)
6261 po = gfc_copy_expr (e->value.compcall.base_object);
6262 else
6263 {
6264 po = gfc_get_expr ();
6265 po->expr_type = EXPR_VARIABLE;
6266 po->symtree = e->symtree;
6267 po->ref = gfc_copy_ref (e->ref);
6268 po->where = e->where;
6269 }
6270
6271 if (!gfc_resolve_expr (po))
6272 return NULL__null;
6273
6274 return po;
6275}
6276
6277
6278/* Update the arglist of an EXPR_COMPCALL expression to include the
6279 passed-object. */
6280
6281static bool
6282update_compcall_arglist (gfc_expr* e)
6283{
6284 gfc_expr* po;
6285 gfc_typebound_proc* tbp;
6286
6287 tbp = e->value.compcall.tbp;
6288
6289 if (tbp->error)
6290 return false;
6291
6292 po = extract_compcall_passed_object (e);
6293 if (!po)
6294 return false;
6295
6296 if (tbp->nopass || e->value.compcall.ignore_pass)
6297 {
6298 gfc_free_expr (po);
6299 return true;
6300 }
6301
6302 if (tbp->pass_arg_num <= 0)
6303 return false;
6304
6305 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
6306 tbp->pass_arg_num,
6307 tbp->pass_arg);
6308
6309 return true;
6310}
6311
6312
6313/* Extract the passed object from a PPC call (a copy of it). */
6314
6315static gfc_expr*
6316extract_ppc_passed_object (gfc_expr *e)
6317{
6318 gfc_expr *po;
6319 gfc_ref **ref;
6320
6321 po = gfc_get_expr ();
6322 po->expr_type = EXPR_VARIABLE;
6323 po->symtree = e->symtree;
6324 po->ref = gfc_copy_ref (e->ref);
6325 po->where = e->where;
6326
6327 /* Remove PPC reference. */
6328 ref = &po->ref;
6329 while ((*ref)->next)
6330 ref = &(*ref)->next;
6331 gfc_free_ref_list (*ref);
6332 *ref = NULL__null;
6333
6334 if (!gfc_resolve_expr (po))
6335 return NULL__null;
6336
6337 return po;
6338}
6339
6340
6341/* Update the actual arglist of a procedure pointer component to include the
6342 passed-object. */
6343
6344static bool
6345update_ppc_arglist (gfc_expr* e)
6346{
6347 gfc_expr* po;
6348 gfc_component *ppc;
6349 gfc_typebound_proc* tb;
6350
6351 ppc = gfc_get_proc_ptr_comp (e);
6352 if (!ppc)
6353 return false;
6354
6355 tb = ppc->tb;
6356
6357 if (tb->error)
6358 return false;
6359 else if (tb->nopass)
6360 return true;
6361
6362 po = extract_ppc_passed_object (e);
6363 if (!po)
6364 return false;
6365
6366 /* F08:R739. */
6367 if (po->rank != 0)
6368 {
6369 gfc_error ("Passed-object at %L must be scalar", &e->where);
6370 return false;
6371 }
6372
6373 /* F08:C611. */
6374 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
6375 {
6376 gfc_error ("Base object for procedure-pointer component call at %L is of"
6377 " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
6378 return false;
6379 }
6380
6381 gcc_assert (tb->pass_arg_num > 0)((void)(!(tb->pass_arg_num > 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6381, __FUNCTION__), 0 : 0))
;
6382 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
6383 tb->pass_arg_num,
6384 tb->pass_arg);
6385
6386 return true;
6387}
6388
6389
6390/* Check that the object a TBP is called on is valid, i.e. it must not be
6391 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6392
6393static bool
6394check_typebound_baseobject (gfc_expr* e)
6395{
6396 gfc_expr* base;
6397 bool return_value = false;
6398
6399 base = extract_compcall_passed_object (e);
6400 if (!base)
6401 return false;
6402
6403 if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
6404 {
6405 gfc_error ("Error in typebound call at %L", &e->where);
6406 goto cleanup;
6407 }
6408
6409 if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
6410 return false;
6411
6412 /* F08:C611. */
6413 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
6414 {
6415 gfc_error ("Base object for type-bound procedure call at %L is of"
6416 " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
6417 goto cleanup;
6418 }
6419
6420 /* F08:C1230. If the procedure called is NOPASS,
6421 the base object must be scalar. */
6422 if (e->value.compcall.tbp->nopass && base->rank != 0)
6423 {
6424 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6425 " be scalar", &e->where);
6426 goto cleanup;
6427 }
6428
6429 return_value = true;
6430
6431cleanup:
6432 gfc_free_expr (base);
6433 return return_value;
6434}
6435
6436
6437/* Resolve a call to a type-bound procedure, either function or subroutine,
6438 statically from the data in an EXPR_COMPCALL expression. The adapted
6439 arglist and the target-procedure symtree are returned. */
6440
6441static bool
6442resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
6443 gfc_actual_arglist** actual)
6444{
6445 gcc_assert (e->expr_type == EXPR_COMPCALL)((void)(!(e->expr_type == EXPR_COMPCALL) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6445, __FUNCTION__), 0 : 0))
;
6446 gcc_assert (!e->value.compcall.tbp->is_generic)((void)(!(!e->value.compcall.tbp->is_generic) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/resolve.c"
, 6446, __FUNCTION__), 0 : 0))
;
6447
6448 /* Update the actual arglist for PASS. */
6449 if (!update_compcall_arglist (e))
6450 return false;
6451
6452 *actual = e->value.compcall.actual;
6453 *target = e->value.compcall.tbp->u.specific;
6454
6455 gfc_free_ref_list (e->ref);
6456 e->ref = NULL__null;
6457 e->value.compcall.actual = NULL__null;
6458
6459 /* If we find a deferred typebound procedure, check for derived types
6460 that an overriding typebound procedure has not been missed. */
6461 if (e->value.compcall.name
6462 && !e->value.compcall.tbp->non_overridable
6463 && e->value.compcall.base_object
6464 && e->value.compcall.base_object->ts.type == BT_DERIVED)
6465 {
6466 gfc_symtree *st;
6467 gfc_symbol *derived;
6468
6469 /* Use the derived type of the base_object. */
6470 derived = e->value.compcall.base_object->ts.u.derived;
6471 st = NULL__null;
6472
6473 /* If necessary, go through the inheritance chain. */
6474 while (!st && derived)
6475 {
6476 /* Look for the typebound procedure 'name'. */
6477 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
6478 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
6479 e->value.compcall.name);
6480 if (!st)
6481 derived = gfc_get_derived_super_type (derived);
6482 }
6483
6484 /* Now find the specific name in the derived type namespace. */
6485 if (st && st->n.tb && st->n.tb->u.specific)
6486 gfc_find_sym_tree (st->n.tb->u.specific->name,
6487 derived->ns, 1, &st);
6488 if (st)
6489 *target = st;
6490 }
6491 return true;
6492}
6493
6494
6495/* Get the ultimate declared type from an expression. In addition,
6496 return the last class/derived type reference and the copy of the
6497 reference list. If check_types is set true, derived types are
6498 identified as well as class references. */
6499static gfc_symbol*
6500get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
6501 gfc_expr *e, bool check_types)
6502{
6503 gfc_symbol *declared;
6504 gfc_ref *ref;
6505
6506 declared = NULL__null;
6507 if (class_ref)
6508 *class_ref = NULL__null;
6509 if (new_ref)
6510 *new_ref = gfc_copy_ref (e->ref);
6511
6512 for (ref = e->ref; ref; ref = ref->next)
6513 {
6514 if (ref->type != REF_COMPONENT)
6515 continue;
6516
6517 if ((ref->u.c.component->ts.type == BT_CLASS
6518 || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)((ref->u.c.component->ts.type) == BT_DERIVED || (ref->
u.c.component->ts.type) == BT_UNION)
))
6519 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
6520 {
6521 declared = ref->u.c.component->ts.u.derived;
6522 if (class_ref)
6523 *class_ref = ref;
6524 }
6525 }
6526
6527 if (declared == NULL__null)
6528 declared = e->symtree->n.sym->ts.u.derived;
6529
6530 return declared;
6531}
6532
6533
6534/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6535 which of the specific bindings (if any) matches the arglist and transform
6536 the expression into a call of that binding. */
6537
6538static bool
6539resolve_typebound_generic_call (gfc_expr* e, const