Bug Summary

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