Bug Summary

File:build/gcc/fortran/expr.c
Warning:line 2712, column 4
Forming reference to null pointer

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 expr.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-4toAtd.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c
1/* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-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 "gfortran.h"
26#include "arith.h"
27#include "match.h"
28#include "target-memory.h" /* for gfc_convert_boz */
29#include "constructor.h"
30#include "tree.h"
31
32
33/* The following set of functions provide access to gfc_expr* of
34 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35
36 There are two functions available elsewhere that provide
37 slightly different flavours of variables. Namely:
38 expr.c (gfc_get_variable_expr)
39 symbol.c (gfc_lval_expr_from_sym)
40 TODO: Merge these functions, if possible. */
41
42/* Get a new expression node. */
43
44gfc_expr *
45gfc_get_expr (void)
46{
47 gfc_expr *e;
48
49 e = XCNEW (gfc_expr)((gfc_expr *) xcalloc (1, sizeof (gfc_expr)));
50 gfc_clear_ts (&e->ts);
51 e->shape = NULL__null;
52 e->ref = NULL__null;
53 e->symtree = NULL__null;
54 return e;
55}
56
57
58/* Get a new expression node that is an array constructor
59 of given type and kind. */
60
61gfc_expr *
62gfc_get_array_expr (bt type, int kind, locus *where)
63{
64 gfc_expr *e;
65
66 e = gfc_get_expr ();
67 e->expr_type = EXPR_ARRAY;
68 e->value.constructor = NULL__null;
69 e->rank = 1;
70 e->shape = NULL__null;
71
72 e->ts.type = type;
73 e->ts.kind = kind;
74 if (where)
75 e->where = *where;
76
77 return e;
78}
79
80
81/* Get a new expression node that is the NULL expression. */
82
83gfc_expr *
84gfc_get_null_expr (locus *where)
85{
86 gfc_expr *e;
87
88 e = gfc_get_expr ();
89 e->expr_type = EXPR_NULL;
90 e->ts.type = BT_UNKNOWN;
91
92 if (where)
93 e->where = *where;
94
95 return e;
96}
97
98
99/* Get a new expression node that is an operator expression node. */
100
101gfc_expr *
102gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
103 gfc_expr *op1, gfc_expr *op2)
104{
105 gfc_expr *e;
106
107 e = gfc_get_expr ();
108 e->expr_type = EXPR_OP;
109 e->value.op.op = op;
110 e->value.op.op1 = op1;
111 e->value.op.op2 = op2;
112
113 if (where)
114 e->where = *where;
115
116 return e;
117}
118
119
120/* Get a new expression node that is an structure constructor
121 of given type and kind. */
122
123gfc_expr *
124gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
125{
126 gfc_expr *e;
127
128 e = gfc_get_expr ();
129 e->expr_type = EXPR_STRUCTURE;
130 e->value.constructor = NULL__null;
131
132 e->ts.type = type;
133 e->ts.kind = kind;
134 if (where)
135 e->where = *where;
136
137 return e;
138}
139
140
141/* Get a new expression node that is an constant of given type and kind. */
142
143gfc_expr *
144gfc_get_constant_expr (bt type, int kind, locus *where)
145{
146 gfc_expr *e;
147
148 if (!where)
149 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
150 "NULL");
151
152 e = gfc_get_expr ();
153
154 e->expr_type = EXPR_CONSTANT;
155 e->ts.type = type;
156 e->ts.kind = kind;
157 e->where = *where;
158
159 switch (type)
160 {
161 case BT_INTEGER:
162 mpz_init__gmpz_init (e->value.integer);
163 break;
164
165 case BT_REAL:
166 gfc_set_model_kind (kind);
167 mpfr_init (e->value.real);
168 break;
169
170 case BT_COMPLEX:
171 gfc_set_model_kind (kind);
172 mpc_init2 (e->value.complex, mpfr_get_default_prec());
173 break;
174
175 default:
176 break;
177 }
178
179 return e;
180}
181
182
183/* Get a new expression node that is an string constant.
184 If no string is passed, a string of len is allocated,
185 blanked and null-terminated. */
186
187gfc_expr *
188gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len)
189{
190 gfc_expr *e;
191 gfc_char_t *dest;
192
193 if (!src)
194 {
195 dest = gfc_get_wide_string (len + 1)((gfc_char_t *) xcalloc ((len + 1), sizeof (gfc_char_t)));
196 gfc_wide_memset (dest, ' ', len);
197 dest[len] = '\0';
198 }
199 else
200 dest = gfc_char_to_widechar (src);
201
202 e = gfc_get_constant_expr (BT_CHARACTER, kind,
203 where ? where : &gfc_current_locus);
204 e->value.character.string = dest;
205 e->value.character.length = len;
206
207 return e;
208}
209
210
211/* Get a new expression node that is an integer constant. */
212
213gfc_expr *
214gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INTlong value)
215{
216 gfc_expr *p;
217 p = gfc_get_constant_expr (BT_INTEGER, kind,
218 where ? where : &gfc_current_locus);
219
220 const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT(8));
221 wi::to_mpz (w, p->value.integer, SIGNED);
222
223 return p;
224}
225
226
227/* Get a new expression node that is a logical constant. */
228
229gfc_expr *
230gfc_get_logical_expr (int kind, locus *where, bool value)
231{
232 gfc_expr *p;
233 p = gfc_get_constant_expr (BT_LOGICAL, kind,
234 where ? where : &gfc_current_locus);
235
236 p->value.logical = value;
237
238 return p;
239}
240
241
242gfc_expr *
243gfc_get_iokind_expr (locus *where, io_kind k)
244{
245 gfc_expr *e;
246
247 /* Set the types to something compatible with iokind. This is needed to
248 get through gfc_free_expr later since iokind really has no Basic Type,
249 BT, of its own. */
250
251 e = gfc_get_expr ();
252 e->expr_type = EXPR_CONSTANT;
253 e->ts.type = BT_LOGICAL;
254 e->value.iokind = k;
255 e->where = *where;
256
257 return e;
258}
259
260
261/* Given an expression pointer, return a copy of the expression. This
262 subroutine is recursive. */
263
264gfc_expr *
265gfc_copy_expr (gfc_expr *p)
266{
267 gfc_expr *q;
268 gfc_char_t *s;
269 char *c;
270
271 if (p == NULL__null)
272 return NULL__null;
273
274 q = gfc_get_expr ();
275 *q = *p;
276
277 switch (q->expr_type)
278 {
279 case EXPR_SUBSTRING:
280 s = gfc_get_wide_string (p->value.character.length + 1)((gfc_char_t *) xcalloc ((p->value.character.length + 1), sizeof
(gfc_char_t)))
;
281 q->value.character.string = s;
282 memcpy (s, p->value.character.string,
283 (p->value.character.length + 1) * sizeof (gfc_char_t));
284 break;
285
286 case EXPR_CONSTANT:
287 /* Copy target representation, if it exists. */
288 if (p->representation.string)
289 {
290 c = XCNEWVEC (char, p->representation.length + 1)((char *) xcalloc ((p->representation.length + 1), sizeof (
char)))
;
291 q->representation.string = c;
292 memcpy (c, p->representation.string, (p->representation.length + 1));
293 }
294
295 /* Copy the values of any pointer components of p->value. */
296 switch (q->ts.type)
297 {
298 case BT_INTEGER:
299 mpz_init_set__gmpz_init_set (q->value.integer, p->value.integer);
300 break;
301
302 case BT_REAL:
303 gfc_set_model_kind (q->ts.kind);
304 mpfr_init (q->value.real);
305 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE)mpfr_set4(q->value.real,p->value.real,MPFR_RNDN,((p->
value.real)->_mpfr_sign))
;
306 break;
307
308 case BT_COMPLEX:
309 gfc_set_model_kind (q->ts.kind);
310 mpc_init2 (q->value.complex, mpfr_get_default_prec());
311 mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
312 break;
313
314 case BT_CHARACTER:
315 if (p->representation.string)
316 q->value.character.string
317 = gfc_char_to_widechar (q->representation.string);
318 else
319 {
320 s = gfc_get_wide_string (p->value.character.length + 1)((gfc_char_t *) xcalloc ((p->value.character.length + 1), sizeof
(gfc_char_t)))
;
321 q->value.character.string = s;
322
323 /* This is the case for the C_NULL_CHAR named constant. */
324 if (p->value.character.length == 0
325 && (p->ts.is_c_interop || p->ts.is_iso_c))
326 {
327 *s = '\0';
328 /* Need to set the length to 1 to make sure the NUL
329 terminator is copied. */
330 q->value.character.length = 1;
331 }
332 else
333 memcpy (s, p->value.character.string,
334 (p->value.character.length + 1) * sizeof (gfc_char_t));
335 }
336 break;
337
338 case BT_HOLLERITH:
339 case BT_LOGICAL:
340 case_bt_structcase BT_DERIVED: case BT_UNION:
341 case BT_CLASS:
342 case BT_ASSUMED:
343 break; /* Already done. */
344
345 case BT_BOZ:
346 q->boz.len = p->boz.len;
347 q->boz.rdx = p->boz.rdx;
348 q->boz.str = XCNEWVEC (char, q->boz.len + 1)((char *) xcalloc ((q->boz.len + 1), sizeof (char)));
349 strncpy (q->boz.str, p->boz.str, p->boz.len);
350 break;
351
352 case BT_PROCEDURE:
353 case BT_VOID:
354 /* Should never be reached. */
355 case BT_UNKNOWN:
356 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
357 /* Not reached. */
358 }
359
360 break;
361
362 case EXPR_OP:
363 switch (q->value.op.op)
364 {
365 case INTRINSIC_NOT:
366 case INTRINSIC_PARENTHESES:
367 case INTRINSIC_UPLUS:
368 case INTRINSIC_UMINUS:
369 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
370 break;
371
372 default: /* Binary operators. */
373 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
374 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
375 break;
376 }
377
378 break;
379
380 case EXPR_FUNCTION:
381 q->value.function.actual =
382 gfc_copy_actual_arglist (p->value.function.actual);
383 break;
384
385 case EXPR_COMPCALL:
386 case EXPR_PPC:
387 q->value.compcall.actual =
388 gfc_copy_actual_arglist (p->value.compcall.actual);
389 q->value.compcall.tbp = p->value.compcall.tbp;
390 break;
391
392 case EXPR_STRUCTURE:
393 case EXPR_ARRAY:
394 q->value.constructor = gfc_constructor_copy (p->value.constructor);
395 break;
396
397 case EXPR_VARIABLE:
398 case EXPR_NULL:
399 break;
400
401 case EXPR_UNKNOWN:
402 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 402, __FUNCTION__))
;
403 }
404
405 q->shape = gfc_copy_shape (p->shape, p->rank);
406
407 q->ref = gfc_copy_ref (p->ref);
408
409 if (p->param_list)
410 q->param_list = gfc_copy_actual_arglist (p->param_list);
411
412 return q;
413}
414
415
416void
417gfc_clear_shape (mpz_t *shape, int rank)
418{
419 int i;
420
421 for (i = 0; i < rank; i++)
422 mpz_clear__gmpz_clear (shape[i]);
423}
424
425
426void
427gfc_free_shape (mpz_t **shape, int rank)
428{
429 if (*shape == NULL__null)
430 return;
431
432 gfc_clear_shape (*shape, rank);
433 free (*shape);
434 *shape = NULL__null;
435}
436
437
438/* Workhorse function for gfc_free_expr() that frees everything
439 beneath an expression node, but not the node itself. This is
440 useful when we want to simplify a node and replace it with
441 something else or the expression node belongs to another structure. */
442
443static void
444free_expr0 (gfc_expr *e)
445{
446 switch (e->expr_type)
447 {
448 case EXPR_CONSTANT:
449 /* Free any parts of the value that need freeing. */
450 switch (e->ts.type)
451 {
452 case BT_INTEGER:
453 mpz_clear__gmpz_clear (e->value.integer);
454 break;
455
456 case BT_REAL:
457 mpfr_clear (e->value.real);
458 break;
459
460 case BT_CHARACTER:
461 free (e->value.character.string);
462 break;
463
464 case BT_COMPLEX:
465 mpc_clear (e->value.complex);
466 break;
467
468 default:
469 break;
470 }
471
472 /* Free the representation. */
473 free (e->representation.string);
474
475 break;
476
477 case EXPR_OP:
478 if (e->value.op.op1 != NULL__null)
479 gfc_free_expr (e->value.op.op1);
480 if (e->value.op.op2 != NULL__null)
481 gfc_free_expr (e->value.op.op2);
482 break;
483
484 case EXPR_FUNCTION:
485 gfc_free_actual_arglist (e->value.function.actual);
486 break;
487
488 case EXPR_COMPCALL:
489 case EXPR_PPC:
490 gfc_free_actual_arglist (e->value.compcall.actual);
491 break;
492
493 case EXPR_VARIABLE:
494 break;
495
496 case EXPR_ARRAY:
497 case EXPR_STRUCTURE:
498 gfc_constructor_free (e->value.constructor);
499 break;
500
501 case EXPR_SUBSTRING:
502 free (e->value.character.string);
503 break;
504
505 case EXPR_NULL:
506 break;
507
508 default:
509 gfc_internal_error ("free_expr0(): Bad expr type");
510 }
511
512 /* Free a shape array. */
513 gfc_free_shape (&e->shape, e->rank);
514
515 gfc_free_ref_list (e->ref);
516
517 gfc_free_actual_arglist (e->param_list);
518
519 memset (e, '\0', sizeof (gfc_expr));
520}
521
522
523/* Free an expression node and everything beneath it. */
524
525void
526gfc_free_expr (gfc_expr *e)
527{
528 if (e == NULL__null)
529 return;
530 free_expr0 (e);
531 free (e);
532}
533
534
535/* Free an argument list and everything below it. */
536
537void
538gfc_free_actual_arglist (gfc_actual_arglist *a1)
539{
540 gfc_actual_arglist *a2;
541
542 while (a1)
543 {
544 a2 = a1->next;
545 if (a1->expr)
546 gfc_free_expr (a1->expr);
547 free (a1);
548 a1 = a2;
549 }
550}
551
552
553/* Copy an arglist structure and all of the arguments. */
554
555gfc_actual_arglist *
556gfc_copy_actual_arglist (gfc_actual_arglist *p)
557{
558 gfc_actual_arglist *head, *tail, *new_arg;
559
560 head = tail = NULL__null;
561
562 for (; p; p = p->next)
563 {
564 new_arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
565 *new_arg = *p;
566
567 new_arg->expr = gfc_copy_expr (p->expr);
568 new_arg->next = NULL__null;
569
570 if (head == NULL__null)
571 head = new_arg;
572 else
573 tail->next = new_arg;
574
575 tail = new_arg;
576 }
577
578 return head;
579}
580
581
582/* Free a list of reference structures. */
583
584void
585gfc_free_ref_list (gfc_ref *p)
586{
587 gfc_ref *q;
588 int i;
589
590 for (; p; p = q)
591 {
592 q = p->next;
593
594 switch (p->type)
595 {
596 case REF_ARRAY:
597 for (i = 0; i < GFC_MAX_DIMENSIONS15; i++)
598 {
599 gfc_free_expr (p->u.ar.start[i]);
600 gfc_free_expr (p->u.ar.end[i]);
601 gfc_free_expr (p->u.ar.stride[i]);
602 }
603
604 break;
605
606 case REF_SUBSTRING:
607 gfc_free_expr (p->u.ss.start);
608 gfc_free_expr (p->u.ss.end);
609 break;
610
611 case REF_COMPONENT:
612 case REF_INQUIRY:
613 break;
614 }
615
616 free (p);
617 }
618}
619
620
621/* Graft the *src expression onto the *dest subexpression. */
622
623void
624gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
625{
626 free_expr0 (dest);
627 *dest = *src;
628 free (src);
629}
630
631
632/* Try to extract an integer constant from the passed expression node.
633 Return true if some error occurred, false on success. If REPORT_ERROR
634 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
635 for negative using gfc_error_now. */
636
637bool
638gfc_extract_int (gfc_expr *expr, int *result, int report_error)
639{
640 gfc_ref *ref;
641
642 /* A KIND component is a parameter too. The expression for it
643 is stored in the initializer and should be consistent with
644 the tests below. */
645 if (gfc_expr_attr(expr).pdt_kind)
646 {
647 for (ref = expr->ref; ref; ref = ref->next)
648 {
649 if (ref->u.c.component->attr.pdt_kind)
650 expr = ref->u.c.component->initializer;
651 }
652 }
653
654 if (expr->expr_type != EXPR_CONSTANT)
655 {
656 if (report_error > 0)
657 gfc_error ("Constant expression required at %C");
658 else if (report_error < 0)
659 gfc_error_now ("Constant expression required at %C");
660 return true;
661 }
662
663 if (expr->ts.type != BT_INTEGER)
664 {
665 if (report_error > 0)
666 gfc_error ("Integer expression required at %C");
667 else if (report_error < 0)
668 gfc_error_now ("Integer expression required at %C");
669 return true;
670 }
671
672 if ((mpz_cmp_si (expr->value.integer, INT_MAX)(__builtin_constant_p ((2147483647) >= 0) && (2147483647
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (2147483647))) && ((static_cast<unsigned long
> (2147483647))) == 0 ? ((expr->value.integer)->_mp_size
< 0 ? -1 : (expr->value.integer)->_mp_size > 0) :
__gmpz_cmp_ui (expr->value.integer,(static_cast<unsigned
long> (2147483647)))) : __gmpz_cmp_si (expr->value.integer
,2147483647))
> 0)
673 || (mpz_cmp_si (expr->value.integer, INT_MIN)(__builtin_constant_p (((-2147483647 -1)) >= 0) &&
((-2147483647 -1)) >= 0 ? (__builtin_constant_p ((static_cast
<unsigned long> ((-2147483647 -1)))) && ((static_cast
<unsigned long> ((-2147483647 -1)))) == 0 ? ((expr->
value.integer)->_mp_size < 0 ? -1 : (expr->value.integer
)->_mp_size > 0) : __gmpz_cmp_ui (expr->value.integer
,(static_cast<unsigned long> ((-2147483647 -1))))) : __gmpz_cmp_si
(expr->value.integer,(-2147483647 -1)))
< 0))
674 {
675 if (report_error > 0)
676 gfc_error ("Integer value too large in expression at %C");
677 else if (report_error < 0)
678 gfc_error_now ("Integer value too large in expression at %C");
679 return true;
680 }
681
682 *result = (int) mpz_get_si__gmpz_get_si (expr->value.integer);
683
684 return false;
685}
686
687
688/* Same as gfc_extract_int, but use a HWI. */
689
690bool
691gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INTlong *result, int report_error)
692{
693 gfc_ref *ref;
694
695 /* A KIND component is a parameter too. The expression for it is
696 stored in the initializer and should be consistent with the tests
697 below. */
698 if (gfc_expr_attr(expr).pdt_kind)
699 {
700 for (ref = expr->ref; ref; ref = ref->next)
701 {
702 if (ref->u.c.component->attr.pdt_kind)
703 expr = ref->u.c.component->initializer;
704 }
705 }
706
707 if (expr->expr_type != EXPR_CONSTANT)
708 {
709 if (report_error > 0)
710 gfc_error ("Constant expression required at %C");
711 else if (report_error < 0)
712 gfc_error_now ("Constant expression required at %C");
713 return true;
714 }
715
716 if (expr->ts.type != BT_INTEGER)
717 {
718 if (report_error > 0)
719 gfc_error ("Integer expression required at %C");
720 else if (report_error < 0)
721 gfc_error_now ("Integer expression required at %C");
722 return true;
723 }
724
725 /* Use long_long_integer_type_node to determine when to saturate. */
726 const wide_int val = wi::from_mpz (long_long_integer_type_nodeinteger_types[itk_long_long],
727 expr->value.integer, false);
728
729 if (!wi::fits_shwi_p (val))
730 {
731 if (report_error > 0)
732 gfc_error ("Integer value too large in expression at %C");
733 else if (report_error < 0)
734 gfc_error_now ("Integer value too large in expression at %C");
735 return true;
736 }
737
738 *result = val.to_shwi ();
739
740 return false;
741}
742
743
744/* Recursively copy a list of reference structures. */
745
746gfc_ref *
747gfc_copy_ref (gfc_ref *src)
748{
749 gfc_array_ref *ar;
750 gfc_ref *dest;
751
752 if (src == NULL__null)
753 return NULL__null;
754
755 dest = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
756 dest->type = src->type;
757
758 switch (src->type)
759 {
760 case REF_ARRAY:
761 ar = gfc_copy_array_ref (&src->u.ar);
762 dest->u.ar = *ar;
763 free (ar);
764 break;
765
766 case REF_COMPONENT:
767 dest->u.c = src->u.c;
768 break;
769
770 case REF_INQUIRY:
771 dest->u.i = src->u.i;
772 break;
773
774 case REF_SUBSTRING:
775 dest->u.ss = src->u.ss;
776 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
777 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
778 break;
779 }
780
781 dest->next = gfc_copy_ref (src->next);
782
783 return dest;
784}
785
786
787/* Detect whether an expression has any vector index array references. */
788
789int
790gfc_has_vector_index (gfc_expr *e)
791{
792 gfc_ref *ref;
793 int i;
794 for (ref = e->ref; ref; ref = ref->next)
795 if (ref->type == REF_ARRAY)
796 for (i = 0; i < ref->u.ar.dimen; i++)
797 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
798 return 1;
799 return 0;
800}
801
802
803/* Copy a shape array. */
804
805mpz_t *
806gfc_copy_shape (mpz_t *shape, int rank)
807{
808 mpz_t *new_shape;
809 int n;
810
811 if (shape == NULL__null)
812 return NULL__null;
813
814 new_shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
815
816 for (n = 0; n < rank; n++)
817 mpz_init_set__gmpz_init_set (new_shape[n], shape[n]);
818
819 return new_shape;
820}
821
822
823/* Copy a shape array excluding dimension N, where N is an integer
824 constant expression. Dimensions are numbered in Fortran style --
825 starting with ONE.
826
827 So, if the original shape array contains R elements
828 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
829 the result contains R-1 elements:
830 { s1 ... sN-1 sN+1 ... sR-1}
831
832 If anything goes wrong -- N is not a constant, its value is out
833 of range -- or anything else, just returns NULL. */
834
835mpz_t *
836gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
837{
838 mpz_t *new_shape, *s;
839 int i, n;
840
841 if (shape == NULL__null
842 || rank <= 1
843 || dim == NULL__null
844 || dim->expr_type != EXPR_CONSTANT
845 || dim->ts.type != BT_INTEGER)
846 return NULL__null;
847
848 n = mpz_get_si__gmpz_get_si (dim->value.integer);
849 n--; /* Convert to zero based index. */
850 if (n < 0 || n >= rank)
851 return NULL__null;
852
853 s = new_shape = gfc_get_shape (rank - 1)(((mpz_t *) xcalloc (((rank - 1)), sizeof (mpz_t))));
854
855 for (i = 0; i < rank; i++)
856 {
857 if (i == n)
858 continue;
859 mpz_init_set__gmpz_init_set (*s, shape[i]);
860 s++;
861 }
862
863 return new_shape;
864}
865
866
867/* Return the maximum kind of two expressions. In general, higher
868 kind numbers mean more precision for numeric types. */
869
870int
871gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
872{
873 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
874}
875
876
877/* Returns nonzero if the type is numeric, zero otherwise. */
878
879static int
880numeric_type (bt type)
881{
882 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
883}
884
885
886/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
887
888int
889gfc_numeric_ts (gfc_typespec *ts)
890{
891 return numeric_type (ts->type);
892}
893
894
895/* Return an expression node with an optional argument list attached.
896 A variable number of gfc_expr pointers are strung together in an
897 argument list with a NULL pointer terminating the list. */
898
899gfc_expr *
900gfc_build_conversion (gfc_expr *e)
901{
902 gfc_expr *p;
903
904 p = gfc_get_expr ();
905 p->expr_type = EXPR_FUNCTION;
906 p->symtree = NULL__null;
907 p->value.function.actual = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
908 p->value.function.actual->expr = e;
909
910 return p;
911}
912
913
914/* Given an expression node with some sort of numeric binary
915 expression, insert type conversions required to make the operands
916 have the same type. Conversion warnings are disabled if wconversion
917 is set to 0.
918
919 The exception is that the operands of an exponential don't have to
920 have the same type. If possible, the base is promoted to the type
921 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
922 1.0**2 stays as it is. */
923
924void
925gfc_type_convert_binary (gfc_expr *e, int wconversion)
926{
927 gfc_expr *op1, *op2;
928
929 op1 = e->value.op.op1;
930 op2 = e->value.op.op2;
931
932 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
933 {
934 gfc_clear_ts (&e->ts);
935 return;
936 }
937
938 /* Kind conversions of same type. */
939 if (op1->ts.type == op2->ts.type)
940 {
941 if (op1->ts.kind == op2->ts.kind)
942 {
943 /* No type conversions. */
944 e->ts = op1->ts;
945 goto done;
946 }
947
948 if (op1->ts.kind > op2->ts.kind)
949 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
950 else
951 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
952
953 e->ts = op1->ts;
954 goto done;
955 }
956
957 /* Integer combined with real or complex. */
958 if (op2->ts.type == BT_INTEGER)
959 {
960 e->ts = op1->ts;
961
962 /* Special case for ** operator. */
963 if (e->value.op.op == INTRINSIC_POWER)
964 goto done;
965
966 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
967 goto done;
968 }
969
970 if (op1->ts.type == BT_INTEGER)
971 {
972 e->ts = op2->ts;
973 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
974 goto done;
975 }
976
977 /* Real combined with complex. */
978 e->ts.type = BT_COMPLEX;
979 if (op1->ts.kind > op2->ts.kind)
980 e->ts.kind = op1->ts.kind;
981 else
982 e->ts.kind = op2->ts.kind;
983 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
984 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
985 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
986 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
987
988done:
989 return;
990}
991
992
993/* Determine if an expression is constant in the sense of F08:7.1.12.
994 * This function expects that the expression has already been simplified. */
995
996bool
997gfc_is_constant_expr (gfc_expr *e)
998{
999 gfc_constructor *c;
1000 gfc_actual_arglist *arg;
1001
1002 if (e == NULL__null)
1003 return true;
1004
1005 switch (e->expr_type)
1006 {
1007 case EXPR_OP:
1008 return (gfc_is_constant_expr (e->value.op.op1)
1009 && (e->value.op.op2 == NULL__null
1010 || gfc_is_constant_expr (e->value.op.op2)));
1011
1012 case EXPR_VARIABLE:
1013 /* The only context in which this can occur is in a parameterized
1014 derived type declaration, so returning true is OK. */
1015 if (e->symtree->n.sym->attr.pdt_len
1016 || e->symtree->n.sym->attr.pdt_kind)
1017 return true;
1018 return false;
1019
1020 case EXPR_FUNCTION:
1021 case EXPR_PPC:
1022 case EXPR_COMPCALL:
1023 gcc_assert (e->symtree || e->value.function.esym((void)(!(e->symtree || e->value.function.esym || e->
value.function.isym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1024, __FUNCTION__), 0 : 0))
1024 || e->value.function.isym)((void)(!(e->symtree || e->value.function.esym || e->
value.function.isym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1024, __FUNCTION__), 0 : 0))
;
1025
1026 /* Call to intrinsic with at least one argument. */
1027 if (e->value.function.isym && e->value.function.actual)
1028 {
1029 for (arg = e->value.function.actual; arg; arg = arg->next)
1030 if (!gfc_is_constant_expr (arg->expr))
1031 return false;
1032 }
1033
1034 if (e->value.function.isym
1035 && (e->value.function.isym->elemental
1036 || e->value.function.isym->pure
1037 || e->value.function.isym->inquiry
1038 || e->value.function.isym->transformational))
1039 return true;
1040
1041 return false;
1042
1043 case EXPR_CONSTANT:
1044 case EXPR_NULL:
1045 return true;
1046
1047 case EXPR_SUBSTRING:
1048 return e->ref == NULL__null || (gfc_is_constant_expr (e->ref->u.ss.start)
1049 && gfc_is_constant_expr (e->ref->u.ss.end));
1050
1051 case EXPR_ARRAY:
1052 case EXPR_STRUCTURE:
1053 c = gfc_constructor_first (e->value.constructor);
1054 if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
1055 return gfc_constant_ac (e);
1056
1057 for (; c; c = gfc_constructor_next (c))
1058 if (!gfc_is_constant_expr (c->expr))
1059 return false;
1060
1061 return true;
1062
1063
1064 default:
1065 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1066 return false;
1067 }
1068}
1069
1070
1071/* Is true if the expression or symbol is a passed CFI descriptor. */
1072bool
1073is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
1074{
1075 if (sym == NULL__null
1076 && e && e->expr_type == EXPR_VARIABLE)
1077 sym = e->symtree->n.sym;
1078
1079 if (sym && sym->attr.dummy
1080 && sym->ns->proc_name->attr.is_bind_c
1081 && sym->attr.dimension
1082 && (sym->attr.pointer
1083 || sym->attr.allocatable
1084 || sym->as->type == AS_ASSUMED_SHAPE
1085 || sym->as->type == AS_ASSUMED_RANK))
1086 return true;
1087
1088return false;
1089}
1090
1091
1092/* Is true if an array reference is followed by a component or substring
1093 reference. */
1094bool
1095is_subref_array (gfc_expr * e)
1096{
1097 gfc_ref * ref;
1098 bool seen_array;
1099 gfc_symbol *sym;
1100
1101 if (e->expr_type != EXPR_VARIABLE)
1102 return false;
1103
1104 sym = e->symtree->n.sym;
1105
1106 if (sym->attr.subref_array_pointer)
1107 return true;
1108
1109 seen_array = false;
1110
1111 for (ref = e->ref; ref; ref = ref->next)
1112 {
1113 /* If we haven't seen the array reference and this is an intrinsic,
1114 what follows cannot be a subreference array, unless there is a
1115 substring reference. */
1116 if (!seen_array && ref->type == REF_COMPONENT
1117 && ref->u.c.component->ts.type != BT_CHARACTER
1118 && ref->u.c.component->ts.type != BT_CLASS
1119 && !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)
)
1120 return false;
1121
1122 if (ref->type == REF_ARRAY
1123 && ref->u.ar.type != AR_ELEMENT)
1124 seen_array = true;
1125
1126 if (seen_array
1127 && ref->type != REF_ARRAY)
1128 return seen_array;
1129 }
1130
1131 if (sym->ts.type == BT_CLASS
1132 && sym->attr.dummy
1133 && CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
1134 && CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer)
1135 return true;
1136
1137 return false;
1138}
1139
1140
1141/* Try to collapse intrinsic expressions. */
1142
1143static bool
1144simplify_intrinsic_op (gfc_expr *p, int type)
1145{
1146 gfc_intrinsic_op op;
1147 gfc_expr *op1, *op2, *result;
1148
1149 if (p->value.op.op == INTRINSIC_USER)
1150 return true;
1151
1152 op1 = p->value.op.op1;
1153 op2 = p->value.op.op2;
1154 op = p->value.op.op;
1155
1156 if (!gfc_simplify_expr (op1, type))
1157 return false;
1158 if (!gfc_simplify_expr (op2, type))
1159 return false;
1160
1161 if (!gfc_is_constant_expr (op1)
1162 || (op2 != NULL__null && !gfc_is_constant_expr (op2)))
1163 return true;
1164
1165 /* Rip p apart. */
1166 p->value.op.op1 = NULL__null;
1167 p->value.op.op2 = NULL__null;
1168
1169 switch (op)
1170 {
1171 case INTRINSIC_PARENTHESES:
1172 result = gfc_parentheses (op1);
1173 break;
1174
1175 case INTRINSIC_UPLUS:
1176 result = gfc_uplus (op1);
1177 break;
1178
1179 case INTRINSIC_UMINUS:
1180 result = gfc_uminus (op1);
1181 break;
1182
1183 case INTRINSIC_PLUS:
1184 result = gfc_add (op1, op2);
1185 break;
1186
1187 case INTRINSIC_MINUS:
1188 result = gfc_subtract (op1, op2);
1189 break;
1190
1191 case INTRINSIC_TIMES:
1192 result = gfc_multiply (op1, op2);
1193 break;
1194
1195 case INTRINSIC_DIVIDE:
1196 result = gfc_divide (op1, op2);
1197 break;
1198
1199 case INTRINSIC_POWER:
1200 result = gfc_power (op1, op2);
1201 break;
1202
1203 case INTRINSIC_CONCAT:
1204 result = gfc_concat (op1, op2);
1205 break;
1206
1207 case INTRINSIC_EQ:
1208 case INTRINSIC_EQ_OS:
1209 result = gfc_eq (op1, op2, op);
1210 break;
1211
1212 case INTRINSIC_NE:
1213 case INTRINSIC_NE_OS:
1214 result = gfc_ne (op1, op2, op);
1215 break;
1216
1217 case INTRINSIC_GT:
1218 case INTRINSIC_GT_OS:
1219 result = gfc_gt (op1, op2, op);
1220 break;
1221
1222 case INTRINSIC_GE:
1223 case INTRINSIC_GE_OS:
1224 result = gfc_ge (op1, op2, op);
1225 break;
1226
1227 case INTRINSIC_LT:
1228 case INTRINSIC_LT_OS:
1229 result = gfc_lt (op1, op2, op);
1230 break;
1231
1232 case INTRINSIC_LE:
1233 case INTRINSIC_LE_OS:
1234 result = gfc_le (op1, op2, op);
1235 break;
1236
1237 case INTRINSIC_NOT:
1238 result = gfc_not (op1);
1239 break;
1240
1241 case INTRINSIC_AND:
1242 result = gfc_and (op1, op2);
1243 break;
1244
1245 case INTRINSIC_OR:
1246 result = gfc_or (op1, op2);
1247 break;
1248
1249 case INTRINSIC_EQV:
1250 result = gfc_eqv (op1, op2);
1251 break;
1252
1253 case INTRINSIC_NEQV:
1254 result = gfc_neqv (op1, op2);
1255 break;
1256
1257 default:
1258 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1259 }
1260
1261 if (result == NULL__null)
1262 {
1263 gfc_free_expr (op1);
1264 gfc_free_expr (op2);
1265 return false;
1266 }
1267
1268 result->rank = p->rank;
1269 result->where = p->where;
1270 gfc_replace_expr (p, result);
1271
1272 return true;
1273}
1274
1275
1276/* Subroutine to simplify constructor expressions. Mutually recursive
1277 with gfc_simplify_expr(). */
1278
1279static bool
1280simplify_constructor (gfc_constructor_base base, int type)
1281{
1282 gfc_constructor *c;
1283 gfc_expr *p;
1284
1285 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1286 {
1287 if (c->iterator
1288 && (!gfc_simplify_expr(c->iterator->start, type)
1289 || !gfc_simplify_expr (c->iterator->end, type)
1290 || !gfc_simplify_expr (c->iterator->step, type)))
1291 return false;
1292
1293 if (c->expr)
1294 {
1295 /* Try and simplify a copy. Replace the original if successful
1296 but keep going through the constructor at all costs. Not
1297 doing so can make a dog's dinner of complicated things. */
1298 p = gfc_copy_expr (c->expr);
1299
1300 if (!gfc_simplify_expr (p, type))
1301 {
1302 gfc_free_expr (p);
1303 continue;
1304 }
1305
1306 gfc_replace_expr (c->expr, p);
1307 }
1308 }
1309
1310 return true;
1311}
1312
1313
1314/* Pull a single array element out of an array constructor. */
1315
1316static bool
1317find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1318 gfc_constructor **rval)
1319{
1320 unsigned long nelemen;
1321 int i;
1322 mpz_t delta;
1323 mpz_t offset;
1324 mpz_t span;
1325 mpz_t tmp;
1326 gfc_constructor *cons;
1327 gfc_expr *e;
1328 bool t;
1329
1330 t = true;
1331 e = NULL__null;
1332
1333 mpz_init_set_ui__gmpz_init_set_ui (offset, 0);
1334 mpz_init__gmpz_init (delta);
1335 mpz_init__gmpz_init (tmp);
1336 mpz_init_set_ui__gmpz_init_set_ui (span, 1);
1337 for (i = 0; i < ar->dimen; i++)
1338 {
1339 if (!gfc_reduce_init_expr (ar->as->lower[i])
1340 || !gfc_reduce_init_expr (ar->as->upper[i]))
1341 {
1342 t = false;
1343 cons = NULL__null;
1344 goto depart;
1345 }
1346
1347 e = ar->start[i];
1348 if (e->expr_type != EXPR_CONSTANT)
1349 {
1350 cons = NULL__null;
1351 goto depart;
1352 }
1353
1354 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT((void)(!(ar->as->upper[i]->expr_type == EXPR_CONSTANT
&& ar->as->lower[i]->expr_type == EXPR_CONSTANT
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1355, __FUNCTION__), 0 : 0))
1355 && ar->as->lower[i]->expr_type == EXPR_CONSTANT)((void)(!(ar->as->upper[i]->expr_type == EXPR_CONSTANT
&& ar->as->lower[i]->expr_type == EXPR_CONSTANT
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1355, __FUNCTION__), 0 : 0))
;
1356
1357 /* Check the bounds. */
1358 if ((ar->as->upper[i]
1359 && mpz_cmp__gmpz_cmp (e->value.integer,
1360 ar->as->upper[i]->value.integer) > 0)
1361 || (mpz_cmp__gmpz_cmp (e->value.integer,
1362 ar->as->lower[i]->value.integer) < 0))
1363 {
1364 gfc_error ("Index in dimension %d is out of bounds "
1365 "at %L", i + 1, &ar->c_where[i]);
1366 cons = NULL__null;
1367 t = false;
1368 goto depart;
1369 }
1370
1371 mpz_sub__gmpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1372 mpz_mul__gmpz_mul (delta, delta, span);
1373 mpz_add__gmpz_add (offset, offset, delta);
1374
1375 mpz_set_ui__gmpz_set_ui (tmp, 1);
1376 mpz_add__gmpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1377 mpz_sub__gmpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1378 mpz_mul__gmpz_mul (span, span, tmp);
1379 }
1380
1381 for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui__gmpz_get_ui (offset);
1382 cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1383 {
1384 if (cons->iterator)
1385 {
1386 cons = NULL__null;
1387 goto depart;
1388 }
1389 }
1390
1391depart:
1392 mpz_clear__gmpz_clear (delta);
1393 mpz_clear__gmpz_clear (offset);
1394 mpz_clear__gmpz_clear (span);
1395 mpz_clear__gmpz_clear (tmp);
1396 *rval = cons;
1397 return t;
1398}
1399
1400
1401/* Find a component of a structure constructor. */
1402
1403static gfc_constructor *
1404find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1405{
1406 gfc_component *pick = ref->u.c.component;
1407 gfc_constructor *c = gfc_constructor_first (base);
1408
1409 gfc_symbol *dt = ref->u.c.sym;
1410 int ext = dt->attr.extension;
1411
1412 /* For extended types, check if the desired component is in one of the
1413 * parent types. */
1414 while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
1415 pick->name, true, true, NULL__null))
1416 {
1417 dt = dt->components->ts.u.derived;
1418 c = gfc_constructor_first (c->expr->value.constructor);
1419 ext--;
1420 }
1421
1422 gfc_component *comp = dt->components;
1423 while (comp != pick)
1424 {
1425 comp = comp->next;
1426 c = gfc_constructor_next (c);
1427 }
1428
1429 return c;
1430}
1431
1432
1433/* Replace an expression with the contents of a constructor, removing
1434 the subobject reference in the process. */
1435
1436static void
1437remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1438{
1439 gfc_expr *e;
1440
1441 if (cons)
1442 {
1443 e = cons->expr;
1444 cons->expr = NULL__null;
1445 }
1446 else
1447 e = gfc_copy_expr (p);
1448 e->ref = p->ref->next;
1449 p->ref->next = NULL__null;
1450 gfc_replace_expr (p, e);
1451}
1452
1453
1454/* Pull an array section out of an array constructor. */
1455
1456static bool
1457find_array_section (gfc_expr *expr, gfc_ref *ref)
1458{
1459 int idx;
1460 int rank;
1461 int d;
1462 int shape_i;
1463 int limit;
1464 long unsigned one = 1;
1465 bool incr_ctr;
1466 mpz_t start[GFC_MAX_DIMENSIONS15];
1467 mpz_t end[GFC_MAX_DIMENSIONS15];
1468 mpz_t stride[GFC_MAX_DIMENSIONS15];
1469 mpz_t delta[GFC_MAX_DIMENSIONS15];
1470 mpz_t ctr[GFC_MAX_DIMENSIONS15];
1471 mpz_t delta_mpz;
1472 mpz_t tmp_mpz;
1473 mpz_t nelts;
1474 mpz_t ptr;
1475 gfc_constructor_base base;
1476 gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS15];
1477 gfc_expr *begin;
1478 gfc_expr *finish;
1479 gfc_expr *step;
1480 gfc_expr *upper;
1481 gfc_expr *lower;
1482 bool t;
1483
1484 t = true;
1485
1486 base = expr->value.constructor;
1487 expr->value.constructor = NULL__null;
1488
1489 rank = ref->u.ar.as->rank;
1490
1491 if (expr->shape == NULL__null)
1492 expr->shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
1493
1494 mpz_init_set_ui__gmpz_init_set_ui (delta_mpz, one);
1495 mpz_init_set_ui__gmpz_init_set_ui (nelts, one);
1496 mpz_init__gmpz_init (tmp_mpz);
1497
1498 /* Do the initialization now, so that we can cleanup without
1499 keeping track of where we were. */
1500 for (d = 0; d < rank; d++)
1501 {
1502 mpz_init__gmpz_init (delta[d]);
1503 mpz_init__gmpz_init (start[d]);
1504 mpz_init__gmpz_init (end[d]);
1505 mpz_init__gmpz_init (ctr[d]);
1506 mpz_init__gmpz_init (stride[d]);
1507 vecsub[d] = NULL__null;
1508 }
1509
1510 /* Build the counters to clock through the array reference. */
1511 shape_i = 0;
1512 for (d = 0; d < rank; d++)
1513 {
1514 /* Make this stretch of code easier on the eye! */
1515 begin = ref->u.ar.start[d];
1516 finish = ref->u.ar.end[d];
1517 step = ref->u.ar.stride[d];
1518 lower = ref->u.ar.as->lower[d];
1519 upper = ref->u.ar.as->upper[d];
1520
1521 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1522 {
1523 gfc_constructor *ci;
1524 gcc_assert (begin)((void)(!(begin) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1524, __FUNCTION__), 0 : 0))
;
1525
1526 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1527 {
1528 t = false;
1529 goto cleanup;
1530 }
1531
1532 gcc_assert (begin->rank == 1)((void)(!(begin->rank == 1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1532, __FUNCTION__), 0 : 0))
;
1533 /* Zero-sized arrays have no shape and no elements, stop early. */
1534 if (!begin->shape)
1535 {
1536 mpz_init_set_ui__gmpz_init_set_ui (nelts, 0);
1537 break;
1538 }
1539
1540 vecsub[d] = gfc_constructor_first (begin->value.constructor);
1541 mpz_set__gmpz_set (ctr[d], vecsub[d]->expr->value.integer);
1542 mpz_mul__gmpz_mul (nelts, nelts, begin->shape[0]);
1543 mpz_set__gmpz_set (expr->shape[shape_i++], begin->shape[0]);
1544
1545 /* Check bounds. */
1546 for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1547 {
1548 if (mpz_cmp__gmpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1549 || mpz_cmp__gmpz_cmp (ci->expr->value.integer,
1550 lower->value.integer) < 0)
1551 {
1552 gfc_error ("index in dimension %d is out of bounds "
1553 "at %L", d + 1, &ref->u.ar.c_where[d]);
1554 t = false;
1555 goto cleanup;
1556 }
1557 }
1558 }
1559 else
1560 {
1561 if ((begin && begin->expr_type != EXPR_CONSTANT)
1562 || (finish && finish->expr_type != EXPR_CONSTANT)
1563 || (step && step->expr_type != EXPR_CONSTANT))
1564 {
1565 t = false;
1566 goto cleanup;
1567 }
1568
1569 /* Obtain the stride. */
1570 if (step)
1571 mpz_set__gmpz_set (stride[d], step->value.integer);
1572 else
1573 mpz_set_ui__gmpz_set_ui (stride[d], one);
1574
1575 if (mpz_cmp_ui (stride[d], 0)(__builtin_constant_p (0) && (0) == 0 ? ((stride[d])->
_mp_size < 0 ? -1 : (stride[d])->_mp_size > 0) : __gmpz_cmp_ui
(stride[d],0))
== 0)
1576 mpz_set_ui__gmpz_set_ui (stride[d], one);
1577
1578 /* Obtain the start value for the index. */
1579 if (begin)
1580 mpz_set__gmpz_set (start[d], begin->value.integer);
1581 else
1582 mpz_set__gmpz_set (start[d], lower->value.integer);
1583
1584 mpz_set__gmpz_set (ctr[d], start[d]);
1585
1586 /* Obtain the end value for the index. */
1587 if (finish)
1588 mpz_set__gmpz_set (end[d], finish->value.integer);
1589 else
1590 mpz_set__gmpz_set (end[d], upper->value.integer);
1591
1592 /* Separate 'if' because elements sometimes arrive with
1593 non-null end. */
1594 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1595 mpz_set__gmpz_set (end [d], begin->value.integer);
1596
1597 /* Check the bounds. */
1598 if (mpz_cmp__gmpz_cmp (ctr[d], upper->value.integer) > 0
1599 || mpz_cmp__gmpz_cmp (end[d], upper->value.integer) > 0
1600 || mpz_cmp__gmpz_cmp (ctr[d], lower->value.integer) < 0
1601 || mpz_cmp__gmpz_cmp (end[d], lower->value.integer) < 0)
1602 {
1603 gfc_error ("index in dimension %d is out of bounds "
1604 "at %L", d + 1, &ref->u.ar.c_where[d]);
1605 t = false;
1606 goto cleanup;
1607 }
1608
1609 /* Calculate the number of elements and the shape. */
1610 mpz_set__gmpz_set (tmp_mpz, stride[d]);
1611 mpz_add__gmpz_add (tmp_mpz, end[d], tmp_mpz);
1612 mpz_sub__gmpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1613 mpz_div__gmpz_fdiv_q (tmp_mpz, tmp_mpz, stride[d]);
1614 mpz_mul__gmpz_mul (nelts, nelts, tmp_mpz);
1615
1616 /* An element reference reduces the rank of the expression; don't
1617 add anything to the shape array. */
1618 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1619 mpz_set__gmpz_set (expr->shape[shape_i++], tmp_mpz);
1620 }
1621
1622 /* Calculate the 'stride' (=delta) for conversion of the
1623 counter values into the index along the constructor. */
1624 mpz_set__gmpz_set (delta[d], delta_mpz);
1625 mpz_sub__gmpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1626 mpz_add_ui__gmpz_add_ui (tmp_mpz, tmp_mpz, one);
1627 mpz_mul__gmpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1628 }
1629
1630 mpz_init__gmpz_init (ptr);
1631 cons = gfc_constructor_first (base);
1632
1633 /* Now clock through the array reference, calculating the index in
1634 the source constructor and transferring the elements to the new
1635 constructor. */
1636 for (idx = 0; idx < (int) mpz_get_si__gmpz_get_si (nelts); idx++)
1637 {
1638 mpz_init_set_ui__gmpz_init_set_ui (ptr, 0);
1639
1640 incr_ctr = true;
1641 for (d = 0; d < rank; d++)
1642 {
1643 mpz_set__gmpz_set (tmp_mpz, ctr[d]);
1644 mpz_sub__gmpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1645 mpz_mul__gmpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1646 mpz_add__gmpz_add (ptr, ptr, tmp_mpz);
1647
1648 if (!incr_ctr) continue;
1649
1650 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1651 {
1652 gcc_assert(vecsub[d])((void)(!(vecsub[d]) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1652, __FUNCTION__), 0 : 0))
;
1653
1654 if (!gfc_constructor_next (vecsub[d]))
1655 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1656 else
1657 {
1658 vecsub[d] = gfc_constructor_next (vecsub[d]);
1659 incr_ctr = false;
1660 }
1661 mpz_set__gmpz_set (ctr[d], vecsub[d]->expr->value.integer);
1662 }
1663 else
1664 {
1665 mpz_add__gmpz_add (ctr[d], ctr[d], stride[d]);
1666
1667 if (mpz_cmp_ui (stride[d], 0)(__builtin_constant_p (0) && (0) == 0 ? ((stride[d])->
_mp_size < 0 ? -1 : (stride[d])->_mp_size > 0) : __gmpz_cmp_ui
(stride[d],0))
> 0
1668 ? mpz_cmp__gmpz_cmp (ctr[d], end[d]) > 0
1669 : mpz_cmp__gmpz_cmp (ctr[d], end[d]) < 0)
1670 mpz_set__gmpz_set (ctr[d], start[d]);
1671 else
1672 incr_ctr = false;
1673 }
1674 }
1675
1676 limit = mpz_get_ui__gmpz_get_ui (ptr);
1677 if (limit >= flag_max_array_constructorglobal_options.x_flag_max_array_constructor)
1678 {
1679 gfc_error ("The number of elements in the array constructor "
1680 "at %L requires an increase of the allowed %d "
1681 "upper limit. See %<-fmax-array-constructor%> "
1682 "option", &expr->where, flag_max_array_constructorglobal_options.x_flag_max_array_constructor);
1683 return false;
1684 }
1685
1686 cons = gfc_constructor_lookup (base, limit);
1687 gcc_assert (cons)((void)(!(cons) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1687, __FUNCTION__), 0 : 0))
;
1688 gfc_constructor_append_expr (&expr->value.constructor,
1689 gfc_copy_expr (cons->expr), NULL__null);
1690 }
1691
1692 mpz_clear__gmpz_clear (ptr);
1693
1694cleanup:
1695
1696 mpz_clear__gmpz_clear (delta_mpz);
1697 mpz_clear__gmpz_clear (tmp_mpz);
1698 mpz_clear__gmpz_clear (nelts);
1699 for (d = 0; d < rank; d++)
1700 {
1701 mpz_clear__gmpz_clear (delta[d]);
1702 mpz_clear__gmpz_clear (start[d]);
1703 mpz_clear__gmpz_clear (end[d]);
1704 mpz_clear__gmpz_clear (ctr[d]);
1705 mpz_clear__gmpz_clear (stride[d]);
1706 }
1707 gfc_constructor_free (base);
1708 return t;
1709}
1710
1711/* Pull a substring out of an expression. */
1712
1713static bool
1714find_substring_ref (gfc_expr *p, gfc_expr **newp)
1715{
1716 gfc_charlen_t end;
1717 gfc_charlen_t start;
1718 gfc_charlen_t length;
1719 gfc_char_t *chr;
1720
1721 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1722 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1723 return false;
1724
1725 *newp = gfc_copy_expr (p);
1726 free ((*newp)->value.character.string);
1727
1728 end = (gfc_charlen_t) mpz_get_ui__gmpz_get_ui (p->ref->u.ss.end->value.integer);
1729 start = (gfc_charlen_t) mpz_get_ui__gmpz_get_ui (p->ref->u.ss.start->value.integer);
1730 if (end >= start)
1731 length = end - start + 1;
1732 else
1733 length = 0;
1734
1735 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1)((gfc_char_t *) xcalloc ((length + 1), sizeof (gfc_char_t)));
1736 (*newp)->value.character.length = length;
1737 memcpy (chr, &p->value.character.string[start - 1],
1738 length * sizeof (gfc_char_t));
1739 chr[length] = '\0';
1740 return true;
1741}
1742
1743
1744/* Pull an inquiry result out of an expression. */
1745
1746static bool
1747find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
1748{
1749 gfc_ref *ref;
1750 gfc_ref *inquiry = NULL__null;
1751 gfc_expr *tmp;
1752
1753 tmp = gfc_copy_expr (p);
1754
1755 if (tmp->ref && tmp->ref->type == REF_INQUIRY)
1756 {
1757 inquiry = tmp->ref;
1758 tmp->ref = NULL__null;
1759 }
1760 else
1761 {
1762 for (ref = tmp->ref; ref; ref = ref->next)
1763 if (ref->next && ref->next->type == REF_INQUIRY)
1764 {
1765 inquiry = ref->next;
1766 ref->next = NULL__null;
1767 }
1768 }
1769
1770 if (!inquiry)
1771 {
1772 gfc_free_expr (tmp);
1773 return false;
1774 }
1775
1776 gfc_resolve_expr (tmp);
1777
1778 /* In principle there can be more than one inquiry reference. */
1779 for (; inquiry; inquiry = inquiry->next)
1780 {
1781 switch (inquiry->u.i)
1782 {
1783 case INQUIRY_LEN:
1784 if (tmp->ts.type != BT_CHARACTER)
1785 goto cleanup;
1786
1787 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "LEN part_ref at %C"))
1788 goto cleanup;
1789
1790 if (tmp->ts.u.cl->length
1791 && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1792 *newp = gfc_copy_expr (tmp->ts.u.cl->length);
1793 else if (tmp->expr_type == EXPR_CONSTANT)
1794 *newp = gfc_get_int_expr (gfc_default_integer_kind,
1795 NULL__null, tmp->value.character.length);
1796 else
1797 goto cleanup;
1798
1799 break;
1800
1801 case INQUIRY_KIND:
1802 if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS)
1803 goto cleanup;
1804
1805 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "KIND part_ref at %C"))
1806 goto cleanup;
1807
1808 *newp = gfc_get_int_expr (gfc_default_integer_kind,
1809 NULL__null, tmp->ts.kind);
1810 break;
1811
1812 case INQUIRY_RE:
1813 if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
1814 goto cleanup;
1815
1816 if (!gfc_notify_std (GFC_STD_F2008(1<<7), "RE part_ref at %C"))
1817 goto cleanup;
1818
1819 *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
1820 mpfr_set ((*newp)->value.real,mpfr_set4((*newp)->value.real,((tmp->value.complex)->
re),MPFR_RNDN,((((tmp->value.complex)->re))->_mpfr_sign
))
1821 mpc_realref (tmp->value.complex), GFC_RND_MODE)mpfr_set4((*newp)->value.real,((tmp->value.complex)->
re),MPFR_RNDN,((((tmp->value.complex)->re))->_mpfr_sign
))
;
1822 break;
1823
1824 case INQUIRY_IM:
1825 if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
1826 goto cleanup;
1827
1828 if (!gfc_notify_std (GFC_STD_F2008(1<<7), "IM part_ref at %C"))
1829 goto cleanup;
1830
1831 *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
1832 mpfr_set ((*newp)->value.real,mpfr_set4((*newp)->value.real,((tmp->value.complex)->
im),MPFR_RNDN,((((tmp->value.complex)->im))->_mpfr_sign
))
1833 mpc_imagref (tmp->value.complex), GFC_RND_MODE)mpfr_set4((*newp)->value.real,((tmp->value.complex)->
im),MPFR_RNDN,((((tmp->value.complex)->im))->_mpfr_sign
))
;
1834 break;
1835 }
1836 tmp = gfc_copy_expr (*newp);
1837 }
1838
1839 if (!(*newp))
1840 goto cleanup;
1841 else if ((*newp)->expr_type != EXPR_CONSTANT)
1842 {
1843 gfc_free_expr (*newp);
1844 goto cleanup;
1845 }
1846
1847 gfc_free_expr (tmp);
1848 return true;
1849
1850cleanup:
1851 gfc_free_expr (tmp);
1852 return false;
1853}
1854
1855
1856
1857/* Simplify a subobject reference of a constructor. This occurs when
1858 parameter variable values are substituted. */
1859
1860static bool
1861simplify_const_ref (gfc_expr *p)
1862{
1863 gfc_constructor *cons, *c;
1864 gfc_expr *newp = NULL__null;
1865 gfc_ref *last_ref;
1866
1867 while (p->ref)
1868 {
1869 switch (p->ref->type)
1870 {
1871 case REF_ARRAY:
1872 switch (p->ref->u.ar.type)
1873 {
1874 case AR_ELEMENT:
1875 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1876 will generate this. */
1877 if (p->expr_type != EXPR_ARRAY)
1878 {
1879 remove_subobject_ref (p, NULL__null);
1880 break;
1881 }
1882 if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
1883 return false;
1884
1885 if (!cons)
1886 return true;
1887
1888 remove_subobject_ref (p, cons);
1889 break;
1890
1891 case AR_SECTION:
1892 if (!find_array_section (p, p->ref))
1893 return false;
1894 p->ref->u.ar.type = AR_FULL;
1895
1896 /* Fall through. */
1897
1898 case AR_FULL:
1899 if (p->ref->next != NULL__null
1900 && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type)((p->ts.type) == BT_DERIVED || (p->ts.type) == BT_UNION
)
))
1901 {
1902 for (c = gfc_constructor_first (p->value.constructor);
1903 c; c = gfc_constructor_next (c))
1904 {
1905 c->expr->ref = gfc_copy_ref (p->ref->next);
1906 if (!simplify_const_ref (c->expr))
1907 return false;
1908 }
1909
1910 if (gfc_bt_struct (p->ts.type)((p->ts.type) == BT_DERIVED || (p->ts.type) == BT_UNION
)
1911 && p->ref->next
1912 && (c = gfc_constructor_first (p->value.constructor)))
1913 {
1914 /* There may have been component references. */
1915 p->ts = c->expr->ts;
1916 }
1917
1918 last_ref = p->ref;
1919 for (; last_ref->next; last_ref = last_ref->next) {};
1920
1921 if (p->ts.type == BT_CHARACTER
1922 && last_ref->type == REF_SUBSTRING)
1923 {
1924 /* If this is a CHARACTER array and we possibly took
1925 a substring out of it, update the type-spec's
1926 character length according to the first element
1927 (as all should have the same length). */
1928 gfc_charlen_t string_len;
1929 if ((c = gfc_constructor_first (p->value.constructor)))
1930 {
1931 const gfc_expr* first = c->expr;
1932 gcc_assert (first->expr_type == EXPR_CONSTANT)((void)(!(first->expr_type == EXPR_CONSTANT) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1932, __FUNCTION__), 0 : 0))
;
1933 gcc_assert (first->ts.type == BT_CHARACTER)((void)(!(first->ts.type == BT_CHARACTER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 1933, __FUNCTION__), 0 : 0))
;
1934 string_len = first->value.character.length;
1935 }
1936 else
1937 string_len = 0;
1938
1939 if (!p->ts.u.cl)
1940 {
1941 if (p->symtree)
1942 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1943 NULL__null);
1944 else
1945 p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
1946 NULL__null);
1947 }
1948 else
1949 gfc_free_expr (p->ts.u.cl->length);
1950
1951 p->ts.u.cl->length
1952 = gfc_get_int_expr (gfc_charlen_int_kind,
1953 NULL__null, string_len);
1954 }
1955 }
1956 gfc_free_ref_list (p->ref);
1957 p->ref = NULL__null;
1958 break;
1959
1960 default:
1961 return true;
1962 }
1963
1964 break;
1965
1966 case REF_COMPONENT:
1967 cons = find_component_ref (p->value.constructor, p->ref);
1968 remove_subobject_ref (p, cons);
1969 break;
1970
1971 case REF_INQUIRY:
1972 if (!find_inquiry_ref (p, &newp))
1973 return false;
1974
1975 gfc_replace_expr (p, newp);
1976 gfc_free_ref_list (p->ref);
1977 p->ref = NULL__null;
1978 break;
1979
1980 case REF_SUBSTRING:
1981 if (!find_substring_ref (p, &newp))
1982 return false;
1983
1984 gfc_replace_expr (p, newp);
1985 gfc_free_ref_list (p->ref);
1986 p->ref = NULL__null;
1987 break;
1988 }
1989 }
1990
1991 return true;
1992}
1993
1994
1995/* Simplify a chain of references. */
1996
1997static bool
1998simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
1999{
2000 int n;
2001 gfc_expr *newp;
2002
2003 for (; ref; ref = ref->next)
2004 {
2005 switch (ref->type)
2006 {
2007 case REF_ARRAY:
2008 for (n = 0; n < ref->u.ar.dimen; n++)
2009 {
2010 if (!gfc_simplify_expr (ref->u.ar.start[n], type))
2011 return false;
2012 if (!gfc_simplify_expr (ref->u.ar.end[n], type))
2013 return false;
2014 if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
2015 return false;
2016 }
2017 break;
2018
2019 case REF_SUBSTRING:
2020 if (!gfc_simplify_expr (ref->u.ss.start, type))
2021 return false;
2022 if (!gfc_simplify_expr (ref->u.ss.end, type))
2023 return false;
2024 break;
2025
2026 case REF_INQUIRY:
2027 if (!find_inquiry_ref (*p, &newp))
2028 return false;
2029
2030 gfc_replace_expr (*p, newp);
2031 gfc_free_ref_list ((*p)->ref);
2032 (*p)->ref = NULL__null;
2033 return true;
2034
2035 default:
2036 break;
2037 }
2038 }
2039 return true;
2040}
2041
2042
2043/* Try to substitute the value of a parameter variable. */
2044
2045static bool
2046simplify_parameter_variable (gfc_expr *p, int type)
2047{
2048 gfc_expr *e;
2049 bool t;
2050
2051 /* Set rank and check array ref; as resolve_variable calls
2052 gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
2053 if (!gfc_resolve_ref (p))
2054 {
2055 gfc_error_check ();
2056 return false;
2057 }
2058 gfc_expression_rank (p);
2059
2060 /* Is this an inquiry? */
2061 bool inquiry = false;
2062 gfc_ref* ref = p->ref;
2063 while (ref)
2064 {
2065 if (ref->type == REF_INQUIRY)
2066 break;
2067 ref = ref->next;
2068 }
2069 if (ref && ref->type == REF_INQUIRY)
2070 inquiry = ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND;
2071
2072 if (gfc_is_size_zero_array (p))
2073 {
2074 if (p->expr_type == EXPR_ARRAY)
2075 return true;
2076
2077 e = gfc_get_expr ();
2078 e->expr_type = EXPR_ARRAY;
2079 e->ts = p->ts;
2080 e->rank = p->rank;
2081 e->value.constructor = NULL__null;
2082 e->shape = gfc_copy_shape (p->shape, p->rank);
2083 e->where = p->where;
2084 /* If %kind and %len are not used then we're done, otherwise
2085 drop through for simplification. */
2086 if (!inquiry)
2087 {
2088 gfc_replace_expr (p, e);
2089 return true;
2090 }
2091 }
2092 else
2093 {
2094 e = gfc_copy_expr (p->symtree->n.sym->value);
2095 if (e == NULL__null)
2096 return false;
2097
2098 e->rank = p->rank;
2099
2100 if (e->ts.type == BT_CHARACTER && p->ts.u.cl)
2101 e->ts = p->ts;
2102 }
2103
2104 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL__null)
2105 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl);
2106
2107 /* Do not copy subobject refs for constant. */
2108 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL__null)
2109 e->ref = gfc_copy_ref (p->ref);
2110 t = gfc_simplify_expr (e, type);
2111 e->where = p->where;
2112
2113 /* Only use the simplification if it eliminated all subobject references. */
2114 if (t && !e->ref)
2115 gfc_replace_expr (p, e);
2116 else
2117 gfc_free_expr (e);
2118
2119 return t;
2120}
2121
2122
2123static bool
2124scalarize_intrinsic_call (gfc_expr *, bool init_flag);
2125
2126/* Given an expression, simplify it by collapsing constant
2127 expressions. Most simplification takes place when the expression
2128 tree is being constructed. If an intrinsic function is simplified
2129 at some point, we get called again to collapse the result against
2130 other constants.
2131
2132 We work by recursively simplifying expression nodes, simplifying
2133 intrinsic functions where possible, which can lead to further
2134 constant collapsing. If an operator has constant operand(s), we
2135 rip the expression apart, and rebuild it, hoping that it becomes
2136 something simpler.
2137
2138 The expression type is defined for:
2139 0 Basic expression parsing
2140 1 Simplifying array constructors -- will substitute
2141 iterator values.
2142 Returns false on error, true otherwise.
2143 NOTE: Will return true even if the expression cannot be simplified. */
2144
2145bool
2146gfc_simplify_expr (gfc_expr *p, int type)
2147{
2148 gfc_actual_arglist *ap;
2149 gfc_intrinsic_sym* isym = NULL__null;
2150
2151
2152 if (p == NULL__null)
2153 return true;
2154
2155 switch (p->expr_type)
2156 {
2157 case EXPR_CONSTANT:
2158 if (p->ref && p->ref->type == REF_INQUIRY)
2159 simplify_ref_chain (p->ref, type, &p);
2160 break;
2161 case EXPR_NULL:
2162 break;
2163
2164 case EXPR_FUNCTION:
2165 // For array-bound functions, we don't need to optimize
2166 // the 'array' argument. In particular, if the argument
2167 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2168 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2169 // can have any lbound.
2170 ap = p->value.function.actual;
2171 if (p->value.function.isym &&
2172 (p->value.function.isym->id == GFC_ISYM_LBOUND
2173 || p->value.function.isym->id == GFC_ISYM_UBOUND
2174 || p->value.function.isym->id == GFC_ISYM_LCOBOUND
2175 || p->value.function.isym->id == GFC_ISYM_UCOBOUND))
2176 ap = ap->next;
2177
2178 for ( ; ap; ap = ap->next)
2179 if (!gfc_simplify_expr (ap->expr, type))
2180 return false;
2181
2182 if (p->value.function.isym != NULL__null
2183 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
2184 return false;
2185
2186 if (p->expr_type == EXPR_FUNCTION)
2187 {
2188 if (p->symtree)
2189 isym = gfc_find_function (p->symtree->n.sym->name);
2190 if (isym && isym->elemental)
2191 scalarize_intrinsic_call (p, false);
2192 }
2193
2194 break;
2195
2196 case EXPR_SUBSTRING:
2197 if (!simplify_ref_chain (p->ref, type, &p))
2198 return false;
2199
2200 if (gfc_is_constant_expr (p))
2201 {
2202 gfc_char_t *s;
2203 HOST_WIDE_INTlong start, end;
2204
2205 start = 0;
2206 if (p->ref && p->ref->u.ss.start)
2207 {
2208 gfc_extract_hwi (p->ref->u.ss.start, &start);
2209 start--; /* Convert from one-based to zero-based. */
2210 }
2211
2212 end = p->value.character.length;
2213 if (p->ref && p->ref->u.ss.end)
2214 gfc_extract_hwi (p->ref->u.ss.end, &end);
2215
2216 if (end < start)
2217 end = start;
2218
2219 s = gfc_get_wide_string (end - start + 2)((gfc_char_t *) xcalloc ((end - start + 2), sizeof (gfc_char_t
)))
;
2220 memcpy (s, p->value.character.string + start,
2221 (end - start) * sizeof (gfc_char_t));
2222 s[end - start + 1] = '\0'; /* TODO: C-style string. */
2223 free (p->value.character.string);
2224 p->value.character.string = s;
2225 p->value.character.length = end - start;
2226 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
2227 p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2228 NULL__null,
2229 p->value.character.length);
2230 gfc_free_ref_list (p->ref);
2231 p->ref = NULL__null;
2232 p->expr_type = EXPR_CONSTANT;
2233 }
2234 break;
2235
2236 case EXPR_OP:
2237 if (!simplify_intrinsic_op (p, type))
2238 return false;
2239 break;
2240
2241 case EXPR_VARIABLE:
2242 /* Only substitute array parameter variables if we are in an
2243 initialization expression, or we want a subsection. */
2244 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
2245 && (gfc_init_expr_flag || p->ref
2246 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
2247 {
2248 if (!simplify_parameter_variable (p, type))
2249 return false;
2250 break;
2251 }
2252
2253 if (type == 1)
2254 {
2255 gfc_simplify_iterator_var (p);
2256 }
2257
2258 /* Simplify subcomponent references. */
2259 if (!simplify_ref_chain (p->ref, type, &p))
2260 return false;
2261
2262 break;
2263
2264 case EXPR_STRUCTURE:
2265 case EXPR_ARRAY:
2266 if (!simplify_ref_chain (p->ref, type, &p))
2267 return false;
2268
2269 /* If the following conditions hold, we found something like kind type
2270 inquiry of the form a(2)%kind while simplify the ref chain. */
2271 if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape)
2272 return true;
2273
2274 if (!simplify_constructor (p->value.constructor, type))
2275 return false;
2276
2277 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
2278 && p->ref->u.ar.type == AR_FULL)
2279 gfc_expand_constructor (p, false);
2280
2281 if (!simplify_const_ref (p))
2282 return false;
2283
2284 break;
2285
2286 case EXPR_COMPCALL:
2287 case EXPR_PPC:
2288 break;
2289
2290 case EXPR_UNKNOWN:
2291 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 2291, __FUNCTION__))
;
2292 }
2293
2294 return true;
2295}
2296
2297
2298/* Returns the type of an expression with the exception that iterator
2299 variables are automatically integers no matter what else they may
2300 be declared as. */
2301
2302static bt
2303et0 (gfc_expr *e)
2304{
2305 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
2306 return BT_INTEGER;
2307
2308 return e->ts.type;
2309}
2310
2311
2312/* Scalarize an expression for an elemental intrinsic call. */
2313
2314static bool
2315scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
2316{
2317 gfc_actual_arglist *a, *b;
2318 gfc_constructor_base ctor;
2319 gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */
2320 gfc_constructor *ci, *new_ctor;
2321 gfc_expr *expr, *old, *p;
2322 int n, i, rank[5], array_arg;
2323
2324 if (e == NULL__null)
2325 return false;
2326
2327 a = e->value.function.actual;
2328 for (; a; a = a->next)
2329 if (a->expr && !gfc_is_constant_expr (a->expr))
2330 return false;
2331
2332 /* Find which, if any, arguments are arrays. Assume that the old
2333 expression carries the type information and that the first arg
2334 that is an array expression carries all the shape information.*/
2335 n = array_arg = 0;
2336 a = e->value.function.actual;
2337 for (; a; a = a->next)
2338 {
2339 n++;
2340 if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
2341 continue;
2342 array_arg = n;
2343 expr = gfc_copy_expr (a->expr);
2344 break;
2345 }
2346
2347 if (!array_arg)
2348 return false;
2349
2350 old = gfc_copy_expr (e);
2351
2352 gfc_constructor_free (expr->value.constructor);
2353 expr->value.constructor = NULL__null;
2354 expr->ts = old->ts;
2355 expr->where = old->where;
2356 expr->expr_type = EXPR_ARRAY;
2357
2358 /* Copy the array argument constructors into an array, with nulls
2359 for the scalars. */
2360 n = 0;
2361 a = old->value.function.actual;
2362 for (; a; a = a->next)
2363 {
2364 /* Check that this is OK for an initialization expression. */
2365 if (a->expr && init_flag && !gfc_check_init_expr (a->expr))
2366 goto cleanup;
2367
2368 rank[n] = 0;
2369 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2370 {
2371 rank[n] = a->expr->rank;
2372 ctor = a->expr->symtree->n.sym->value->value.constructor;
2373 args[n] = gfc_constructor_first (ctor);
2374 }
2375 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2376 {
2377 if (a->expr->rank)
2378 rank[n] = a->expr->rank;
2379 else
2380 rank[n] = 1;
2381 ctor = gfc_constructor_copy (a->expr->value.constructor);
2382 args[n] = gfc_constructor_first (ctor);
2383 }
2384 else
2385 args[n] = NULL__null;
2386
2387 n++;
2388 }
2389
2390 /* Using the array argument as the master, step through the array
2391 calling the function for each element and advancing the array
2392 constructors together. */
2393 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2394 {
2395 new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2396 gfc_copy_expr (old), NULL__null);
2397
2398 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2399 a = NULL__null;
2400 b = old->value.function.actual;
2401 for (i = 0; i < n; i++)
2402 {
2403 if (a == NULL__null)
2404 new_ctor->expr->value.function.actual
2405 = a = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
2406 else
2407 {
2408 a->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
2409 a = a->next;
2410 }
2411
2412 if (args[i])
2413 a->expr = gfc_copy_expr (args[i]->expr);
2414 else
2415 a->expr = gfc_copy_expr (b->expr);
2416
2417 b = b->next;
2418 }
2419
2420 /* Simplify the function calls. If the simplification fails, the
2421 error will be flagged up down-stream or the library will deal
2422 with it. */
2423 p = gfc_copy_expr (new_ctor->expr);
2424
2425 if (!gfc_simplify_expr (p, init_flag))
2426 gfc_free_expr (p);
2427 else
2428 gfc_replace_expr (new_ctor->expr, p);
2429
2430 for (i = 0; i < n; i++)
2431 if (args[i])
2432 args[i] = gfc_constructor_next (args[i]);
2433
2434 for (i = 1; i < n; i++)
2435 if (rank[i] && ((args[i] != NULL__null && args[array_arg - 1] == NULL__null)
2436 || (args[i] == NULL__null && args[array_arg - 1] != NULL__null)))
2437 goto compliance;
2438 }
2439
2440 free_expr0 (e);
2441 *e = *expr;
2442 /* Free "expr" but not the pointers it contains. */
2443 free (expr);
2444 gfc_free_expr (old);
2445 return true;
2446
2447compliance:
2448 gfc_error_now ("elemental function arguments at %C are not compliant");
2449
2450cleanup:
2451 gfc_free_expr (expr);
2452 gfc_free_expr (old);
2453 return false;
2454}
2455
2456
2457static bool
2458check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
2459{
2460 gfc_expr *op1 = e->value.op.op1;
2461 gfc_expr *op2 = e->value.op.op2;
2462
2463 if (!(*check_function)(op1))
2464 return false;
2465
2466 switch (e->value.op.op)
2467 {
2468 case INTRINSIC_UPLUS:
2469 case INTRINSIC_UMINUS:
2470 if (!numeric_type (et0 (op1)))
2471 goto not_numeric;
2472 break;
2473
2474 case INTRINSIC_EQ:
2475 case INTRINSIC_EQ_OS:
2476 case INTRINSIC_NE:
2477 case INTRINSIC_NE_OS:
2478 case INTRINSIC_GT:
2479 case INTRINSIC_GT_OS:
2480 case INTRINSIC_GE:
2481 case INTRINSIC_GE_OS:
2482 case INTRINSIC_LT:
2483 case INTRINSIC_LT_OS:
2484 case INTRINSIC_LE:
2485 case INTRINSIC_LE_OS:
2486 if (!(*check_function)(op2))
2487 return false;
2488
2489 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2490 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2491 {
2492 gfc_error ("Numeric or CHARACTER operands are required in "
2493 "expression at %L", &e->where);
2494 return false;
2495 }
2496 break;
2497
2498 case INTRINSIC_PLUS:
2499 case INTRINSIC_MINUS:
2500 case INTRINSIC_TIMES:
2501 case INTRINSIC_DIVIDE:
2502 case INTRINSIC_POWER:
2503 if (!(*check_function)(op2))
2504 return false;
2505
2506 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2507 goto not_numeric;
2508
2509 break;
2510
2511 case INTRINSIC_CONCAT:
2512 if (!(*check_function)(op2))
2513 return false;
2514
2515 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2516 {
2517 gfc_error ("Concatenation operator in expression at %L "
2518 "must have two CHARACTER operands", &op1->where);
2519 return false;
2520 }
2521
2522 if (op1->ts.kind != op2->ts.kind)
2523 {
2524 gfc_error ("Concat operator at %L must concatenate strings of the "
2525 "same kind", &e->where);
2526 return false;
2527 }
2528
2529 break;
2530
2531 case INTRINSIC_NOT:
2532 if (et0 (op1) != BT_LOGICAL)
2533 {
2534 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2535 "operand", &op1->where);
2536 return false;
2537 }
2538
2539 break;
2540
2541 case INTRINSIC_AND:
2542 case INTRINSIC_OR:
2543 case INTRINSIC_EQV:
2544 case INTRINSIC_NEQV:
2545 if (!(*check_function)(op2))
2546 return false;
2547
2548 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2549 {
2550 gfc_error ("LOGICAL operands are required in expression at %L",
2551 &e->where);
2552 return false;
2553 }
2554
2555 break;
2556
2557 case INTRINSIC_PARENTHESES:
2558 break;
2559
2560 default:
2561 gfc_error ("Only intrinsic operators can be used in expression at %L",
2562 &e->where);
2563 return false;
2564 }
2565
2566 return true;
2567
2568not_numeric:
2569 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2570
2571 return false;
2572}
2573
2574/* F2003, 7.1.7 (3): In init expression, allocatable components
2575 must not be data-initialized. */
2576static bool
2577check_alloc_comp_init (gfc_expr *e)
2578{
2579 gfc_component *comp;
2580 gfc_constructor *ctor;
2581
2582 gcc_assert (e->expr_type == EXPR_STRUCTURE)((void)(!(e->expr_type == EXPR_STRUCTURE) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 2582, __FUNCTION__), 0 : 0))
;
2583 gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)((void)(!(e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 2583, __FUNCTION__), 0 : 0))
;
2584
2585 for (comp = e->ts.u.derived->components,
2586 ctor = gfc_constructor_first (e->value.constructor);
2587 comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2588 {
2589 if (comp->attr.allocatable && ctor->expr
2590 && ctor->expr->expr_type != EXPR_NULL)
2591 {
2592 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2593 "component %qs in structure constructor at %L",
2594 comp->name, &ctor->expr->where);
2595 return false;
2596 }
2597 }
2598
2599 return true;
2600}
2601
2602static match
2603check_init_expr_arguments (gfc_expr *e)
2604{
2605 gfc_actual_arglist *ap;
2606
2607 for (ap = e->value.function.actual; ap; ap = ap->next)
2608 if (!gfc_check_init_expr (ap->expr))
2609 return MATCH_ERROR;
2610
2611 return MATCH_YES;
2612}
2613
2614static bool check_restricted (gfc_expr *);
2615
2616/* F95, 7.1.6.1, Initialization expressions, (7)
2617 F2003, 7.1.7 Initialization expression, (8)
2618 F2008, 7.1.12 Constant expression, (4) */
2619
2620static match
2621check_inquiry (gfc_expr *e, int not_restricted)
2622{
2623 const char *name;
2624 const char *const *functions;
2625
2626 static const char *const inquiry_func_f95[] = {
2627 "lbound", "shape", "size", "ubound",
2628 "bit_size", "len", "kind",
2629 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2630 "precision", "radix", "range", "tiny",
2631 NULL__null
2632 };
2633
2634 static const char *const inquiry_func_f2003[] = {
2635 "lbound", "shape", "size", "ubound",
2636 "bit_size", "len", "kind",
2637 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2638 "precision", "radix", "range", "tiny",
2639 "new_line", NULL__null
2640 };
2641
2642 /* std=f2008+ or -std=gnu */
2643 static const char *const inquiry_func_gnu[] = {
2644 "lbound", "shape", "size", "ubound",
2645 "bit_size", "len", "kind",
2646 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2647 "precision", "radix", "range", "tiny",
2648 "new_line", "storage_size", NULL__null
2649 };
2650
2651 int i = 0;
2652 gfc_actual_arglist *ap;
2653 gfc_symbol *sym;
2654 gfc_symbol *asym;
2655
2656 if (!e->value.function.isym
33.1
Field 'isym' is non-null
35
Taking false branch
2657 || !e->value.function.isym->inquiry)
34
Assuming field 'inquiry' is not equal to 0
2658 return MATCH_NO; 2659 2660 /* An undeclared parameter will get us here (PR25018). */ 2661 if (e->symtree == NULL__null)
36
Assuming field 'symtree' is not equal to NULL
37
Taking false branch
2662 return MATCH_NO; 2663 2664 sym = e->symtree->n.sym; 2665 2666 if (sym->from_intmod)
38
Assuming field 'from_intmod' is 0
39
Taking false branch
2667 { 2668 if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV 2669 && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS 2670 && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) 2671 return MATCH_NO; 2672 2673 if (sym->from_intmod == INTMOD_ISO_C_BINDING 2674 && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) 2675 return MATCH_NO; 2676 } 2677 else 2678 { 2679 name = sym->name; 2680 2681 functions = inquiry_func_gnu; 2682 if (gfc_option.warn_std & GFC_STD_F2003(1<<4))
40
Assuming the condition is false
41
Taking false branch
2683 functions = inquiry_func_f2003; 2684 if (gfc_option.warn_std & GFC_STD_F95(1<<3))
42
Assuming the condition is false
43
Taking false branch
2685 functions = inquiry_func_f95; 2686 2687 for (i = 0; functions[i]; i++)
44
Loop condition is true. Entering loop body
2688 if (strcmp (functions[i], name) == 0)
45
Taking true branch
2689 break;
46
Execution continues on line 2691
2690 2691 if (functions[i] == NULL__null)
47
Taking false branch
2692 return MATCH_ERROR; 2693 } 2694 2695 /* At this point we have an inquiry function with a variable argument. The 2696 type of the variable might be undefined, but we need it now, because the 2697 arguments of these functions are not allowed to be undefined. */ 2698 2699 for (ap = e->value.function.actual; ap; ap = ap->next)
48
Loop condition is true. Entering loop body
2700 { 2701 if (!ap->expr)
49
Assuming field 'expr' is non-null
50
Taking false branch
2702 continue; 2703 2704 asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL__null;
51
Assuming field 'symtree' is null
52
'?' condition is false
53
Null pointer value stored to 'asym'
2705 2706 if (ap->expr->ts.type == BT_UNKNOWN)
54
Assuming field 'type' is equal to BT_UNKNOWN
55
Taking true branch
2707 { 2708 if (asym
55.1
'asym' is null
&& asym->ts.type == BT_UNKNOWN 2709 && !gfc_set_default_type (asym, 0, gfc_current_ns)) 2710 return MATCH_NO; 2711 2712 ap->expr->ts = asym->ts;
56
Forming reference to null pointer
2713 } 2714 2715 if (asym && asym->assoc && asym->assoc->target 2716 && asym->assoc->target->expr_type == EXPR_CONSTANT) 2717 { 2718 gfc_free_expr (ap->expr); 2719 ap->expr = gfc_copy_expr (asym->assoc->target); 2720 } 2721 2722 /* Assumed character length will not reduce to a constant expression 2723 with LEN, as required by the standard. */ 2724 if (i == 5 && not_restricted && asym 2725 && asym->ts.type == BT_CHARACTER 2726 && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL__null) 2727 || asym->ts.deferred)) 2728 { 2729 gfc_error ("Assumed or deferred character length variable %qs " 2730 "in constant expression at %L", 2731 asym->name, &ap->expr->where); 2732 return MATCH_ERROR; 2733 } 2734 else if (not_restricted && !gfc_check_init_expr (ap->expr)) 2735 return MATCH_ERROR; 2736 2737 if (not_restricted == 0 2738 && ap->expr->expr_type != EXPR_VARIABLE 2739 && !check_restricted (ap->expr)) 2740 return MATCH_ERROR; 2741 2742 if (not_restricted == 0 2743 && ap->expr->expr_type == EXPR_VARIABLE 2744 && asym->attr.dummy && asym->attr.optional) 2745 return MATCH_NO; 2746 } 2747 2748 return MATCH_YES; 2749} 2750 2751 2752/* F95, 7.1.6.1, Initialization expressions, (5) 2753 F2003, 7.1.7 Initialization expression, (5) */ 2754 2755static match 2756check_transformational (gfc_expr *e) 2757{ 2758 static const char * const trans_func_f95[] = { 2759 "repeat", "reshape", "selected_int_kind", 2760 "selected_real_kind", "transfer", "trim", NULL__null 2761 }; 2762 2763 static const char * const trans_func_f2003[] = { 2764 "all", "any", "count", "dot_product", "matmul", "null", "pack", 2765 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", 2766 "selected_real_kind", "spread", "sum", "transfer", "transpose", 2767 "trim", "unpack", NULL__null 2768 }; 2769 2770 static const char * const trans_func_f2008[] = { 2771 "all", "any", "count", "dot_product", "matmul", "null", "pack", 2772 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", 2773 "selected_real_kind", "spread", "sum", "transfer", "transpose", 2774 "trim", "unpack", "findloc", NULL__null 2775 }; 2776 2777 int i; 2778 const char *name; 2779 const char *const *functions; 2780 2781 if (!e->value.function.isym 2782 || !e->value.function.isym->transformational) 2783 return MATCH_NO; 2784 2785 name = e->symtree->n.sym->name; 2786 2787 if (gfc_option.allow_std & GFC_STD_F2008(1<<7)) 2788 functions = trans_func_f2008; 2789 else if (gfc_option.allow_std & GFC_STD_F2003(1<<4)) 2790 functions = trans_func_f2003; 2791 else 2792 functions = trans_func_f95; 2793 2794 /* NULL() is dealt with below. */ 2795 if (strcmp ("null", name) == 0) 2796 return MATCH_NO; 2797 2798 for (i = 0; functions[i]; i++) 2799 if (strcmp (functions[i], name) == 0) 2800 break; 2801 2802 if (functions[i] == NULL__null) 2803 { 2804 gfc_error ("transformational intrinsic %qs at %L is not permitted " 2805 "in an initialization expression", name, &e->where); 2806 return MATCH_ERROR; 2807 } 2808 2809 return check_init_expr_arguments (e); 2810} 2811 2812 2813/* F95, 7.1.6.1, Initialization expressions, (6) 2814 F2003, 7.1.7 Initialization expression, (6) */ 2815 2816static match 2817check_null (gfc_expr *e) 2818{ 2819 if (strcmp ("null", e->symtree->n.sym->name) != 0) 2820 return MATCH_NO; 2821 2822 return check_init_expr_arguments (e); 2823} 2824 2825 2826static match 2827check_elemental (gfc_expr *e) 2828{ 2829 if (!e->value.function.isym 2830 || !e->value.function.isym->elemental) 2831 return MATCH_NO; 2832 2833 if (e->ts.type != BT_INTEGER 2834 && e->ts.type != BT_CHARACTER 2835 && !gfc_notify_std (GFC_STD_F2003(1<<4), "Evaluation of nonstandard " 2836 "initialization expression at %L", &e->where)) 2837 return MATCH_ERROR; 2838 2839 return check_init_expr_arguments (e); 2840} 2841 2842 2843static match 2844check_conversion (gfc_expr *e) 2845{ 2846 if (!e->value.function.isym
27
Assuming field 'isym' is non-null
29
Taking true branch
2847 || !e->value.function.isym->conversion)
28
Assuming field 'conversion' is 0
2848 return MATCH_NO;
30
Returning without writing to 'e->value.function.isym', which participates in a condition later
31
Returning without writing to 'e->value.function.actual', which participates in a condition later
2849 2850 return check_init_expr_arguments (e); 2851} 2852 2853 2854/* Verify that an expression is an initialization expression. A side 2855 effect is that the expression tree is reduced to a single constant 2856 node if all goes well. This would normally happen when the 2857 expression is constructed but function references are assumed to be 2858 intrinsics in the context of initialization expressions. If 2859 false is returned an error message has been generated. */ 2860 2861bool 2862gfc_check_init_expr (gfc_expr *e) 2863{ 2864 match m; 2865 bool t; 2866 2867 if (e
13.1
'e' is not equal to NULL
== NULL__null)
14
Taking false branch
2868 return true; 2869 2870 switch (e->expr_type)
15
Control jumps to 'case EXPR_FUNCTION:' at line 2879
2871 { 2872 case EXPR_OP: 2873 t = check_intrinsic_op (e, gfc_check_init_expr); 2874 if (t) 2875 t = gfc_simplify_expr (e, 0); 2876 2877 break; 2878 2879 case EXPR_FUNCTION: 2880 t = false; 2881 2882 { 2883 bool conversion; 2884 gfc_intrinsic_sym* isym = NULL__null; 2885 gfc_symbol* sym = e->symtree->n.sym; 2886 2887 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and 2888 IEEE_EXCEPTIONS modules. */ 2889 int mod = sym->from_intmod; 2890 if (mod == INTMOD_NONE && sym->generic)
16
Assuming 'mod' is not equal to INTMOD_NONE
2891 mod = sym->generic->sym->from_intmod; 2892 if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
17
Assuming 'mod' is not equal to INTMOD_IEEE_ARITHMETIC
18
Assuming 'mod' is equal to INTMOD_IEEE_EXCEPTIONS
19
Taking true branch
2893 { 2894 gfc_expr *new_expr = gfc_simplify_ieee_functions (e); 2895 if (new_expr)
20
Assuming 'new_expr' is null
21
Taking false branch
2896 { 2897 gfc_replace_expr (e, new_expr); 2898 t = true; 2899 break; 2900 } 2901 } 2902 2903 /* If a conversion function, e.g., __convert_i8_i4, was inserted 2904 into an array constructor, we need to skip the error check here. 2905 Conversion errors are caught below in scalarize_intrinsic_call. */ 2906 conversion = e->value.function.isym
22
Assuming field 'isym' is null
2907 && (e->value.function.isym->conversion == 1); 2908 2909 if (!conversion
22.1
'conversion' is false
&& (!gfc_is_intrinsic (sym, 0, e->where)
23
Assuming the condition is false
25
Taking false branch
2910 || (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO))
24
Assuming the condition is false
2911 { 2912 gfc_error ("Function %qs in initialization expression at %L " 2913 "must be an intrinsic function", 2914 e->symtree->n.sym->name, &e->where); 2915 break; 2916 } 2917 2918 if ((m = check_conversion (e)) == MATCH_NO
26
Calling 'check_conversion'
32
Returning from 'check_conversion'
2919 && (m = check_inquiry (e, 1)) == MATCH_NO
33
Calling 'check_inquiry'
2920 && (m = check_null (e)) == MATCH_NO 2921 && (m = check_transformational (e)) == MATCH_NO 2922 && (m = check_elemental (e)) == MATCH_NO) 2923 { 2924 gfc_error ("Intrinsic function %qs at %L is not permitted " 2925 "in an initialization expression", 2926 e->symtree->n.sym->name, &e->where); 2927 m = MATCH_ERROR; 2928 } 2929 2930 if (m == MATCH_ERROR) 2931 return false; 2932 2933 /* Try to scalarize an elemental intrinsic function that has an 2934 array argument. */ 2935 isym = gfc_find_function (e->symtree->n.sym->name); 2936 if (isym && isym->elemental 2937 && (t = scalarize_intrinsic_call (e, true))) 2938 break; 2939 } 2940 2941 if (m == MATCH_YES) 2942 t = gfc_simplify_expr (e, 0); 2943 2944 break; 2945 2946 case EXPR_VARIABLE: 2947 t = true; 2948 2949 /* This occurs when parsing pdt templates. */ 2950 if (gfc_expr_attr (e).pdt_kind) 2951 break; 2952 2953 if (gfc_check_iter_variable (e)) 2954 break; 2955 2956 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) 2957 { 2958 /* A PARAMETER shall not be used to define itself, i.e. 2959 REAL, PARAMETER :: x = transfer(0, x) 2960 is invalid. */ 2961 if (!e->symtree->n.sym->value) 2962 { 2963 gfc_error ("PARAMETER %qs is used at %L before its definition " 2964 "is complete", e->symtree->n.sym->name, &e->where); 2965 t = false; 2966 } 2967 else 2968 t = simplify_parameter_variable (e, 0); 2969 2970 break; 2971 } 2972 2973 if (gfc_in_match_data ()) 2974 break; 2975 2976 t = false; 2977 2978 if (e->symtree->n.sym->as) 2979 { 2980 switch (e->symtree->n.sym->as->type) 2981 { 2982 case AS_ASSUMED_SIZE: 2983 gfc_error ("Assumed size array %qs at %L is not permitted " 2984 "in an initialization expression", 2985 e->symtree->n.sym->name, &e->where); 2986 break; 2987 2988 case AS_ASSUMED_SHAPE: 2989 gfc_error ("Assumed shape array %qs at %L is not permitted " 2990 "in an initialization expression", 2991 e->symtree->n.sym->name, &e->where); 2992 break; 2993 2994 case AS_DEFERRED: 2995 if (!e->symtree->n.sym->attr.allocatable 2996 && !e->symtree->n.sym->attr.pointer 2997 && e->symtree->n.sym->attr.dummy) 2998 gfc_error ("Assumed-shape array %qs at %L is not permitted " 2999 "in an initialization expression", 3000 e->symtree->n.sym->name, &e->where); 3001 else 3002 gfc_error ("Deferred array %qs at %L is not permitted " 3003 "in an initialization expression", 3004 e->symtree->n.sym->name, &e->where); 3005 break; 3006 3007 case AS_EXPLICIT: 3008 gfc_error ("Array %qs at %L is a variable, which does " 3009 "not reduce to a constant expression", 3010 e->symtree->n.sym->name, &e->where); 3011 break; 3012 3013 case AS_ASSUMED_RANK: 3014 gfc_error ("Assumed-rank array %qs at %L is not permitted " 3015 "in an initialization expression", 3016 e->symtree->n.sym->name, &e->where); 3017 break; 3018 3019 default: 3020 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 3020, __FUNCTION__))
; 3021 } 3022 } 3023 else 3024 gfc_error ("Parameter %qs at %L has not been declared or is " 3025 "a variable, which does not reduce to a constant " 3026 "expression", e->symtree->name, &e->where); 3027 3028 break; 3029 3030 case EXPR_CONSTANT: 3031 case EXPR_NULL: 3032 t = true; 3033 break; 3034 3035 case EXPR_SUBSTRING: 3036 if (e->ref) 3037 { 3038 t = gfc_check_init_expr (e->ref->u.ss.start); 3039 if (!t) 3040 break; 3041 3042 t = gfc_check_init_expr (e->ref->u.ss.end); 3043 if (t) 3044 t = gfc_simplify_expr (e, 0); 3045 } 3046 else 3047 t = false; 3048 break; 3049 3050 case EXPR_STRUCTURE: 3051 t = e->ts.is_iso_c ? true : false; 3052 if (t) 3053 break; 3054 3055 t = check_alloc_comp_init (e); 3056 if (!t) 3057 break; 3058 3059 t = gfc_check_constructor (e, gfc_check_init_expr); 3060 if (!t) 3061 break; 3062 3063 break; 3064 3065 case EXPR_ARRAY: 3066 t = gfc_check_constructor (e, gfc_check_init_expr); 3067 if (!t) 3068 break; 3069 3070 t = gfc_expand_constructor (e, true); 3071 if (!t) 3072 break; 3073 3074 t = gfc_check_constructor_type (e); 3075 break; 3076 3077 default: 3078 gfc_internal_error ("check_init_expr(): Unknown expression type"); 3079 } 3080 3081 return t; 3082} 3083 3084/* Reduces a general expression to an initialization expression (a constant). 3085 This used to be part of gfc_match_init_expr. 3086 Note that this function doesn't free the given expression on false. */ 3087 3088bool 3089gfc_reduce_init_expr (gfc_expr *expr) 3090{ 3091 bool t; 3092 3093 gfc_init_expr_flag = true; 3094 t = gfc_resolve_expr (expr); 3095 if (t) 3096 t = gfc_check_init_expr (expr); 3097 gfc_init_expr_flag = false; 3098 3099 if (!t || !expr) 3100 return false; 3101 3102 if (expr->expr_type == EXPR_ARRAY) 3103 { 3104 if (!gfc_check_constructor_type (expr)) 3105 return false; 3106 if (!gfc_expand_constructor (expr, true)) 3107 return false; 3108 } 3109 3110 return true; 3111} 3112 3113 3114/* Match an initialization expression. We work by first matching an 3115 expression, then reducing it to a constant. */ 3116 3117match 3118gfc_match_init_expr (gfc_expr **result) 3119{ 3120 gfc_expr *expr; 3121 match m; 3122 bool t; 3123 3124 expr = NULL__null; 3125 3126 gfc_init_expr_flag = true; 3127 3128 m = gfc_match_expr (&expr); 3129 if (m != MATCH_YES) 3130 { 3131 gfc_init_expr_flag = false; 3132 return m; 3133 } 3134 3135 if (gfc_derived_parameter_expr (expr)) 3136 { 3137 *result = expr; 3138 gfc_init_expr_flag = false; 3139 return m; 3140 } 3141 3142 t = gfc_reduce_init_expr (expr); 3143 if (!t) 3144 { 3145 gfc_free_expr (expr); 3146 gfc_init_expr_flag = false; 3147 return MATCH_ERROR; 3148 } 3149 3150 *result = expr; 3151 gfc_init_expr_flag = false; 3152 3153 return MATCH_YES; 3154} 3155 3156 3157/* Given an actual argument list, test to see that each argument is a 3158 restricted expression and optionally if the expression type is 3159 integer or character. */ 3160 3161static bool 3162restricted_args (gfc_actual_arglist *a) 3163{ 3164 for (; a; a = a->next) 3165 { 3166 if (!check_restricted (a->expr)) 3167 return false; 3168 } 3169 3170 return true; 3171} 3172 3173 3174/************* Restricted/specification expressions *************/ 3175 3176 3177/* Make sure a non-intrinsic function is a specification function, 3178 * see F08:7.1.11.5. */ 3179 3180static bool 3181external_spec_function (gfc_expr *e) 3182{ 3183 gfc_symbol *f; 3184 3185 f = e->value.function.esym; 3186 3187 /* IEEE functions allowed are "a reference to a transformational function 3188 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and 3189 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and 3190 IEEE_EXCEPTIONS". */ 3191 if (f->from_intmod == INTMOD_IEEE_ARITHMETIC 3192 || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) 3193 { 3194 if (!strcmp (f->name, "ieee_selected_real_kind") 3195 || !strcmp (f->name, "ieee_support_rounding") 3196 || !strcmp (f->name, "ieee_support_flag") 3197 || !strcmp (f->name, "ieee_support_halting") 3198 || !strcmp (f->name, "ieee_support_datatype") 3199 || !strcmp (f->name, "ieee_support_denormal") 3200 || !strcmp (f->name, "ieee_support_subnormal") 3201 || !strcmp (f->name, "ieee_support_divide") 3202 || !strcmp (f->name, "ieee_support_inf") 3203 || !strcmp (f->name, "ieee_support_io") 3204 || !strcmp (f->name, "ieee_support_nan") 3205 || !strcmp (f->name, "ieee_support_sqrt") 3206 || !strcmp (f->name, "ieee_support_standard") 3207 || !strcmp (f->name, "ieee_support_underflow_control")) 3208 goto function_allowed; 3209 } 3210 3211 if (f->attr.proc == PROC_ST_FUNCTION) 3212 { 3213 gfc_error ("Specification function %qs at %L cannot be a statement " 3214 "function", f->name, &e->where); 3215 return false; 3216 } 3217 3218 if (f->attr.proc == PROC_INTERNAL) 3219 { 3220 gfc_error ("Specification function %qs at %L cannot be an internal " 3221 "function", f->name, &e->where); 3222 return false; 3223 } 3224 3225 if (!f->attr.pure && !f->attr.elemental) 3226 { 3227 gfc_error ("Specification function %qs at %L must be PURE", f->name, 3228 &e->where); 3229 return false; 3230 } 3231 3232 /* F08:7.1.11.6. */ 3233 if (f->attr.recursive 3234 && !gfc_notify_std (GFC_STD_F2003(1<<4), 3235 "Specification function %qs " 3236 "at %L cannot be RECURSIVE", f->name, &e->where)) 3237 return false; 3238 3239function_allowed: 3240 return restricted_args (e->value.function.actual); 3241} 3242 3243 3244/* Check to see that a function reference to an intrinsic is a 3245 restricted expression. */ 3246 3247static bool 3248restricted_intrinsic (gfc_expr *e) 3249{ 3250 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ 3251 if (check_inquiry (e, 0) == MATCH_YES) 3252 return true; 3253 3254 return restricted_args (e->value.function.actual); 3255} 3256 3257 3258/* Check the expressions of an actual arglist. Used by check_restricted. */ 3259 3260static bool 3261check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) 3262{ 3263 for (; arg; arg = arg->next) 3264 if (!checker (arg->expr)) 3265 return false; 3266 3267 return true; 3268} 3269 3270 3271/* Check the subscription expressions of a reference chain with a checking 3272 function; used by check_restricted. */ 3273 3274static bool 3275check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) 3276{ 3277 int dim; 3278 3279 if (!ref) 3280 return true; 3281 3282 switch (ref->type) 3283 { 3284 case REF_ARRAY: 3285 for (dim = 0; dim < ref->u.ar.dimen; ++dim) 3286 { 3287 if (!checker (ref->u.ar.start[dim])) 3288 return false; 3289 if (!checker (ref->u.ar.end[dim])) 3290 return false; 3291 if (!checker (ref->u.ar.stride[dim])) 3292 return false; 3293 } 3294 break; 3295 3296 case REF_COMPONENT: 3297 /* Nothing needed, just proceed to next reference. */ 3298 break; 3299 3300 case REF_SUBSTRING: 3301 if (!checker (ref->u.ss.start)) 3302 return false; 3303 if (!checker (ref->u.ss.end)) 3304 return false; 3305 break; 3306 3307 default: 3308 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 3308, __FUNCTION__))
; 3309 break; 3310 } 3311 3312 return check_references (ref->next, checker); 3313} 3314 3315/* Return true if ns is a parent of the current ns. */ 3316 3317static bool 3318is_parent_of_current_ns (gfc_namespace *ns) 3319{ 3320 gfc_namespace *p; 3321 for (p = gfc_current_ns->parent; p; p = p->parent) 3322 if (ns == p) 3323 return true; 3324 3325 return false; 3326} 3327 3328/* Verify that an expression is a restricted expression. Like its 3329 cousin check_init_expr(), an error message is generated if we 3330 return false. */ 3331 3332static bool 3333check_restricted (gfc_expr *e) 3334{ 3335 gfc_symbol* sym; 3336 bool t; 3337 3338 if (e == NULL__null) 3339 return true; 3340 3341 switch (e->expr_type) 3342 { 3343 case EXPR_OP: 3344 t = check_intrinsic_op (e, check_restricted); 3345 if (t) 3346 t = gfc_simplify_expr (e, 0); 3347 3348 break; 3349 3350 case EXPR_FUNCTION: 3351 if (e->value.function.esym) 3352 { 3353 t = check_arglist (e->value.function.actual, &check_restricted); 3354 if (t) 3355 t = external_spec_function (e); 3356 } 3357 else 3358 { 3359 if (e->value.function.isym && e->value.function.isym->inquiry) 3360 t = true; 3361 else 3362 t = check_arglist (e->value.function.actual, &check_restricted); 3363 3364 if (t) 3365 t = restricted_intrinsic (e); 3366 } 3367 break; 3368 3369 case EXPR_VARIABLE: 3370 sym = e->symtree->n.sym; 3371 t = false; 3372 3373 /* If a dummy argument appears in a context that is valid for a 3374 restricted expression in an elemental procedure, it will have 3375 already been simplified away once we get here. Therefore we 3376 don't need to jump through hoops to distinguish valid from 3377 invalid cases. Allowed in F2008 and F2018. */ 3378 if (gfc_notification_std (GFC_STD_F2008(1<<7)) 3379 && sym->attr.dummy && sym->ns == gfc_current_ns 3380 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) 3381 { 3382 gfc_error_now ("Dummy argument %qs not " 3383 "allowed in expression at %L", 3384 sym->name, &e->where); 3385 break; 3386 } 3387 3388 if (sym->attr.optional) 3389 { 3390 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", 3391 sym->name, &e->where); 3392 break; 3393 } 3394 3395 if (sym->attr.intent == INTENT_OUT) 3396 { 3397 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", 3398 sym->name, &e->where); 3399 break; 3400 } 3401 3402 /* Check reference chain if any. */ 3403 if (!check_references (e->ref, &check_restricted)) 3404 break; 3405 3406 /* gfc_is_formal_arg broadcasts that a formal argument list is being 3407 processed in resolve.c(resolve_formal_arglist). This is done so 3408 that host associated dummy array indices are accepted (PR23446). 3409 This mechanism also does the same for the specification expressions 3410 of array-valued functions. */ 3411 if (e->error 3412 || sym->attr.in_common 3413 || sym->attr.use_assoc 3414 || sym->attr.dummy 3415 || sym->attr.implied_index 3416 || sym->attr.flavor == FL_PARAMETER 3417 || is_parent_of_current_ns (sym->ns) 3418 || (sym->ns->proc_name != NULL__null 3419 && sym->ns->proc_name->attr.flavor == FL_MODULE) 3420 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) 3421 { 3422 t = true; 3423 break; 3424 } 3425 3426 gfc_error ("Variable %qs cannot appear in the expression at %L", 3427 sym->name, &e->where); 3428 /* Prevent a repetition of the error. */ 3429 e->error = 1; 3430 break; 3431 3432 case EXPR_NULL: 3433 case EXPR_CONSTANT: 3434 t = true; 3435 break; 3436 3437 case EXPR_SUBSTRING: 3438 t = gfc_specification_expr (e->ref->u.ss.start); 3439 if (!t) 3440 break; 3441 3442 t = gfc_specification_expr (e->ref->u.ss.end); 3443 if (t) 3444 t = gfc_simplify_expr (e, 0); 3445 3446 break; 3447 3448 case EXPR_STRUCTURE: 3449 t = gfc_check_constructor (e, check_restricted); 3450 break; 3451 3452 case EXPR_ARRAY: 3453 t = gfc_check_constructor (e, check_restricted); 3454 break; 3455 3456 default: 3457 gfc_internal_error ("check_restricted(): Unknown expression type"); 3458 } 3459 3460 return t; 3461} 3462 3463 3464/* Check to see that an expression is a specification expression. If 3465 we return false, an error has been generated. */ 3466 3467bool 3468gfc_specification_expr (gfc_expr *e) 3469{ 3470 gfc_component *comp; 3471 3472 if (e == NULL__null) 3473 return true; 3474 3475 if (e->ts.type != BT_INTEGER) 3476 { 3477 gfc_error ("Expression at %L must be of INTEGER type, found %s", 3478 &e->where, gfc_basic_typename (e->ts.type)); 3479 return false; 3480 } 3481 3482 comp = gfc_get_proc_ptr_comp (e); 3483 if (e->expr_type == EXPR_FUNCTION 3484 && !e->value.function.isym 3485 && !e->value.function.esym 3486 && !gfc_pure (e->symtree->n.sym) 3487 && (!comp || !comp->attr.pure)) 3488 { 3489 gfc_error ("Function %qs at %L must be PURE", 3490 e->symtree->n.sym->name, &e->where); 3491 /* Prevent repeat error messages. */ 3492 e->symtree->n.sym->attr.pure = 1; 3493 return false; 3494 } 3495 3496 if (e->rank != 0) 3497 { 3498 gfc_error ("Expression at %L must be scalar", &e->where); 3499 return false; 3500 } 3501 3502 if (!gfc_simplify_expr (e, 0)) 3503 return false; 3504 3505 return check_restricted (e); 3506} 3507 3508 3509/************** Expression conformance checks. *************/ 3510 3511/* Given two expressions, make sure that the arrays are conformable. */ 3512 3513bool 3514gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) 3515{ 3516 int op1_flag, op2_flag, d; 3517 mpz_t op1_size, op2_size; 3518 bool t; 3519 3520 va_list argp; 3521 char buffer[240]; 3522 3523 if (op1->rank == 0 || op2->rank == 0) 3524 return true; 3525 3526 va_start (argp, optype_msgid)__builtin_va_start(argp, optype_msgid); 3527 d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp); 3528 va_end (argp)__builtin_va_end(argp); 3529 if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */ 3530 gfc_internal_error ("optype_msgid overflow: %d", d); 3531 3532 if (op1->rank != op2->rank) 3533 { 3534 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer)gettext (buffer), 3535 op1->rank, op2->rank, &op1->where); 3536 return false; 3537 } 3538 3539 t = true; 3540 3541 for (d = 0; d < op1->rank; d++) 3542 { 3543 op1_flag = gfc_array_dimen_size(op1, d, &op1_size); 3544 op2_flag = gfc_array_dimen_size(op2, d, &op2_size); 3545 3546 if (op1_flag && op2_flag && mpz_cmp__gmpz_cmp (op1_size, op2_size) != 0) 3547 { 3548 gfc_error ("Different shape for %s at %L on dimension %d " 3549 "(%d and %d)", _(buffer)gettext (buffer), &op1->where, d + 1, 3550 (int) mpz_get_si__gmpz_get_si (op1_size), 3551 (int) mpz_get_si__gmpz_get_si (op2_size)); 3552 3553 t = false; 3554 } 3555 3556 if (op1_flag) 3557 mpz_clear__gmpz_clear (op1_size); 3558 if (op2_flag) 3559 mpz_clear__gmpz_clear (op2_size); 3560 3561 if (!t) 3562 return false; 3563 } 3564 3565 return true; 3566} 3567 3568 3569/* Given an assignable expression and an arbitrary expression, make 3570 sure that the assignment can take place. Only add a call to the intrinsic 3571 conversion routines, when allow_convert is set. When this assign is a 3572 coarray call, then the convert is done by the coarray routine implictly and 3573 adding the intrinsic conversion would do harm in most cases. */ 3574 3575bool 3576gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, 3577 bool allow_convert) 3578{ 3579 gfc_symbol *sym; 3580 gfc_ref *ref; 3581 int has_pointer; 3582 3583 sym = lvalue->symtree->n.sym; 3584 3585 /* See if this is the component or subcomponent of a pointer and guard 3586 against assignment to LEN or KIND part-refs. */ 3587 has_pointer = sym->attr.pointer; 3588 for (ref = lvalue->ref; ref; ref = ref->next) 3589 { 3590 if (!has_pointer && ref->type == REF_COMPONENT 3591 && ref->u.c.component->attr.pointer) 3592 has_pointer = 1; 3593 else if (ref->type == REF_INQUIRY 3594 && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) 3595 { 3596 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " 3597 "allowed", &lvalue->where); 3598 return false; 3599 } 3600 } 3601 3602 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other 3603 variable local to a function subprogram. Its existence begins when 3604 execution of the function is initiated and ends when execution of the 3605 function is terminated... 3606 Therefore, the left hand side is no longer a variable, when it is: */ 3607 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION 3608 && !sym->attr.external) 3609 { 3610 bool bad_proc; 3611 bad_proc = false; 3612 3613 /* (i) Use associated; */ 3614 if (sym->attr.use_assoc) 3615 bad_proc = true; 3616 3617 /* (ii) The assignment is in the main program; or */ 3618 if (gfc_current_ns->proc_name 3619 && gfc_current_ns->proc_name->attr.is_main_program) 3620 bad_proc = true; 3621 3622 /* (iii) A module or internal procedure... */ 3623 if (gfc_current_ns->proc_name 3624 && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL 3625 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) 3626 && gfc_current_ns->parent 3627 && (!(gfc_current_ns->parent->proc_name->attr.function 3628 || gfc_current_ns->parent->proc_name->attr.subroutine) 3629 || gfc_current_ns->parent->proc_name->attr.is_main_program)) 3630 { 3631 /* ... that is not a function... */ 3632 if (gfc_current_ns->proc_name 3633 && !gfc_current_ns->proc_name->attr.function) 3634 bad_proc = true; 3635 3636 /* ... or is not an entry and has a different name. */ 3637 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) 3638 bad_proc = true; 3639 } 3640 3641 /* (iv) Host associated and not the function symbol or the 3642 parent result. This picks up sibling references, which 3643 cannot be entries. */ 3644 if (!sym->attr.entry 3645 && sym->ns == gfc_current_ns->parent 3646 && sym != gfc_current_ns->proc_name 3647 && sym != gfc_current_ns->parent->proc_name->result) 3648 bad_proc = true; 3649 3650 if (bad_proc) 3651 { 3652 gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); 3653 return false; 3654 } 3655 } 3656 else 3657 { 3658 /* Reject assigning to an external symbol. For initializers, this 3659 was already done before, in resolve_fl_procedure. */ 3660 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external 3661 && sym->attr.proc != PROC_MODULE && !rvalue->error) 3662 { 3663 gfc_error ("Illegal assignment to external procedure at %L", 3664 &lvalue->where); 3665 return false; 3666 } 3667 } 3668 3669 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) 3670 { 3671 gfc_error ("Incompatible ranks %d and %d in assignment at %L", 3672 lvalue->rank, rvalue->rank, &lvalue->where); 3673 return false; 3674 } 3675 3676 if (lvalue->ts.type == BT_UNKNOWN) 3677 { 3678 gfc_error ("Variable type is UNKNOWN in assignment at %L", 3679 &lvalue->where); 3680 return false; 3681 } 3682 3683 if (rvalue->expr_type == EXPR_NULL) 3684 { 3685 if (has_pointer && (ref == NULL__null || ref->next == NULL__null) 3686 && lvalue->symtree->n.sym->attr.data) 3687 return true; 3688 else 3689 { 3690 gfc_error ("NULL appears on right-hand side in assignment at %L", 3691 &rvalue->where); 3692 return false; 3693 } 3694 } 3695 3696 /* This is possibly a typo: x = f() instead of x => f(). */ 3697 if (warn_surprisingglobal_options.x_warn_surprising 3698 && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) 3699 gfc_warning (OPT_Wsurprising, 3700 "POINTER-valued function appears on right-hand side of " 3701 "assignment at %L", &rvalue->where); 3702 3703 /* Check size of array assignments. */ 3704 if (lvalue->rank != 0 && rvalue->rank != 0 3705 && !gfc_check_conformance (lvalue, rvalue, _("array assignment")gettext ("array assignment"))) 3706 return false; 3707 3708 /* Handle the case of a BOZ literal on the RHS. */ 3709 if (rvalue->ts.type == BT_BOZ) 3710 { 3711 if (lvalue->symtree->n.sym->attr.data) 3712 { 3713 if (lvalue->ts.type == BT_INTEGER 3714 && gfc_boz2int (rvalue, lvalue->ts.kind)) 3715 return true; 3716 3717 if (lvalue->ts.type == BT_REAL 3718 && gfc_boz2real (rvalue, lvalue->ts.kind)) 3719 { 3720 if (gfc_invalid_boz ("BOZ literal constant near %L cannot " 3721 "be assigned to a REAL variable", 3722 &rvalue->where)) 3723 return false; 3724 return true; 3725 } 3726 } 3727 3728 if (!lvalue->symtree->n.sym->attr.data 3729 && gfc_invalid_boz ("BOZ literal constant at %L is neither a " 3730 "data-stmt-constant nor an actual argument to " 3731 "INT, REAL, DBLE, or CMPLX intrinsic function", 3732 &rvalue->where)) 3733 return false; 3734 3735 if (lvalue->ts.type == BT_INTEGER 3736 && gfc_boz2int (rvalue, lvalue->ts.kind)) 3737 return true; 3738 3739 if (lvalue->ts.type == BT_REAL 3740 && gfc_boz2real (rvalue, lvalue->ts.kind)) 3741 return true; 3742 3743 gfc_error ("BOZ literal constant near %L cannot be assigned to a " 3744 "%qs variable", &rvalue->where, gfc_typename (lvalue)); 3745 return false; 3746 } 3747 3748 if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) 3749 { 3750 gfc_error ("The assignment to a KIND or LEN component of a " 3751 "parameterized type at %L is not allowed", 3752 &lvalue->where); 3753 return false; 3754 } 3755 3756 if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) 3757 return true; 3758 3759 /* Only DATA Statements come here. */ 3760 if (!conform) 3761 { 3762 locus *where; 3763 3764 /* Numeric can be converted to any other numeric. And Hollerith can be 3765 converted to any other type. */ 3766 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) 3767 || rvalue->ts.type == BT_HOLLERITH) 3768 return true; 3769 3770 if (flag_dec_char_conversionsglobal_options.x_flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts) 3771 || lvalue->ts.type == BT_LOGICAL) 3772 && rvalue->ts.type == BT_CHARACTER 3773 && rvalue->ts.kind == gfc_default_character_kind) 3774 return true; 3775 3776 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) 3777 return true; 3778 3779 where = lvalue->where.lb ? &lvalue->where : &rvalue->where; 3780 gfc_error ("Incompatible types in DATA statement at %L; attempted " 3781 "conversion of %s to %s", where, 3782 gfc_typename (rvalue), gfc_typename (lvalue)); 3783 3784 return false; 3785 } 3786 3787 /* Assignment is the only case where character variables of different 3788 kind values can be converted into one another. */ 3789 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) 3790 { 3791 if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) 3792 return gfc_convert_chartype (rvalue, &lvalue->ts); 3793 else 3794 return true; 3795 } 3796 3797 if (!allow_convert) 3798 return true; 3799 3800 return gfc_convert_type (rvalue, &lvalue->ts, 1); 3801} 3802 3803 3804/* Check that a pointer assignment is OK. We first check lvalue, and 3805 we only check rvalue if it's not an assignment to NULL() or a 3806 NULLIFY statement. */ 3807 3808bool 3809gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, 3810 bool suppress_type_test, bool is_init_expr) 3811{ 3812 symbol_attribute attr, lhs_attr; 3813 gfc_ref *ref; 3814 bool is_pure, is_implicit_pure, rank_remap; 3815 int proc_pointer; 3816 bool same_rank; 3817 3818 lhs_attr = gfc_expr_attr (lvalue); 3819 if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) 3820 { 3821 gfc_error ("Pointer assignment target is not a POINTER at %L", 3822 &lvalue->where); 3823 return false; 3824 } 3825 3826 if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc 3827 && !lhs_attr.proc_pointer) 3828 { 3829 gfc_error ("%qs in the pointer assignment at %L cannot be an " 3830 "l-value since it is a procedure", 3831 lvalue->symtree->n.sym->name, &lvalue->where); 3832 return false; 3833 } 3834 3835 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; 3836 3837 rank_remap = false; 3838 same_rank = lvalue->rank == rvalue->rank; 3839 for (ref = lvalue->ref; ref; ref = ref->next) 3840 { 3841 if (ref->type == REF_COMPONENT) 3842 proc_pointer = ref->u.c.component->attr.proc_pointer; 3843 3844 if (ref->type == REF_ARRAY && ref->next == NULL__null) 3845 { 3846 int dim; 3847 3848 if (ref->u.ar.type == AR_FULL) 3849 break; 3850 3851 if (ref->u.ar.type != AR_SECTION) 3852 { 3853 gfc_error ("Expected bounds specification for %qs at %L", 3854 lvalue->symtree->n.sym->name, &lvalue->where); 3855 return false; 3856 } 3857 3858 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "Bounds specification " 3859 "for %qs in pointer assignment at %L", 3860 lvalue->symtree->n.sym->name, &lvalue->where)) 3861 return false; 3862 3863 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment): 3864 * 3865 * (C1017) If bounds-spec-list is specified, the number of 3866 * bounds-specs shall equal the rank of data-pointer-object. 3867 * 3868 * If bounds-spec-list appears, it specifies the lower bounds. 3869 * 3870 * (C1018) If bounds-remapping-list is specified, the number of 3871 * bounds-remappings shall equal the rank of data-pointer-object. 3872 * 3873 * If bounds-remapping-list appears, it specifies the upper and 3874 * lower bounds of each dimension of the pointer; the pointer target 3875 * shall be simply contiguous or of rank one. 3876 * 3877 * (C1019) If bounds-remapping-list is not specified, the ranks of 3878 * data-pointer-object and data-target shall be the same. 3879 * 3880 * Thus when bounds are given, all lbounds are necessary and either 3881 * all or none of the upper bounds; no strides are allowed. If the 3882 * upper bounds are present, we may do rank remapping. */ 3883 for (dim = 0; dim < ref->u.ar.dimen; ++dim) 3884 { 3885 if (ref->u.ar.stride[dim]) 3886 { 3887 gfc_error ("Stride must not be present at %L", 3888 &lvalue->where); 3889 return false; 3890 } 3891 if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim])) 3892 { 3893 gfc_error ("Rank remapping requires a " 3894 "list of %<lower-bound : upper-bound%> " 3895 "specifications at %L", &lvalue->where); 3896 return false; 3897 } 3898 if (!ref->u.ar.start[dim] 3899 || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) 3900 { 3901 gfc_error ("Expected list of %<lower-bound :%> or " 3902 "list of %<lower-bound : upper-bound%> " 3903 "specifications at %L", &lvalue->where); 3904 return false; 3905 } 3906 3907 if (dim == 0) 3908 rank_remap = (ref->u.ar.end[dim] != NULL__null); 3909 else 3910 { 3911 if ((rank_remap && !ref->u.ar.end[dim])) 3912 { 3913 gfc_error ("Rank remapping requires a " 3914 "list of %<lower-bound : upper-bound%> " 3915 "specifications at %L", &lvalue->where); 3916 return false; 3917 } 3918 if (!rank_remap && ref->u.ar.end[dim]) 3919 { 3920 gfc_error ("Expected list of %<lower-bound :%> or " 3921 "list of %<lower-bound : upper-bound%> " 3922 "specifications at %L", &lvalue->where); 3923 return false; 3924 } 3925 } 3926 } 3927 } 3928 } 3929 3930 is_pure = gfc_pure (NULL__null); 3931 is_implicit_pure = gfc_implicit_pure (NULL__null); 3932 3933 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, 3934 kind, etc for lvalue and rvalue must match, and rvalue must be a 3935 pure variable if we're in a pure function. */ 3936 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) 3937 return true; 3938 3939 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ 3940 if (lvalue->expr_type == EXPR_VARIABLE 3941 && gfc_is_coindexed (lvalue)) 3942 { 3943 gfc_ref *ref; 3944 for (ref = lvalue->ref; ref; ref = ref->next) 3945 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 3946 { 3947 gfc_error ("Pointer object at %L shall not have a coindex", 3948 &lvalue->where); 3949 return false; 3950 } 3951 } 3952 3953 /* Checks on rvalue for procedure pointer assignments. */ 3954 if (proc_pointer) 3955 { 3956 char err[200]; 3957 gfc_symbol *s1,*s2; 3958 gfc_component *comp1, *comp2; 3959 const char *name; 3960 3961 attr = gfc_expr_attr (rvalue); 3962 if (!((rvalue->expr_type == EXPR_NULL) 3963 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) 3964 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) 3965 || (rvalue->expr_type == EXPR_VARIABLE 3966 && attr.flavor == FL_PROCEDURE))) 3967 { 3968 gfc_error ("Invalid procedure pointer assignment at %L", 3969 &rvalue->where); 3970 return false; 3971 } 3972 3973 if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) 3974 { 3975 /* Check for intrinsics. */ 3976 gfc_symbol *sym = rvalue->symtree->n.sym; 3977 if (!sym->attr.intrinsic 3978 && (gfc_is_intrinsic (sym, 0, sym->declared_at) 3979 || gfc_is_intrinsic (sym, 1, sym->declared_at))) 3980 { 3981 sym->attr.intrinsic = 1; 3982 gfc_resolve_intrinsic (sym, &rvalue->where); 3983 attr = gfc_expr_attr (rvalue); 3984 } 3985 /* Check for result of embracing function. */ 3986 if (sym->attr.function && sym->result == sym) 3987 { 3988 gfc_namespace *ns; 3989 3990 for (ns = gfc_current_ns; ns; ns = ns->parent) 3991 if (sym == ns->proc_name) 3992 { 3993 gfc_error ("Function result %qs is invalid as proc-target " 3994 "in procedure pointer assignment at %L", 3995 sym->name, &rvalue->where); 3996 return false; 3997 } 3998 } 3999 } 4000 if (attr.abstract) 4001 { 4002 gfc_error ("Abstract interface %qs is invalid " 4003 "in procedure pointer assignment at %L", 4004 rvalue->symtree->name, &rvalue->where); 4005 return false; 4006 } 4007 /* Check for F08:C729. */ 4008 if (attr.flavor == FL_PROCEDURE) 4009 { 4010 if (attr.proc == PROC_ST_FUNCTION) 4011 { 4012 gfc_error ("Statement function %qs is invalid " 4013 "in procedure pointer assignment at %L", 4014 rvalue->symtree->name, &rvalue->where); 4015 return false; 4016 } 4017 if (attr.proc == PROC_INTERNAL && 4018 !gfc_notify_std(GFC_STD_F2008(1<<7), "Internal procedure %qs " 4019 "is invalid in procedure pointer assignment " 4020 "at %L", rvalue->symtree->name, &rvalue->where)) 4021 return false; 4022 if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, 4023 attr.subroutine) == 0) 4024 { 4025 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " 4026 "assignment", rvalue->symtree->name, &rvalue->where); 4027 return false; 4028 } 4029 } 4030 /* Check for F08:C730. */ 4031 if (attr.elemental && !attr.intrinsic) 4032 { 4033 gfc_error ("Nonintrinsic elemental procedure %qs is invalid " 4034 "in procedure pointer assignment at %L", 4035 rvalue->symtree->name, &rvalue->where); 4036 return false; 4037 } 4038 4039 /* Ensure that the calling convention is the same. As other attributes 4040 such as DLLEXPORT may differ, one explicitly only tests for the 4041 calling conventions. */ 4042 if (rvalue->expr_type == EXPR_VARIABLE 4043 && lvalue->symtree->n.sym->attr.ext_attr 4044 != rvalue->symtree->n.sym->attr.ext_attr) 4045 { 4046 symbol_attribute calls; 4047 4048 calls.ext_attr = 0; 4049 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL__null); 4050 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL__null); 4051 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL__null); 4052 4053 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) 4054 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) 4055 { 4056 gfc_error ("Mismatch in the procedure pointer assignment " 4057 "at %L: mismatch in the calling convention", 4058 &rvalue->where); 4059 return false; 4060 } 4061 } 4062 4063 comp1 = gfc_get_proc_ptr_comp (lvalue); 4064 if (comp1) 4065 s1 = comp1->ts.interface; 4066 else 4067 { 4068 s1 = lvalue->symtree->n.sym; 4069 if (s1->ts.interface) 4070 s1 = s1->ts.interface; 4071 } 4072 4073 comp2 = gfc_get_proc_ptr_comp (rvalue); 4074 if (comp2) 4075 { 4076 if (rvalue->expr_type == EXPR_FUNCTION) 4077 { 4078 s2 = comp2->ts.interface->result; 4079 name = s2->name; 4080 } 4081 else 4082 { 4083 s2 = comp2->ts.interface; 4084 name = comp2->name; 4085 } 4086 } 4087 else if (rvalue->expr_type == EXPR_FUNCTION) 4088 { 4089 if (rvalue->value.function.esym) 4090 s2 = rvalue->value.function.esym->result; 4091 else 4092 s2 = rvalue->symtree->n.sym->result; 4093 4094 name = s2->name; 4095 } 4096 else 4097 { 4098 s2 = rvalue->symtree->n.sym; 4099 name = s2->name; 4100 } 4101 4102 if (s2 && s2->attr.proc_pointer && s2->ts.interface) 4103 s2 = s2->ts.interface; 4104 4105 /* Special check for the case of absent interface on the lvalue. 4106 * All other interface checks are done below. */ 4107 if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) 4108 { 4109 gfc_error ("Interface mismatch in procedure pointer assignment " 4110 "at %L: %qs is not a subroutine", &rvalue->where, name); 4111 return false; 4112 } 4113 4114 /* F08:7.2.2.4 (4) */ 4115 if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) 4116 { 4117 if (comp1 && !s1) 4118 { 4119 gfc_error ("Explicit interface required for component %qs at %L: %s", 4120 comp1->name, &lvalue->where, err); 4121 return false; 4122 } 4123 else if (s1->attr.if_source == IFSRC_UNKNOWN) 4124 { 4125 gfc_error ("Explicit interface required for %qs at %L: %s", 4126 s1->name, &lvalue->where, err); 4127 return false; 4128 } 4129 } 4130 if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) 4131 { 4132 if (comp2 && !s2) 4133 { 4134 gfc_error ("Explicit interface required for component %qs at %L: %s", 4135 comp2->name, &rvalue->where, err); 4136 return false; 4137 } 4138 else if (s2->attr.if_source == IFSRC_UNKNOWN) 4139 { 4140 gfc_error ("Explicit interface required for %qs at %L: %s", 4141 s2->name, &rvalue->where, err); 4142 return false; 4143 } 4144 } 4145 4146 if (s1 == s2 || !s1 || !s2) 4147 return true; 4148 4149 if (!gfc_compare_interfaces (s1, s2, name, 0, 1, 4150 err, sizeof(err), NULL__null, NULL__null)) 4151 { 4152 gfc_error ("Interface mismatch in procedure pointer assignment " 4153 "at %L: %s", &rvalue->where, err); 4154 return false; 4155 } 4156 4157 /* Check F2008Cor2, C729. */ 4158 if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN 4159 && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) 4160 { 4161 gfc_error ("Procedure pointer target %qs at %L must be either an " 4162 "intrinsic, host or use associated, referenced or have " 4163 "the EXTERNAL attribute", s2->name, &rvalue->where); 4164 return false; 4165 } 4166 4167 return true; 4168 } 4169 else 4170 { 4171 /* A non-proc pointer cannot point to a constant. */ 4172 if (rvalue->expr_type == EXPR_CONSTANT) 4173 { 4174 gfc_error_now ("Pointer assignment target cannot be a constant at %L", 4175 &rvalue->where); 4176 return false; 4177 } 4178 } 4179 4180 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) 4181 { 4182 /* Check for F03:C717. */ 4183 if (UNLIMITED_POLY (rvalue)(rvalue != __null && rvalue->ts.type == BT_CLASS &&
rvalue->ts.u.derived->components && rvalue->
ts.u.derived->components->ts.u.derived && rvalue
->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)
4184 && !(UNLIMITED_POLY (lvalue)(lvalue != __null && lvalue->ts.type == BT_CLASS &&
lvalue->ts.u.derived->components && lvalue->
ts.u.derived->components->ts.u.derived && lvalue
->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)
4185 || (lvalue->ts.type == BT_DERIVED 4186 && (lvalue->ts.u.derived->attr.is_bind_c 4187 || lvalue->ts.u.derived->attr.sequence)))) 4188 gfc_error ("Data-pointer-object at %L must be unlimited " 4189 "polymorphic, or of a type with the BIND or SEQUENCE " 4190 "attribute, to be compatible with an unlimited " 4191 "polymorphic target", &lvalue->where); 4192 else if (!suppress_type_test) 4193 gfc_error ("Different types in pointer assignment at %L; " 4194 "attempted assignment of %s to %s", &lvalue->where, 4195 gfc_typename (rvalue), gfc_typename (lvalue)); 4196 return false; 4197 } 4198 4199 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) 4200 { 4201 gfc_error ("Different kind type parameters in pointer " 4202 "assignment at %L", &lvalue->where); 4203 return false; 4204 } 4205 4206 if (lvalue->rank != rvalue->rank && !rank_remap) 4207 { 4208 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); 4209 return false; 4210 } 4211 4212 /* Make sure the vtab is present. */ 4213 if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)(rvalue != __null && rvalue->ts.type == BT_CLASS &&
rvalue->ts.u.derived->components && rvalue->
ts.u.derived->components->ts.u.derived && rvalue
->ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)
) 4214 gfc_find_vtab (&rvalue->ts); 4215 4216 /* Check rank remapping. */ 4217 if (rank_remap) 4218 { 4219 mpz_t lsize, rsize; 4220 4221 /* If this can be determined, check that the target must be at least as 4222 large as the pointer assigned to it is. */ 4223 if (gfc_array_size (lvalue, &lsize) 4224 && gfc_array_size (rvalue, &rsize) 4225 && mpz_cmp__gmpz_cmp (rsize, lsize) < 0) 4226 { 4227 gfc_error ("Rank remapping target is smaller than size of the" 4228 " pointer (%ld < %ld) at %L", 4229 mpz_get_si__gmpz_get_si (rsize), mpz_get_si__gmpz_get_si (lsize), 4230 &lvalue->where); 4231 return false; 4232 } 4233 4234 /* The target must be either rank one or it must be simply contiguous 4235 and F2008 must be allowed. */ 4236 if (rvalue->rank != 1) 4237 { 4238 if (!gfc_is_simply_contiguous (rvalue, true, false)) 4239 { 4240 gfc_error ("Rank remapping target must be rank 1 or" 4241 " simply contiguous at %L", &rvalue->where); 4242 return false; 4243 } 4244 if (!gfc_notify_std (GFC_STD_F2008(1<<7), "Rank remapping target is not " 4245 "rank 1 at %L", &rvalue->where)) 4246 return false; 4247 } 4248 } 4249 4250 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ 4251 if (rvalue->expr_type == EXPR_NULL) 4252 return true; 4253 4254 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) 4255 lvalue->symtree->n.sym->attr.subref_array_pointer = 1; 4256 4257 attr = gfc_expr_attr (rvalue); 4258 4259 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) 4260 { 4261 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call 4262 to caf_get. Map this to the same error message as below when it is 4263 still a variable expression. */ 4264 if (rvalue->value.function.isym 4265 && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) 4266 /* The test above might need to be extend when F08, Note 5.4 has to be 4267 interpreted in the way that target and pointer with the same coindex 4268 are allowed. */ 4269 gfc_error ("Data target at %L shall not have a coindex", 4270 &rvalue->where); 4271 else 4272 gfc_error ("Target expression in pointer assignment " 4273 "at %L must deliver a pointer result", 4274 &rvalue->where); 4275 return false; 4276 } 4277 4278 if (is_init_expr) 4279 { 4280 gfc_symbol *sym; 4281 bool target; 4282 4283 if (gfc_is_size_zero_array (rvalue)) 4284 { 4285 gfc_error ("Zero-sized array detected at %L where an entity with " 4286 "the TARGET attribute is expected", &rvalue->where); 4287 return false; 4288 } 4289 else if (!rvalue->symtree) 4290 { 4291 gfc_error ("Pointer assignment target in initialization expression " 4292 "does not have the TARGET attribute at %L", 4293 &rvalue->where); 4294 return false; 4295 } 4296 4297 sym = rvalue->symtree->n.sym; 4298 4299 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 4300 target = CLASS_DATA (sym)sym->ts.u.derived->components->attr.target; 4301 else 4302 target = sym->attr.target; 4303 4304 if (!target && !proc_pointer) 4305 { 4306 gfc_error ("Pointer assignment target in initialization expression " 4307 "does not have the TARGET attribute at %L", 4308 &rvalue->where); 4309 return false; 4310 } 4311 } 4312 else 4313 { 4314 if (!attr.target && !attr.pointer) 4315 { 4316 gfc_error ("Pointer assignment target is neither TARGET " 4317 "nor POINTER at %L", &rvalue->where); 4318 return false; 4319 } 4320 } 4321 4322 if (lvalue->ts.type == BT_CHARACTER) 4323 { 4324 bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); 4325 if (!t) 4326 return false; 4327 } 4328 4329 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 4330 { 4331 gfc_error ("Bad target in pointer assignment in PURE " 4332 "procedure at %L", &rvalue->where); 4333 } 4334 4335 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) 4336 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 4337 4338 if (gfc_has_vector_index (rvalue)) 4339 { 4340 gfc_error ("Pointer assignment with vector subscript " 4341 "on rhs at %L", &rvalue->where); 4342 return false; 4343 } 4344 4345 if (attr.is_protected && attr.use_assoc 4346 && !(attr.pointer || attr.proc_pointer)) 4347 { 4348 gfc_error ("Pointer assignment target has PROTECTED " 4349 "attribute at %L", &rvalue->where); 4350 return false; 4351 } 4352 4353 /* F2008, C725. For PURE also C1283. */ 4354 if (rvalue->expr_type == EXPR_VARIABLE 4355 && gfc_is_coindexed (rvalue)) 4356 { 4357 gfc_ref *ref; 4358 for (ref = rvalue->ref; ref; ref = ref->next) 4359 if (ref->type == REF_ARRAY && ref->u.ar.codimen) 4360 { 4361 gfc_error ("Data target at %L shall not have a coindex", 4362 &rvalue->where); 4363 return false; 4364 } 4365 } 4366 4367 /* Warn for assignments of contiguous pointers to targets which is not 4368 contiguous. Be lenient in the definition of what counts as 4369 contiguous. */ 4370 4371 if (lhs_attr.contiguous 4372 && lhs_attr.dimension > 0) 4373 { 4374 if (gfc_is_not_contiguous (rvalue)) 4375 { 4376 gfc_error ("Assignment to contiguous pointer from " 4377 "non-contiguous target at %L", &rvalue->where); 4378 return false; 4379 } 4380 if (!gfc_is_simply_contiguous (rvalue, false, true)) 4381 gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from " 4382 "non-contiguous target at %L", &rvalue->where); 4383 } 4384 4385 /* Warn if it is the LHS pointer may lives longer than the RHS target. */ 4386 if (warn_target_lifetimeglobal_options.x_warn_target_lifetime 4387 && rvalue->expr_type == EXPR_VARIABLE 4388 && !rvalue->symtree->n.sym->attr.save 4389 && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer 4390 && !rvalue->symtree->n.sym->attr.host_assoc 4391 && !rvalue->symtree->n.sym->attr.in_common 4392 && !rvalue->symtree->n.sym->attr.use_assoc 4393 && !rvalue->symtree->n.sym->attr.dummy) 4394 { 4395 bool warn; 4396 gfc_namespace *ns; 4397 4398 warn = lvalue->symtree->n.sym->attr.dummy 4399 || lvalue->symtree->n.sym->attr.result 4400 || lvalue->symtree->n.sym->attr.function 4401 || (lvalue->symtree->n.sym->attr.host_assoc 4402 && lvalue->symtree->n.sym->ns 4403 != rvalue->symtree->n.sym->ns) 4404 || lvalue->symtree->n.sym->attr.use_assoc 4405 || lvalue->symtree->n.sym->attr.in_common; 4406 4407 if (rvalue->symtree->n.sym->ns->proc_name 4408 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE 4409 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) 4410 for (ns = rvalue->symtree->n.sym->ns; 4411 ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; 4412 ns = ns->parent) 4413 if (ns->parent == lvalue->symtree->n.sym->ns) 4414 { 4415 warn = true; 4416 break; 4417 } 4418 4419 if (warn) 4420 gfc_warning (OPT_Wtarget_lifetime, 4421 "Pointer at %L in pointer assignment might outlive the " 4422 "pointer target", &lvalue->where); 4423 } 4424 4425 return true; 4426} 4427 4428 4429/* Relative of gfc_check_assign() except that the lvalue is a single 4430 symbol. Used for initialization assignments. */ 4431 4432bool 4433gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) 4434{ 4435 gfc_expr lvalue; 4436 bool r; 4437 bool pointer, proc_pointer; 4438 4439 memset (&lvalue, '\0', sizeof (gfc_expr)); 4440 4441 lvalue.expr_type = EXPR_VARIABLE; 4442 lvalue.ts = sym->ts; 4443 if (sym->as)
1
Assuming field 'as' is null
2
Taking false branch
4444 lvalue.rank = sym->as->rank; 4445 lvalue.symtree = XCNEW (gfc_symtree)((gfc_symtree *) xcalloc (1, sizeof (gfc_symtree))); 4446 lvalue.symtree->n.sym = sym; 4447 lvalue.where = sym->declared_at; 4448 4449 if (comp)
3
Assuming 'comp' is null
4
Taking false branch
4450 { 4451 lvalue.ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 4452 lvalue.ref->type = REF_COMPONENT; 4453 lvalue.ref->u.c.component = comp; 4454 lvalue.ref->u.c.sym = sym; 4455 lvalue.ts = comp->ts; 4456 lvalue.rank = comp->as ? comp->as->rank : 0; 4457 lvalue.where = comp->loc; 4458 pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)comp->ts.u.derived->components 4459 ? CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer : comp->attr.pointer; 4460 proc_pointer = comp->attr.proc_pointer; 4461 } 4462 else 4463 { 4464 pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components
5
Assuming field 'type' is not equal to BT_CLASS
4465 ? CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer : sym->attr.pointer; 4466 proc_pointer = sym->attr.proc_pointer; 4467 } 4468 4469 if (pointer || proc_pointer)
6
Assuming 'pointer' is false
7
Assuming 'proc_pointer' is false
8
Taking false branch
4470 r = gfc_check_pointer_assign (&lvalue, rvalue, false, true); 4471 else 4472 { 4473 /* If a conversion function, e.g., __convert_i8_i4, was inserted 4474 into an array constructor, we should check if it can be reduced 4475 as an initialization expression. */ 4476 if (rvalue->expr_type == EXPR_FUNCTION
9
Assuming field 'expr_type' is equal to EXPR_FUNCTION
12
Taking true branch
4477 && rvalue->value.function.isym
10
Assuming field 'isym' is non-null
4478 && (rvalue->value.function.isym->conversion == 1))
11
Assuming field 'conversion' is equal to 1
4479 gfc_check_init_expr (rvalue);
13
Calling 'gfc_check_init_expr'
4480 4481 r = gfc_check_assign (&lvalue, rvalue, 1); 4482 } 4483 4484 free (lvalue.symtree); 4485 free (lvalue.ref); 4486 4487 if (!r) 4488 return r; 4489 4490 if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer) 4491 { 4492 /* F08:C461. Additional checks for pointer initialization. */ 4493 symbol_attribute attr; 4494 attr = gfc_expr_attr (rvalue); 4495 if (attr.allocatable) 4496 { 4497 gfc_error ("Pointer initialization target at %L " 4498 "must not be ALLOCATABLE", &rvalue->where); 4499 return false; 4500 } 4501 if (!attr.target || attr.pointer) 4502 { 4503 gfc_error ("Pointer initialization target at %L " 4504 "must have the TARGET attribute", &rvalue->where); 4505 return false; 4506 } 4507 4508 if (!attr.save && rvalue->expr_type == EXPR_VARIABLE 4509 && rvalue->symtree->n.sym->ns->proc_name 4510 && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) 4511 { 4512 rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; 4513 attr.save = SAVE_IMPLICIT; 4514 } 4515 4516 if (!attr.save) 4517 { 4518 gfc_error ("Pointer initialization target at %L " 4519 "must have the SAVE attribute", &rvalue->where); 4520 return false; 4521 } 4522 } 4523 4524 if (proc_pointer && rvalue->expr_type != EXPR_NULL) 4525 { 4526 /* F08:C1220. Additional checks for procedure pointer initialization. */ 4527 symbol_attribute attr = gfc_expr_attr (rvalue); 4528 if (attr.proc_pointer) 4529 { 4530 gfc_error ("Procedure pointer initialization target at %L " 4531 "may not be a procedure pointer", &rvalue->where); 4532 return false; 4533 } 4534 if (attr.proc == PROC_INTERNAL) 4535 { 4536 gfc_error ("Internal procedure %qs is invalid in " 4537 "procedure pointer initialization at %L", 4538 rvalue->symtree->name, &rvalue->where); 4539 return false; 4540 } 4541 if (attr.dummy) 4542 { 4543 gfc_error ("Dummy procedure %qs is invalid in " 4544 "procedure pointer initialization at %L", 4545 rvalue->symtree->name, &rvalue->where); 4546 return false; 4547 } 4548 } 4549 4550 return true; 4551} 4552 4553/* Invoke gfc_build_init_expr to create an initializer expression, but do not 4554 * require that an expression be built. */ 4555 4556gfc_expr * 4557gfc_build_default_init_expr (gfc_typespec *ts, locus *where) 4558{ 4559 return gfc_build_init_expr (ts, where, false); 4560} 4561 4562/* Build an initializer for a local integer, real, complex, logical, or 4563 character variable, based on the command line flags finit-local-zero, 4564 finit-integer=, finit-real=, finit-logical=, and finit-character=. 4565 With force, an initializer is ALWAYS generated. */ 4566 4567gfc_expr * 4568gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) 4569{ 4570 gfc_expr *init_expr; 4571 4572 /* Try to build an initializer expression. */ 4573 init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); 4574 4575 /* If we want to force generation, make sure we default to zero. */ 4576 gfc_init_local_real init_real = flag_init_realglobal_options.x_flag_init_real; 4577 int init_logical = gfc_option.flag_init_logical; 4578 if (force) 4579 { 4580 if (init_real == GFC_INIT_REAL_OFF) 4581 init_real = GFC_INIT_REAL_ZERO; 4582 if (init_logical == GFC_INIT_LOGICAL_OFF) 4583 init_logical = GFC_INIT_LOGICAL_FALSE; 4584 } 4585 4586 /* We will only initialize integers, reals, complex, logicals, and 4587 characters, and only if the corresponding command-line flags 4588 were set. Otherwise, we free init_expr and return null. */ 4589 switch (ts->type) 4590 { 4591 case BT_INTEGER: 4592 if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) 4593 mpz_set_si__gmpz_set_si (init_expr->value.integer, 4594 gfc_option.flag_init_integer_value); 4595 else 4596 { 4597 gfc_free_expr (init_expr); 4598 init_expr = NULL__null; 4599 } 4600 break; 4601 4602 case BT_REAL: 4603 switch (init_real) 4604 { 4605 case GFC_INIT_REAL_SNAN: 4606 init_expr->is_snan = 1; 4607 /* Fall through. */ 4608 case GFC_INIT_REAL_NAN: 4609 mpfr_set_nan (init_expr->value.real); 4610 break; 4611 4612 case GFC_INIT_REAL_INF: 4613 mpfr_set_inf (init_expr->value.real, 1); 4614 break; 4615 4616 case GFC_INIT_REAL_NEG_INF: 4617 mpfr_set_inf (init_expr->value.real, -1); 4618 break; 4619 4620 case GFC_INIT_REAL_ZERO: 4621 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODEMPFR_RNDN); 4622 break; 4623 4624 default: 4625 gfc_free_expr (init_expr); 4626 init_expr = NULL__null; 4627 break; 4628 } 4629 break; 4630 4631 case BT_COMPLEX: 4632 switch (init_real) 4633 { 4634 case GFC_INIT_REAL_SNAN: 4635 init_expr->is_snan = 1; 4636 /* Fall through. */ 4637 case GFC_INIT_REAL_NAN: 4638 mpfr_set_nan (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re)); 4639 mpfr_set_nan (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im)); 4640 break; 4641 4642 case GFC_INIT_REAL_INF: 4643 mpfr_set_inf (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re), 1); 4644 mpfr_set_inf (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im), 1); 4645 break; 4646 4647 case GFC_INIT_REAL_NEG_INF: 4648 mpfr_set_inf (mpc_realref (init_expr->value.complex)((init_expr->value.complex)->re), -1); 4649 mpfr_set_inf (mpc_imagref (init_expr->value.complex)((init_expr->value.complex)->im), -1); 4650 break; 4651 4652 case GFC_INIT_REAL_ZERO: 4653 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 4654 break; 4655 4656 default: 4657 gfc_free_expr (init_expr); 4658 init_expr = NULL__null; 4659 break; 4660 } 4661 break; 4662 4663 case BT_LOGICAL: 4664 if (init_logical == GFC_INIT_LOGICAL_FALSE) 4665 init_expr->value.logical = 0; 4666 else if (init_logical == GFC_INIT_LOGICAL_TRUE) 4667 init_expr->value.logical = 1; 4668 else 4669 { 4670 gfc_free_expr (init_expr); 4671 init_expr = NULL__null; 4672 } 4673 break; 4674 4675 case BT_CHARACTER: 4676 /* For characters, the length must be constant in order to 4677 create a default initializer. */ 4678 if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) 4679 && ts->u.cl->length 4680 && ts->u.cl->length->expr_type == EXPR_CONSTANT) 4681 { 4682 HOST_WIDE_INTlong char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 4683 init_expr->value.character.length = char_len; 4684 init_expr->value.character.string = gfc_get_wide_string (char_len+1)((gfc_char_t *) xcalloc ((char_len+1), sizeof (gfc_char_t))); 4685 for (size_t i = 0; i < (size_t) char_len; i++) 4686 init_expr->value.character.string[i] 4687 = (unsigned char) gfc_option.flag_init_character_value; 4688 } 4689 else 4690 { 4691 gfc_free_expr (init_expr); 4692 init_expr = NULL__null; 4693 } 4694 if (!init_expr 4695 && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) 4696 && ts->u.cl->length && flag_max_stack_var_sizeglobal_options.x_flag_max_stack_var_size != 0) 4697 { 4698 gfc_actual_arglist *arg; 4699 init_expr = gfc_get_expr (); 4700 init_expr->where = *where; 4701 init_expr->ts = *ts; 4702 init_expr->expr_type = EXPR_FUNCTION; 4703 init_expr->value.function.isym = 4704 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); 4705 init_expr->value.function.name = "repeat"; 4706 arg = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
; 4707 arg->expr = gfc_get_character_expr (ts->kind, where, NULL__null, 1); 4708 arg->expr->value.character.string[0] = 4709 gfc_option.flag_init_character_value; 4710 arg->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
; 4711 arg->next->expr = gfc_copy_expr (ts->u.cl->length); 4712 init_expr->value.function.actual = arg; 4713 } 4714 break; 4715 4716 default: 4717 gfc_free_expr (init_expr); 4718 init_expr = NULL__null; 4719 } 4720 4721 return init_expr; 4722} 4723 4724/* Apply an initialization expression to a typespec. Can be used for symbols or 4725 components. Similar to add_init_expr_to_sym in decl.c; could probably be 4726 combined with some effort. */ 4727 4728void 4729gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) 4730{ 4731 if (ts->type == BT_CHARACTER && !attr->pointer && init 4732 && ts->u.cl 4733 && ts->u.cl->length 4734 && ts->u.cl->length->expr_type == EXPR_CONSTANT 4735 && ts->u.cl->length->ts.type == BT_INTEGER) 4736 { 4737 HOST_WIDE_INTlong len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); 4738 4739 if (init->expr_type == EXPR_CONSTANT) 4740 gfc_set_constant_character_len (len, init, -1); 4741 else if (init 4742 && init->ts.type == BT_CHARACTER 4743 && init->ts.u.cl && init->ts.u.cl->length 4744 && mpz_cmp__gmpz_cmp (ts->u.cl->length->value.integer, 4745 init->ts.u.cl->length->value.integer)) 4746 { 4747 gfc_constructor *ctor; 4748 ctor = gfc_constructor_first (init->value.constructor); 4749 4750 if (ctor) 4751 { 4752 bool has_ts = (init->ts.u.cl 4753 && init->ts.u.cl->length_from_typespec); 4754 4755 /* Remember the length of the first element for checking 4756 that all elements *in the constructor* have the same 4757 length. This need not be the length of the LHS! */ 4758 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT)((void)(!(ctor->expr->expr_type == EXPR_CONSTANT) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 4758, __FUNCTION__), 0 : 0))
; 4759 gcc_assert (ctor->expr->ts.type == BT_CHARACTER)((void)(!(ctor->expr->ts.type == BT_CHARACTER) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 4759, __FUNCTION__), 0 : 0))
; 4760 gfc_charlen_t first_len = ctor->expr->value.character.length; 4761 4762 for ( ; ctor; ctor = gfc_constructor_next (ctor)) 4763 if (ctor->expr->expr_type == EXPR_CONSTANT) 4764 { 4765 gfc_set_constant_character_len (len, ctor->expr, 4766 has_ts ? -1 : first_len); 4767 if (!ctor->expr->ts.u.cl) 4768 ctor->expr->ts.u.cl 4769 = gfc_new_charlen (gfc_current_ns, ts->u.cl); 4770 else 4771 ctor->expr->ts.u.cl->length 4772 = gfc_copy_expr (ts->u.cl->length); 4773 } 4774 } 4775 } 4776 } 4777} 4778 4779 4780/* Check whether an expression is a structure constructor and whether it has 4781 other values than NULL. */ 4782 4783bool 4784is_non_empty_structure_constructor (gfc_expr * e) 4785{ 4786 if (e->expr_type != EXPR_STRUCTURE) 4787 return false; 4788 4789 gfc_constructor *cons = gfc_constructor_first (e->value.constructor); 4790 while (cons) 4791 { 4792 if (!cons->expr || cons->expr->expr_type != EXPR_NULL) 4793 return true; 4794 cons = gfc_constructor_next (cons); 4795 } 4796 return false; 4797} 4798 4799 4800/* Check for default initializer; sym->value is not enough 4801 as it is also set for EXPR_NULL of allocatables. */ 4802 4803bool 4804gfc_has_default_initializer (gfc_symbol *der) 4805{ 4806 gfc_component *c; 4807 4808 gcc_assert (gfc_fl_struct (der->attr.flavor))((void)(!(((der->attr.flavor) == FL_DERIVED || (der->attr
.flavor) == FL_UNION || (der->attr.flavor) == FL_STRUCT)) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 4808, __FUNCTION__), 0 : 0))
; 4809 for (c = der->components; c; c = c->next) 4810 if (gfc_bt_struct (c->ts.type)((c->ts.type) == BT_DERIVED || (c->ts.type) == BT_UNION
)
) 4811 { 4812 if (!c->attr.pointer && !c->attr.proc_pointer 4813 && !(c->attr.allocatable && der == c->ts.u.derived) 4814 && ((c->initializer 4815 && is_non_empty_structure_constructor (c->initializer)) 4816 || gfc_has_default_initializer (c->ts.u.derived))) 4817 return true; 4818 if (c->attr.pointer && c->initializer) 4819 return true; 4820 } 4821 else 4822 { 4823 if (c->initializer) 4824 return true; 4825 } 4826 4827 return false; 4828} 4829 4830 4831/* 4832 Generate an initializer expression which initializes the entirety of a union. 4833 A normal structure constructor is insufficient without undue effort, because 4834 components of maps may be oddly aligned/overlapped. (For example if a 4835 character is initialized from one map overtop a real from the other, only one 4836 byte of the real is actually initialized.) Unfortunately we don't know the 4837 size of the union right now, so we can't generate a proper initializer, but 4838 we use a NULL expr as a placeholder and do the right thing later in 4839 gfc_trans_subcomponent_assign. 4840 */ 4841static gfc_expr * 4842generate_union_initializer (gfc_component *un) 4843{ 4844 if (un == NULL__null || un->ts.type != BT_UNION) 4845 return NULL__null; 4846 4847 gfc_expr *placeholder = gfc_get_null_expr (&un->loc); 4848 placeholder->ts = un->ts; 4849 return placeholder; 4850} 4851 4852 4853/* Get the user-specified initializer for a union, if any. This means the user 4854 has said to initialize component(s) of a map. For simplicity's sake we 4855 only allow the user to initialize the first map. We don't have to worry 4856 about overlapping initializers as they are released early in resolution (see 4857 resolve_fl_struct). */ 4858 4859static gfc_expr * 4860get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) 4861{ 4862 gfc_component *map; 4863 gfc_expr *init=NULL__null; 4864 4865 if (!union_type || union_type->attr.flavor != FL_UNION) 4866 return NULL__null; 4867 4868 for (map = union_type->components; map; map = map->next) 4869 { 4870 if (gfc_has_default_initializer (map->ts.u.derived)) 4871 { 4872 init = gfc_default_initializer (&map->ts); 4873 if (map_p) 4874 *map_p = map; 4875 break; 4876 } 4877 } 4878 4879 if (map_p && !init) 4880 *map_p = NULL__null; 4881 4882 return init; 4883} 4884 4885static bool 4886class_allocatable (gfc_component *comp) 4887{ 4888 return comp->ts.type == BT_CLASS && CLASS_DATA (comp)comp->ts.u.derived->components 4889 && CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable; 4890} 4891 4892static bool 4893class_pointer (gfc_component *comp) 4894{ 4895 return comp->ts.type == BT_CLASS && CLASS_DATA (comp)comp->ts.u.derived->components 4896 && CLASS_DATA (comp)comp->ts.u.derived->components->attr.pointer; 4897} 4898 4899static bool 4900comp_allocatable (gfc_component *comp) 4901{ 4902 return comp->attr.allocatable || class_allocatable (comp); 4903} 4904 4905static bool 4906comp_pointer (gfc_component *comp) 4907{ 4908 return comp->attr.pointer 4909 || comp->attr.proc_pointer 4910 || comp->attr.class_pointer 4911 || class_pointer (comp); 4912} 4913 4914/* Fetch or generate an initializer for the given component. 4915 Only generate an initializer if generate is true. */ 4916 4917static gfc_expr * 4918component_initializer (gfc_component *c, bool generate) 4919{ 4920 gfc_expr *init = NULL__null; 4921 4922 /* Allocatable components always get EXPR_NULL. 4923 Pointer components are only initialized when generating, and only if they 4924 do not already have an initializer. */ 4925 if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer)) 4926 { 4927 init = gfc_get_null_expr (&c->loc); 4928 init->ts = c->ts; 4929 return init; 4930 } 4931 4932 /* See if we can find the initializer immediately. */ 4933 if (c->initializer || !generate) 4934 return c->initializer; 4935 4936 /* Recursively handle derived type components. */ 4937 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 4938 init = gfc_generate_initializer (&c->ts, true); 4939 4940 else if (c->ts.type == BT_UNION && c->ts.u.derived->components) 4941 { 4942 gfc_component *map = NULL__null; 4943 gfc_constructor *ctor; 4944 gfc_expr *user_init; 4945 4946 /* If we don't have a user initializer and we aren't generating one, this 4947 union has no initializer. */ 4948 user_init = get_union_initializer (c->ts.u.derived, &map); 4949 if (!user_init && !generate) 4950 return NULL__null; 4951 4952 /* Otherwise use a structure constructor. */ 4953 init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, 4954 &c->loc); 4955 init->ts = c->ts; 4956 4957 /* If we are to generate an initializer for the union, add a constructor 4958 which initializes the whole union first. */ 4959 if (generate) 4960 { 4961 ctor = gfc_constructor_get (); 4962 ctor->expr = generate_union_initializer (c); 4963 gfc_constructor_append (&init->value.constructor, ctor); 4964 } 4965 4966 /* If we found an initializer in one of our maps, apply it. Note this 4967 is applied _after_ the entire-union initializer above if any. */ 4968 if (user_init) 4969 { 4970 ctor = gfc_constructor_get (); 4971 ctor->expr = user_init; 4972 ctor->n.component = map; 4973 gfc_constructor_append (&init->value.constructor, ctor); 4974 } 4975 } 4976 4977 /* Treat simple components like locals. */ 4978 else 4979 { 4980 /* We MUST give an initializer, so force generation. */ 4981 init = gfc_build_init_expr (&c->ts, &c->loc, true); 4982 gfc_apply_init (&c->ts, &c->attr, init); 4983 } 4984 4985 return init; 4986} 4987 4988 4989/* Get an expression for a default initializer of a derived type. */ 4990 4991gfc_expr * 4992gfc_default_initializer (gfc_typespec *ts) 4993{ 4994 return gfc_generate_initializer (ts, false); 4995} 4996 4997/* Generate an initializer expression for an iso_c_binding type 4998 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */ 4999 5000static gfc_expr * 5001generate_isocbinding_initializer (gfc_symbol *derived) 5002{ 5003 /* The initializers have already been built into the c_null_[fun]ptr symbols 5004 from gen_special_c_interop_ptr. */ 5005 gfc_symtree *npsym = NULL__null; 5006 if (0 == strcmp (derived->name, "c_ptr")) 5007 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym); 5008 else if (0 == strcmp (derived->name, "c_funptr")) 5009 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym); 5010 else 5011 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding" 5012 " type, expected %<c_ptr%> or %<c_funptr%>"); 5013 if (npsym) 5014 { 5015 gfc_expr *init = gfc_copy_expr (npsym->n.sym->value); 5016 init->symtree = npsym; 5017 init->ts.is_iso_c = true; 5018 return init; 5019 } 5020 5021 return NULL__null; 5022} 5023 5024/* Get or generate an expression for a default initializer of a derived type. 5025 If -finit-derived is specified, generate default initialization expressions 5026 for components that lack them when generate is set. */ 5027 5028gfc_expr * 5029gfc_generate_initializer (gfc_typespec *ts, bool generate) 5030{ 5031 gfc_expr *init, *tmp; 5032 gfc_component *comp; 5033 5034 generate = flag_init_derivedglobal_options.x_flag_init_derived && generate; 5035 5036 if (ts->u.derived->ts.is_iso_c && generate) 5037 return generate_isocbinding_initializer (ts->u.derived); 5038 5039 /* See if we have a default initializer in this, but not in nested 5040 types (otherwise we could use gfc_has_default_initializer()). 5041 We don't need to check if we are going to generate them. */ 5042 comp = ts->u.derived->components; 5043 if (!generate) 5044 { 5045 for (; comp; comp = comp->next) 5046 if (comp->initializer || comp_allocatable (comp)) 5047 break; 5048 } 5049 5050 if (!comp) 5051 return NULL__null; 5052 5053 init = gfc_get_structure_constructor_expr (ts->type, ts->kind, 5054 &ts->u.derived->declared_at); 5055 init->ts = *ts; 5056 5057 for (comp = ts->u.derived->components; comp; comp = comp->next) 5058 { 5059 gfc_constructor *ctor = gfc_constructor_get(); 5060 5061 /* Fetch or generate an initializer for the component. */ 5062 tmp = component_initializer (comp, generate); 5063 if (tmp) 5064 { 5065 /* Save the component ref for STRUCTUREs and UNIONs. */ 5066 if (ts->u.derived->attr.flavor == FL_STRUCT 5067 || ts->u.derived->attr.flavor == FL_UNION) 5068 ctor->n.component = comp; 5069 5070 /* If the initializer was not generated, we need a copy. */ 5071 ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; 5072 if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind) 5073 && !comp->attr.pointer && !comp->attr.proc_pointer) 5074 { 5075 bool val; 5076 val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); 5077 if (val == false) 5078 return NULL__null; 5079 } 5080 } 5081 5082 gfc_constructor_append (&init->value.constructor, ctor); 5083 } 5084 5085 return init; 5086} 5087 5088 5089/* Given a symbol, create an expression node with that symbol as a 5090 variable. If the symbol is array valued, setup a reference of the 5091 whole array. */ 5092 5093gfc_expr * 5094gfc_get_variable_expr (gfc_symtree *var) 5095{ 5096 gfc_expr *e; 5097 5098 e = gfc_get_expr (); 5099 e->expr_type = EXPR_VARIABLE; 5100 e->symtree = var; 5101 e->ts = var->n.sym->ts; 5102 5103 if (var->n.sym->attr.flavor != FL_PROCEDURE 5104 && ((var->n.sym->as != NULL__null && var->n.sym->ts.type != BT_CLASS) 5105 || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components 5106 && CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as))) 5107 { 5108 e->rank = var->n.sym->ts.type == BT_CLASS 5109 ? CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as->rank : var->n.sym->as->rank; 5110 e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 5111 e->ref->type = REF_ARRAY; 5112 e->ref->u.ar.type = AR_FULL; 5113 e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS 5114 ? CLASS_DATA (var->n.sym)var->n.sym->ts.u.derived->components->as 5115 : var->n.sym->as); 5116 } 5117 5118 return e; 5119} 5120 5121 5122/* Adds a full array reference to an expression, as needed. */ 5123 5124void 5125gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) 5126{ 5127 gfc_ref *ref; 5128 for (ref = e->ref; ref; ref = ref->next) 5129 if (!ref->next) 5130 break; 5131 if (ref) 5132 { 5133 ref->next = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 5134 ref = ref->next; 5135 } 5136 else 5137 { 5138 e->ref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref))); 5139 ref = e->ref; 5140 } 5141 ref->type = REF_ARRAY; 5142 ref->u.ar.type = AR_FULL; 5143 ref->u.ar.dimen = e->rank; 5144 ref->u.ar.where = e->where; 5145 ref->u.ar.as = as; 5146} 5147 5148 5149gfc_expr * 5150gfc_lval_expr_from_sym (gfc_symbol *sym) 5151{ 5152 gfc_expr *lval; 5153 gfc_array_spec *as; 5154 lval = gfc_get_expr (); 5155 lval->expr_type = EXPR_VARIABLE; 5156 lval->where = sym->declared_at; 5157 lval->ts = sym->ts; 5158 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); 5159 5160 /* It will always be a full array. */ 5161 as = IS_CLASS_ARRAY (sym)(sym->ts.type == BT_CLASS && sym->ts.u.derived->
components && sym->ts.u.derived->components->
attr.dimension && !sym->ts.u.derived->components
->attr.class_pointer)
? CLASS_DATA (sym)sym->ts.u.derived->components->as : sym->as; 5162 lval->rank = as ? as->rank : 0; 5163 if (lval->rank) 5164 gfc_add_full_array_ref (lval, as); 5165 return lval; 5166} 5167 5168 5169/* Returns the array_spec of a full array expression. A NULL is 5170 returned otherwise. */ 5171gfc_array_spec * 5172gfc_get_full_arrayspec_from_expr (gfc_expr *expr) 5173{ 5174 gfc_array_spec *as; 5175 gfc_ref *ref; 5176 5177 if (expr->rank == 0) 5178 return NULL__null; 5179 5180 /* Follow any component references. */ 5181 if (expr->expr_type == EXPR_VARIABLE 5182 || expr->expr_type == EXPR_CONSTANT) 5183 { 5184 if (expr->symtree) 5185 as = expr->symtree->n.sym->as; 5186 else 5187 as = NULL__null; 5188 5189 for (ref = expr->ref; ref; ref = ref->next) 5190 { 5191 switch (ref->type) 5192 { 5193 case REF_COMPONENT: 5194 as = ref->u.c.component->as; 5195 continue; 5196 5197 case REF_SUBSTRING: 5198 case REF_INQUIRY: 5199 continue; 5200 5201 case REF_ARRAY: 5202 { 5203 switch (ref->u.ar.type) 5204 { 5205 case AR_ELEMENT: 5206 case AR_SECTION: 5207 case AR_UNKNOWN: 5208 as = NULL__null; 5209 continue; 5210 5211 case AR_FULL: 5212 break; 5213 } 5214 break; 5215 } 5216 } 5217 } 5218 } 5219 else 5220 as = NULL__null; 5221 5222 return as; 5223} 5224 5225 5226/* General expression traversal function. */ 5227 5228bool 5229gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, 5230 bool (*func)(gfc_expr *, gfc_symbol *, int*), 5231 int f) 5232{ 5233 gfc_array_ref ar; 5234 gfc_ref *ref; 5235 gfc_actual_arglist *args; 5236 gfc_constructor *c; 5237 int i; 5238 5239 if (!expr) 5240 return false; 5241 5242 if ((*func) (expr, sym, &f)) 5243 return true; 5244 5245 if (expr->ts.type == BT_CHARACTER 5246 && expr->ts.u.cl 5247 && expr->ts.u.cl->length 5248 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT 5249 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) 5250 return true; 5251 5252 switch (expr->expr_type) 5253 { 5254 case EXPR_PPC: 5255 case EXPR_COMPCALL: 5256 case EXPR_FUNCTION: 5257 for (args = expr->value.function.actual; args; args = args->next) 5258 { 5259 if (gfc_traverse_expr (args->expr, sym, func, f)) 5260 return true; 5261 } 5262 break; 5263 5264 case EXPR_VARIABLE: 5265 case EXPR_CONSTANT: 5266 case EXPR_NULL: 5267 case EXPR_SUBSTRING: 5268 break; 5269 5270 case EXPR_STRUCTURE: 5271 case EXPR_ARRAY: 5272 for (c = gfc_constructor_first (expr->value.constructor); 5273 c; c = gfc_constructor_next (c)) 5274 { 5275 if (gfc_traverse_expr (c->expr, sym, func, f)) 5276 return true; 5277 if (c->iterator) 5278 { 5279 if (gfc_traverse_expr (c->iterator->var, sym, func, f)) 5280 return true; 5281 if (gfc_traverse_expr (c->iterator->start, sym, func, f)) 5282 return true; 5283 if (gfc_traverse_expr (c->iterator->end, sym, func, f)) 5284 return true; 5285 if (gfc_traverse_expr (c->iterator->step, sym, func, f)) 5286 return true; 5287 } 5288 } 5289 break; 5290 5291 case EXPR_OP: 5292 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) 5293 return true; 5294 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) 5295 return true; 5296 break; 5297 5298 default: 5299 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5299, __FUNCTION__))
; 5300 break; 5301 } 5302 5303 ref = expr->ref; 5304 while (ref != NULL__null) 5305 { 5306 switch (ref->type) 5307 { 5308 case REF_ARRAY: 5309 ar = ref->u.ar; 5310 for (i = 0; i < GFC_MAX_DIMENSIONS15; i++) 5311 { 5312 if (gfc_traverse_expr (ar.start[i], sym, func, f)) 5313 return true; 5314 if (gfc_traverse_expr (ar.end[i], sym, func, f)) 5315 return true; 5316 if (gfc_traverse_expr (ar.stride[i], sym, func, f)) 5317 return true; 5318 } 5319 break; 5320 5321 case REF_SUBSTRING: 5322 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) 5323 return true; 5324 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) 5325 return true; 5326 break; 5327 5328 case REF_COMPONENT: 5329 if (ref->u.c.component->ts.type == BT_CHARACTER 5330 && ref->u.c.component->ts.u.cl 5331 && ref->u.c.component->ts.u.cl->length 5332 && ref->u.c.component->ts.u.cl->length->expr_type 5333 != EXPR_CONSTANT 5334 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, 5335 sym, func, f)) 5336 return true; 5337 5338 if (ref->u.c.component->as) 5339 for (i = 0; i < ref->u.c.component->as->rank 5340 + ref->u.c.component->as->corank; i++) 5341 { 5342 if (gfc_traverse_expr (ref->u.c.component->as->lower[i], 5343 sym, func, f)) 5344 return true; 5345 if (gfc_traverse_expr (ref->u.c.component->as->upper[i], 5346 sym, func, f)) 5347 return true; 5348 } 5349 break; 5350 5351 case REF_INQUIRY: 5352 return true; 5353 5354 default: 5355 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5355, __FUNCTION__))
; 5356 } 5357 ref = ref->next; 5358 } 5359 return false; 5360} 5361 5362/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ 5363 5364static bool 5365expr_set_symbols_referenced (gfc_expr *expr, 5366 gfc_symbol *sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)), 5367 int *f ATTRIBUTE_UNUSED__attribute__ ((__unused__))) 5368{ 5369 if (expr->expr_type != EXPR_VARIABLE) 5370 return false; 5371 gfc_set_sym_referenced (expr->symtree->n.sym); 5372 return false; 5373} 5374 5375void 5376gfc_expr_set_symbols_referenced (gfc_expr *expr) 5377{ 5378 gfc_traverse_expr (expr, NULL__null, expr_set_symbols_referenced, 0); 5379} 5380 5381 5382/* Determine if an expression is a procedure pointer component and return 5383 the component in that case. Otherwise return NULL. */ 5384 5385gfc_component * 5386gfc_get_proc_ptr_comp (gfc_expr *expr) 5387{ 5388 gfc_ref *ref; 5389 5390 if (!expr || !expr->ref) 5391 return NULL__null; 5392 5393 ref = expr->ref; 5394 while (ref->next) 5395 ref = ref->next; 5396 5397 if (ref->type == REF_COMPONENT 5398 && ref->u.c.component->attr.proc_pointer) 5399 return ref->u.c.component; 5400 5401 return NULL__null; 5402} 5403 5404 5405/* Determine if an expression is a procedure pointer component. */ 5406 5407bool 5408gfc_is_proc_ptr_comp (gfc_expr *expr) 5409{ 5410 return (gfc_get_proc_ptr_comp (expr) != NULL__null); 5411} 5412 5413 5414/* Determine if an expression is a function with an allocatable class scalar 5415 result. */ 5416bool 5417gfc_is_alloc_class_scalar_function (gfc_expr *expr) 5418{ 5419 if (expr->expr_type == EXPR_FUNCTION 5420 && expr->value.function.esym 5421 && expr->value.function.esym->result 5422 && expr->value.function.esym->result->ts.type == BT_CLASS 5423 && !CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components
->attr.dimension 5424 && CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components
->attr.allocatable) 5425 return true; 5426 5427 return false; 5428} 5429 5430 5431/* Determine if an expression is a function with an allocatable class array 5432 result. */ 5433bool 5434gfc_is_class_array_function (gfc_expr *expr) 5435{ 5436 if (expr->expr_type == EXPR_FUNCTION 5437 && expr->value.function.esym 5438 && expr->value.function.esym->result 5439 && expr->value.function.esym->result->ts.type == BT_CLASS 5440 && CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components
->attr.dimension 5441 && (CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components
->attr.allocatable 5442 || CLASS_DATA (expr->value.function.esym->result)expr->value.function.esym->result->ts.u.derived->
components
->attr.pointer)) 5443 return true; 5444 5445 return false; 5446} 5447 5448 5449/* Walk an expression tree and check each variable encountered for being typed. 5450 If strict is not set, a top-level variable is tolerated untyped in -std=gnu 5451 mode as is a basic arithmetic expression using those; this is for things in 5452 legacy-code like: 5453 5454 INTEGER :: arr(n), n 5455 INTEGER :: arr(n + 1), n 5456 5457 The namespace is needed for IMPLICIT typing. */ 5458 5459static gfc_namespace* check_typed_ns; 5460 5461static bool 5462expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)), 5463 int* f ATTRIBUTE_UNUSED__attribute__ ((__unused__))) 5464{ 5465 bool t; 5466 5467 if (e->expr_type != EXPR_VARIABLE) 5468 return false; 5469 5470 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5470, __FUNCTION__), 0 : 0))
; 5471 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, 5472 true, e->where); 5473 5474 return (!t); 5475} 5476 5477bool 5478gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) 5479{ 5480 bool error_found; 5481 5482 /* If this is a top-level variable or EXPR_OP, do the check with strict given 5483 to us. */ 5484 if (!strict) 5485 { 5486 if (e->expr_type == EXPR_VARIABLE && !e->ref) 5487 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); 5488 5489 if (e->expr_type == EXPR_OP) 5490 { 5491 bool t = true; 5492 5493 gcc_assert (e->value.op.op1)((void)(!(e->value.op.op1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5493, __FUNCTION__), 0 : 0))
; 5494 t = gfc_expr_check_typed (e->value.op.op1, ns, strict); 5495 5496 if (t && e->value.op.op2) 5497 t = gfc_expr_check_typed (e->value.op.op2, ns, strict); 5498 5499 return t; 5500 } 5501 } 5502 5503 /* Otherwise, walk the expression and do it strictly. */ 5504 check_typed_ns = ns; 5505 error_found = gfc_traverse_expr (e, NULL__null, &expr_check_typed_help, 0); 5506 5507 return error_found ? false : true; 5508} 5509 5510 5511/* This function returns true if it contains any references to PDT KIND 5512 or LEN parameters. */ 5513 5514static bool 5515derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)), 5516 int* f ATTRIBUTE_UNUSED__attribute__ ((__unused__))) 5517{ 5518 if (e->expr_type != EXPR_VARIABLE) 5519 return false; 5520 5521 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5521, __FUNCTION__), 0 : 0))
; 5522 if (e->symtree->n.sym->attr.pdt_kind 5523 || e->symtree->n.sym->attr.pdt_len) 5524 return true; 5525 5526 return false; 5527} 5528 5529 5530bool 5531gfc_derived_parameter_expr (gfc_expr *e) 5532{ 5533 return gfc_traverse_expr (e, NULL__null, &derived_parameter_expr, 0); 5534} 5535 5536 5537/* This function returns the overall type of a type parameter spec list. 5538 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the 5539 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned 5540 unless derived is not NULL. In this latter case, all the LEN parameters 5541 must be either assumed or deferred for the return argument to be set to 5542 anything other than SPEC_EXPLICIT. */ 5543 5544gfc_param_spec_type 5545gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) 5546{ 5547 gfc_param_spec_type res = SPEC_EXPLICIT; 5548 gfc_component *c; 5549 bool seen_assumed = false; 5550 bool seen_deferred = false; 5551 5552 if (derived == NULL__null) 5553 { 5554 for (; param_list; param_list = param_list->next) 5555 if (param_list->spec_type == SPEC_ASSUMED 5556 || param_list->spec_type == SPEC_DEFERRED) 5557 return param_list->spec_type; 5558 } 5559 else 5560 { 5561 for (; param_list; param_list = param_list->next) 5562 { 5563 c = gfc_find_component (derived, param_list->name, 5564 true, true, NULL__null); 5565 gcc_assert (c != NULL)((void)(!(c != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5565, __FUNCTION__), 0 : 0))
; 5566 if (c->attr.pdt_kind) 5567 continue; 5568 else if (param_list->spec_type == SPEC_EXPLICIT) 5569 return SPEC_EXPLICIT; 5570 seen_assumed = param_list->spec_type == SPEC_ASSUMED; 5571 seen_deferred = param_list->spec_type == SPEC_DEFERRED; 5572 if (seen_assumed && seen_deferred) 5573 return SPEC_EXPLICIT; 5574 } 5575 res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; 5576 } 5577 return res; 5578} 5579 5580 5581bool 5582gfc_ref_this_image (gfc_ref *ref) 5583{ 5584 int n; 5585 5586 gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)((void)(!(ref->type == REF_ARRAY && ref->u.ar.codimen
> 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5586, __FUNCTION__), 0 : 0))
; 5587 5588 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) 5589 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) 5590 return false; 5591 5592 return true; 5593} 5594 5595gfc_expr * 5596gfc_find_team_co (gfc_expr *e) 5597{ 5598 gfc_ref *ref; 5599 5600 for (ref = e->ref; ref; ref = ref->next) 5601 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5602 return ref->u.ar.team; 5603 5604 if (e->value.function.actual->expr) 5605 for (ref = e->value.function.actual->expr->ref; ref; 5606 ref = ref->next) 5607 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5608 return ref->u.ar.team; 5609 5610 return NULL__null; 5611} 5612 5613gfc_expr * 5614gfc_find_stat_co (gfc_expr *e) 5615{ 5616 gfc_ref *ref; 5617 5618 for (ref = e->ref; ref; ref = ref->next) 5619 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5620 return ref->u.ar.stat; 5621 5622 if (e->value.function.actual->expr) 5623 for (ref = e->value.function.actual->expr->ref; ref; 5624 ref = ref->next) 5625 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5626 return ref->u.ar.stat; 5627 5628 return NULL__null; 5629} 5630 5631bool 5632gfc_is_coindexed (gfc_expr *e) 5633{ 5634 gfc_ref *ref; 5635 5636 for (ref = e->ref; ref; ref = ref->next) 5637 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5638 return !gfc_ref_this_image (ref); 5639 5640 return false; 5641} 5642 5643 5644/* Coarrays are variables with a corank but not being coindexed. However, also 5645 the following is a coarray: A subobject of a coarray is a coarray if it does 5646 not have any cosubscripts, vector subscripts, allocatable component 5647 selection, or pointer component selection. (F2008, 2.4.7) */ 5648 5649bool 5650gfc_is_coarray (gfc_expr *e) 5651{ 5652 gfc_ref *ref; 5653 gfc_symbol *sym; 5654 gfc_component *comp; 5655 bool coindexed; 5656 bool coarray; 5657 int i; 5658 5659 if (e->expr_type != EXPR_VARIABLE) 5660 return false; 5661 5662 coindexed = false; 5663 sym = e->symtree->n.sym; 5664 5665 if (sym->ts.type == BT_CLASS && sym->attr.class_ok) 5666 coarray = CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension; 5667 else 5668 coarray = sym->attr.codimension; 5669 5670 for (ref = e->ref; ref; ref = ref->next) 5671 switch (ref->type) 5672 { 5673 case REF_COMPONENT: 5674 comp = ref->u.c.component; 5675 if (comp->ts.type == BT_CLASS && comp->attr.class_ok 5676 && (CLASS_DATA (comp)comp->ts.u.derived->components->attr.class_pointer 5677 || CLASS_DATA (comp)comp->ts.u.derived->components->attr.allocatable)) 5678 { 5679 coindexed = false; 5680 coarray = CLASS_DATA (comp)comp->ts.u.derived->components->attr.codimension; 5681 } 5682 else if (comp->attr.pointer || comp->attr.allocatable) 5683 { 5684 coindexed = false; 5685 coarray = comp->attr.codimension; 5686 } 5687 break; 5688 5689 case REF_ARRAY: 5690 if (!coarray) 5691 break; 5692 5693 if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) 5694 { 5695 coindexed = true; 5696 break; 5697 } 5698 5699 for (i = 0; i < ref->u.ar.dimen; i++) 5700 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 5701 { 5702 coarray = false; 5703 break; 5704 } 5705 break; 5706 5707 case REF_SUBSTRING: 5708 case REF_INQUIRY: 5709 break; 5710 } 5711 5712 return coarray && !coindexed; 5713} 5714 5715 5716int 5717gfc_get_corank (gfc_expr *e) 5718{ 5719 int corank; 5720 gfc_ref *ref; 5721 5722 if (!gfc_is_coarray (e)) 5723 return 0; 5724 5725 if (e->ts.type == BT_CLASS && e->ts.u.derived->components) 5726 corank = e->ts.u.derived->components->as 5727 ? e->ts.u.derived->components->as->corank : 0; 5728 else 5729 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; 5730 5731 for (ref = e->ref; ref; ref = ref->next) 5732 { 5733 if (ref->type == REF_ARRAY) 5734 corank = ref->u.ar.as->corank; 5735 gcc_assert (ref->type != REF_SUBSTRING)((void)(!(ref->type != REF_SUBSTRING) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5735, __FUNCTION__), 0 : 0))
; 5736 } 5737 5738 return corank; 5739} 5740 5741 5742/* Check whether the expression has an ultimate allocatable component. 5743 Being itself allocatable does not count. */ 5744bool 5745gfc_has_ultimate_allocatable (gfc_expr *e) 5746{ 5747 gfc_ref *ref, *last = NULL__null; 5748 5749 if (e->expr_type != EXPR_VARIABLE) 5750 return false; 5751 5752 for (ref = e->ref; ref; ref = ref->next) 5753 if (ref->type == REF_COMPONENT) 5754 last = ref; 5755 5756 if (last && last->u.c.component->ts.type == BT_CLASS) 5757 return CLASS_DATA (last->u.c.component)last->u.c.component->ts.u.derived->components->attr.alloc_comp; 5758 else if (last && last->u.c.component->ts.type == BT_DERIVED) 5759 return last->u.c.component->ts.u.derived->attr.alloc_comp; 5760 else if (last) 5761 return false; 5762 5763 if (e->ts.type == BT_CLASS) 5764 return CLASS_DATA (e)e->ts.u.derived->components->attr.alloc_comp; 5765 else if (e->ts.type == BT_DERIVED) 5766 return e->ts.u.derived->attr.alloc_comp; 5767 else 5768 return false; 5769} 5770 5771 5772/* Check whether the expression has an pointer component. 5773 Being itself a pointer does not count. */ 5774bool 5775gfc_has_ultimate_pointer (gfc_expr *e) 5776{ 5777 gfc_ref *ref, *last = NULL__null; 5778 5779 if (e->expr_type != EXPR_VARIABLE) 5780 return false; 5781 5782 for (ref = e->ref; ref; ref = ref->next) 5783 if (ref->type == REF_COMPONENT) 5784 last = ref; 5785 5786 if (last && last->u.c.component->ts.type == BT_CLASS) 5787 return CLASS_DATA (last->u.c.component)last->u.c.component->ts.u.derived->components->attr.pointer_comp; 5788 else if (last && last->u.c.component->ts.type == BT_DERIVED) 5789 return last->u.c.component->ts.u.derived->attr.pointer_comp; 5790 else if (last) 5791 return false; 5792 5793 if (e->ts.type == BT_CLASS) 5794 return CLASS_DATA (e)e->ts.u.derived->components->attr.pointer_comp; 5795 else if (e->ts.type == BT_DERIVED) 5796 return e->ts.u.derived->attr.pointer_comp; 5797 else 5798 return false; 5799} 5800 5801 5802/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. 5803 Note: A scalar is not regarded as "simply contiguous" by the standard. 5804 if bool is not strict, some further checks are done - for instance, 5805 a "(::1)" is accepted. */ 5806 5807bool 5808gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) 5809{ 5810 bool colon; 5811 int i; 5812 gfc_array_ref *ar = NULL__null; 5813 gfc_ref *ref, *part_ref = NULL__null; 5814 gfc_symbol *sym; 5815 5816 if (expr->expr_type == EXPR_ARRAY) 5817 return true; 5818 5819 if (expr->expr_type == EXPR_FUNCTION) 5820 { 5821 if (expr->value.function.esym) 5822 return expr->value.function.esym->result->attr.contiguous; 5823 else 5824 { 5825 /* Type-bound procedures. */ 5826 gfc_symbol *s = expr->symtree->n.sym; 5827 if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED) 5828 return false; 5829 5830 gfc_ref *rc = NULL__null; 5831 for (gfc_ref *r = expr->ref; r; r = r->next) 5832 if (r->type == REF_COMPONENT) 5833 rc = r; 5834 5835 if (rc == NULL__null || rc->u.c.component == NULL__null 5836 || rc->u.c.component->ts.interface == NULL__null) 5837 return false; 5838 5839 return rc->u.c.component->ts.interface->attr.contiguous; 5840 } 5841 } 5842 else if (expr->expr_type != EXPR_VARIABLE) 5843 return false; 5844 5845 if (!permit_element && expr->rank == 0) 5846 return false; 5847 5848 for (ref = expr->ref; ref; ref = ref->next) 5849 { 5850 if (ar) 5851 return false; /* Array shall be last part-ref. */ 5852 5853 if (ref->type == REF_COMPONENT) 5854 part_ref = ref; 5855 else if (ref->type == REF_SUBSTRING) 5856 return false; 5857 else if (ref->u.ar.type != AR_ELEMENT) 5858 ar = &ref->u.ar; 5859 } 5860 5861 sym = expr->symtree->n.sym; 5862 if (expr->ts.type != BT_CLASS 5863 && ((part_ref 5864 && !part_ref->u.c.component->attr.contiguous 5865 && part_ref->u.c.component->attr.pointer) 5866 || (!part_ref 5867 && !sym->attr.contiguous 5868 && (sym->attr.pointer 5869 || (sym->as && sym->as->type == AS_ASSUMED_RANK) 5870 || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))) 5871 return false; 5872 5873 if (!ar || ar->type == AR_FULL) 5874 return true; 5875 5876 gcc_assert (ar->type == AR_SECTION)((void)(!(ar->type == AR_SECTION) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5876, __FUNCTION__), 0 : 0))
; 5877 5878 /* Check for simply contiguous array */ 5879 colon = true; 5880 for (i = 0; i < ar->dimen; i++) 5881 { 5882 if (ar->dimen_type[i] == DIMEN_VECTOR) 5883 return false; 5884 5885 if (ar->dimen_type[i] == DIMEN_ELEMENT) 5886 { 5887 colon = false; 5888 continue; 5889 } 5890 5891 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE)((void)(!(ar->dimen_type[i] == DIMEN_RANGE) ? fancy_abort (
"/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 5891, __FUNCTION__), 0 : 0))
; 5892 5893 5894 /* If the previous section was not contiguous, that's an error, 5895 unless we have effective only one element and checking is not 5896 strict. */ 5897 if (!colon && (strict || !ar->start[i] || !ar->end[i] 5898 || ar->start[i]->expr_type != EXPR_CONSTANT 5899 || ar->end[i]->expr_type != EXPR_CONSTANT 5900 || mpz_cmp__gmpz_cmp (ar->start[i]->value.integer, 5901 ar->end[i]->value.integer) != 0)) 5902 return false; 5903 5904 /* Following the standard, "(::1)" or - if known at compile time - 5905 "(lbound:ubound)" are not simply contiguous; if strict 5906 is false, they are regarded as simply contiguous. */ 5907 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT 5908 || ar->stride[i]->ts.type != BT_INTEGER 5909 || mpz_cmp_si (ar->stride[i]->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
&& ((static_cast<unsigned long> (1))) == 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> (1)))) : __gmpz_cmp_si (ar->stride[i
]->value.integer,1))
!= 0)) 5910 return false; 5911 5912 if (ar->start[i] 5913 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT 5914 || !ar->as->lower[i] 5915 || ar->as->lower[i]->expr_type != EXPR_CONSTANT 5916 || mpz_cmp__gmpz_cmp (ar->start[i]->value.integer, 5917 ar->as->lower[i]->value.integer) != 0)) 5918 colon = false; 5919 5920 if (ar->end[i] 5921 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT 5922 || !ar->as->upper[i] 5923 || ar->as->upper[i]->expr_type != EXPR_CONSTANT 5924 || mpz_cmp__gmpz_cmp (ar->end[i]->value.integer, 5925 ar->as->upper[i]->value.integer) != 0)) 5926 colon = false; 5927 } 5928 5929 return true; 5930} 5931 5932/* Return true if the expression is guaranteed to be non-contiguous, 5933 false if we cannot prove anything. It is probably best to call 5934 this after gfc_is_simply_contiguous. If neither of them returns 5935 true, we cannot say (at compile-time). */ 5936 5937bool 5938gfc_is_not_contiguous (gfc_expr *array) 5939{ 5940 int i; 5941 gfc_array_ref *ar = NULL__null; 5942 gfc_ref *ref; 5943 bool previous_incomplete; 5944 5945 for (ref = array->ref; ref; ref = ref->next) 5946 { 5947 /* Array-ref shall be last ref. */ 5948 5949 if (ar && ar->type != AR_ELEMENT) 5950 return true; 5951 5952 if (ref->type == REF_ARRAY) 5953 ar = &ref->u.ar; 5954 } 5955 5956 if (ar == NULL__null || ar->type != AR_SECTION) 5957 return false; 5958 5959 previous_incomplete = false; 5960 5961 /* Check if we can prove that the array is not contiguous. */ 5962 5963 for (i = 0; i < ar->dimen; i++) 5964 { 5965 mpz_t arr_size, ref_size; 5966 5967 if (gfc_ref_dimen_size (ar, i, &ref_size, NULL__null)) 5968 { 5969 if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size)) 5970 { 5971 /* a(2:4,2:) is known to be non-contiguous, but 5972 a(2:4,i:i) can be contiguous. */ 5973 mpz_add_ui__gmpz_add_ui (arr_size, arr_size, 1L); 5974 if (previous_incomplete && mpz_cmp_si (ref_size, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
&& ((static_cast<unsigned long> (1))) == 0 ? (
(ref_size)->_mp_size < 0 ? -1 : (ref_size)->_mp_size
> 0) : __gmpz_cmp_ui (ref_size,(static_cast<unsigned long
> (1)))) : __gmpz_cmp_si (ref_size,1))
!= 0) 5975 { 5976 mpz_clear__gmpz_clear (arr_size); 5977 mpz_clear__gmpz_clear (ref_size); 5978 return true; 5979 } 5980 else if (mpz_cmp__gmpz_cmp (arr_size, ref_size) != 0) 5981 previous_incomplete = true; 5982 5983 mpz_clear__gmpz_clear (arr_size); 5984 } 5985 5986 /* Check for a(::2), i.e. where the stride is not unity. 5987 This is only done if there is more than one element in 5988 the reference along this dimension. */ 5989 5990 if (mpz_cmp_ui (ref_size, 1)(__builtin_constant_p (1) && (1) == 0 ? ((ref_size)->
_mp_size < 0 ? -1 : (ref_size)->_mp_size > 0) : __gmpz_cmp_ui
(ref_size,1))
> 0 && ar->type == AR_SECTION 5991 && ar->dimen_type[i] == DIMEN_RANGE 5992 && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT 5993 && mpz_cmp_si (ar->stride[i]->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
&& ((static_cast<unsigned long> (1))) == 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> (1)))) : __gmpz_cmp_si (ar->stride[i
]->value.integer,1))
!= 0) 5994 { 5995 mpz_clear__gmpz_clear (ref_size); 5996 return true; 5997 } 5998 5999 mpz_clear__gmpz_clear (ref_size); 6000 } 6001 } 6002 /* We didn't find anything definitive. */ 6003 return false; 6004} 6005 6006/* Build call to an intrinsic procedure. The number of arguments has to be 6007 passed (rather than ending the list with a NULL value) because we may 6008 want to add arguments but with a NULL-expression. */ 6009 6010gfc_expr* 6011gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, 6012 locus where, unsigned numarg, ...) 6013{ 6014 gfc_expr* result; 6015 gfc_actual_arglist* atail; 6016 gfc_intrinsic_sym* isym; 6017 va_list ap; 6018 unsigned i; 6019 const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s")"_F." "%s", name); 6020 6021 isym = gfc_intrinsic_function_by_id (id); 6022 gcc_assert (isym)((void)(!(isym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6022, __FUNCTION__), 0 : 0))
; 6023 6024 result = gfc_get_expr (); 6025 result->expr_type = EXPR_FUNCTION; 6026 result->ts = isym->ts; 6027 result->where = where; 6028 result->value.function.name = mangled_name; 6029 result->value.function.isym = isym; 6030 6031 gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); 6032 gfc_commit_symbol (result->symtree->n.sym); 6033 gcc_assert (result->symtree((void)(!(result->symtree && (result->symtree->
n.sym->attr.flavor == FL_PROCEDURE || result->symtree->
n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6035, __FUNCTION__), 0 : 0))
6034 && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE((void)(!(result->symtree && (result->symtree->
n.sym->attr.flavor == FL_PROCEDURE || result->symtree->
n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6035, __FUNCTION__), 0 : 0))
6035 || result->symtree->n.sym->attr.flavor == FL_UNKNOWN))((void)(!(result->symtree && (result->symtree->
n.sym->attr.flavor == FL_PROCEDURE || result->symtree->
n.sym->attr.flavor == FL_UNKNOWN)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6035, __FUNCTION__), 0 : 0))
; 6036 result->symtree->n.sym->intmod_sym_id = id; 6037 result->symtree->n.sym->attr.flavor = FL_PROCEDURE; 6038 result->symtree->n.sym->attr.intrinsic = 1; 6039 result->symtree->n.sym->attr.artificial = 1; 6040 6041 va_start (ap, numarg)__builtin_va_start(ap, numarg); 6042 atail = NULL__null; 6043 for (i = 0; i < numarg; ++i) 6044 { 6045 if (atail) 6046 { 6047 atail->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
; 6048 atail = atail->next; 6049 } 6050 else 6051 atail = result->value.function.actual = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
; 6052 6053 atail->expr = va_arg (ap, gfc_expr*)__builtin_va_arg(ap, gfc_expr*); 6054 } 6055 va_end (ap)__builtin_va_end(ap); 6056 6057 return result; 6058} 6059 6060 6061/* Check if an expression may appear in a variable definition context 6062 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). 6063 This is called from the various places when resolving 6064 the pieces that make up such a context. 6065 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do 6066 variables), some checks are not performed. 6067 6068 Optionally, a possible error message can be suppressed if context is NULL 6069 and just the return status (true / false) be requested. */ 6070 6071bool 6072gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, 6073 bool own_scope, const char* context) 6074{ 6075 gfc_symbol* sym = NULL__null; 6076 bool is_pointer; 6077 bool check_intentin; 6078 bool ptr_component; 6079 symbol_attribute attr; 6080 gfc_ref* ref; 6081 int i; 6082 6083 if (e->expr_type == EXPR_VARIABLE) 6084 { 6085 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6085, __FUNCTION__), 0 : 0))
; 6086 sym = e->symtree->n.sym; 6087 } 6088 else if (e->expr_type == EXPR_FUNCTION) 6089 { 6090 gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6090, __FUNCTION__), 0 : 0))
; 6091 sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; 6092 } 6093 6094 attr = gfc_expr_attr (e); 6095 if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) 6096 { 6097 if (!(gfc_option.allow_std & GFC_STD_F2008(1<<7))) 6098 { 6099 if (context) 6100 gfc_error ("Fortran 2008: Pointer functions in variable definition" 6101 " context (%s) at %L", context, &e->where); 6102 return false; 6103 } 6104 } 6105 else if (e->expr_type != EXPR_VARIABLE) 6106 { 6107 if (context) 6108 gfc_error ("Non-variable expression in variable definition context (%s)" 6109 " at %L", context, &e->where); 6110 return false; 6111 } 6112 6113 if (!pointer && sym->attr.flavor == FL_PARAMETER) 6114 { 6115 if (context) 6116 gfc_error ("Named constant %qs in variable definition context (%s)" 6117 " at %L", sym->name, context, &e->where); 6118 return false; 6119 } 6120 if (!pointer && sym->attr.flavor != FL_VARIABLE 6121 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) 6122 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) 6123 { 6124 if (context) 6125 gfc_error ("%qs in variable definition context (%s) at %L is not" 6126 " a variable", sym->name, context, &e->where); 6127 return false; 6128 } 6129 6130 /* Find out whether the expr is a pointer; this also means following 6131 component references to the last one. */ 6132 is_pointer = (attr.pointer || attr.proc_pointer); 6133 if (pointer && !is_pointer) 6134 { 6135 if (context) 6136 gfc_error ("Non-POINTER in pointer association context (%s)" 6137 " at %L", context, &e->where); 6138 return false; 6139 } 6140 6141 if (e->ts.type == BT_DERIVED 6142 && e->ts.u.derived == NULL__null) 6143 { 6144 if (context) 6145 gfc_error ("Type inaccessible in variable definition context (%s) " 6146 "at %L", context, &e->where); 6147 return false; 6148 } 6149 6150 /* F2008, C1303. */ 6151 if (!alloc_obj 6152 && (attr.lock_comp 6153 || (e->ts.type == BT_DERIVED 6154 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 6155 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) 6156 { 6157 if (context) 6158 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", 6159 context, &e->where); 6160 return false; 6161 } 6162 6163 /* TS18508, C702/C203. */ 6164 if (!alloc_obj 6165 && (attr.lock_comp 6166 || (e->ts.type == BT_DERIVED 6167 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 6168 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) 6169 { 6170 if (context) 6171 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", 6172 context, &e->where); 6173 return false; 6174 } 6175 6176 /* INTENT(IN) dummy argument. Check this, unless the object itself is the 6177 component of sub-component of a pointer; we need to distinguish 6178 assignment to a pointer component from pointer-assignment to a pointer 6179 component. Note that (normal) assignment to procedure pointers is not 6180 possible. */ 6181 check_intentin = !own_scope; 6182 ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived 6183 && CLASS_DATA (sym)sym->ts.u.derived->components) 6184 ? CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer : sym->attr.pointer; 6185 for (ref = e->ref; ref && check_intentin; ref = ref->next) 6186 { 6187 if (ptr_component && ref->type == REF_COMPONENT) 6188 check_intentin = false; 6189 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) 6190 { 6191 ptr_component = true; 6192 if (!pointer) 6193 check_intentin = false; 6194 } 6195 } 6196 6197 if (check_intentin 6198 && (sym->attr.intent == INTENT_IN 6199 || (sym->attr.select_type_temporary && sym->assoc 6200 && sym->assoc->target && sym->assoc->target->symtree 6201 && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN))) 6202 { 6203 if (pointer && is_pointer) 6204 { 6205 if (context) 6206 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" 6207 " association context (%s) at %L", 6208 sym->name, context, &e->where); 6209 return false; 6210 } 6211 if (!pointer && !is_pointer && !sym->attr.pointer) 6212 { 6213 const char *name = sym->attr.select_type_temporary 6214 ? sym->assoc->target->symtree->name : sym->name; 6215 if (context) 6216 gfc_error ("Dummy argument %qs with INTENT(IN) in variable" 6217 " definition context (%s) at %L", 6218 name, context, &e->where); 6219 return false; 6220 } 6221 } 6222 6223 /* PROTECTED and use-associated. */ 6224 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) 6225 { 6226 if (pointer && is_pointer) 6227 { 6228 if (context) 6229 gfc_error ("Variable %qs is PROTECTED and cannot appear in a" 6230 " pointer association context (%s) at %L", 6231 sym->name, context, &e->where); 6232 return false; 6233 } 6234 if (!pointer && !is_pointer) 6235 { 6236 if (context) 6237 gfc_error ("Variable %qs is PROTECTED and cannot appear in a" 6238 " variable definition context (%s) at %L", 6239 sym->name, context, &e->where); 6240 return false; 6241 } 6242 } 6243 6244 /* Variable not assignable from a PURE procedure but appears in 6245 variable definition context. */ 6246 if (!pointer && !own_scope && gfc_pure (NULL__null) && gfc_impure_variable (sym)) 6247 { 6248 if (context) 6249 gfc_error ("Variable %qs cannot appear in a variable definition" 6250 " context (%s) at %L in PURE procedure", 6251 sym->name, context, &e->where); 6252 return false; 6253 } 6254 6255 if (!pointer && context && gfc_implicit_pure (NULL__null) 6256 && gfc_impure_variable (sym)) 6257 { 6258 gfc_namespace *ns; 6259 gfc_symbol *sym; 6260 6261 for (ns = gfc_current_ns; ns; ns = ns->parent) 6262 { 6263 sym = ns->proc_name; 6264 if (sym == NULL__null) 6265 break; 6266 if (sym->attr.flavor == FL_PROCEDURE) 6267 { 6268 sym->attr.implicit_pure = 0; 6269 break; 6270 } 6271 } 6272 } 6273 /* Check variable definition context for associate-names. */ 6274 if (!pointer && sym->assoc && !sym->attr.select_rank_temporary) 6275 { 6276 const char* name; 6277 gfc_association_list* assoc; 6278 6279 gcc_assert (sym->assoc->target)((void)(!(sym->assoc->target) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6279, __FUNCTION__), 0 : 0))
; 6280 6281 /* If this is a SELECT TYPE temporary (the association is used internally 6282 for SELECT TYPE), silently go over to the target. */ 6283 if (sym->attr.select_type_temporary) 6284 { 6285 gfc_expr* t = sym->assoc->target; 6286 6287 gcc_assert (t->expr_type == EXPR_VARIABLE)((void)(!(t->expr_type == EXPR_VARIABLE) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6287, __FUNCTION__), 0 : 0))
; 6288 name = t->symtree->name; 6289 6290 if (t->symtree->n.sym->assoc) 6291 assoc = t->symtree->n.sym->assoc; 6292 else 6293 assoc = sym->assoc; 6294 } 6295 else 6296 { 6297 name = sym->name; 6298 assoc = sym->assoc; 6299 } 6300 gcc_assert (name && assoc)((void)(!(name && assoc) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/expr.c"
, 6300, __FUNCTION__), 0 : 0))
; 6301 6302 /* Is association to a valid variable? */ 6303 if (!assoc->variable) 6304 { 6305 if (context) 6306 { 6307 if (assoc->target->expr_type == EXPR_VARIABLE) 6308 gfc_error ("%qs at %L associated to vector-indexed target" 6309 " cannot be used in a variable definition" 6310 " context (%s)", 6311 name, &e->where, context); 6312 else 6313 gfc_error ("%qs at %L associated to expression" 6314 " cannot be used in a variable definition" 6315 " context (%s)", 6316 name, &e->where, context); 6317 } 6318 return false; 6319 } 6320 6321 /* Target must be allowed to appear in a variable definition context. */ 6322 if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL__null)) 6323 { 6324 if (context) 6325 gfc_error ("Associate-name %qs cannot appear in a variable" 6326 " definition context (%s) at %L because its target" 6327 " at %L cannot, either", 6328 name, context, &e->where, 6329 &assoc->target->where); 6330 return false; 6331 } 6332 } 6333 6334 /* Check for same value in vector expression subscript. */ 6335 6336 if (e->rank > 0) 6337 for (ref = e->ref; ref != NULL__null; ref = ref->next) 6338 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) 6339 for (i = 0; i < GFC_MAX_DIMENSIONS15 6340 && ref->u.ar.dimen_type[i] != 0; i++) 6341 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 6342 { 6343 gfc_expr *arr = ref->u.ar.start[i]; 6344 if (arr->expr_type == EXPR_ARRAY) 6345 { 6346 gfc_constructor *c, *n; 6347 gfc_expr *ec, *en; 6348 6349 for (c = gfc_constructor_first (arr->value.constructor); 6350 c != NULL__null; c = gfc_constructor_next (c)) 6351 { 6352 if (c == NULL__null || c->iterator != NULL__null) 6353 continue; 6354 6355 ec = c->expr; 6356 6357 for (n = gfc_constructor_next (c); n != NULL__null; 6358 n = gfc_constructor_next (n)) 6359 { 6360 if (n->iterator != NULL__null) 6361 continue; 6362 6363 en = n->expr; 6364 if (gfc_dep_compare_expr (ec, en) == 0) 6365 { 6366 if (context) 6367 gfc_error_now ("Elements with the same value " 6368 "at %L and %L in vector " 6369 "subscript in a variable " 6370 "definition context (%s)", 6371 &(ec->where), &(en->where), 6372 context); 6373 return false; 6374 } 6375 } 6376 } 6377 } 6378 } 6379 6380 return true; 6381}