Bug Summary

File:build/gcc/fortran/simplify.c
Warning:line 677, column 8
The expression is an uninitialized value. The computed value will also be garbage

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 simplify.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/13.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11/backward -internal-isystem /usr/lib64/clang/13.0.0/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-11-20-133755-20252-1/report-iWcZv1.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c
1/* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2021 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
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 "tm.h" /* For BITS_PER_UNIT. */
25#include "gfortran.h"
26#include "arith.h"
27#include "intrinsic.h"
28#include "match.h"
29#include "target-memory.h"
30#include "constructor.h"
31#include "version.h" /* For version_string. */
32
33/* Prototypes. */
34
35static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false);
36
37gfc_expr gfc_bad_expr;
38
39static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int);
40
41
42/* Note that 'simplification' is not just transforming expressions.
43 For functions that are not simplified at compile time, range
44 checking is done if possible.
45
46 The return convention is that each simplification function returns:
47
48 A new expression node corresponding to the simplified arguments.
49 The original arguments are destroyed by the caller, and must not
50 be a part of the new expression.
51
52 NULL pointer indicating that no simplification was possible and
53 the original expression should remain intact.
54
55 An expression pointer to gfc_bad_expr (a static placeholder)
56 indicating that some error has prevented simplification. The
57 error is generated within the function and should be propagated
58 upwards
59
60 By the time a simplification function gets control, it has been
61 decided that the function call is really supposed to be the
62 intrinsic. No type checking is strictly necessary, since only
63 valid types will be passed on. On the other hand, a simplification
64 subroutine may have to look at the type of an argument as part of
65 its processing.
66
67 Array arguments are only passed to these subroutines that implement
68 the simplification of transformational intrinsics.
69
70 The functions in this file don't have much comment with them, but
71 everything is reasonably straight-forward. The Standard, chapter 13
72 is the best comment you'll find for this file anyway. */
73
74/* Range checks an expression node. If all goes well, returns the
75 node, otherwise returns &gfc_bad_expr and frees the node. */
76
77static gfc_expr *
78range_check (gfc_expr *result, const char *name)
79{
80 if (result == NULL__null)
81 return &gfc_bad_expr;
82
83 if (result->expr_type != EXPR_CONSTANT)
84 return result;
85
86 switch (gfc_range_check (result))
87 {
88 case ARITH_OK:
89 return result;
90
91 case ARITH_OVERFLOW:
92 gfc_error ("Result of %s overflows its kind at %L", name,
93 &result->where);
94 break;
95
96 case ARITH_UNDERFLOW:
97 gfc_error ("Result of %s underflows its kind at %L", name,
98 &result->where);
99 break;
100
101 case ARITH_NAN:
102 gfc_error ("Result of %s is NaN at %L", name, &result->where);
103 break;
104
105 default:
106 gfc_error ("Result of %s gives range error for its kind at %L", name,
107 &result->where);
108 break;
109 }
110
111 gfc_free_expr (result);
112 return &gfc_bad_expr;
113}
114
115
116/* A helper function that gets an optional and possibly missing
117 kind parameter. Returns the kind, -1 if something went wrong. */
118
119static int
120get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
121{
122 int kind;
123
124 if (k == NULL__null)
125 return default_kind;
126
127 if (k->expr_type != EXPR_CONSTANT)
128 {
129 gfc_error ("KIND parameter of %s at %L must be an initialization "
130 "expression", name, &k->where);
131 return -1;
132 }
133
134 if (gfc_extract_int (k, &kind)
135 || gfc_validate_kind (type, kind, true) < 0)
136 {
137 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
138 return -1;
139 }
140
141 return kind;
142}
143
144
145/* Converts an mpz_t signed variable into an unsigned one, assuming
146 two's complement representations and a binary width of bitsize.
147 The conversion is a no-op unless x is negative; otherwise, it can
148 be accomplished by masking out the high bits. */
149
150static void
151convert_mpz_to_unsigned (mpz_t x, int bitsize)
152{
153 mpz_t mask;
154
155 if (mpz_sgn (x)((x)->_mp_size < 0 ? -1 : (x)->_mp_size > 0) < 0)
156 {
157 /* Confirm that no bits above the signed range are unset if we
158 are doing range checking. */
159 if (flag_range_checkglobal_options.x_flag_range_check != 0)
160 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX)((void)(!(__gmpz_scan0 (x, bitsize-1) == (9223372036854775807L
*2UL+1UL)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 160, __FUNCTION__), 0 : 0))
;
161
162 mpz_init_set_ui__gmpz_init_set_ui (mask, 1);
163 mpz_mul_2exp__gmpz_mul_2exp (mask, mask, bitsize);
164 mpz_sub_ui__gmpz_sub_ui (mask, mask, 1);
165
166 mpz_and__gmpz_and (x, x, mask);
167
168 mpz_clear__gmpz_clear (mask);
169 }
170 else
171 {
172 /* Confirm that no bits above the signed range are set if we
173 are doing range checking. */
174 if (flag_range_checkglobal_options.x_flag_range_check != 0)
175 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX)((void)(!(__gmpz_scan1 (x, bitsize-1) == (9223372036854775807L
*2UL+1UL)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 175, __FUNCTION__), 0 : 0))
;
176 }
177}
178
179
180/* Converts an mpz_t unsigned variable into a signed one, assuming
181 two's complement representations and a binary width of bitsize.
182 If the bitsize-1 bit is set, this is taken as a sign bit and
183 the number is converted to the corresponding negative number. */
184
185void
186gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
187{
188 mpz_t mask;
189
190 /* Confirm that no bits above the unsigned range are set if we are
191 doing range checking. */
192 if (flag_range_checkglobal_options.x_flag_range_check != 0)
193 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX)((void)(!(__gmpz_scan1 (x, bitsize) == (9223372036854775807L *
2UL+1UL)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 193, __FUNCTION__), 0 : 0))
;
194
195 if (mpz_tstbit__gmpz_tstbit (x, bitsize - 1) == 1)
196 {
197 mpz_init_set_ui__gmpz_init_set_ui (mask, 1);
198 mpz_mul_2exp__gmpz_mul_2exp (mask, mask, bitsize);
199 mpz_sub_ui__gmpz_sub_ui (mask, mask, 1);
200
201 /* We negate the number by hand, zeroing the high bits, that is
202 make it the corresponding positive number, and then have it
203 negated by GMP, giving the correct representation of the
204 negative number. */
205 mpz_com__gmpz_com (x, x);
206 mpz_add_ui__gmpz_add_ui (x, x, 1);
207 mpz_and__gmpz_and (x, x, mask);
208
209 mpz_neg__gmpz_neg (x, x);
210
211 mpz_clear__gmpz_clear (mask);
212 }
213}
214
215
216/* Test that the expression is a constant array, simplifying if
217 we are dealing with a parameter array. */
218
219static bool
220is_constant_array_expr (gfc_expr *e)
221{
222 gfc_constructor *c;
223 bool array_OK = true;
224 mpz_t size;
225
226 if (e == NULL__null)
227 return true;
228
229 if (e->expr_type == EXPR_VARIABLE && e->rank > 0
230 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
231 gfc_simplify_expr (e, 1);
232
233 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
234 return false;
235
236 for (c = gfc_constructor_first (e->value.constructor);
237 c; c = gfc_constructor_next (c))
238 if (c->expr->expr_type != EXPR_CONSTANT
239 && c->expr->expr_type != EXPR_STRUCTURE)
240 {
241 array_OK = false;
242 break;
243 }
244
245 /* Check and expand the constructor. */
246 if (!array_OK && gfc_init_expr_flag && e->rank == 1)
247 {
248 array_OK = gfc_reduce_init_expr (e);
249 /* gfc_reduce_init_expr resets the flag. */
250 gfc_init_expr_flag = true;
251 }
252 else
253 return array_OK;
254
255 /* Recheck to make sure that any EXPR_ARRAYs have gone. */
256 for (c = gfc_constructor_first (e->value.constructor);
257 c; c = gfc_constructor_next (c))
258 if (c->expr->expr_type != EXPR_CONSTANT
259 && c->expr->expr_type != EXPR_STRUCTURE)
260 return false;
261
262 /* Make sure that the array has a valid shape. */
263 if (e->shape == NULL__null && e->rank == 1)
264 {
265 if (!gfc_array_size(e, &size))
266 return false;
267 e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
268 mpz_init_set__gmpz_init_set (e->shape[0], size);
269 mpz_clear__gmpz_clear (size);
270 }
271
272 return array_OK;
273}
274
275/* Test for a size zero array. */
276bool
277gfc_is_size_zero_array (gfc_expr *array)
278{
279
280 if (array->rank == 0)
3
Assuming field 'rank' is not equal to 0
4
Taking false branch
281 return false;
282
283 if (array->expr_type == EXPR_VARIABLE && array->rank > 0
5
Assuming field 'expr_type' is not equal to EXPR_VARIABLE
284 && array->symtree->n.sym->attr.flavor == FL_PARAMETER
285 && array->shape != NULL__null)
286 {
287 for (int i = 0; i < array->rank; i++)
288 if (mpz_cmp_si (array->shape[i], 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
&& ((static_cast<unsigned long> (0))) == 0 ? (
(array->shape[i])->_mp_size < 0 ? -1 : (array->shape
[i])->_mp_size > 0) : __gmpz_cmp_ui (array->shape[i]
,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (array
->shape[i],0))
<= 0)
289 return true;
290
291 return false;
292 }
293
294 if (array->expr_type == EXPR_ARRAY)
6
Assuming field 'expr_type' is not equal to EXPR_ARRAY
7
Taking false branch
295 return array->value.constructor == NULL__null;
296
297 return false;
8
Returning zero, which participates in a condition later
298}
299
300
301/* Initialize a transformational result expression with a given value. */
302
303static void
304init_result_expr (gfc_expr *e, int init, gfc_expr *array)
305{
306 if (e && e->expr_type == EXPR_ARRAY)
307 {
308 gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
309 while (ctor)
310 {
311 init_result_expr (ctor->expr, init, array);
312 ctor = gfc_constructor_next (ctor);
313 }
314 }
315 else if (e && e->expr_type == EXPR_CONSTANT)
316 {
317 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
318 HOST_WIDE_INTlong length;
319 gfc_char_t *string;
320
321 switch (e->ts.type)
322 {
323 case BT_LOGICAL:
324 e->value.logical = (init ? 1 : 0);
325 break;
326
327 case BT_INTEGER:
328 if (init == INT_MIN(-2147483647 -1))
329 mpz_set__gmpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
330 else if (init == INT_MAX2147483647)
331 mpz_set__gmpz_set (e->value.integer, gfc_integer_kinds[i].huge);
332 else
333 mpz_set_si__gmpz_set_si (e->value.integer, init);
334 break;
335
336 case BT_REAL:
337 if (init == INT_MIN(-2147483647 -1))
338 {
339 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)mpfr_set4(e->value.real,gfc_real_kinds[i].huge,MPFR_RNDN,(
(gfc_real_kinds[i].huge)->_mpfr_sign))
;
340 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODEMPFR_RNDN);
341 }
342 else if (init == INT_MAX2147483647)
343 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)mpfr_set4(e->value.real,gfc_real_kinds[i].huge,MPFR_RNDN,(
(gfc_real_kinds[i].huge)->_mpfr_sign))
;
344 else
345 mpfr_set_si (e->value.real, init, GFC_RND_MODEMPFR_RNDN);
346 break;
347
348 case BT_COMPLEX:
349 mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
350 break;
351
352 case BT_CHARACTER:
353 if (init == INT_MIN(-2147483647 -1))
354 {
355 gfc_expr *len = gfc_simplify_len (array, NULL__null);
356 gfc_extract_hwi (len, &length);
357 string = gfc_get_wide_string (length + 1)((gfc_char_t *) xcalloc ((length + 1), sizeof (gfc_char_t)));
358 gfc_wide_memset (string, 0, length);
359 }
360 else if (init == INT_MAX2147483647)
361 {
362 gfc_expr *len = gfc_simplify_len (array, NULL__null);
363 gfc_extract_hwi (len, &length);
364 string = gfc_get_wide_string (length + 1)((gfc_char_t *) xcalloc ((length + 1), sizeof (gfc_char_t)));
365 gfc_wide_memset (string, 255, length);
366 }
367 else
368 {
369 length = 0;
370 string = gfc_get_wide_string (1)((gfc_char_t *) xcalloc ((1), sizeof (gfc_char_t)));
371 }
372
373 string[length] = '\0';
374 e->value.character.length = length;
375 e->value.character.string = string;
376 break;
377
378 default:
379 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 379, __FUNCTION__))
;
380 }
381 }
382 else
383 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 383, __FUNCTION__))
;
384}
385
386
387/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
388 if conj_a is true, the matrix_a is complex conjugated. */
389
390static gfc_expr *
391compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
392 gfc_expr *matrix_b, int stride_b, int offset_b,
393 bool conj_a)
394{
395 gfc_expr *result, *a, *b, *c;
396
397 /* Set result to an INTEGER(1) 0 for numeric types and .false. for
398 LOGICAL. Mixed-mode math in the loop will promote result to the
399 correct type and kind. */
400 if (matrix_a->ts.type == BT_LOGICAL)
401 result = gfc_get_logical_expr (gfc_default_logical_kind, NULL__null, false);
402 else
403 result = gfc_get_int_expr (1, NULL__null, 0);
404 result->where = matrix_a->where;
405
406 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
407 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
408 while (a && b)
409 {
410 /* Copying of expressions is required as operands are free'd
411 by the gfc_arith routines. */
412 switch (result->ts.type)
413 {
414 case BT_LOGICAL:
415 result = gfc_or (result,
416 gfc_and (gfc_copy_expr (a),
417 gfc_copy_expr (b)));
418 break;
419
420 case BT_INTEGER:
421 case BT_REAL:
422 case BT_COMPLEX:
423 if (conj_a && a->ts.type == BT_COMPLEX)
424 c = gfc_simplify_conjg (a);
425 else
426 c = gfc_copy_expr (a);
427 result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
428 break;
429
430 default:
431 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 431, __FUNCTION__))
;
432 }
433
434 offset_a += stride_a;
435 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
436
437 offset_b += stride_b;
438 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
439 }
440
441 return result;
442}
443
444
445/* Build a result expression for transformational intrinsics,
446 depending on DIM. */
447
448static gfc_expr *
449transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
450 int kind, locus* where)
451{
452 gfc_expr *result;
453 int i, nelem;
454
455 if (!dim || array->rank == 1)
16
Assuming 'dim' is non-null
17
Assuming field 'rank' is equal to 1
18
Taking true branch
456 return gfc_get_constant_expr (type, kind, where);
457
458 result = gfc_get_array_expr (type, kind, where);
459 result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
460 result->rank = array->rank - 1;
461
462 /* gfc_array_size() would count the number of elements in the constructor,
463 we have not built those yet. */
464 nelem = 1;
465 for (i = 0; i < result->rank; ++i)
466 nelem *= mpz_get_ui__gmpz_get_ui (result->shape[i]);
467
468 for (i = 0; i < nelem; ++i)
469 {
470 gfc_constructor_append_expr (&result->value.constructor,
471 gfc_get_constant_expr (type, kind, where),
472 NULL__null);
473 }
474
475 return result;
476}
477
478
479typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
480
481/* Wrapper function, implements 'op1 += 1'. Only called if MASK
482 of COUNT intrinsic is .TRUE..
483
484 Interface and implementation mimics arith functions as
485 gfc_add, gfc_multiply, etc. */
486
487static gfc_expr *
488gfc_count (gfc_expr *op1, gfc_expr *op2)
489{
490 gfc_expr *result;
491
492 gcc_assert (op1->ts.type == BT_INTEGER)((void)(!(op1->ts.type == BT_INTEGER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 492, __FUNCTION__), 0 : 0))
;
493 gcc_assert (op2->ts.type == BT_LOGICAL)((void)(!(op2->ts.type == BT_LOGICAL) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 493, __FUNCTION__), 0 : 0))
;
494 gcc_assert (op2->value.logical)((void)(!(op2->value.logical) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 494, __FUNCTION__), 0 : 0))
;
495
496 result = gfc_copy_expr (op1);
497 mpz_add_ui__gmpz_add_ui (result->value.integer, result->value.integer, 1);
498
499 gfc_free_expr (op1);
500 gfc_free_expr (op2);
501 return result;
502}
503
504
505/* Transforms an ARRAY with operation OP, according to MASK, to a
506 scalar RESULT. E.g. called if
507
508 REAL, PARAMETER :: array(n, m) = ...
509 REAL, PARAMETER :: s = SUM(array)
510
511 where OP == gfc_add(). */
512
513static gfc_expr *
514simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
515 transformational_op op)
516{
517 gfc_expr *a, *m;
518 gfc_constructor *array_ctor, *mask_ctor;
519
520 /* Shortcut for constant .FALSE. MASK. */
521 if (mask
522 && mask->expr_type == EXPR_CONSTANT
523 && !mask->value.logical)
524 return result;
525
526 array_ctor = gfc_constructor_first (array->value.constructor);
527 mask_ctor = NULL__null;
528 if (mask && mask->expr_type == EXPR_ARRAY)
529 mask_ctor = gfc_constructor_first (mask->value.constructor);
530
531 while (array_ctor)
532 {
533 a = array_ctor->expr;
534 array_ctor = gfc_constructor_next (array_ctor);
535
536 /* A constant MASK equals .TRUE. here and can be ignored. */
537 if (mask_ctor)
538 {
539 m = mask_ctor->expr;
540 mask_ctor = gfc_constructor_next (mask_ctor);
541 if (!m->value.logical)
542 continue;
543 }
544
545 result = op (result, gfc_copy_expr (a));
546 if (!result)
547 return result;
548 }
549
550 return result;
551}
552
553/* Transforms an ARRAY with operation OP, according to MASK, to an
554 array RESULT. E.g. called if
555
556 REAL, PARAMETER :: array(n, m) = ...
557 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
558
559 where OP == gfc_multiply().
560 The result might be post processed using post_op. */
561
562static gfc_expr *
563simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
564 gfc_expr *mask, transformational_op op,
565 transformational_op post_op)
566{
567 mpz_t size;
568 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
569 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
570 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
571
572 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
573 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15],
574 tmpstride[GFC_MAX_DIMENSIONS15];
575
576 /* Shortcut for constant .FALSE. MASK. */
577 if (mask
23.1
'mask' is null
578 && mask->expr_type == EXPR_CONSTANT 579 && !mask->value.logical) 580 return result; 581 582 /* Build an indexed table for array element expressions to minimize 583 linked-list traversal. Masked elements are set to NULL. */ 584 gfc_array_size (array, &size); 585 arraysize = mpz_get_ui__gmpz_get_ui (size); 586 mpz_clear__gmpz_clear (size); 587 588 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*))); 589 590 array_ctor = gfc_constructor_first (array->value.constructor); 591 mask_ctor = NULL__null; 592 if (mask
23.2
'mask' is null
&& mask->expr_type == EXPR_ARRAY) 593 mask_ctor = gfc_constructor_first (mask->value.constructor); 594 595 for (i = 0; i < arraysize; ++i)
24
Loop condition is false. Execution continues on line 610
596 { 597 arrayvec[i] = array_ctor->expr; 598 array_ctor = gfc_constructor_next (array_ctor); 599 600 if (mask_ctor) 601 { 602 if (!mask_ctor->expr->value.logical) 603 arrayvec[i] = NULL__null; 604 605 mask_ctor = gfc_constructor_next (mask_ctor); 606 } 607 } 608 609 /* Same for the result expression. */ 610 gfc_array_size (result, &size); 611 resultsize = mpz_get_ui__gmpz_get_ui (size); 612 mpz_clear__gmpz_clear (size); 613 614 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*))); 615 result_ctor = gfc_constructor_first (result->value.constructor); 616 for (i = 0; i < resultsize; ++i)
25
Assuming 'i' is < 'resultsize'
26
Loop condition is true. Entering loop body
27
Assuming 'i' is >= 'resultsize'
28
Loop condition is false. Execution continues on line 622
617 { 618 resultvec[i] = result_ctor->expr; 619 result_ctor = gfc_constructor_next (result_ctor); 620 } 621 622 gfc_extract_int (dim, &dim_index); 623 dim_index -= 1; /* zero-base index */ 624 dim_extent = 0; 625 dim_stride = 0; 626 627 for (i = 0, n = 0; i < array->rank; ++i)
29
Assuming 'i' is < field 'rank'
30
Loop condition is true. Entering loop body
35
Assuming 'i' is >= field 'rank'
36
Loop condition is false. Execution continues on line 644
628 { 629 count[i] = 0; 630 tmpstride[i] = (i
30.1
'i' is equal to 0
== 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
31
'?' condition is true
631 if (i == dim_index)
32
Assuming 'i' is not equal to 'dim_index'
33
Taking false branch
632 { 633 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]); 634 dim_stride = tmpstride[i]; 635 continue; 636 } 637 638 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]); 639 sstride[n] = tmpstride[i]; 640 dstride[n] = (n
33.1
'n' is equal to 0
== 0) ? 1 : dstride[n-1] * extent[n-1];
34
'?' condition is true
641 n += 1; 642 } 643 644 done = resultsize <= 0; 645 base = arrayvec; 646 dest = resultvec; 647 while (!done)
37
Loop condition is true. Entering loop body
648 { 649 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
38
Loop condition is false. Execution continues on line 653
650 if (*src) 651 *dest = op (*dest, gfc_copy_expr (*src)); 652 653 if (post_op
38.1
'post_op' is null
)
39
Taking false branch
654 *dest = post_op (*dest, *dest); 655 656 count[0]++; 657 base += sstride[0]; 658 dest += dstride[0]; 659 660 n = 0; 661 while (!done
39.1
'done' is 0
&& count[n] == extent[n])
40
Assuming the condition is true
41
Loop condition is true. Entering loop body
662 { 663 count[n] = 0; 664 base -= sstride[n] * extent[n]; 665 dest -= dstride[n] * extent[n]; 666 667 n++;
42
The value 1 is assigned to 'n'
668 if (n < result->rank)
43
Assuming 'n' is < field 'rank'
44
Taking true branch
669 { 670 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 671 times, we'd warn for the last iteration, because the 672 array index will have already been incremented to the 673 array sizes, and we can't tell that this must make 674 the test against result->rank false, because ranks 675 must not exceed GFC_MAX_DIMENSIONS. */ 676 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 677 count[n]++;
45
The expression is an uninitialized value. The computed value will also be garbage
678 base += sstride[n]; 679 dest += dstride[n]; 680 GCC_DIAGNOSTIC_POP 681 } 682 else 683 done = true; 684 } 685 } 686 687 /* Place updated expression in result constructor. */ 688 result_ctor = gfc_constructor_first (result->value.constructor); 689 for (i = 0; i < resultsize; ++i) 690 { 691 result_ctor->expr = resultvec[i]; 692 result_ctor = gfc_constructor_next (result_ctor); 693 } 694 695 free (arrayvec); 696 free (resultvec); 697 return result; 698} 699 700 701static gfc_expr * 702simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 703 int init_val, transformational_op op) 704{ 705 gfc_expr *result; 706 bool size_zero; 707 708 size_zero = gfc_is_size_zero_array (array);
2
Calling 'gfc_is_size_zero_array'
9
Returning from 'gfc_is_size_zero_array'
709 710 if (!(is_constant_array_expr (array) || size_zero)
10
Assuming the condition is true
12
Taking false branch
711 || !gfc_is_constant_expr (dim))
11
Assuming the condition is false
712 return NULL__null; 713 714 if (mask
13
Assuming pointer value is null
14
Assuming 'mask' is null
715 && !is_constant_array_expr (mask) 716 && mask->expr_type != EXPR_CONSTANT) 717 return NULL__null; 718 719 result = transformational_result (array, dim, array->ts.type,
15
Calling 'transformational_result'
19
Returning from 'transformational_result'
720 array->ts.kind, &array->where); 721 init_result_expr (result, init_val, array); 722 723 if (size_zero
19.1
'size_zero' is false
)
20
Taking false branch
724 return result; 725 726 return !dim
20.1
'dim' is non-null
|| array->rank == 1 ?
21
Assuming field 'rank' is not equal to 1
22
'?' condition is false
727 simplify_transformation_to_scalar (result, array, mask, op) : 728 simplify_transformation_to_array (result, array, dim, mask, op, NULL__null);
23
Calling 'simplify_transformation_to_array'
729} 730 731 732/********************** Simplification functions *****************************/ 733 734gfc_expr * 735gfc_simplify_abs (gfc_expr *e) 736{ 737 gfc_expr *result; 738 739 if (e->expr_type != EXPR_CONSTANT) 740 return NULL__null; 741 742 switch (e->ts.type) 743 { 744 case BT_INTEGER: 745 result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); 746 mpz_abs__gmpz_abs (result->value.integer, e->value.integer); 747 return range_check (result, "IABS"); 748 749 case BT_REAL: 750 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 751 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,e->value.real,MPFR_RNDN,1); 752 return range_check (result, "ABS"); 753 754 case BT_COMPLEX: 755 gfc_set_model_kind (e->ts.kind); 756 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 757 mpc_abs (result->value.real, e->value.complex, GFC_RND_MODEMPFR_RNDN); 758 return range_check (result, "CABS"); 759 760 default: 761 gfc_internal_error ("gfc_simplify_abs(): Bad type"); 762 } 763} 764 765 766static gfc_expr * 767simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) 768{ 769 gfc_expr *result; 770 int kind; 771 bool too_large = false; 772 773 if (e->expr_type != EXPR_CONSTANT) 774 return NULL__null; 775 776 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); 777 if (kind == -1) 778 return &gfc_bad_expr; 779 780 if (mpz_cmp_si (e->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
&& ((static_cast<unsigned long> (0))) == 0 ? (
(e->value.integer)->_mp_size < 0 ? -1 : (e->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer
,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e->
value.integer,0))
< 0) 781 { 782 gfc_error ("Argument of %s function at %L is negative", name, 783 &e->where); 784 return &gfc_bad_expr; 785 } 786 787 if (ascii && warn_surprisingglobal_options.x_warn_surprising && mpz_cmp_si (e->value.integer, 127)(__builtin_constant_p ((127) >= 0) && (127) >= 0
? (__builtin_constant_p ((static_cast<unsigned long> (
127))) && ((static_cast<unsigned long> (127))) ==
0 ? ((e->value.integer)->_mp_size < 0 ? -1 : (e->
value.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value
.integer,(static_cast<unsigned long> (127)))) : __gmpz_cmp_si
(e->value.integer,127))
> 0) 788 gfc_warning (OPT_Wsurprising, 789 "Argument of %s function at %L outside of range [0,127]", 790 name, &e->where); 791 792 if (kind == 1 && mpz_cmp_si (e->value.integer, 255)(__builtin_constant_p ((255) >= 0) && (255) >= 0
? (__builtin_constant_p ((static_cast<unsigned long> (
255))) && ((static_cast<unsigned long> (255))) ==
0 ? ((e->value.integer)->_mp_size < 0 ? -1 : (e->
value.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value
.integer,(static_cast<unsigned long> (255)))) : __gmpz_cmp_si
(e->value.integer,255))
> 0) 793 too_large = true; 794 else if (kind == 4) 795 { 796 mpz_t t; 797 mpz_init_set_ui__gmpz_init_set_ui (t, 2); 798 mpz_pow_ui__gmpz_pow_ui (t, t, 32); 799 mpz_sub_ui__gmpz_sub_ui (t, t, 1); 800 if (mpz_cmp__gmpz_cmp (e->value.integer, t) > 0) 801 too_large = true; 802 mpz_clear__gmpz_clear (t); 803 } 804 805 if (too_large) 806 { 807 gfc_error ("Argument of %s function at %L is too large for the " 808 "collating sequence of kind %d", name, &e->where, kind); 809 return &gfc_bad_expr; 810 } 811 812 result = gfc_get_character_expr (kind, &e->where, NULL__null, 1); 813 result->value.character.string[0] = mpz_get_ui__gmpz_get_ui (e->value.integer); 814 815 return result; 816} 817 818 819 820/* We use the processor's collating sequence, because all 821 systems that gfortran currently works on are ASCII. */ 822 823gfc_expr * 824gfc_simplify_achar (gfc_expr *e, gfc_expr *k) 825{ 826 return simplify_achar_char (e, k, "ACHAR", true); 827} 828 829 830gfc_expr * 831gfc_simplify_acos (gfc_expr *x) 832{ 833 gfc_expr *result; 834 835 if (x->expr_type != EXPR_CONSTANT) 836 return NULL__null; 837 838 switch (x->ts.type) 839 { 840 case BT_REAL: 841 if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0 842 || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0) 843 { 844 gfc_error ("Argument of ACOS at %L must be between -1 and 1", 845 &x->where); 846 return &gfc_bad_expr; 847 } 848 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 849 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 850 break; 851 852 case BT_COMPLEX: 853 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 854 mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 855 break; 856 857 default: 858 gfc_internal_error ("in gfc_simplify_acos(): Bad type"); 859 } 860 861 return range_check (result, "ACOS"); 862} 863 864gfc_expr * 865gfc_simplify_acosh (gfc_expr *x) 866{ 867 gfc_expr *result; 868 869 if (x->expr_type != EXPR_CONSTANT) 870 return NULL__null; 871 872 switch (x->ts.type) 873 { 874 case BT_REAL: 875 if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) < 0) 876 { 877 gfc_error ("Argument of ACOSH at %L must not be less than 1", 878 &x->where); 879 return &gfc_bad_expr; 880 } 881 882 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 883 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 884 break; 885 886 case BT_COMPLEX: 887 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 888 mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 889 break; 890 891 default: 892 gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); 893 } 894 895 return range_check (result, "ACOSH"); 896} 897 898gfc_expr * 899gfc_simplify_adjustl (gfc_expr *e) 900{ 901 gfc_expr *result; 902 int count, i, len; 903 gfc_char_t ch; 904 905 if (e->expr_type != EXPR_CONSTANT) 906 return NULL__null; 907 908 len = e->value.character.length; 909 910 for (count = 0, i = 0; i < len; ++i) 911 { 912 ch = e->value.character.string[i]; 913 if (ch != ' ') 914 break; 915 ++count; 916 } 917 918 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, len); 919 for (i = 0; i < len - count; ++i) 920 result->value.character.string[i] = e->value.character.string[count + i]; 921 922 return result; 923} 924 925 926gfc_expr * 927gfc_simplify_adjustr (gfc_expr *e) 928{ 929 gfc_expr *result; 930 int count, i, len; 931 gfc_char_t ch; 932 933 if (e->expr_type != EXPR_CONSTANT) 934 return NULL__null; 935 936 len = e->value.character.length; 937 938 for (count = 0, i = len - 1; i >= 0; --i) 939 { 940 ch = e->value.character.string[i]; 941 if (ch != ' ') 942 break; 943 ++count; 944 } 945 946 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, len); 947 for (i = 0; i < count; ++i) 948 result->value.character.string[i] = ' '; 949 950 for (i = count; i < len; ++i) 951 result->value.character.string[i] = e->value.character.string[i - count]; 952 953 return result; 954} 955 956 957gfc_expr * 958gfc_simplify_aimag (gfc_expr *e) 959{ 960 gfc_expr *result; 961 962 if (e->expr_type != EXPR_CONSTANT) 963 return NULL__null; 964 965 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 966 mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE)mpfr_set4(result->value.real,((e->value.complex)->im
),MPFR_RNDN,((((e->value.complex)->im))->_mpfr_sign)
)
; 967 968 return range_check (result, "AIMAG"); 969} 970 971 972gfc_expr * 973gfc_simplify_aint (gfc_expr *e, gfc_expr *k) 974{ 975 gfc_expr *rtrunc, *result; 976 int kind; 977 978 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); 979 if (kind == -1) 980 return &gfc_bad_expr; 981 982 if (e->expr_type != EXPR_CONSTANT) 983 return NULL__null; 984 985 rtrunc = gfc_copy_expr (e); 986 mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
)
; 987 988 result = gfc_real2real (rtrunc, kind); 989 990 gfc_free_expr (rtrunc); 991 992 return range_check (result, "AINT"); 993} 994 995 996gfc_expr * 997gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) 998{ 999 return simplify_transformation (mask, dim, NULL__null, true, gfc_and); 1000} 1001 1002 1003gfc_expr * 1004gfc_simplify_dint (gfc_expr *e) 1005{ 1006 gfc_expr *rtrunc, *result; 1007 1008 if (e->expr_type != EXPR_CONSTANT) 1009 return NULL__null; 1010 1011 rtrunc = gfc_copy_expr (e); 1012 mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
)
; 1013 1014 result = gfc_real2real (rtrunc, gfc_default_double_kind); 1015 1016 gfc_free_expr (rtrunc); 1017 1018 return range_check (result, "DINT"); 1019} 1020 1021 1022gfc_expr * 1023gfc_simplify_dreal (gfc_expr *e) 1024{ 1025 gfc_expr *result = NULL__null; 1026 1027 if (e->expr_type != EXPR_CONSTANT) 1028 return NULL__null; 1029 1030 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 1031 mpc_real (result->value.real, e->value.complex, GFC_RND_MODEMPFR_RNDN); 1032 1033 return range_check (result, "DREAL"); 1034} 1035 1036 1037gfc_expr * 1038gfc_simplify_anint (gfc_expr *e, gfc_expr *k) 1039{ 1040 gfc_expr *result; 1041 int kind; 1042 1043 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); 1044 if (kind == -1) 1045 return &gfc_bad_expr; 1046 1047 if (e->expr_type != EXPR_CONSTANT) 1048 return NULL__null; 1049 1050 result = gfc_get_constant_expr (e->ts.type, kind, &e->where); 1051 mpfr_round (result->value.real, e->value.real)mpfr_rint((result->value.real), (e->value.real), MPFR_RNDNA
)
; 1052 1053 return range_check (result, "ANINT"); 1054} 1055 1056 1057gfc_expr * 1058gfc_simplify_and (gfc_expr *x, gfc_expr *y) 1059{ 1060 gfc_expr *result; 1061 int kind; 1062 1063 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1064 return NULL__null; 1065 1066 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 1067 1068 switch (x->ts.type) 1069 { 1070 case BT_INTEGER: 1071 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 1072 mpz_and__gmpz_and (result->value.integer, x->value.integer, y->value.integer); 1073 return range_check (result, "AND"); 1074 1075 case BT_LOGICAL: 1076 return gfc_get_logical_expr (kind, &x->where, 1077 x->value.logical && y->value.logical); 1078 1079 default: 1080 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1080, __FUNCTION__))
; 1081 } 1082} 1083 1084 1085gfc_expr * 1086gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) 1087{ 1088 return simplify_transformation (mask, dim, NULL__null, false, gfc_or); 1089} 1090 1091 1092gfc_expr * 1093gfc_simplify_dnint (gfc_expr *e) 1094{ 1095 gfc_expr *result; 1096 1097 if (e->expr_type != EXPR_CONSTANT) 1098 return NULL__null; 1099 1100 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); 1101 mpfr_round (result->value.real, e->value.real)mpfr_rint((result->value.real), (e->value.real), MPFR_RNDNA
)
; 1102 1103 return range_check (result, "DNINT"); 1104} 1105 1106 1107gfc_expr * 1108gfc_simplify_asin (gfc_expr *x) 1109{ 1110 gfc_expr *result; 1111 1112 if (x->expr_type != EXPR_CONSTANT) 1113 return NULL__null; 1114 1115 switch (x->ts.type) 1116 { 1117 case BT_REAL: 1118 if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0 1119 || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0) 1120 { 1121 gfc_error ("Argument of ASIN at %L must be between -1 and 1", 1122 &x->where); 1123 return &gfc_bad_expr; 1124 } 1125 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1126 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1127 break; 1128 1129 case BT_COMPLEX: 1130 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1131 mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1132 break; 1133 1134 default: 1135 gfc_internal_error ("in gfc_simplify_asin(): Bad type"); 1136 } 1137 1138 return range_check (result, "ASIN"); 1139} 1140 1141 1142/* Convert radians to degrees, i.e., x * 180 / pi. */ 1143 1144static void 1145rad2deg (mpfr_t x) 1146{ 1147 mpfr_t tmp; 1148 1149 mpfr_init (tmp); 1150 mpfr_const_pi (tmp, GFC_RND_MODEMPFR_RNDN); 1151 mpfr_mul_ui (x, x, 180, GFC_RND_MODEMPFR_RNDN); 1152 mpfr_div (x, x, tmp, GFC_RND_MODEMPFR_RNDN); 1153 mpfr_clear (tmp); 1154} 1155 1156 1157/* Simplify ACOSD(X) where the returned value has units of degree. */ 1158 1159gfc_expr * 1160gfc_simplify_acosd (gfc_expr *x) 1161{ 1162 gfc_expr *result; 1163 1164 if (x->expr_type != EXPR_CONSTANT) 1165 return NULL__null; 1166 1167 if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0 1168 || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0) 1169 { 1170 gfc_error ("Argument of ACOSD at %L must be between -1 and 1", 1171 &x->where); 1172 return &gfc_bad_expr; 1173 } 1174 1175 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1176 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1177 rad2deg (result->value.real); 1178 1179 return range_check (result, "ACOSD"); 1180} 1181 1182 1183/* Simplify asind (x) where the returned value has units of degree. */ 1184 1185gfc_expr * 1186gfc_simplify_asind (gfc_expr *x) 1187{ 1188 gfc_expr *result; 1189 1190 if (x->expr_type != EXPR_CONSTANT) 1191 return NULL__null; 1192 1193 if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0 1194 || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 0) 1195 { 1196 gfc_error ("Argument of ASIND at %L must be between -1 and 1", 1197 &x->where); 1198 return &gfc_bad_expr; 1199 } 1200 1201 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1202 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1203 rad2deg (result->value.real); 1204 1205 return range_check (result, "ASIND"); 1206} 1207 1208 1209/* Simplify atand (x) where the returned value has units of degree. */ 1210 1211gfc_expr * 1212gfc_simplify_atand (gfc_expr *x) 1213{ 1214 gfc_expr *result; 1215 1216 if (x->expr_type != EXPR_CONSTANT) 1217 return NULL__null; 1218 1219 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1220 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1221 rad2deg (result->value.real); 1222 1223 return range_check (result, "ATAND"); 1224} 1225 1226 1227gfc_expr * 1228gfc_simplify_asinh (gfc_expr *x) 1229{ 1230 gfc_expr *result; 1231 1232 if (x->expr_type != EXPR_CONSTANT) 1233 return NULL__null; 1234 1235 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1236 1237 switch (x->ts.type) 1238 { 1239 case BT_REAL: 1240 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1241 break; 1242 1243 case BT_COMPLEX: 1244 mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1245 break; 1246 1247 default: 1248 gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); 1249 } 1250 1251 return range_check (result, "ASINH"); 1252} 1253 1254 1255gfc_expr * 1256gfc_simplify_atan (gfc_expr *x) 1257{ 1258 gfc_expr *result; 1259 1260 if (x->expr_type != EXPR_CONSTANT) 1261 return NULL__null; 1262 1263 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1264 1265 switch (x->ts.type) 1266 { 1267 case BT_REAL: 1268 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1269 break; 1270 1271 case BT_COMPLEX: 1272 mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1273 break; 1274 1275 default: 1276 gfc_internal_error ("in gfc_simplify_atan(): Bad type"); 1277 } 1278 1279 return range_check (result, "ATAN"); 1280} 1281 1282 1283gfc_expr * 1284gfc_simplify_atanh (gfc_expr *x) 1285{ 1286 gfc_expr *result; 1287 1288 if (x->expr_type != EXPR_CONSTANT) 1289 return NULL__null; 1290 1291 switch (x->ts.type) 1292 { 1293 case BT_REAL: 1294 if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) >= 0 1295 || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) <= 0) 1296 { 1297 gfc_error ("Argument of ATANH at %L must be inside the range -1 " 1298 "to 1", &x->where); 1299 return &gfc_bad_expr; 1300 } 1301 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1302 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1303 break; 1304 1305 case BT_COMPLEX: 1306 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1307 mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1308 break; 1309 1310 default: 1311 gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); 1312 } 1313 1314 return range_check (result, "ATANH"); 1315} 1316 1317 1318gfc_expr * 1319gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) 1320{ 1321 gfc_expr *result; 1322 1323 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1324 return NULL__null; 1325 1326 if (mpfr_zero_p (y->value.real)((y->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
&& mpfr_zero_p (x->value.real)((x->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
) 1327 { 1328 gfc_error ("If first argument of ATAN2 at %L is zero, then the " 1329 "second argument must not be zero", &y->where); 1330 return &gfc_bad_expr; 1331 } 1332 1333 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1334 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1335 1336 return range_check (result, "ATAN2"); 1337} 1338 1339 1340gfc_expr * 1341gfc_simplify_bessel_j0 (gfc_expr *x) 1342{ 1343 gfc_expr *result; 1344 1345 if (x->expr_type != EXPR_CONSTANT) 1346 return NULL__null; 1347 1348 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1349 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1350 1351 return range_check (result, "BESSEL_J0"); 1352} 1353 1354 1355gfc_expr * 1356gfc_simplify_bessel_j1 (gfc_expr *x) 1357{ 1358 gfc_expr *result; 1359 1360 if (x->expr_type != EXPR_CONSTANT) 1361 return NULL__null; 1362 1363 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1364 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1365 1366 return range_check (result, "BESSEL_J1"); 1367} 1368 1369 1370gfc_expr * 1371gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) 1372{ 1373 gfc_expr *result; 1374 long n; 1375 1376 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) 1377 return NULL__null; 1378 1379 n = mpz_get_si__gmpz_get_si (order->value.integer); 1380 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1381 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODEMPFR_RNDN); 1382 1383 return range_check (result, "BESSEL_JN"); 1384} 1385 1386 1387/* Simplify transformational form of JN and YN. */ 1388 1389static gfc_expr * 1390gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, 1391 bool jn) 1392{ 1393 gfc_expr *result; 1394 gfc_expr *e; 1395 long n1, n2; 1396 int i; 1397 mpfr_t x2rev, last1, last2; 1398 1399 if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT 1400 || order2->expr_type != EXPR_CONSTANT) 1401 return NULL__null; 1402 1403 n1 = mpz_get_si__gmpz_get_si (order1->value.integer); 1404 n2 = mpz_get_si__gmpz_get_si (order2->value.integer); 1405 result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); 1406 result->rank = 1; 1407 result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 1408 mpz_init_set_ui__gmpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)((n2-n1+1) > (0) ? (n2-n1+1) : (0))); 1409 1410 if (n2 < n1) 1411 return result; 1412 1413 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and 1414 YN(N, 0.0) = -Inf. */ 1415 1416 if (mpfr_cmp_ui (x->value.real, 0.0)mpfr_cmp_ui_2exp((x->value.real),(0.0),0) == 0) 1417 { 1418 if (!jn && flag_range_checkglobal_options.x_flag_range_check) 1419 { 1420 gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); 1421 gfc_free_expr (result); 1422 return &gfc_bad_expr; 1423 } 1424 1425 if (jn && n1 == 0) 1426 { 1427 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1428 mpfr_set_ui (e->value.real, 1, GFC_RND_MODEMPFR_RNDN); 1429 gfc_constructor_append_expr (&result->value.constructor, e, 1430 &x->where); 1431 n1++; 1432 } 1433 1434 for (i = n1; i <= n2; i++) 1435 { 1436 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1437 if (jn) 1438 mpfr_set_ui (e->value.real, 0, GFC_RND_MODEMPFR_RNDN); 1439 else 1440 mpfr_set_inf (e->value.real, -1); 1441 gfc_constructor_append_expr (&result->value.constructor, e, 1442 &x->where); 1443 } 1444 1445 return result; 1446 } 1447 1448 /* Use the faster but more verbose recurrence algorithm. Bessel functions 1449 are stable for downward recursion and Neumann functions are stable 1450 for upward recursion. It is 1451 x2rev = 2.0/x, 1452 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), 1453 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). 1454 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ 1455 1456 gfc_set_model_kind (x->ts.kind); 1457 1458 /* Get first recursion anchor. */ 1459 1460 mpfr_init (last1); 1461 if (jn) 1462 mpfr_jn (last1, n2, x->value.real, GFC_RND_MODEMPFR_RNDN); 1463 else 1464 mpfr_yn (last1, n1, x->value.real, GFC_RND_MODEMPFR_RNDN); 1465 1466 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1467 mpfr_set (e->value.real, last1, GFC_RND_MODE)mpfr_set4(e->value.real,last1,MPFR_RNDN,((last1)->_mpfr_sign
))
; 1468 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1469 { 1470 mpfr_clear (last1); 1471 gfc_free_expr (e); 1472 gfc_free_expr (result); 1473 return &gfc_bad_expr; 1474 } 1475 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1476 1477 if (n1 == n2) 1478 { 1479 mpfr_clear (last1); 1480 return result; 1481 } 1482 1483 /* Get second recursion anchor. */ 1484 1485 mpfr_init (last2); 1486 if (jn) 1487 mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODEMPFR_RNDN); 1488 else 1489 mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODEMPFR_RNDN); 1490 1491 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1492 mpfr_set (e->value.real, last2, GFC_RND_MODE)mpfr_set4(e->value.real,last2,MPFR_RNDN,((last2)->_mpfr_sign
))
; 1493 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1494 { 1495 mpfr_clear (last1); 1496 mpfr_clear (last2); 1497 gfc_free_expr (e); 1498 gfc_free_expr (result); 1499 return &gfc_bad_expr; 1500 } 1501 if (jn) 1502 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); 1503 else 1504 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1505 1506 if (n1 + 1 == n2) 1507 { 1508 mpfr_clear (last1); 1509 mpfr_clear (last2); 1510 return result; 1511 } 1512 1513 /* Start actual recursion. */ 1514 1515 mpfr_init (x2rev); 1516 mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODEMPFR_RNDN); 1517 1518 for (i = 2; i <= n2-n1; i++) 1519 { 1520 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1521 1522 /* Special case: For YN, if the previous N gave -INF, set 1523 also N+1 to -INF. */ 1524 if (!jn && !flag_range_checkglobal_options.x_flag_range_check && mpfr_inf_p (last2)((last2)->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -
1) >> 1))))
) 1525 { 1526 mpfr_set_inf (e->value.real, -1); 1527 gfc_constructor_append_expr (&result->value.constructor, e, 1528 &x->where); 1529 continue; 1530 } 1531 1532 mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), 1533 GFC_RND_MODEMPFR_RNDN); 1534 mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODEMPFR_RNDN); 1535 mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODEMPFR_RNDN); 1536 1537 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) 1538 { 1539 /* Range_check frees "e" in that case. */ 1540 e = NULL__null; 1541 goto error; 1542 } 1543 1544 if (jn) 1545 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, 1546 -i-1); 1547 else 1548 gfc_constructor_append_expr (&result->value.constructor, e, &x->where); 1549 1550 mpfr_set (last1, last2, GFC_RND_MODE)mpfr_set4(last1,last2,MPFR_RNDN,((last2)->_mpfr_sign)); 1551 mpfr_set (last2, e->value.real, GFC_RND_MODE)mpfr_set4(last2,e->value.real,MPFR_RNDN,((e->value.real
)->_mpfr_sign))
; 1552 } 1553 1554 mpfr_clear (last1); 1555 mpfr_clear (last2); 1556 mpfr_clear (x2rev); 1557 return result; 1558 1559error: 1560 mpfr_clear (last1); 1561 mpfr_clear (last2); 1562 mpfr_clear (x2rev); 1563 gfc_free_expr (e); 1564 gfc_free_expr (result); 1565 return &gfc_bad_expr; 1566} 1567 1568 1569gfc_expr * 1570gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) 1571{ 1572 return gfc_simplify_bessel_n2 (order1, order2, x, true); 1573} 1574 1575 1576gfc_expr * 1577gfc_simplify_bessel_y0 (gfc_expr *x) 1578{ 1579 gfc_expr *result; 1580 1581 if (x->expr_type != EXPR_CONSTANT) 1582 return NULL__null; 1583 1584 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1585 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1586 1587 return range_check (result, "BESSEL_Y0"); 1588} 1589 1590 1591gfc_expr * 1592gfc_simplify_bessel_y1 (gfc_expr *x) 1593{ 1594 gfc_expr *result; 1595 1596 if (x->expr_type != EXPR_CONSTANT) 1597 return NULL__null; 1598 1599 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1600 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1601 1602 return range_check (result, "BESSEL_Y1"); 1603} 1604 1605 1606gfc_expr * 1607gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) 1608{ 1609 gfc_expr *result; 1610 long n; 1611 1612 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) 1613 return NULL__null; 1614 1615 n = mpz_get_si__gmpz_get_si (order->value.integer); 1616 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1617 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODEMPFR_RNDN); 1618 1619 return range_check (result, "BESSEL_YN"); 1620} 1621 1622 1623gfc_expr * 1624gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) 1625{ 1626 return gfc_simplify_bessel_n2 (order1, order2, x, false); 1627} 1628 1629 1630gfc_expr * 1631gfc_simplify_bit_size (gfc_expr *e) 1632{ 1633 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 1634 return gfc_get_int_expr (e->ts.kind, &e->where, 1635 gfc_integer_kinds[i].bit_size); 1636} 1637 1638 1639gfc_expr * 1640gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) 1641{ 1642 int b; 1643 1644 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) 1645 return NULL__null; 1646 1647 if (gfc_extract_int (bit, &b) || b < 0) 1648 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); 1649 1650 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, 1651 mpz_tstbit__gmpz_tstbit (e->value.integer, b)); 1652} 1653 1654 1655static int 1656compare_bitwise (gfc_expr *i, gfc_expr *j) 1657{ 1658 mpz_t x, y; 1659 int k, res; 1660 1661 gcc_assert (i->ts.type == BT_INTEGER)((void)(!(i->ts.type == BT_INTEGER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1661, __FUNCTION__), 0 : 0))
; 1662 gcc_assert (j->ts.type == BT_INTEGER)((void)(!(j->ts.type == BT_INTEGER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1662, __FUNCTION__), 0 : 0))
; 1663 1664 mpz_init_set__gmpz_init_set (x, i->value.integer); 1665 k = gfc_validate_kind (i->ts.type, i->ts.kind, false); 1666 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); 1667 1668 mpz_init_set__gmpz_init_set (y, j->value.integer); 1669 k = gfc_validate_kind (j->ts.type, j->ts.kind, false); 1670 convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); 1671 1672 res = mpz_cmp__gmpz_cmp (x, y); 1673 mpz_clear__gmpz_clear (x); 1674 mpz_clear__gmpz_clear (y); 1675 return res; 1676} 1677 1678 1679gfc_expr * 1680gfc_simplify_bge (gfc_expr *i, gfc_expr *j) 1681{ 1682 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1683 return NULL__null; 1684 1685 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1686 compare_bitwise (i, j) >= 0); 1687} 1688 1689 1690gfc_expr * 1691gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) 1692{ 1693 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1694 return NULL__null; 1695 1696 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1697 compare_bitwise (i, j) > 0); 1698} 1699 1700 1701gfc_expr * 1702gfc_simplify_ble (gfc_expr *i, gfc_expr *j) 1703{ 1704 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1705 return NULL__null; 1706 1707 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1708 compare_bitwise (i, j) <= 0); 1709} 1710 1711 1712gfc_expr * 1713gfc_simplify_blt (gfc_expr *i, gfc_expr *j) 1714{ 1715 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) 1716 return NULL__null; 1717 1718 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, 1719 compare_bitwise (i, j) < 0); 1720} 1721 1722 1723gfc_expr * 1724gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) 1725{ 1726 gfc_expr *ceil, *result; 1727 int kind; 1728 1729 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); 1730 if (kind == -1) 1731 return &gfc_bad_expr; 1732 1733 if (e->expr_type != EXPR_CONSTANT) 1734 return NULL__null; 1735 1736 ceil = gfc_copy_expr (e); 1737 mpfr_ceil (ceil->value.real, e->value.real)mpfr_rint((ceil->value.real), (e->value.real), MPFR_RNDU
)
; 1738 1739 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 1740 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); 1741 1742 gfc_free_expr (ceil); 1743 1744 return range_check (result, "CEILING"); 1745} 1746 1747 1748gfc_expr * 1749gfc_simplify_char (gfc_expr *e, gfc_expr *k) 1750{ 1751 return simplify_achar_char (e, k, "CHAR", false); 1752} 1753 1754 1755/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ 1756 1757static gfc_expr * 1758simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) 1759{ 1760 gfc_expr *result; 1761 1762 if (x->expr_type != EXPR_CONSTANT 1763 || (y != NULL__null && y->expr_type != EXPR_CONSTANT)) 1764 return NULL__null; 1765 1766 result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); 1767 1768 switch (x->ts.type) 1769 { 1770 case BT_INTEGER: 1771 mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1772 break; 1773 1774 case BT_REAL: 1775 mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODEMPFR_RNDN); 1776 break; 1777 1778 case BT_COMPLEX: 1779 mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1780 break; 1781 1782 default: 1783 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); 1784 } 1785 1786 if (!y) 1787 return range_check (result, name); 1788 1789 switch (y->ts.type) 1790 { 1791 case BT_INTEGER: 1792 mpfr_set_z (mpc_imagref (result->value.complex)((result->value.complex)->im), 1793 y->value.integer, GFC_RND_MODEMPFR_RNDN); 1794 break; 1795 1796 case BT_REAL: 1797 mpfr_set (mpc_imagref (result->value.complex),mpfr_set4(((result->value.complex)->im),y->value.real
,MPFR_RNDN,((y->value.real)->_mpfr_sign))
1798 y->value.real, GFC_RND_MODE)mpfr_set4(((result->value.complex)->im),y->value.real
,MPFR_RNDN,((y->value.real)->_mpfr_sign))
; 1799 break; 1800 1801 default: 1802 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); 1803 } 1804 1805 return range_check (result, name); 1806} 1807 1808 1809gfc_expr * 1810gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) 1811{ 1812 int kind; 1813 1814 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); 1815 if (kind == -1) 1816 return &gfc_bad_expr; 1817 1818 return simplify_cmplx ("CMPLX", x, y, kind); 1819} 1820 1821 1822gfc_expr * 1823gfc_simplify_complex (gfc_expr *x, gfc_expr *y) 1824{ 1825 int kind; 1826 1827 if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) 1828 kind = gfc_default_complex_kind; 1829 else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) 1830 kind = x->ts.kind; 1831 else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) 1832 kind = y->ts.kind; 1833 else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) 1834 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; 1835 else 1836 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1836, __FUNCTION__))
; 1837 1838 return simplify_cmplx ("COMPLEX", x, y, kind); 1839} 1840 1841 1842gfc_expr * 1843gfc_simplify_conjg (gfc_expr *e) 1844{ 1845 gfc_expr *result; 1846 1847 if (e->expr_type != EXPR_CONSTANT) 1848 return NULL__null; 1849 1850 result = gfc_copy_expr (e); 1851 mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1852 1853 return range_check (result, "CONJG"); 1854} 1855 1856 1857/* Simplify atan2d (x) where the unit is degree. */ 1858 1859gfc_expr * 1860gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x) 1861{ 1862 gfc_expr *result; 1863 1864 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 1865 return NULL__null; 1866 1867 if (mpfr_zero_p (y->value.real)((y->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
&& mpfr_zero_p (x->value.real)((x->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
) 1868 { 1869 gfc_error ("If first argument of ATAN2D at %L is zero, then the " 1870 "second argument must not be zero", &y->where); 1871 return &gfc_bad_expr; 1872 } 1873 1874 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1875 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1876 rad2deg (result->value.real); 1877 1878 return range_check (result, "ATAN2D"); 1879} 1880 1881 1882gfc_expr * 1883gfc_simplify_cos (gfc_expr *x) 1884{ 1885 gfc_expr *result; 1886 1887 if (x->expr_type != EXPR_CONSTANT) 1888 return NULL__null; 1889 1890 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1891 1892 switch (x->ts.type) 1893 { 1894 case BT_REAL: 1895 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 1896 break; 1897 1898 case BT_COMPLEX: 1899 gfc_set_model_kind (x->ts.kind); 1900 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 1901 break; 1902 1903 default: 1904 gfc_internal_error ("in gfc_simplify_cos(): Bad type"); 1905 } 1906 1907 return range_check (result, "COS"); 1908} 1909 1910 1911static void 1912deg2rad (mpfr_t x) 1913{ 1914 mpfr_t d2r; 1915 1916 mpfr_init (d2r); 1917 mpfr_const_pi (d2r, GFC_RND_MODEMPFR_RNDN); 1918 mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODEMPFR_RNDN); 1919 mpfr_mul (x, x, d2r, GFC_RND_MODEMPFR_RNDN); 1920 mpfr_clear (d2r); 1921} 1922 1923 1924/* Simplification routines for SIND, COSD, TAND. */ 1925#include "trigd_fe.inc" 1926 1927 1928/* Simplify COSD(X) where X has the unit of degree. */ 1929 1930gfc_expr * 1931gfc_simplify_cosd (gfc_expr *x) 1932{ 1933 gfc_expr *result; 1934 1935 if (x->expr_type != EXPR_CONSTANT) 1936 return NULL__null; 1937 1938 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1939 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_mpfr_sign))
; 1940 simplify_cosd (result->value.real); 1941 1942 return range_check (result, "COSD"); 1943} 1944 1945 1946/* Simplify SIND(X) where X has the unit of degree. */ 1947 1948gfc_expr * 1949gfc_simplify_sind (gfc_expr *x) 1950{ 1951 gfc_expr *result; 1952 1953 if (x->expr_type != EXPR_CONSTANT) 1954 return NULL__null; 1955 1956 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1957 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_mpfr_sign))
; 1958 simplify_sind (result->value.real); 1959 1960 return range_check (result, "SIND"); 1961} 1962 1963 1964/* Simplify TAND(X) where X has the unit of degree. */ 1965 1966gfc_expr * 1967gfc_simplify_tand (gfc_expr *x) 1968{ 1969 gfc_expr *result; 1970 1971 if (x->expr_type != EXPR_CONSTANT) 1972 return NULL__null; 1973 1974 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1975 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_mpfr_sign))
; 1976 simplify_tand (result->value.real); 1977 1978 return range_check (result, "TAND"); 1979} 1980 1981 1982/* Simplify COTAND(X) where X has the unit of degree. */ 1983 1984gfc_expr * 1985gfc_simplify_cotand (gfc_expr *x) 1986{ 1987 gfc_expr *result; 1988 1989 if (x->expr_type != EXPR_CONSTANT) 1990 return NULL__null; 1991 1992 /* Implement COTAND = -TAND(x+90). 1993 TAND offers correct exact values for multiples of 30 degrees. 1994 This implementation is also compatible with the behavior of some legacy 1995 compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */ 1996 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 1997 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_mpfr_sign))
; 1998 mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODEMPFR_RNDN); 1999 simplify_tand (result->value.real); 2000 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN); 2001 2002 return range_check (result, "COTAND"); 2003} 2004 2005 2006gfc_expr * 2007gfc_simplify_cosh (gfc_expr *x) 2008{ 2009 gfc_expr *result; 2010 2011 if (x->expr_type != EXPR_CONSTANT) 2012 return NULL__null; 2013 2014 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2015 2016 switch (x->ts.type) 2017 { 2018 case BT_REAL: 2019 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 2020 break; 2021 2022 case BT_COMPLEX: 2023 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 2024 break; 2025 2026 default: 2027 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2027, __FUNCTION__))
; 2028 } 2029 2030 return range_check (result, "COSH"); 2031} 2032 2033 2034gfc_expr * 2035gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) 2036{ 2037 gfc_expr *result; 2038 bool size_zero; 2039 2040 size_zero = gfc_is_size_zero_array (mask); 2041 2042 if (!(is_constant_array_expr (mask) || size_zero) 2043 || !gfc_is_constant_expr (dim) 2044 || !gfc_is_constant_expr (kind)) 2045 return NULL__null; 2046 2047 result = transformational_result (mask, dim, 2048 BT_INTEGER, 2049 get_kind (BT_INTEGER, kind, "COUNT", 2050 gfc_default_integer_kind), 2051 &mask->where); 2052 2053 init_result_expr (result, 0, NULL__null); 2054 2055 if (size_zero) 2056 return result; 2057 2058 /* Passing MASK twice, once as data array, once as mask. 2059 Whenever gfc_count is called, '1' is added to the result. */ 2060 return !dim || mask->rank == 1 ? 2061 simplify_transformation_to_scalar (result, mask, mask, gfc_count) : 2062 simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL__null); 2063} 2064 2065/* Simplification routine for cshift. This works by copying the array 2066 expressions into a one-dimensional array, shuffling the values into another 2067 one-dimensional array and creating the new array expression from this. The 2068 shuffling part is basically taken from the library routine. */ 2069 2070gfc_expr * 2071gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) 2072{ 2073 gfc_expr *result; 2074 int which; 2075 gfc_expr **arrayvec, **resultvec; 2076 gfc_expr **rptr, **sptr; 2077 mpz_t size; 2078 size_t arraysize, shiftsize, i; 2079 gfc_constructor *array_ctor, *shift_ctor; 2080 ssize_t *shiftvec, *hptr; 2081 ssize_t shift_val, len; 2082 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 2083 hs_ex[GFC_MAX_DIMENSIONS15 + 1], 2084 hstride[GFC_MAX_DIMENSIONS15], sstride[GFC_MAX_DIMENSIONS15], 2085 a_extent[GFC_MAX_DIMENSIONS15], a_stride[GFC_MAX_DIMENSIONS15], 2086 h_extent[GFC_MAX_DIMENSIONS15], 2087 ss_ex[GFC_MAX_DIMENSIONS15 + 1]; 2088 ssize_t rsoffset; 2089 int d, n; 2090 bool continue_loop; 2091 gfc_expr **src, **dest; 2092 2093 if (!is_constant_array_expr (array)) 2094 return NULL__null; 2095 2096 if (shift->rank > 0) 2097 gfc_simplify_expr (shift, 1); 2098 2099 if (!gfc_is_constant_expr (shift)) 2100 return NULL__null; 2101 2102 /* Make dim zero-based. */ 2103 if (dim) 2104 { 2105 if (!gfc_is_constant_expr (dim)) 2106 return NULL__null; 2107 which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1; 2108 } 2109 else 2110 which = 0; 2111 2112 if (array->shape == NULL__null) 2113 return NULL__null; 2114 2115 gfc_array_size (array, &size); 2116 arraysize = mpz_get_ui__gmpz_get_ui (size); 2117 mpz_clear__gmpz_clear (size); 2118 2119 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 2120 result->shape = gfc_copy_shape (array->shape, array->rank); 2121 result->rank = array->rank; 2122 result->ts.u.derived = array->ts.u.derived; 2123 2124 if (arraysize == 0) 2125 return result; 2126 2127 arrayvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *))); 2128 array_ctor = gfc_constructor_first (array->value.constructor); 2129 for (i = 0; i < arraysize; i++) 2130 { 2131 arrayvec[i] = array_ctor->expr; 2132 array_ctor = gfc_constructor_next (array_ctor); 2133 } 2134 2135 resultvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *))); 2136 2137 extent[0] = 1; 2138 count[0] = 0; 2139 2140 for (d=0; d < array->rank; d++) 2141 { 2142 a_extent[d] = mpz_get_si__gmpz_get_si (array->shape[d]); 2143 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; 2144 } 2145 2146 if (shift->rank > 0) 2147 { 2148 gfc_array_size (shift, &size); 2149 shiftsize = mpz_get_ui__gmpz_get_ui (size); 2150 mpz_clear__gmpz_clear (size); 2151 shiftvec = XCNEWVEC (ssize_t, shiftsize)((ssize_t *) xcalloc ((shiftsize), sizeof (ssize_t))); 2152 shift_ctor = gfc_constructor_first (shift->value.constructor); 2153 for (d = 0; d < shift->rank; d++) 2154 { 2155 h_extent[d] = mpz_get_si__gmpz_get_si (shift->shape[d]); 2156 hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1]; 2157 } 2158 } 2159 else 2160 shiftvec = NULL__null; 2161 2162 /* Shut up compiler */ 2163 len = 1; 2164 rsoffset = 1; 2165 2166 n = 0; 2167 for (d=0; d < array->rank; d++) 2168 { 2169 if (d == which) 2170 { 2171 rsoffset = a_stride[d]; 2172 len = a_extent[d]; 2173 } 2174 else 2175 { 2176 count[n] = 0; 2177 extent[n] = a_extent[d]; 2178 sstride[n] = a_stride[d]; 2179 ss_ex[n] = sstride[n] * extent[n]; 2180 if (shiftvec) 2181 hs_ex[n] = hstride[n] * extent[n]; 2182 n++; 2183 } 2184 } 2185 ss_ex[n] = 0; 2186 hs_ex[n] = 0; 2187 2188 if (shiftvec) 2189 { 2190 for (i = 0; i < shiftsize; i++) 2191 { 2192 ssize_t val; 2193 val = mpz_get_si__gmpz_get_si (shift_ctor->expr->value.integer); 2194 val = val % len; 2195 if (val < 0) 2196 val += len; 2197 shiftvec[i] = val; 2198 shift_ctor = gfc_constructor_next (shift_ctor); 2199 } 2200 shift_val = 0; 2201 } 2202 else 2203 { 2204 shift_val = mpz_get_si__gmpz_get_si (shift->value.integer); 2205 shift_val = shift_val % len; 2206 if (shift_val < 0) 2207 shift_val += len; 2208 } 2209 2210 continue_loop = true; 2211 d = array->rank; 2212 rptr = resultvec; 2213 sptr = arrayvec; 2214 hptr = shiftvec; 2215 2216 while (continue_loop) 2217 { 2218 ssize_t sh; 2219 if (shiftvec) 2220 sh = *hptr; 2221 else 2222 sh = shift_val; 2223 2224 src = &sptr[sh * rsoffset]; 2225 dest = rptr; 2226 for (n = 0; n < len - sh; n++) 2227 { 2228 *dest = *src; 2229 dest += rsoffset; 2230 src += rsoffset; 2231 } 2232 src = sptr; 2233 for ( n = 0; n < sh; n++) 2234 { 2235 *dest = *src; 2236 dest += rsoffset; 2237 src += rsoffset; 2238 } 2239 rptr += sstride[0]; 2240 sptr += sstride[0]; 2241 if (shiftvec) 2242 hptr += hstride[0]; 2243 count[0]++; 2244 n = 0; 2245 while (count[n] == extent[n]) 2246 { 2247 count[n] = 0; 2248 rptr -= ss_ex[n]; 2249 sptr -= ss_ex[n]; 2250 if (shiftvec) 2251 hptr -= hs_ex[n]; 2252 n++; 2253 if (n >= d - 1) 2254 { 2255 continue_loop = false; 2256 break; 2257 } 2258 else 2259 { 2260 count[n]++; 2261 rptr += sstride[n]; 2262 sptr += sstride[n]; 2263 if (shiftvec) 2264 hptr += hstride[n]; 2265 } 2266 } 2267 } 2268 2269 for (i = 0; i < arraysize; i++) 2270 { 2271 gfc_constructor_append_expr (&result->value.constructor, 2272 gfc_copy_expr (resultvec[i]), 2273 NULL__null); 2274 } 2275 return result; 2276} 2277 2278 2279gfc_expr * 2280gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) 2281{ 2282 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); 2283} 2284 2285 2286gfc_expr * 2287gfc_simplify_dble (gfc_expr *e) 2288{ 2289 gfc_expr *result = NULL__null; 2290 int tmp1, tmp2; 2291 2292 if (e->expr_type != EXPR_CONSTANT) 2293 return NULL__null; 2294 2295 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 2296 warnings. */ 2297 tmp1 = warn_conversionglobal_options.x_warn_conversion; 2298 tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra; 2299 warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0; 2300 2301 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); 2302 2303 warn_conversionglobal_options.x_warn_conversion = tmp1; 2304 warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2; 2305 2306 if (result == &gfc_bad_expr) 2307 return &gfc_bad_expr; 2308 2309 return range_check (result, "DBLE"); 2310} 2311 2312 2313gfc_expr * 2314gfc_simplify_digits (gfc_expr *x) 2315{ 2316 int i, digits; 2317 2318 i = gfc_validate_kind (x->ts.type, x->ts.kind, false); 2319 2320 switch (x->ts.type) 2321 { 2322 case BT_INTEGER: 2323 digits = gfc_integer_kinds[i].digits; 2324 break; 2325 2326 case BT_REAL: 2327 case BT_COMPLEX: 2328 digits = gfc_real_kinds[i].digits; 2329 break; 2330 2331 default: 2332 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2332, __FUNCTION__))
; 2333 } 2334 2335 return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, digits); 2336} 2337 2338 2339gfc_expr * 2340gfc_simplify_dim (gfc_expr *x, gfc_expr *y) 2341{ 2342 gfc_expr *result; 2343 int kind; 2344 2345 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2346 return NULL__null; 2347 2348 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 2349 result = gfc_get_constant_expr (x->ts.type, kind, &x->where); 2350 2351 switch (x->ts.type) 2352 { 2353 case BT_INTEGER: 2354 if (mpz_cmp__gmpz_cmp (x->value.integer, y->value.integer) > 0) 2355 mpz_sub__gmpz_sub (result->value.integer, x->value.integer, y->value.integer); 2356 else 2357 mpz_set_ui__gmpz_set_ui (result->value.integer, 0); 2358 2359 break; 2360 2361 case BT_REAL: 2362 if (mpfr_cmp (x->value.real, y->value.real)mpfr_cmp3(x->value.real, y->value.real, 1) > 0) 2363 mpfr_sub (result->value.real, x->value.real, y->value.real, 2364 GFC_RND_MODEMPFR_RNDN); 2365 else 2366 mpfr_set_ui (result->value.real, 0, GFC_RND_MODEMPFR_RNDN); 2367 2368 break; 2369 2370 default: 2371 gfc_internal_error ("gfc_simplify_dim(): Bad type"); 2372 } 2373 2374 return range_check (result, "DIM"); 2375} 2376 2377 2378gfc_expr* 2379gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) 2380{ 2381 /* If vector_a is a zero-sized array, the result is 0 for INTEGER, 2382 REAL, and COMPLEX types and .false. for LOGICAL. */ 2383 if (vector_a->shape && mpz_get_si__gmpz_get_si (vector_a->shape[0]) == 0) 2384 { 2385 if (vector_a->ts.type == BT_LOGICAL) 2386 return gfc_get_logical_expr (gfc_default_logical_kind, NULL__null, false); 2387 else 2388 return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 0); 2389 } 2390 2391 if (!is_constant_array_expr (vector_a) 2392 || !is_constant_array_expr (vector_b)) 2393 return NULL__null; 2394 2395 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true); 2396} 2397 2398 2399gfc_expr * 2400gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) 2401{ 2402 gfc_expr *a1, *a2, *result; 2403 2404 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 2405 return NULL__null; 2406 2407 a1 = gfc_real2real (x, gfc_default_double_kind); 2408 a2 = gfc_real2real (y, gfc_default_double_kind); 2409 2410 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); 2411 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODEMPFR_RNDN); 2412 2413 gfc_free_expr (a2); 2414 gfc_free_expr (a1); 2415 2416 return range_check (result, "DPROD"); 2417} 2418 2419 2420static gfc_expr * 2421simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, 2422 bool right) 2423{ 2424 gfc_expr *result; 2425 int i, k, size, shift; 2426 2427 if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT 2428 || shiftarg->expr_type != EXPR_CONSTANT) 2429 return NULL__null; 2430 2431 k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); 2432 size = gfc_integer_kinds[k].bit_size; 2433 2434 gfc_extract_int (shiftarg, &shift); 2435 2436 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ 2437 if (right) 2438 shift = size - shift; 2439 2440 result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); 2441 mpz_set_ui__gmpz_set_ui (result->value.integer, 0); 2442 2443 for (i = 0; i < shift; i++) 2444 if (mpz_tstbit__gmpz_tstbit (arg2->value.integer, size - shift + i)) 2445 mpz_setbit__gmpz_setbit (result->value.integer, i); 2446 2447 for (i = 0; i < size - shift; i++) 2448 if (mpz_tstbit__gmpz_tstbit (arg1->value.integer, i)) 2449 mpz_setbit__gmpz_setbit (result->value.integer, shift + i); 2450 2451 /* Convert to a signed value. */ 2452 gfc_convert_mpz_to_signed (result->value.integer, size); 2453 2454 return result; 2455} 2456 2457 2458gfc_expr * 2459gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) 2460{ 2461 return simplify_dshift (arg1, arg2, shiftarg, true); 2462} 2463 2464 2465gfc_expr * 2466gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) 2467{ 2468 return simplify_dshift (arg1, arg2, shiftarg, false); 2469} 2470 2471 2472gfc_expr * 2473gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, 2474 gfc_expr *dim) 2475{ 2476 bool temp_boundary; 2477 gfc_expr *bnd; 2478 gfc_expr *result; 2479 int which; 2480 gfc_expr **arrayvec, **resultvec; 2481 gfc_expr **rptr, **sptr; 2482 mpz_t size; 2483 size_t arraysize, i; 2484 gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor; 2485 ssize_t shift_val, len; 2486 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 2487 sstride[GFC_MAX_DIMENSIONS15], a_extent[GFC_MAX_DIMENSIONS15], 2488 a_stride[GFC_MAX_DIMENSIONS15], ss_ex[GFC_MAX_DIMENSIONS15 + 1]; 2489 ssize_t rsoffset; 2490 int d, n; 2491 bool continue_loop; 2492 gfc_expr **src, **dest; 2493 size_t s_len; 2494 2495 if (!is_constant_array_expr (array)) 2496 return NULL__null; 2497 2498 if (shift->rank > 0) 2499 gfc_simplify_expr (shift, 1); 2500 2501 if (!gfc_is_constant_expr (shift)) 2502 return NULL__null; 2503 2504 if (boundary) 2505 { 2506 if (boundary->rank > 0) 2507 gfc_simplify_expr (boundary, 1); 2508 2509 if (!gfc_is_constant_expr (boundary)) 2510 return NULL__null; 2511 } 2512 2513 if (dim) 2514 { 2515 if (!gfc_is_constant_expr (dim)) 2516 return NULL__null; 2517 which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1; 2518 } 2519 else 2520 which = 0; 2521 2522 s_len = 0; 2523 if (boundary == NULL__null) 2524 { 2525 temp_boundary = true; 2526 switch (array->ts.type) 2527 { 2528 2529 case BT_INTEGER: 2530 bnd = gfc_get_int_expr (array->ts.kind, NULL__null, 0); 2531 break; 2532 2533 case BT_LOGICAL: 2534 bnd = gfc_get_logical_expr (array->ts.kind, NULL__null, 0); 2535 break; 2536 2537 case BT_REAL: 2538 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); 2539 mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODEMPFR_RNDN); 2540 break; 2541 2542 case BT_COMPLEX: 2543 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); 2544 mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODEMPFR_RNDN); 2545 break; 2546 2547 case BT_CHARACTER: 2548 s_len = mpz_get_ui__gmpz_get_ui (array->ts.u.cl->length->value.integer); 2549 bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL__null, s_len); 2550 break; 2551 2552 default: 2553 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2553, __FUNCTION__))
; 2554 2555 } 2556 } 2557 else 2558 { 2559 temp_boundary = false; 2560 bnd = boundary; 2561 } 2562 2563 gfc_array_size (array, &size); 2564 arraysize = mpz_get_ui__gmpz_get_ui (size); 2565 mpz_clear__gmpz_clear (size); 2566 2567 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 2568 result->shape = gfc_copy_shape (array->shape, array->rank); 2569 result->rank = array->rank; 2570 result->ts = array->ts; 2571 2572 if (arraysize == 0) 2573 goto final; 2574 2575 arrayvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *))); 2576 array_ctor = gfc_constructor_first (array->value.constructor); 2577 for (i = 0; i < arraysize; i++) 2578 { 2579 arrayvec[i] = array_ctor->expr; 2580 array_ctor = gfc_constructor_next (array_ctor); 2581 } 2582 2583 resultvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *))); 2584 2585 extent[0] = 1; 2586 count[0] = 0; 2587 2588 for (d=0; d < array->rank; d++) 2589 { 2590 a_extent[d] = mpz_get_si__gmpz_get_si (array->shape[d]); 2591 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; 2592 } 2593 2594 if (shift->rank > 0) 2595 { 2596 shift_ctor = gfc_constructor_first (shift->value.constructor); 2597 shift_val = 0; 2598 } 2599 else 2600 { 2601 shift_ctor = NULL__null; 2602 shift_val = mpz_get_si__gmpz_get_si (shift->value.integer); 2603 } 2604 2605 if (bnd->rank > 0) 2606 bnd_ctor = gfc_constructor_first (bnd->value.constructor); 2607 else 2608 bnd_ctor = NULL__null; 2609 2610 /* Shut up compiler */ 2611 len = 1; 2612 rsoffset = 1; 2613 2614 n = 0; 2615 for (d=0; d < array->rank; d++) 2616 { 2617 if (d == which) 2618 { 2619 rsoffset = a_stride[d]; 2620 len = a_extent[d]; 2621 } 2622 else 2623 { 2624 count[n] = 0; 2625 extent[n] = a_extent[d]; 2626 sstride[n] = a_stride[d]; 2627 ss_ex[n] = sstride[n] * extent[n]; 2628 n++; 2629 } 2630 } 2631 ss_ex[n] = 0; 2632 2633 continue_loop = true; 2634 d = array->rank; 2635 rptr = resultvec; 2636 sptr = arrayvec; 2637 2638 while (continue_loop) 2639 { 2640 ssize_t sh, delta; 2641 2642 if (shift_ctor) 2643 sh = mpz_get_si__gmpz_get_si (shift_ctor->expr->value.integer); 2644 else 2645 sh = shift_val; 2646 2647 if (( sh >= 0 ? sh : -sh ) > len) 2648 { 2649 delta = len; 2650 sh = len; 2651 } 2652 else 2653 delta = (sh >= 0) ? sh: -sh; 2654 2655 if (sh > 0) 2656 { 2657 src = &sptr[delta * rsoffset]; 2658 dest = rptr; 2659 } 2660 else 2661 { 2662 src = sptr; 2663 dest = &rptr[delta * rsoffset]; 2664 } 2665 2666 for (n = 0; n < len - delta; n++) 2667 { 2668 *dest = *src; 2669 dest += rsoffset; 2670 src += rsoffset; 2671 } 2672 2673 if (sh < 0) 2674 dest = rptr; 2675 2676 n = delta; 2677 2678 if (bnd_ctor) 2679 { 2680 while (n--) 2681 { 2682 *dest = gfc_copy_expr (bnd_ctor->expr); 2683 dest += rsoffset; 2684 } 2685 } 2686 else 2687 { 2688 while (n--) 2689 { 2690 *dest = gfc_copy_expr (bnd); 2691 dest += rsoffset; 2692 } 2693 } 2694 rptr += sstride[0]; 2695 sptr += sstride[0]; 2696 if (shift_ctor) 2697 shift_ctor = gfc_constructor_next (shift_ctor); 2698 2699 if (bnd_ctor) 2700 bnd_ctor = gfc_constructor_next (bnd_ctor); 2701 2702 count[0]++; 2703 n = 0; 2704 while (count[n] == extent[n]) 2705 { 2706 count[n] = 0; 2707 rptr -= ss_ex[n]; 2708 sptr -= ss_ex[n]; 2709 n++; 2710 if (n >= d - 1) 2711 { 2712 continue_loop = false; 2713 break; 2714 } 2715 else 2716 { 2717 count[n]++; 2718 rptr += sstride[n]; 2719 sptr += sstride[n]; 2720 } 2721 } 2722 } 2723 2724 for (i = 0; i < arraysize; i++) 2725 { 2726 gfc_constructor_append_expr (&result->value.constructor, 2727 gfc_copy_expr (resultvec[i]), 2728 NULL__null); 2729 } 2730 2731 final: 2732 if (temp_boundary) 2733 gfc_free_expr (bnd); 2734 2735 return result; 2736} 2737 2738gfc_expr * 2739gfc_simplify_erf (gfc_expr *x) 2740{ 2741 gfc_expr *result; 2742 2743 if (x->expr_type != EXPR_CONSTANT) 2744 return NULL__null; 2745 2746 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2747 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 2748 2749 return range_check (result, "ERF"); 2750} 2751 2752 2753gfc_expr * 2754gfc_simplify_erfc (gfc_expr *x) 2755{ 2756 gfc_expr *result; 2757 2758 if (x->expr_type != EXPR_CONSTANT) 2759 return NULL__null; 2760 2761 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2762 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 2763 2764 return range_check (result, "ERFC"); 2765} 2766 2767 2768/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */ 2769 2770#define MAX_ITER 200 2771#define ARG_LIMIT 12 2772 2773/* Calculate ERFC_SCALED directly by its definition: 2774 2775 ERFC_SCALED(x) = ERFC(x) * EXP(X**2) 2776 2777 using a large precision for intermediate results. This is used for all 2778 but large values of the argument. */ 2779static void 2780fullprec_erfc_scaled (mpfr_t res, mpfr_t arg) 2781{ 2782 mpfr_prec_t prec; 2783 mpfr_t a, b; 2784 2785 prec = mpfr_get_default_prec (); 2786 mpfr_set_default_prec (10 * prec); 2787 2788 mpfr_init (a); 2789 mpfr_init (b); 2790 2791 mpfr_set (a, arg, GFC_RND_MODE)mpfr_set4(a,arg,MPFR_RNDN,((arg)->_mpfr_sign)); 2792 mpfr_sqr (b, a, GFC_RND_MODEMPFR_RNDN); 2793 mpfr_exp (b, b, GFC_RND_MODEMPFR_RNDN); 2794 mpfr_erfc (a, a, GFC_RND_MODEMPFR_RNDN); 2795 mpfr_mul (a, a, b, GFC_RND_MODEMPFR_RNDN); 2796 2797 mpfr_set (res, a, GFC_RND_MODE)mpfr_set4(res,a,MPFR_RNDN,((a)->_mpfr_sign)); 2798 mpfr_set_default_prec (prec); 2799 2800 mpfr_clear (a); 2801 mpfr_clear (b); 2802} 2803 2804/* Calculate ERFC_SCALED using a power series expansion in 1/arg: 2805 2806 ERFC_SCALED(x) = 1 / (x * sqrt(pi)) 2807 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1)) 2808 / (2 * x**2)**n) 2809 2810 This is used for large values of the argument. Intermediate calculations 2811 are performed with twice the precision. We don't do a fixed number of 2812 iterations of the sum, but stop when it has converged to the required 2813 precision. */ 2814static void 2815asympt_erfc_scaled (mpfr_t res, mpfr_t arg) 2816{ 2817 mpfr_t sum, x, u, v, w, oldsum, sumtrunc; 2818 mpz_t num; 2819 mpfr_prec_t prec; 2820 unsigned i; 2821 2822 prec = mpfr_get_default_prec (); 2823 mpfr_set_default_prec (2 * prec); 2824 2825 mpfr_init (sum); 2826 mpfr_init (x); 2827 mpfr_init (u); 2828 mpfr_init (v); 2829 mpfr_init (w); 2830 mpz_init__gmpz_init (num); 2831 2832 mpfr_init (oldsum); 2833 mpfr_init (sumtrunc); 2834 mpfr_set_prec (oldsum, prec); 2835 mpfr_set_prec (sumtrunc, prec); 2836 2837 mpfr_set (x, arg, GFC_RND_MODE)mpfr_set4(x,arg,MPFR_RNDN,((arg)->_mpfr_sign)); 2838 mpfr_set_ui (sum, 1, GFC_RND_MODEMPFR_RNDN); 2839 mpz_set_ui__gmpz_set_ui (num, 1); 2840 2841 mpfr_set (u, x, GFC_RND_MODE)mpfr_set4(u,x,MPFR_RNDN,((x)->_mpfr_sign)); 2842 mpfr_sqr (u, u, GFC_RND_MODEMPFR_RNDN); 2843 mpfr_mul_ui (u, u, 2, GFC_RND_MODEMPFR_RNDN); 2844 mpfr_pow_si (u, u, -1, GFC_RND_MODEMPFR_RNDN); 2845 2846 for (i = 1; i < MAX_ITER; i++) 2847 { 2848 mpfr_set (oldsum, sum, GFC_RND_MODE)mpfr_set4(oldsum,sum,MPFR_RNDN,((sum)->_mpfr_sign)); 2849 2850 mpz_mul_ui__gmpz_mul_ui (num, num, 2 * i - 1); 2851 mpz_neg__gmpz_neg (num, num); 2852 2853 mpfr_set (w, u, GFC_RND_MODE)mpfr_set4(w,u,MPFR_RNDN,((u)->_mpfr_sign)); 2854 mpfr_pow_ui (w, w, i, GFC_RND_MODEMPFR_RNDN); 2855 2856 mpfr_set_z (v, num, GFC_RND_MODEMPFR_RNDN); 2857 mpfr_mul (v, v, w, GFC_RND_MODEMPFR_RNDN); 2858 2859 mpfr_add (sum, sum, v, GFC_RND_MODEMPFR_RNDN); 2860 2861 mpfr_set (sumtrunc, sum, GFC_RND_MODE)mpfr_set4(sumtrunc,sum,MPFR_RNDN,((sum)->_mpfr_sign)); 2862 if (mpfr_cmp (sumtrunc, oldsum)mpfr_cmp3(sumtrunc, oldsum, 1) == 0) 2863 break; 2864 } 2865 2866 /* We should have converged by now; otherwise, ARG_LIMIT is probably 2867 set too low. */ 2868 gcc_assert (i < MAX_ITER)((void)(!(i < MAX_ITER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2868, __FUNCTION__), 0 : 0))
; 2869 2870 /* Divide by x * sqrt(Pi). */ 2871 mpfr_const_pi (u, GFC_RND_MODEMPFR_RNDN); 2872 mpfr_sqrt (u, u, GFC_RND_MODEMPFR_RNDN); 2873 mpfr_mul (u, u, x, GFC_RND_MODEMPFR_RNDN); 2874 mpfr_div (sum, sum, u, GFC_RND_MODEMPFR_RNDN); 2875 2876 mpfr_set (res, sum, GFC_RND_MODE)mpfr_set4(res,sum,MPFR_RNDN,((sum)->_mpfr_sign)); 2877 mpfr_set_default_prec (prec); 2878 2879 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL__null); 2880 mpz_clear__gmpz_clear (num); 2881} 2882 2883 2884gfc_expr * 2885gfc_simplify_erfc_scaled (gfc_expr *x) 2886{ 2887 gfc_expr *result; 2888 2889 if (x->expr_type != EXPR_CONSTANT) 2890 return NULL__null; 2891 2892 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2893 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) 2894 asympt_erfc_scaled (result->value.real, x->value.real); 2895 else 2896 fullprec_erfc_scaled (result->value.real, x->value.real); 2897 2898 return range_check (result, "ERFC_SCALED"); 2899} 2900 2901#undef MAX_ITER 2902#undef ARG_LIMIT 2903 2904 2905gfc_expr * 2906gfc_simplify_epsilon (gfc_expr *e) 2907{ 2908 gfc_expr *result; 2909 int i; 2910 2911 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 2912 2913 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); 2914 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE)mpfr_set4(result->value.real,gfc_real_kinds[i].epsilon,MPFR_RNDN
,((gfc_real_kinds[i].epsilon)->_mpfr_sign))
; 2915 2916 return range_check (result, "EPSILON"); 2917} 2918 2919 2920gfc_expr * 2921gfc_simplify_exp (gfc_expr *x) 2922{ 2923 gfc_expr *result; 2924 2925 if (x->expr_type != EXPR_CONSTANT) 2926 return NULL__null; 2927 2928 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 2929 2930 switch (x->ts.type) 2931 { 2932 case BT_REAL: 2933 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 2934 break; 2935 2936 case BT_COMPLEX: 2937 gfc_set_model_kind (x->ts.kind); 2938 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 2939 break; 2940 2941 default: 2942 gfc_internal_error ("in gfc_simplify_exp(): Bad type"); 2943 } 2944 2945 return range_check (result, "EXP"); 2946} 2947 2948 2949gfc_expr * 2950gfc_simplify_exponent (gfc_expr *x) 2951{ 2952 long int val; 2953 gfc_expr *result; 2954 2955 if (x->expr_type != EXPR_CONSTANT) 2956 return NULL__null; 2957 2958 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 2959 &x->where); 2960 2961 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */ 2962 if (mpfr_inf_p (x->value.real)((x->value.real)->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
|| mpfr_nan_p (x->value.real)((x->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
) 2963 { 2964 int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); 2965 mpz_set__gmpz_set (result->value.integer, gfc_integer_kinds[i].huge); 2966 return result; 2967 } 2968 2969 /* EXPONENT(+/- 0.0) = 0 */ 2970 if (mpfr_zero_p (x->value.real)((x->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
) 2971 { 2972 mpz_set_ui__gmpz_set_ui (result->value.integer, 0); 2973 return result; 2974 } 2975 2976 gfc_set_model (x->value.real); 2977 2978 val = (long int) mpfr_get_exp (x->value.real)(0 ? ((x->value.real)->_mpfr_exp) : ((x->value.real)
->_mpfr_exp))
; 2979 mpz_set_si__gmpz_set_si (result->value.integer, val); 2980 2981 return range_check (result, "EXPONENT"); 2982} 2983 2984 2985gfc_expr * 2986gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED__attribute__ ((__unused__)), 2987 gfc_expr *kind) 2988{ 2989 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE) 2990 { 2991 gfc_current_locus = *gfc_current_intrinsic_where; 2992 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 2993 return &gfc_bad_expr; 2994 } 2995 2996 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE) 2997 { 2998 gfc_expr *result; 2999 int actual_kind; 3000 if (kind) 3001 gfc_extract_int (kind, &actual_kind); 3002 else 3003 actual_kind = gfc_default_integer_kind; 3004 3005 result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus); 3006 result->rank = 1; 3007 return result; 3008 } 3009 3010 /* For fcoarray = lib no simplification is possible, because it is not known 3011 what images failed or are stopped at compile time. */ 3012 return NULL__null; 3013} 3014 3015 3016gfc_expr * 3017gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED__attribute__ ((__unused__))) 3018{ 3019 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE) 3020 { 3021 gfc_current_locus = *gfc_current_intrinsic_where; 3022 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 3023 return &gfc_bad_expr; 3024 } 3025 3026 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE) 3027 { 3028 gfc_expr *result; 3029 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); 3030 result->rank = 0; 3031 return result; 3032 } 3033 3034 /* For fcoarray = lib no simplification is possible, because it is not known 3035 what images failed or are stopped at compile time. */ 3036 return NULL__null; 3037} 3038 3039 3040gfc_expr * 3041gfc_simplify_float (gfc_expr *a) 3042{ 3043 gfc_expr *result; 3044 3045 if (a->expr_type != EXPR_CONSTANT) 3046 return NULL__null; 3047 3048 result = gfc_int2real (a, gfc_default_real_kind); 3049 3050 return range_check (result, "FLOAT"); 3051} 3052 3053 3054static bool 3055is_last_ref_vtab (gfc_expr *e) 3056{ 3057 gfc_ref *ref; 3058 gfc_component *comp = NULL__null; 3059 3060 if (e->expr_type != EXPR_VARIABLE) 3061 return false; 3062 3063 for (ref = e->ref; ref; ref = ref->next) 3064 if (ref->type == REF_COMPONENT) 3065 comp = ref->u.c.component; 3066 3067 if (!e->ref || !comp) 3068 return e->symtree->n.sym->attr.vtab; 3069 3070 if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) 3071 return true; 3072 3073 return false; 3074} 3075 3076 3077gfc_expr * 3078gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) 3079{ 3080 /* Avoid simplification of resolved symbols. */ 3081 if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) 3082 return NULL__null; 3083 3084 if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) 3085 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3086 gfc_type_is_extension_of (mold->ts.u.derived, 3087 a->ts.u.derived)); 3088 3089 if (UNLIMITED_POLY (a)(a != __null && a->ts.type == BT_CLASS && a
->ts.u.derived->components && a->ts.u.derived
->components->ts.u.derived && a->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)
|| UNLIMITED_POLY (mold)(mold != __null && mold->ts.type == BT_CLASS &&
mold->ts.u.derived->components && mold->ts.
u.derived->components->ts.u.derived && mold->
ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)
) 3090 return NULL__null; 3091 3092 /* Return .false. if the dynamic type can never be an extension. */ 3093 if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS 3094 && !gfc_type_is_extension_of 3095 (mold->ts.u.derived->components->ts.u.derived, 3096 a->ts.u.derived->components->ts.u.derived) 3097 && !gfc_type_is_extension_of 3098 (a->ts.u.derived->components->ts.u.derived, 3099 mold->ts.u.derived->components->ts.u.derived)) 3100 || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS 3101 && !gfc_type_is_extension_of 3102 (mold->ts.u.derived->components->ts.u.derived, 3103 a->ts.u.derived)) 3104 || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED 3105 && !gfc_type_is_extension_of 3106 (mold->ts.u.derived, 3107 a->ts.u.derived->components->ts.u.derived) 3108 && !gfc_type_is_extension_of 3109 (a->ts.u.derived->components->ts.u.derived, 3110 mold->ts.u.derived))) 3111 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); 3112 3113 /* Return .true. if the dynamic type is guaranteed to be an extension. */ 3114 if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED 3115 && gfc_type_is_extension_of (mold->ts.u.derived, 3116 a->ts.u.derived->components->ts.u.derived)) 3117 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); 3118 3119 return NULL__null; 3120} 3121 3122 3123gfc_expr * 3124gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) 3125{ 3126 /* Avoid simplification of resolved symbols. */ 3127 if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) 3128 return NULL__null; 3129 3130 /* Return .false. if the dynamic type can never be the 3131 same. */ 3132 if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok) 3133 || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok)) 3134 && !gfc_type_compatible (&a->ts, &b->ts) 3135 && !gfc_type_compatible (&b->ts, &a->ts)) 3136 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); 3137 3138 if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) 3139 return NULL__null; 3140 3141 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 3142 gfc_compare_derived_types (a->ts.u.derived, 3143 b->ts.u.derived)); 3144} 3145 3146 3147gfc_expr * 3148gfc_simplify_floor (gfc_expr *e, gfc_expr *k) 3149{ 3150 gfc_expr *result; 3151 mpfr_t floor; 3152 int kind; 3153 3154 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); 3155 if (kind == -1) 3156 gfc_internal_error ("gfc_simplify_floor(): Bad kind"); 3157 3158 if (e->expr_type != EXPR_CONSTANT) 3159 return NULL__null; 3160 3161 mpfr_init2 (floor, mpfr_get_prec (e->value.real)(0 ? ((e->value.real)->_mpfr_prec) : ((e->value.real
)->_mpfr_prec))
); 3162 mpfr_floor (floor, e->value.real)mpfr_rint((floor), (e->value.real), MPFR_RNDD); 3163 3164 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 3165 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); 3166 3167 mpfr_clear (floor); 3168 3169 return range_check (result, "FLOOR"); 3170} 3171 3172 3173gfc_expr * 3174gfc_simplify_fraction (gfc_expr *x) 3175{ 3176 gfc_expr *result; 3177 mpfr_exp_t e; 3178 3179 if (x->expr_type != EXPR_CONSTANT) 3180 return NULL__null; 3181 3182 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); 3183 3184 /* FRACTION(inf) = NaN. */ 3185 if (mpfr_inf_p (x->value.real)((x->value.real)->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
) 3186 { 3187 mpfr_set_nan (result->value.real); 3188 return result; 3189 } 3190 3191 /* mpfr_frexp() correctly handles zeros and NaNs. */ 3192 mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 3193 3194 return range_check (result, "FRACTION"); 3195} 3196 3197 3198gfc_expr * 3199gfc_simplify_gamma (gfc_expr *x) 3200{ 3201 gfc_expr *result; 3202 3203 if (x->expr_type != EXPR_CONSTANT) 3204 return NULL__null; 3205 3206 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3207 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 3208 3209 return range_check (result, "GAMMA"); 3210} 3211 3212 3213gfc_expr * 3214gfc_simplify_huge (gfc_expr *e) 3215{ 3216 gfc_expr *result; 3217 int i; 3218 3219 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 3220 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 3221 3222 switch (e->ts.type) 3223 { 3224 case BT_INTEGER: 3225 mpz_set__gmpz_set (result->value.integer, gfc_integer_kinds[i].huge); 3226 break; 3227 3228 case BT_REAL: 3229 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)mpfr_set4(result->value.real,gfc_real_kinds[i].huge,MPFR_RNDN
,((gfc_real_kinds[i].huge)->_mpfr_sign))
; 3230 break; 3231 3232 default: 3233 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3233, __FUNCTION__))
; 3234 } 3235 3236 return result; 3237} 3238 3239 3240gfc_expr * 3241gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) 3242{ 3243 gfc_expr *result; 3244 3245 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3246 return NULL__null; 3247 3248 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3249 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODEMPFR_RNDN); 3250 return range_check (result, "HYPOT"); 3251} 3252 3253 3254/* We use the processor's collating sequence, because all 3255 systems that gfortran currently works on are ASCII. */ 3256 3257gfc_expr * 3258gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) 3259{ 3260 gfc_expr *result; 3261 gfc_char_t index; 3262 int k; 3263 3264 if (e->expr_type != EXPR_CONSTANT) 3265 return NULL__null; 3266 3267 if (e->value.character.length != 1) 3268 { 3269 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); 3270 return &gfc_bad_expr; 3271 } 3272 3273 index = e->value.character.string[0]; 3274 3275 if (warn_surprisingglobal_options.x_warn_surprising && index > 127) 3276 gfc_warning (OPT_Wsurprising, 3277 "Argument of IACHAR function at %L outside of range 0..127", 3278 &e->where); 3279 3280 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); 3281 if (k == -1) 3282 return &gfc_bad_expr; 3283 3284 result = gfc_get_int_expr (k, &e->where, index); 3285 3286 return range_check (result, "IACHAR"); 3287} 3288 3289 3290static gfc_expr * 3291do_bit_and (gfc_expr *result, gfc_expr *e) 3292{ 3293 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3293, __FUNCTION__), 0 : 0))
; 3294 gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3295, __FUNCTION__), 0 : 0))
3295 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3295, __FUNCTION__), 0 : 0))
; 3296 3297 mpz_and__gmpz_and (result->value.integer, result->value.integer, e->value.integer); 3298 return result; 3299} 3300 3301 3302gfc_expr * 3303gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 3304{ 3305 return simplify_transformation (array, dim, mask, -1, do_bit_and); 3306} 3307 3308 3309static gfc_expr * 3310do_bit_ior (gfc_expr *result, gfc_expr *e) 3311{ 3312 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3312, __FUNCTION__), 0 : 0))
; 3313 gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3314, __FUNCTION__), 0 : 0))
3314 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3314, __FUNCTION__), 0 : 0))
; 3315 3316 mpz_ior__gmpz_ior (result->value.integer, result->value.integer, e->value.integer); 3317 return result; 3318} 3319 3320 3321gfc_expr * 3322gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 3323{ 3324 return simplify_transformation (array, dim, mask, 0, do_bit_ior); 3325} 3326 3327 3328gfc_expr * 3329gfc_simplify_iand (gfc_expr *x, gfc_expr *y) 3330{ 3331 gfc_expr *result; 3332 3333 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3334 return NULL__null; 3335 3336 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 3337 mpz_and__gmpz_and (result->value.integer, x->value.integer, y->value.integer); 3338 3339 return range_check (result, "IAND"); 3340} 3341 3342 3343gfc_expr * 3344gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) 3345{ 3346 gfc_expr *result; 3347 int k, pos; 3348 3349 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3350 return NULL__null; 3351 3352 gfc_extract_int (y, &pos); 3353 3354 k = gfc_validate_kind (x->ts.type, x->ts.kind, false); 3355 3356 result = gfc_copy_expr (x); 3357 3358 convert_mpz_to_unsigned (result->value.integer, 3359 gfc_integer_kinds[k].bit_size); 3360 3361 mpz_clrbit__gmpz_clrbit (result->value.integer, pos); 3362 3363 gfc_convert_mpz_to_signed (result->value.integer, 3364 gfc_integer_kinds[k].bit_size); 3365 3366 return result; 3367} 3368 3369 3370gfc_expr * 3371gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) 3372{ 3373 gfc_expr *result; 3374 int pos, len; 3375 int i, k, bitsize; 3376 int *bits; 3377 3378 if (x->expr_type != EXPR_CONSTANT 3379 || y->expr_type != EXPR_CONSTANT 3380 || z->expr_type != EXPR_CONSTANT) 3381 return NULL__null; 3382 3383 gfc_extract_int (y, &pos); 3384 gfc_extract_int (z, &len); 3385 3386 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); 3387 3388 bitsize = gfc_integer_kinds[k].bit_size; 3389 3390 if (pos + len > bitsize) 3391 { 3392 gfc_error ("Sum of second and third arguments of IBITS exceeds " 3393 "bit size at %L", &y->where); 3394 return &gfc_bad_expr; 3395 } 3396 3397 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 3398 convert_mpz_to_unsigned (result->value.integer, 3399 gfc_integer_kinds[k].bit_size); 3400 3401 bits = XCNEWVEC (int, bitsize)((int *) xcalloc ((bitsize), sizeof (int))); 3402 3403 for (i = 0; i < bitsize; i++) 3404 bits[i] = 0; 3405 3406 for (i = 0; i < len; i++) 3407 bits[i] = mpz_tstbit__gmpz_tstbit (x->value.integer, i + pos); 3408 3409 for (i = 0; i < bitsize; i++) 3410 { 3411 if (bits[i] == 0) 3412 mpz_clrbit__gmpz_clrbit (result->value.integer, i); 3413 else if (bits[i] == 1) 3414 mpz_setbit__gmpz_setbit (result->value.integer, i); 3415 else 3416 gfc_internal_error ("IBITS: Bad bit"); 3417 } 3418 3419 free (bits); 3420 3421 gfc_convert_mpz_to_signed (result->value.integer, 3422 gfc_integer_kinds[k].bit_size); 3423 3424 return result; 3425} 3426 3427 3428gfc_expr * 3429gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) 3430{ 3431 gfc_expr *result; 3432 int k, pos; 3433 3434 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3435 return NULL__null; 3436 3437 gfc_extract_int (y, &pos); 3438 3439 k = gfc_validate_kind (x->ts.type, x->ts.kind, false); 3440 3441 result = gfc_copy_expr (x); 3442 3443 convert_mpz_to_unsigned (result->value.integer, 3444 gfc_integer_kinds[k].bit_size); 3445 3446 mpz_setbit__gmpz_setbit (result->value.integer, pos); 3447 3448 gfc_convert_mpz_to_signed (result->value.integer, 3449 gfc_integer_kinds[k].bit_size); 3450 3451 return result; 3452} 3453 3454 3455gfc_expr * 3456gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) 3457{ 3458 gfc_expr *result; 3459 gfc_char_t index; 3460 int k; 3461 3462 if (e->expr_type != EXPR_CONSTANT) 3463 return NULL__null; 3464 3465 if (e->value.character.length != 1) 3466 { 3467 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); 3468 return &gfc_bad_expr; 3469 } 3470 3471 index = e->value.character.string[0]; 3472 3473 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); 3474 if (k == -1) 3475 return &gfc_bad_expr; 3476 3477 result = gfc_get_int_expr (k, &e->where, index); 3478 3479 return range_check (result, "ICHAR"); 3480} 3481 3482 3483gfc_expr * 3484gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) 3485{ 3486 gfc_expr *result; 3487 3488 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3489 return NULL__null; 3490 3491 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 3492 mpz_xor__gmpz_xor (result->value.integer, x->value.integer, y->value.integer); 3493 3494 return range_check (result, "IEOR"); 3495} 3496 3497 3498gfc_expr * 3499gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) 3500{ 3501 gfc_expr *result; 3502 int back, len, lensub; 3503 int i, j, k, count, index = 0, start; 3504 3505 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT 3506 || ( b != NULL__null && b->expr_type != EXPR_CONSTANT)) 3507 return NULL__null; 3508 3509 if (b != NULL__null && b->value.logical != 0) 3510 back = 1; 3511 else 3512 back = 0; 3513 3514 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); 3515 if (k == -1) 3516 return &gfc_bad_expr; 3517 3518 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); 3519 3520 len = x->value.character.length; 3521 lensub = y->value.character.length; 3522 3523 if (len < lensub) 3524 { 3525 mpz_set_si__gmpz_set_si (result->value.integer, 0); 3526 return result; 3527 } 3528 3529 if (back == 0) 3530 { 3531 if (lensub == 0) 3532 { 3533 mpz_set_si__gmpz_set_si (result->value.integer, 1); 3534 return result; 3535 } 3536 else if (lensub == 1) 3537 { 3538 for (i = 0; i < len; i++) 3539 { 3540 for (j = 0; j < lensub; j++) 3541 { 3542 if (y->value.character.string[j] 3543 == x->value.character.string[i]) 3544 { 3545 index = i + 1; 3546 goto done; 3547 } 3548 } 3549 } 3550 } 3551 else 3552 { 3553 for (i = 0; i < len; i++) 3554 { 3555 for (j = 0; j < lensub; j++) 3556 { 3557 if (y->value.character.string[j] 3558 == x->value.character.string[i]) 3559 { 3560 start = i; 3561 count = 0; 3562 3563 for (k = 0; k < lensub; k++) 3564 { 3565 if (y->value.character.string[k] 3566 == x->value.character.string[k + start]) 3567 count++; 3568 } 3569 3570 if (count == lensub) 3571 { 3572 index = start + 1; 3573 goto done; 3574 } 3575 } 3576 } 3577 } 3578 } 3579 3580 } 3581 else 3582 { 3583 if (lensub == 0) 3584 { 3585 mpz_set_si__gmpz_set_si (result->value.integer, len + 1); 3586 return result; 3587 } 3588 else if (lensub == 1) 3589 { 3590 for (i = 0; i < len; i++) 3591 { 3592 for (j = 0; j < lensub; j++) 3593 { 3594 if (y->value.character.string[j] 3595 == x->value.character.string[len - i]) 3596 { 3597 index = len - i + 1; 3598 goto done; 3599 } 3600 } 3601 } 3602 } 3603 else 3604 { 3605 for (i = 0; i < len; i++) 3606 { 3607 for (j = 0; j < lensub; j++) 3608 { 3609 if (y->value.character.string[j] 3610 == x->value.character.string[len - i]) 3611 { 3612 start = len - i; 3613 if (start <= len - lensub) 3614 { 3615 count = 0; 3616 for (k = 0; k < lensub; k++) 3617 if (y->value.character.string[k] 3618 == x->value.character.string[k + start]) 3619 count++; 3620 3621 if (count == lensub) 3622 { 3623 index = start + 1; 3624 goto done; 3625 } 3626 } 3627 else 3628 { 3629 continue; 3630 } 3631 } 3632 } 3633 } 3634 } 3635 } 3636 3637done: 3638 mpz_set_si__gmpz_set_si (result->value.integer, index); 3639 return range_check (result, "INDEX"); 3640} 3641 3642 3643static gfc_expr * 3644simplify_intconv (gfc_expr *e, int kind, const char *name) 3645{ 3646 gfc_expr *result = NULL__null; 3647 int tmp1, tmp2; 3648 3649 /* Convert BOZ to integer, and return without range checking. */ 3650 if (e->ts.type == BT_BOZ) 3651 { 3652 if (!gfc_boz2int (e, kind)) 3653 return NULL__null; 3654 result = gfc_copy_expr (e); 3655 return result; 3656 } 3657 3658 if (e->expr_type != EXPR_CONSTANT) 3659 return NULL__null; 3660 3661 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra 3662 warnings. */ 3663 tmp1 = warn_conversionglobal_options.x_warn_conversion; 3664 tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra; 3665 warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0; 3666 3667 result = gfc_convert_constant (e, BT_INTEGER, kind); 3668 3669 warn_conversionglobal_options.x_warn_conversion = tmp1; 3670 warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2; 3671 3672 if (result == &gfc_bad_expr) 3673 return &gfc_bad_expr; 3674 3675 return range_check (result, name); 3676} 3677 3678 3679gfc_expr * 3680gfc_simplify_int (gfc_expr *e, gfc_expr *k) 3681{ 3682 int kind; 3683 3684 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); 3685 if (kind == -1) 3686 return &gfc_bad_expr; 3687 3688 return simplify_intconv (e, kind, "INT"); 3689} 3690 3691gfc_expr * 3692gfc_simplify_int2 (gfc_expr *e) 3693{ 3694 return simplify_intconv (e, 2, "INT2"); 3695} 3696 3697 3698gfc_expr * 3699gfc_simplify_int8 (gfc_expr *e) 3700{ 3701 return simplify_intconv (e, 8, "INT8"); 3702} 3703 3704 3705gfc_expr * 3706gfc_simplify_long (gfc_expr *e) 3707{ 3708 return simplify_intconv (e, 4, "LONG"); 3709} 3710 3711 3712gfc_expr * 3713gfc_simplify_ifix (gfc_expr *e) 3714{ 3715 gfc_expr *rtrunc, *result; 3716 3717 if (e->expr_type != EXPR_CONSTANT) 3718 return NULL__null; 3719 3720 rtrunc = gfc_copy_expr (e); 3721 mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
)
; 3722 3723 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 3724 &e->where); 3725 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); 3726 3727 gfc_free_expr (rtrunc); 3728 3729 return range_check (result, "IFIX"); 3730} 3731 3732 3733gfc_expr * 3734gfc_simplify_idint (gfc_expr *e) 3735{ 3736 gfc_expr *rtrunc, *result; 3737 3738 if (e->expr_type != EXPR_CONSTANT) 3739 return NULL__null; 3740 3741 rtrunc = gfc_copy_expr (e); 3742 mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
)
; 3743 3744 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 3745 &e->where); 3746 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); 3747 3748 gfc_free_expr (rtrunc); 3749 3750 return range_check (result, "IDINT"); 3751} 3752 3753 3754gfc_expr * 3755gfc_simplify_ior (gfc_expr *x, gfc_expr *y) 3756{ 3757 gfc_expr *result; 3758 3759 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 3760 return NULL__null; 3761 3762 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); 3763 mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer); 3764 3765 return range_check (result, "IOR"); 3766} 3767 3768 3769static gfc_expr * 3770do_bit_xor (gfc_expr *result, gfc_expr *e) 3771{ 3772 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3772, __FUNCTION__), 0 : 0))
; 3773 gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3774, __FUNCTION__), 0 : 0))
3774 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3774, __FUNCTION__), 0 : 0))
; 3775 3776 mpz_xor__gmpz_xor (result->value.integer, result->value.integer, e->value.integer); 3777 return result; 3778} 3779 3780 3781gfc_expr * 3782gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) 3783{ 3784 return simplify_transformation (array, dim, mask, 0, do_bit_xor); 3785} 3786 3787 3788gfc_expr * 3789gfc_simplify_is_iostat_end (gfc_expr *x) 3790{ 3791 if (x->expr_type != EXPR_CONSTANT) 3792 return NULL__null; 3793 3794 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3795 mpz_cmp_si (x->value.integer,(__builtin_constant_p ((LIBERROR_END) >= 0) && (LIBERROR_END
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_END))) && ((static_cast<unsigned long
> (LIBERROR_END))) == 0 ? ((x->value.integer)->_mp_size
< 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
(x->value.integer,(static_cast<unsigned long> (LIBERROR_END
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_END))
3796 LIBERROR_END)(__builtin_constant_p ((LIBERROR_END) >= 0) && (LIBERROR_END
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_END))) && ((static_cast<unsigned long
> (LIBERROR_END))) == 0 ? ((x->value.integer)->_mp_size
< 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
(x->value.integer,(static_cast<unsigned long> (LIBERROR_END
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_END))
== 0); 3797} 3798 3799 3800gfc_expr * 3801gfc_simplify_is_iostat_eor (gfc_expr *x) 3802{ 3803 if (x->expr_type != EXPR_CONSTANT) 3804 return NULL__null; 3805 3806 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3807 mpz_cmp_si (x->value.integer,(__builtin_constant_p ((LIBERROR_EOR) >= 0) && (LIBERROR_EOR
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_EOR))) && ((static_cast<unsigned long
> (LIBERROR_EOR))) == 0 ? ((x->value.integer)->_mp_size
< 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
(x->value.integer,(static_cast<unsigned long> (LIBERROR_EOR
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_EOR))
3808 LIBERROR_EOR)(__builtin_constant_p ((LIBERROR_EOR) >= 0) && (LIBERROR_EOR
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_EOR))) && ((static_cast<unsigned long
> (LIBERROR_EOR))) == 0 ? ((x->value.integer)->_mp_size
< 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
(x->value.integer,(static_cast<unsigned long> (LIBERROR_EOR
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_EOR))
== 0); 3809} 3810 3811 3812gfc_expr * 3813gfc_simplify_isnan (gfc_expr *x) 3814{ 3815 if (x->expr_type != EXPR_CONSTANT) 3816 return NULL__null; 3817 3818 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, 3819 mpfr_nan_p (x->value.real)((x->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
); 3820} 3821 3822 3823/* Performs a shift on its first argument. Depending on the last 3824 argument, the shift can be arithmetic, i.e. with filling from the 3825 left like in the SHIFTA intrinsic. */ 3826static gfc_expr * 3827simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, 3828 bool arithmetic, int direction) 3829{ 3830 gfc_expr *result; 3831 int ashift, *bits, i, k, bitsize, shift; 3832 3833 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 3834 return NULL__null; 3835 3836 gfc_extract_int (s, &shift); 3837 3838 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); 3839 bitsize = gfc_integer_kinds[k].bit_size; 3840 3841 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 3842 3843 if (shift == 0) 3844 { 3845 mpz_set__gmpz_set (result->value.integer, e->value.integer); 3846 return result; 3847 } 3848 3849 if (direction > 0 && shift < 0) 3850 { 3851 /* Left shift, as in SHIFTL. */ 3852 gfc_error ("Second argument of %s is negative at %L", name, &e->where); 3853 return &gfc_bad_expr; 3854 } 3855 else if (direction < 0) 3856 { 3857 /* Right shift, as in SHIFTR or SHIFTA. */ 3858 if (shift < 0) 3859 { 3860 gfc_error ("Second argument of %s is negative at %L", 3861 name, &e->where); 3862 return &gfc_bad_expr; 3863 } 3864 3865 shift = -shift; 3866 } 3867 3868 ashift = (shift >= 0 ? shift : -shift); 3869 3870 if (ashift > bitsize) 3871 { 3872 gfc_error ("Magnitude of second argument of %s exceeds bit size " 3873 "at %L", name, &e->where); 3874 return &gfc_bad_expr; 3875 } 3876 3877 bits = XCNEWVEC (int, bitsize)((int *) xcalloc ((bitsize), sizeof (int))); 3878 3879 for (i = 0; i < bitsize; i++) 3880 bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i); 3881 3882 if (shift > 0) 3883 { 3884 /* Left shift. */ 3885 for (i = 0; i < shift; i++) 3886 mpz_clrbit__gmpz_clrbit (result->value.integer, i); 3887 3888 for (i = 0; i < bitsize - shift; i++) 3889 { 3890 if (bits[i] == 0) 3891 mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift); 3892 else 3893 mpz_setbit__gmpz_setbit (result->value.integer, i + shift); 3894 } 3895 } 3896 else 3897 { 3898 /* Right shift. */ 3899 if (arithmetic && bits[bitsize - 1]) 3900 for (i = bitsize - 1; i >= bitsize - ashift; i--) 3901 mpz_setbit__gmpz_setbit (result->value.integer, i); 3902 else 3903 for (i = bitsize - 1; i >= bitsize - ashift; i--) 3904 mpz_clrbit__gmpz_clrbit (result->value.integer, i); 3905 3906 for (i = bitsize - 1; i >= ashift; i--) 3907 { 3908 if (bits[i] == 0) 3909 mpz_clrbit__gmpz_clrbit (result->value.integer, i - ashift); 3910 else 3911 mpz_setbit__gmpz_setbit (result->value.integer, i - ashift); 3912 } 3913 } 3914 3915 gfc_convert_mpz_to_signed (result->value.integer, bitsize); 3916 free (bits); 3917 3918 return result; 3919} 3920 3921 3922gfc_expr * 3923gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) 3924{ 3925 return simplify_shift (e, s, "ISHFT", false, 0); 3926} 3927 3928 3929gfc_expr * 3930gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) 3931{ 3932 return simplify_shift (e, s, "LSHIFT", false, 1); 3933} 3934 3935 3936gfc_expr * 3937gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) 3938{ 3939 return simplify_shift (e, s, "RSHIFT", true, -1); 3940} 3941 3942 3943gfc_expr * 3944gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) 3945{ 3946 return simplify_shift (e, s, "SHIFTA", true, -1); 3947} 3948 3949 3950gfc_expr * 3951gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) 3952{ 3953 return simplify_shift (e, s, "SHIFTL", false, 1); 3954} 3955 3956 3957gfc_expr * 3958gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) 3959{ 3960 return simplify_shift (e, s, "SHIFTR", false, -1); 3961} 3962 3963 3964gfc_expr * 3965gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) 3966{ 3967 gfc_expr *result; 3968 int shift, ashift, isize, ssize, delta, k; 3969 int i, *bits; 3970 3971 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 3972 return NULL__null; 3973 3974 gfc_extract_int (s, &shift); 3975 3976 k = gfc_validate_kind (e->ts.type, e->ts.kind, false); 3977 isize = gfc_integer_kinds[k].bit_size; 3978 3979 if (sz != NULL__null) 3980 { 3981 if (sz->expr_type != EXPR_CONSTANT) 3982 return NULL__null; 3983 3984 gfc_extract_int (sz, &ssize); 3985 } 3986 else 3987 ssize = isize; 3988 3989 if (shift >= 0) 3990 ashift = shift; 3991 else 3992 ashift = -shift; 3993 3994 if (ashift > ssize) 3995 { 3996 if (sz == NULL__null) 3997 gfc_error ("Magnitude of second argument of ISHFTC exceeds " 3998 "BIT_SIZE of first argument at %C"); 3999 else 4000 gfc_error ("Absolute value of SHIFT shall be less than or equal " 4001 "to SIZE at %C"); 4002 return &gfc_bad_expr; 4003 } 4004 4005 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 4006 4007 mpz_set__gmpz_set (result->value.integer, e->value.integer); 4008 4009 if (shift == 0) 4010 return result; 4011 4012 convert_mpz_to_unsigned (result->value.integer, isize); 4013 4014 bits = XCNEWVEC (int, ssize)((int *) xcalloc ((ssize), sizeof (int))); 4015 4016 for (i = 0; i < ssize; i++) 4017 bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i); 4018 4019 delta = ssize - ashift; 4020 4021 if (shift > 0) 4022 { 4023 for (i = 0; i < delta; i++) 4024 { 4025 if (bits[i] == 0) 4026 mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift); 4027 else 4028 mpz_setbit__gmpz_setbit (result->value.integer, i + shift); 4029 } 4030 4031 for (i = delta; i < ssize; i++) 4032 { 4033 if (bits[i] == 0) 4034 mpz_clrbit__gmpz_clrbit (result->value.integer, i - delta); 4035 else 4036 mpz_setbit__gmpz_setbit (result->value.integer, i - delta); 4037 } 4038 } 4039 else 4040 { 4041 for (i = 0; i < ashift; i++) 4042 { 4043 if (bits[i] == 0) 4044 mpz_clrbit__gmpz_clrbit (result->value.integer, i + delta); 4045 else 4046 mpz_setbit__gmpz_setbit (result->value.integer, i + delta); 4047 } 4048 4049 for (i = ashift; i < ssize; i++) 4050 { 4051 if (bits[i] == 0) 4052 mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift); 4053 else 4054 mpz_setbit__gmpz_setbit (result->value.integer, i + shift); 4055 } 4056 } 4057 4058 gfc_convert_mpz_to_signed (result->value.integer, isize); 4059 4060 free (bits); 4061 return result; 4062} 4063 4064 4065gfc_expr * 4066gfc_simplify_kind (gfc_expr *e) 4067{ 4068 return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, e->ts.kind); 4069} 4070 4071 4072static gfc_expr * 4073simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, 4074 gfc_array_spec *as, gfc_ref *ref, bool coarray) 4075{ 4076 gfc_expr *l, *u, *result; 4077 int k; 4078 4079 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", 4080 gfc_default_integer_kind); 4081 if (k == -1) 4082 return &gfc_bad_expr; 4083 4084 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 4085 4086 /* For non-variables, LBOUND(expr, DIM=n) = 1 and 4087 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ 4088 if (!coarray && array->expr_type != EXPR_VARIABLE) 4089 { 4090 if (upper) 4091 { 4092 gfc_expr* dim = result; 4093 mpz_set_si__gmpz_set_si (dim->value.integer, d); 4094 4095 result = simplify_size (array, dim, k); 4096 gfc_free_expr (dim); 4097 if (!result) 4098 goto returnNull; 4099 } 4100 else 4101 mpz_set_si__gmpz_set_si (result->value.integer, 1); 4102 4103 goto done; 4104 } 4105 4106 /* Otherwise, we have a variable expression. */ 4107 gcc_assert (array->expr_type == EXPR_VARIABLE)((void)(!(array->expr_type == EXPR_VARIABLE) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4107, __FUNCTION__), 0 : 0))
; 4108 gcc_assert (as)((void)(!(as) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4108, __FUNCTION__), 0 : 0))
; 4109 4110 if (!gfc_resolve_array_spec (as, 0)) 4111 return NULL__null; 4112 4113 /* The last dimension of an assumed-size array is special. */ 4114 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) 4115 || (coarray && d == as->rank + as->corank 4116 && (!upper || flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE))) 4117 { 4118 if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT) 4119 { 4120 gfc_free_expr (result); 4121 return gfc_copy_expr (as->lower[d-1]); 4122 } 4123 4124 goto returnNull; 4125 } 4126 4127 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); 4128 4129 /* Then, we need to know the extent of the given dimension. */ 4130 if (coarray || (ref->u.ar.type == AR_FULL && !ref->next)) 4131 { 4132 gfc_expr *declared_bound; 4133 int empty_bound; 4134 bool constant_lbound, constant_ubound; 4135 4136 l = as->lower[d-1]; 4137 u = as->upper[d-1]; 4138 4139 gcc_assert (l != NULL)((void)(!(l != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4139, __FUNCTION__), 0 : 0))
; 4140 4141 constant_lbound = l->expr_type == EXPR_CONSTANT; 4142 constant_ubound = u && u->expr_type == EXPR_CONSTANT; 4143 4144 empty_bound = upper ? 0 : 1; 4145 declared_bound = upper ? u : l; 4146 4147 if ((!upper && !constant_lbound) 4148 || (upper && !constant_ubound)) 4149 goto returnNull; 4150 4151 if (!coarray) 4152 { 4153 /* For {L,U}BOUND, the value depends on whether the array 4154 is empty. We can nevertheless simplify if the declared bound 4155 has the same value as that of an empty array, in which case 4156 the result isn't dependent on the array emptyness. */ 4157 if (mpz_cmp_si (declared_bound->value.integer, empty_bound)(__builtin_constant_p ((empty_bound) >= 0) && (empty_bound
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (empty_bound))) && ((static_cast<unsigned long
> (empty_bound))) == 0 ? ((declared_bound->value.integer
)->_mp_size < 0 ? -1 : (declared_bound->value.integer
)->_mp_size > 0) : __gmpz_cmp_ui (declared_bound->value
.integer,(static_cast<unsigned long> (empty_bound)))) :
__gmpz_cmp_si (declared_bound->value.integer,empty_bound)
)
== 0) 4158 mpz_set_si__gmpz_set_si (result->value.integer, empty_bound); 4159 else if (!constant_lbound || !constant_ubound) 4160 /* Array emptyness can't be determined, we can't simplify. */ 4161 goto returnNull; 4162 else if (mpz_cmp__gmpz_cmp (l->value.integer, u->value.integer) > 0) 4163 mpz_set_si__gmpz_set_si (result->value.integer, empty_bound); 4164 else 4165 mpz_set__gmpz_set (result->value.integer, declared_bound->value.integer); 4166 } 4167 else 4168 mpz_set__gmpz_set (result->value.integer, declared_bound->value.integer); 4169 } 4170 else 4171 { 4172 if (upper) 4173 { 4174 int d2 = 0, cnt = 0; 4175 for (int idx = 0; idx < ref->u.ar.dimen; ++idx) 4176 { 4177 if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT) 4178 d2++; 4179 else if (cnt < d - 1) 4180 cnt++; 4181 else 4182 break; 4183 } 4184 if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL__null)) 4185 goto returnNull; 4186 } 4187 else 4188 mpz_set_si__gmpz_set_si (result->value.integer, (long int) 1); 4189 } 4190 4191done: 4192 return range_check (result, upper ? "UBOUND" : "LBOUND"); 4193 4194returnNull: 4195 gfc_free_expr (result); 4196 return NULL__null; 4197} 4198 4199 4200static gfc_expr * 4201simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 4202{ 4203 gfc_ref *ref; 4204 gfc_array_spec *as; 4205 ar_type type = AR_UNKNOWN; 4206 int d; 4207 4208 if (array->ts.type == BT_CLASS) 4209 return NULL__null; 4210 4211 if (array->expr_type != EXPR_VARIABLE) 4212 { 4213 as = NULL__null; 4214 ref = NULL__null; 4215 goto done; 4216 } 4217 4218 /* Do not attempt to resolve if error has already been issued. */ 4219 if (array->symtree->n.sym->error) 4220 return NULL__null; 4221 4222 /* Follow any component references. */ 4223 as = array->symtree->n.sym->as; 4224 for (ref = array->ref; ref; ref = ref->next) 4225 { 4226 switch (ref->type) 4227 { 4228 case REF_ARRAY: 4229 type = ref->u.ar.type; 4230 switch (ref->u.ar.type) 4231 { 4232 case AR_ELEMENT: 4233 as = NULL__null; 4234 continue; 4235 4236 case AR_FULL: 4237 /* We're done because 'as' has already been set in the 4238 previous iteration. */ 4239 goto done; 4240 4241 case AR_UNKNOWN: 4242 return NULL__null; 4243 4244 case AR_SECTION: 4245 as = ref->u.ar.as; 4246 goto done; 4247 } 4248 4249 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4249, __FUNCTION__))
; 4250 4251 case REF_COMPONENT: 4252 as = ref->u.c.component->as; 4253 continue; 4254 4255 case REF_SUBSTRING: 4256 case REF_INQUIRY: 4257 continue; 4258 } 4259 } 4260 4261 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4261, __FUNCTION__))
; 4262 4263 done: 4264 4265 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK 4266 || (as->type == AS_ASSUMED_SHAPE && upper))) 4267 return NULL__null; 4268 4269 gcc_assert (!as((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4273, __FUNCTION__), 0 : 0))
4270 || (as->type != AS_DEFERRED((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4273, __FUNCTION__), 0 : 0))
4271 && array->expr_type == EXPR_VARIABLE((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4273, __FUNCTION__), 0 : 0))
4272 && !gfc_expr_attr (array).allocatable((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4273, __FUNCTION__), 0 : 0))
4273 && !gfc_expr_attr (array).pointer))((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4273, __FUNCTION__), 0 : 0))
; 4274 4275 if (dim == NULL__null) 4276 { 4277 /* Multi-dimensional bounds. */ 4278 gfc_expr *bounds[GFC_MAX_DIMENSIONS15]; 4279 gfc_expr *e; 4280 int k; 4281 4282 /* UBOUND(ARRAY) is not valid for an assumed-size array. */ 4283 if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE) 4284 { 4285 /* An error message will be emitted in 4286 check_assumed_size_reference (resolve.c). */ 4287 return &gfc_bad_expr; 4288 } 4289 4290 /* Simplify the bounds for each dimension. */ 4291 for (d = 0; d < array->rank; d++) 4292 { 4293 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, 4294 false); 4295 if (bounds[d] == NULL__null || bounds[d] == &gfc_bad_expr) 4296 { 4297 int j; 4298 4299 for (j = 0; j < d; j++) 4300 gfc_free_expr (bounds[j]); 4301 4302 if (gfc_seen_div0) 4303 return &gfc_bad_expr; 4304 else 4305 return bounds[d]; 4306 } 4307 } 4308 4309 /* Allocate the result expression. */ 4310 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", 4311 gfc_default_integer_kind); 4312 if (k == -1) 4313 return &gfc_bad_expr; 4314 4315 e = gfc_get_array_expr (BT_INTEGER, k, &array->where); 4316 4317 /* The result is a rank 1 array; its size is the rank of the first 4318 argument to {L,U}BOUND. */ 4319 e->rank = 1; 4320 e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 4321 mpz_init_set_ui__gmpz_init_set_ui (e->shape[0], array->rank); 4322 4323 /* Create the constructor for this array. */ 4324 for (d = 0; d < array->rank; d++) 4325 gfc_constructor_append_expr (&e->value.constructor, 4326 bounds[d], &e->where); 4327 4328 return e; 4329 } 4330 else 4331 { 4332 /* A DIM argument is specified. */ 4333 if (dim->expr_type != EXPR_CONSTANT) 4334 return NULL__null; 4335 4336 d = mpz_get_si__gmpz_get_si (dim->value.integer); 4337 4338 if ((d < 1 || d > array->rank) 4339 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) 4340 { 4341 gfc_error ("DIM argument at %L is out of bounds", &dim->where); 4342 return &gfc_bad_expr; 4343 } 4344 4345 if (as && as->type == AS_ASSUMED_RANK) 4346 return NULL__null; 4347 4348 return simplify_bound_dim (array, kind, d, upper, as, ref, false); 4349 } 4350} 4351 4352 4353static gfc_expr * 4354simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 4355{ 4356 gfc_ref *ref; 4357 gfc_array_spec *as; 4358 int d; 4359 4360 if (array->expr_type != EXPR_VARIABLE) 4361 return NULL__null; 4362 4363 /* Follow any component references. */ 4364 as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) 4365 ? array->ts.u.derived->components->as 4366 : array->symtree->n.sym->as; 4367 for (ref = array->ref; ref; ref = ref->next) 4368 { 4369 switch (ref->type) 4370 { 4371 case REF_ARRAY: 4372 switch (ref->u.ar.type) 4373 { 4374 case AR_ELEMENT: 4375 if (ref->u.ar.as->corank > 0) 4376 { 4377 gcc_assert (as == ref->u.ar.as)((void)(!(as == ref->u.ar.as) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4377, __FUNCTION__), 0 : 0))
; 4378 goto done; 4379 } 4380 as = NULL__null; 4381 continue; 4382 4383 case AR_FULL: 4384 /* We're done because 'as' has already been set in the 4385 previous iteration. */ 4386 goto done; 4387 4388 case AR_UNKNOWN: 4389 return NULL__null; 4390 4391 case AR_SECTION: 4392 as = ref->u.ar.as; 4393 goto done; 4394 } 4395 4396 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4396, __FUNCTION__))
; 4397 4398 case REF_COMPONENT: 4399 as = ref->u.c.component->as; 4400 continue; 4401 4402 case REF_SUBSTRING: 4403 case REF_INQUIRY: 4404 continue; 4405 } 4406 } 4407 4408 if (!as) 4409 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4409, __FUNCTION__))
; 4410 4411 done: 4412 4413 if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) 4414 return NULL__null; 4415 4416 if (dim == NULL__null) 4417 { 4418 /* Multi-dimensional cobounds. */ 4419 gfc_expr *bounds[GFC_MAX_DIMENSIONS15]; 4420 gfc_expr *e; 4421 int k; 4422 4423 /* Simplify the cobounds for each dimension. */ 4424 for (d = 0; d < as->corank; d++) 4425 { 4426 bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, 4427 upper, as, ref, true); 4428 if (bounds[d] == NULL__null || bounds[d] == &gfc_bad_expr) 4429 { 4430 int j; 4431 4432 for (j = 0; j < d; j++) 4433 gfc_free_expr (bounds[j]); 4434 return bounds[d]; 4435 } 4436 } 4437 4438 /* Allocate the result expression. */ 4439 e = gfc_get_expr (); 4440 e->where = array->where; 4441 e->expr_type = EXPR_ARRAY; 4442 e->ts.type = BT_INTEGER; 4443 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", 4444 gfc_default_integer_kind); 4445 if (k == -1) 4446 { 4447 gfc_free_expr (e); 4448 return &gfc_bad_expr; 4449 } 4450 e->ts.kind = k; 4451 4452 /* The result is a rank 1 array; its size is the rank of the first 4453 argument to {L,U}COBOUND. */ 4454 e->rank = 1; 4455 e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 4456 mpz_init_set_ui__gmpz_init_set_ui (e->shape[0], as->corank); 4457 4458 /* Create the constructor for this array. */ 4459 for (d = 0; d < as->corank; d++) 4460 gfc_constructor_append_expr (&e->value.constructor, 4461 bounds[d], &e->where); 4462 return e; 4463 } 4464 else 4465 { 4466 /* A DIM argument is specified. */ 4467 if (dim->expr_type != EXPR_CONSTANT) 4468 return NULL__null; 4469 4470 d = mpz_get_si__gmpz_get_si (dim->value.integer); 4471 4472 if (d < 1 || d > as->corank) 4473 { 4474 gfc_error ("DIM argument at %L is out of bounds", &dim->where); 4475 return &gfc_bad_expr; 4476 } 4477 4478 return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); 4479 } 4480} 4481 4482 4483gfc_expr * 4484gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 4485{ 4486 return simplify_bound (array, dim, kind, 0); 4487} 4488 4489 4490gfc_expr * 4491gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 4492{ 4493 return simplify_cobound (array, dim, kind, 0); 4494} 4495 4496gfc_expr * 4497gfc_simplify_leadz (gfc_expr *e) 4498{ 4499 unsigned long lz, bs; 4500 int i; 4501 4502 if (e->expr_type != EXPR_CONSTANT) 4503 return NULL__null; 4504 4505 i = gfc_validate_kind (e->ts.type, e->ts.kind, false); 4506 bs = gfc_integer_kinds[i].bit_size; 4507 if (mpz_cmp_si (e->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
&& ((static_cast<unsigned long> (0))) == 0 ? (
(e->value.integer)->_mp_size < 0 ? -1 : (e->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer
,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e->
value.integer,0))
== 0) 4508 lz = bs; 4509 else if (mpz_cmp_si (e->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
&& ((static_cast<unsigned long> (0))) == 0 ? (
(e->value.integer)->_mp_size < 0 ? -1 : (e->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer
,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e->
value.integer,0))
< 0) 4510 lz = 0; 4511 else 4512 lz = bs - mpz_sizeinbase__gmpz_sizeinbase (e->value.integer, 2); 4513 4514 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); 4515} 4516 4517 4518/* Check for constant length of a substring. */ 4519 4520static bool 4521substring_has_constant_len (gfc_expr *e) 4522{ 4523 gfc_ref *ref; 4524 HOST_WIDE_INTlong istart, iend, length; 4525 bool equal_length = false; 4526 4527 if (e->ts.type != BT_CHARACTER) 4528 return false; 4529 4530 for (ref = e->ref; ref; ref = ref->next) 4531 if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY) 4532 break; 4533 4534 if (!ref 4535 || ref->type != REF_SUBSTRING 4536 || !ref->u.ss.start 4537 || ref->u.ss.start->expr_type != EXPR_CONSTANT 4538 || !ref->u.ss.end 4539 || ref->u.ss.end->expr_type != EXPR_CONSTANT) 4540 return false; 4541 4542 /* Basic checks on substring starting and ending indices. */ 4543 if (!gfc_resolve_substring (ref, &equal_length)) 4544 return false; 4545 4546 istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer); 4547 iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer); 4548 4549 if (istart <= iend) 4550 length = iend - istart + 1; 4551 else 4552 length = 0; 4553 4554 /* Fix substring length. */ 4555 e->value.character.length = length; 4556 4557 return true; 4558} 4559 4560 4561gfc_expr * 4562gfc_simplify_len (gfc_expr *e, gfc_expr *kind) 4563{ 4564 gfc_expr *result; 4565 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); 4566 4567 if (k == -1) 4568 return &gfc_bad_expr; 4569 4570 if (e->expr_type == EXPR_CONSTANT 4571 || substring_has_constant_len (e)) 4572 { 4573 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); 4574 mpz_set_si__gmpz_set_si (result->value.integer, e->value.character.length); 4575 return range_check (result, "LEN"); 4576 } 4577 else if (e->ts.u.cl != NULL__null && e->ts.u.cl->length != NULL__null 4578 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT 4579 && e->ts.u.cl->length->ts.type == BT_INTEGER) 4580 { 4581 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); 4582 mpz_set__gmpz_set (result->value.integer, e->ts.u.cl->length->value.integer); 4583 return range_check (result, "LEN"); 4584 } 4585 else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER 4586 && e->symtree->n.sym 4587 && e->symtree->n.sym->ts.type != BT_DERIVED 4588 && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target 4589 && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED 4590 && e->symtree->n.sym->assoc->target->symtree->n.sym 4591 && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym)(e->symtree->n.sym->assoc->target->symtree->
n.sym != __null && e->symtree->n.sym->assoc->
target->symtree->n.sym->ts.type == BT_CLASS &&
e->symtree->n.sym->assoc->target->symtree->
n.sym->ts.u.derived->components && e->symtree
->n.sym->assoc->target->symtree->n.sym->ts.
u.derived->components->ts.u.derived && e->symtree
->n.sym->assoc->target->symtree->n.sym->ts.
u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)
) 4592 4593 /* The expression in assoc->target points to a ref to the _data component 4594 of the unlimited polymorphic entity. To get the _len component the last 4595 _data ref needs to be stripped and a ref to the _len component added. */ 4596 return gfc_get_len_component (e->symtree->n.sym->assoc->target, k); 4597 else 4598 return NULL__null; 4599} 4600 4601 4602gfc_expr * 4603gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) 4604{ 4605 gfc_expr *result; 4606 size_t count, len, i; 4607 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); 4608 4609 if (k == -1) 4610 return &gfc_bad_expr; 4611 4612 if (e->expr_type != EXPR_CONSTANT) 4613 return NULL__null; 4614 4615 len = e->value.character.length; 4616 for (count = 0, i = 1; i <= len; i++) 4617 if (e->value.character.string[len - i] == ' ') 4618 count++; 4619 else 4620 break; 4621 4622 result = gfc_get_int_expr (k, &e->where, len - count); 4623 return range_check (result, "LEN_TRIM"); 4624} 4625 4626gfc_expr * 4627gfc_simplify_lgamma (gfc_expr *x) 4628{ 4629 gfc_expr *result; 4630 int sg; 4631 4632 if (x->expr_type != EXPR_CONSTANT) 4633 return NULL__null; 4634 4635 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4636 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODEMPFR_RNDN); 4637 4638 return range_check (result, "LGAMMA"); 4639} 4640 4641 4642gfc_expr * 4643gfc_simplify_lge (gfc_expr *a, gfc_expr *b) 4644{ 4645 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4646 return NULL__null; 4647 4648 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4649 gfc_compare_string (a, b) >= 0); 4650} 4651 4652 4653gfc_expr * 4654gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) 4655{ 4656 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4657 return NULL__null; 4658 4659 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4660 gfc_compare_string (a, b) > 0); 4661} 4662 4663 4664gfc_expr * 4665gfc_simplify_lle (gfc_expr *a, gfc_expr *b) 4666{ 4667 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4668 return NULL__null; 4669 4670 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4671 gfc_compare_string (a, b) <= 0); 4672} 4673 4674 4675gfc_expr * 4676gfc_simplify_llt (gfc_expr *a, gfc_expr *b) 4677{ 4678 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) 4679 return NULL__null; 4680 4681 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, 4682 gfc_compare_string (a, b) < 0); 4683} 4684 4685 4686gfc_expr * 4687gfc_simplify_log (gfc_expr *x) 4688{ 4689 gfc_expr *result; 4690 4691 if (x->expr_type != EXPR_CONSTANT) 4692 return NULL__null; 4693 4694 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4695 4696 switch (x->ts.type) 4697 { 4698 case BT_REAL: 4699 if (mpfr_sgn (x->value.real)((x->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? (((x->value.real)->_mpfr_exp
== (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
() : (mpfr_void) 0), 0 : ((x->value.real)->_mpfr_sign)
)
<= 0) 4700 { 4701 gfc_error ("Argument of LOG at %L cannot be less than or equal " 4702 "to zero", &x->where); 4703 gfc_free_expr (result); 4704 return &gfc_bad_expr; 4705 } 4706 4707 mpfr_log (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 4708 break; 4709 4710 case BT_COMPLEX: 4711 if (mpfr_zero_p (mpc_realref (x->value.complex))((((x->value.complex)->re))->_mpfr_exp == (0 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
4712 && mpfr_zero_p (mpc_imagref (x->value.complex))((((x->value.complex)->im))->_mpfr_exp == (0 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
) 4713 { 4714 gfc_error ("Complex argument of LOG at %L cannot be zero", 4715 &x->where); 4716 gfc_free_expr (result); 4717 return &gfc_bad_expr; 4718 } 4719 4720 gfc_set_model_kind (x->ts.kind); 4721 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4))); 4722 break; 4723 4724 default: 4725 gfc_internal_error ("gfc_simplify_log: bad type"); 4726 } 4727 4728 return range_check (result, "LOG"); 4729} 4730 4731 4732gfc_expr * 4733gfc_simplify_log10 (gfc_expr *x) 4734{ 4735 gfc_expr *result; 4736 4737 if (x->expr_type != EXPR_CONSTANT) 4738 return NULL__null; 4739 4740 if (mpfr_sgn (x->value.real)((x->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? (((x->value.real)->_mpfr_exp
== (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
() : (mpfr_void) 0), 0 : ((x->value.real)->_mpfr_sign)
)
<= 0) 4741 { 4742 gfc_error ("Argument of LOG10 at %L cannot be less than or equal " 4743 "to zero", &x->where); 4744 return &gfc_bad_expr; 4745 } 4746 4747 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); 4748 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN); 4749 4750 return range_check (result, "LOG10"); 4751} 4752 4753 4754gfc_expr * 4755gfc_simplify_logical (gfc_expr *e, gfc_expr *k) 4756{ 4757 int kind; 4758 4759 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); 4760 if (kind < 0) 4761 return &gfc_bad_expr; 4762 4763 if (e->expr_type != EXPR_CONSTANT) 4764 return NULL__null; 4765 4766 return gfc_get_logical_expr (kind, &e->where, e->value.logical); 4767} 4768 4769 4770gfc_expr* 4771gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) 4772{ 4773 gfc_expr *result; 4774 int row, result_rows, col, result_columns; 4775 int stride_a, offset_a, stride_b, offset_b; 4776 4777 if (!is_constant_array_expr (matrix_a) 4778 || !is_constant_array_expr (matrix_b)) 4779 return NULL__null; 4780 4781 /* MATMUL should do mixed-mode arithmetic. Set the result type. */ 4782 if (matrix_a->ts.type != matrix_b->ts.type) 4783 { 4784 gfc_expr e; 4785 e.expr_type = EXPR_OP; 4786 gfc_clear_ts (&e.ts); 4787 e.value.op.op = INTRINSIC_NONE; 4788 e.value.op.op1 = matrix_a; 4789 e.value.op.op2 = matrix_b; 4790 gfc_type_convert_binary (&e, 1); 4791 result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where); 4792 } 4793 else 4794 { 4795 result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind, 4796 &matrix_a->where); 4797 } 4798 4799 if (matrix_a->rank == 1 && matrix_b->rank == 2) 4800 { 4801 result_rows = 1; 4802 result_columns = mpz_get_si__gmpz_get_si (matrix_b->shape[1]); 4803 stride_a = 1; 4804 stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]); 4805 4806 result->rank = 1; 4807 result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t)))); 4808 mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_columns); 4809 } 4810 else if (matrix_a->rank == 2 && matrix_b->rank == 1) 4811 { 4812 result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]); 4813 result_columns = 1; 4814 stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]); 4815 stride_b = 1; 4816 4817 result->rank = 1; 4818 result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t)))); 4819 mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows); 4820 } 4821 else if (matrix_a->rank == 2 && matrix_b->rank == 2) 4822 { 4823 result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]); 4824 result_columns = mpz_get_si__gmpz_get_si (matrix_b->shape[1]); 4825 stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]); 4826 stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]); 4827 4828 result->rank = 2; 4829 result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t)))); 4830 mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows); 4831 mpz_init_set_si__gmpz_init_set_si (result->shape[1], result_columns); 4832 } 4833 else 4834 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4834, __FUNCTION__))
; 4835 4836 offset_b = 0; 4837 for (col = 0; col < result_columns; ++col) 4838 { 4839 offset_a = 0; 4840 4841 for (row = 0; row < result_rows; ++row) 4842 { 4843 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, 4844 matrix_b, 1, offset_b, false); 4845 gfc_constructor_append_expr (&result->value.constructor, 4846 e, NULL__null); 4847 4848 offset_a += 1; 4849 } 4850 4851 offset_b += stride_b; 4852 } 4853 4854 return result; 4855} 4856 4857 4858gfc_expr * 4859gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) 4860{ 4861 gfc_expr *result; 4862 int kind, arg, k; 4863 4864 if (i->expr_type != EXPR_CONSTANT) 4865 return NULL__null; 4866 4867 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); 4868 if (kind == -1) 4869 return &gfc_bad_expr; 4870 k = gfc_validate_kind (BT_INTEGER, kind, false); 4871 4872 bool fail = gfc_extract_int (i, &arg); 4873 gcc_assert (!fail)((void)(!(!fail) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4873, __FUNCTION__), 0 : 0))
; 4874 4875 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 4876 4877 /* MASKR(n) = 2^n - 1 */ 4878 mpz_set_ui__gmpz_set_ui (result->value.integer, 1); 4879 mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer, arg); 4880 mpz_sub_ui__gmpz_sub_ui (result->value.integer, result->value.integer, 1); 4881 4882 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 4883 4884 return result; 4885} 4886 4887 4888gfc_expr * 4889gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) 4890{ 4891 gfc_expr *result; 4892 int kind, arg, k; 4893 mpz_t z; 4894 4895 if (i->expr_type != EXPR_CONSTANT) 4896 return NULL__null; 4897 4898 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); 4899 if (kind == -1) 4900 return &gfc_bad_expr; 4901 k = gfc_validate_kind (BT_INTEGER, kind, false); 4902 4903 bool fail = gfc_extract_int (i, &arg); 4904 gcc_assert (!fail)((void)(!(!fail) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4904, __FUNCTION__), 0 : 0))
; 4905 4906 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); 4907 4908 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ 4909 mpz_init_set_ui__gmpz_init_set_ui (z, 1); 4910 mpz_mul_2exp__gmpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); 4911 mpz_set_ui__gmpz_set_ui (result->value.integer, 1); 4912 mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer, 4913 gfc_integer_kinds[k].bit_size - arg); 4914 mpz_sub__gmpz_sub (result->value.integer, z, result->value.integer); 4915 mpz_clear__gmpz_clear (z); 4916 4917 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); 4918 4919 return result; 4920} 4921 4922 4923gfc_expr * 4924gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) 4925{ 4926 gfc_expr * result; 4927 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; 4928 4929 if (mask->expr_type == EXPR_CONSTANT) 4930 { 4931 result = gfc_copy_expr (mask->value.logical ? tsource : fsource); 4932 /* Parenthesis is needed to get lower bounds of 1. */ 4933 result = gfc_get_parentheses (result); 4934 gfc_simplify_expr (result, 1); 4935 return result; 4936 } 4937 4938 if (!mask->rank || !is_constant_array_expr (mask) 4939 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) 4940 return NULL__null; 4941 4942 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, 4943 &tsource->where); 4944 if (tsource->ts.type == BT_DERIVED) 4945 result->ts.u.derived = tsource->ts.u.derived; 4946 else if (tsource->ts.type == BT_CHARACTER) 4947 result->ts.u.cl = tsource->ts.u.cl; 4948 4949 tsource_ctor = gfc_constructor_first (tsource->value.constructor); 4950 fsource_ctor = gfc_constructor_first (fsource->value.constructor); 4951 mask_ctor = gfc_constructor_first (mask->value.constructor); 4952 4953 while (mask_ctor) 4954 { 4955 if (mask_ctor->expr->value.logical) 4956 gfc_constructor_append_expr (&result->value.constructor, 4957 gfc_copy_expr (tsource_ctor->expr), 4958 NULL__null); 4959 else 4960 gfc_constructor_append_expr (&result->value.constructor, 4961 gfc_copy_expr (fsource_ctor->expr), 4962 NULL__null); 4963 tsource_ctor = gfc_constructor_next (tsource_ctor); 4964 fsource_ctor = gfc_constructor_next (fsource_ctor); 4965 mask_ctor = gfc_constructor_next (mask_ctor); 4966 } 4967 4968 result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 4969 gfc_array_size (result, &result->shape[0]); 4970 4971 return result; 4972} 4973 4974 4975gfc_expr * 4976gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) 4977{ 4978 mpz_t arg1, arg2, mask; 4979 gfc_expr *result; 4980 4981 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT 4982 || mask_expr->expr_type != EXPR_CONSTANT) 4983 return NULL__null; 4984 4985 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); 4986 4987 /* Convert all argument to unsigned. */ 4988 mpz_init_set__gmpz_init_set (arg1, i->value.integer); 4989 mpz_init_set__gmpz_init_set (arg2, j->value.integer); 4990 mpz_init_set__gmpz_init_set (mask, mask_expr->value.integer); 4991 4992 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ 4993 mpz_and__gmpz_and (arg1, arg1, mask); 4994 mpz_com__gmpz_com (mask, mask); 4995 mpz_and__gmpz_and (arg2, arg2, mask); 4996 mpz_ior__gmpz_ior (result->value.integer, arg1, arg2); 4997 4998 mpz_clear__gmpz_clear (arg1); 4999 mpz_clear__gmpz_clear (arg2); 5000 mpz_clear__gmpz_clear (mask); 5001 5002 return result; 5003} 5004 5005 5006/* Selects between current value and extremum for simplify_min_max 5007 and simplify_minval_maxval. */ 5008static int 5009min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) 5010{ 5011 int ret; 5012 5013 switch (arg->ts.type) 5014 { 5015 case BT_INTEGER: 5016 if (extremum->ts.kind < arg->ts.kind) 5017 extremum->ts.kind = arg->ts.kind; 5018 ret = mpz_cmp__gmpz_cmp (arg->value.integer, 5019 extremum->value.integer) * sign; 5020 if (ret > 0) 5021 mpz_set__gmpz_set (extremum->value.integer, arg->value.integer); 5022 break; 5023 5024 case BT_REAL: 5025 if (extremum->ts.kind < arg->ts.kind) 5026 extremum->ts.kind = arg->ts.kind; 5027 if (mpfr_nan_p (extremum->value.real)((extremum->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
) 5028 { 5029 ret = 1; 5030 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE)mpfr_set4(extremum->value.real,arg->value.real,MPFR_RNDN
,((arg->value.real)->_mpfr_sign))
; 5031 } 5032 else if (mpfr_nan_p (arg->value.real)((arg->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))))
) 5033 ret = -1; 5034 else 5035 { 5036 ret = mpfr_cmp (arg->value.real, extremum->value.real)mpfr_cmp3(arg->value.real, extremum->value.real, 1) * sign; 5037 if (ret > 0) 5038 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE)mpfr_set4(extremum->value.real,arg->value.real,MPFR_RNDN
,((arg->value.real)->_mpfr_sign))
; 5039 } 5040 break; 5041 5042 case BT_CHARACTER: 5043#define LENGTH(x) ((x)->value.character.length) 5044#define STRING(x) ((x)->value.character.string) 5045 if (LENGTH (extremum) < LENGTH(arg)) 5046 { 5047 gfc_char_t *tmp = STRING(extremum); 5048 5049 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1)((gfc_char_t *) xcalloc ((LENGTH(arg) + 1), sizeof (gfc_char_t
)))
; 5050 memcpy (STRING(extremum), tmp, 5051 LENGTH(extremum) * sizeof (gfc_char_t)); 5052 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', 5053 LENGTH(arg) - LENGTH(extremum)); 5054 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ 5055 LENGTH(extremum) = LENGTH(arg); 5056 free (tmp); 5057 } 5058 ret = gfc_compare_string (arg, extremum) * sign; 5059 if (ret > 0) 5060 { 5061 free (STRING(extremum)); 5062 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1)((gfc_char_t *) xcalloc ((LENGTH(extremum) + 1), sizeof (gfc_char_t
)))
; 5063 memcpy (STRING(extremum), STRING(arg), 5064 LENGTH(arg) * sizeof (gfc_char_t)); 5065 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', 5066 LENGTH(extremum) - LENGTH(arg)); 5067 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ 5068 } 5069#undef LENGTH 5070#undef STRING 5071 break; 5072 5073 default: 5074 gfc_internal_error ("simplify_min_max(): Bad type in arglist"); 5075 } 5076 if (back_val && ret == 0) 5077 ret = 1; 5078 5079 return ret; 5080} 5081 5082 5083/* This function is special since MAX() can take any number of 5084 arguments. The simplified expression is a rewritten version of the 5085 argument list containing at most one constant element. Other 5086 constant elements are deleted. Because the argument list has 5087 already been checked, this function always succeeds. sign is 1 for 5088 MAX(), -1 for MIN(). */ 5089 5090static gfc_expr * 5091simplify_min_max (gfc_expr *expr, int sign) 5092{ 5093 gfc_actual_arglist *arg, *last, *extremum; 5094 gfc_expr *tmp, *ret; 5095 const char *fname; 5096 5097 last = NULL__null; 5098 extremum = NULL__null; 5099 5100 arg = expr->value.function.actual; 5101 5102 for (; arg; last = arg, arg = arg->next) 5103 { 5104 if (arg->expr->expr_type != EXPR_CONSTANT) 5105 continue; 5106 5107 if (extremum == NULL__null) 5108 { 5109 extremum = arg; 5110 continue; 5111 } 5112 5113 min_max_choose (arg->expr, extremum->expr, sign); 5114 5115 /* Delete the extra constant argument. */ 5116 last->next = arg->next; 5117 5118 arg->next = NULL__null; 5119 gfc_free_actual_arglist (arg); 5120 arg = last; 5121 } 5122 5123 /* If there is one value left, replace the function call with the 5124 expression. */ 5125 if (expr->value.function.actual->next != NULL__null) 5126 return NULL__null; 5127 5128 /* Handle special cases of specific functions (min|max)1 and 5129 a(min|max)0. */ 5130 5131 tmp = expr->value.function.actual->expr; 5132 fname = expr->value.function.isym->name; 5133 5134 if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind4) 5135 && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0)) 5136 { 5137 ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind4); 5138 } 5139 else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind4) 5140 && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0)) 5141 { 5142 ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind4); 5143 } 5144 else 5145 ret = gfc_copy_expr (tmp); 5146 5147 return ret; 5148 5149} 5150 5151 5152gfc_expr * 5153gfc_simplify_min (gfc_expr *e) 5154{ 5155 return simplify_min_max (e, -1); 5156} 5157 5158 5159gfc_expr * 5160gfc_simplify_max (gfc_expr *e) 5161{ 5162 return simplify_min_max (e, 1); 5163} 5164 5165/* Helper function for gfc_simplify_minval. */ 5166 5167static gfc_expr * 5168gfc_min (gfc_expr *op1, gfc_expr *op2) 5169{ 5170 min_max_choose (op1, op2, -1); 5171 gfc_free_expr (op1); 5172 return op2; 5173} 5174 5175/* Simplify minval for constant arrays. */ 5176 5177gfc_expr * 5178gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 5179{ 5180 return simplify_transformation (array, dim, mask, INT_MAX2147483647, gfc_min); 5181} 5182 5183/* Helper function for gfc_simplify_maxval. */ 5184 5185static gfc_expr * 5186gfc_max (gfc_expr *op1, gfc_expr *op2) 5187{ 5188 min_max_choose (op1, op2, 1); 5189 gfc_free_expr (op1); 5190 return op2; 5191} 5192 5193 5194/* Simplify maxval for constant arrays. */ 5195 5196gfc_expr * 5197gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) 5198{ 5199 return simplify_transformation (array, dim, mask, INT_MIN(-2147483647 -1), gfc_max); 5200} 5201 5202 5203/* Transform minloc or maxloc of an array, according to MASK, 5204 to the scalar result. This code is mostly identical to 5205 simplify_transformation_to_scalar. */ 5206 5207static gfc_expr * 5208simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, 5209 gfc_expr *extremum, int sign, bool back_val) 5210{ 5211 gfc_expr *a, *m; 5212 gfc_constructor *array_ctor, *mask_ctor; 5213 mpz_t count; 5214 5215 mpz_set_si__gmpz_set_si (result->value.integer, 0); 5216 5217 5218 /* Shortcut for constant .FALSE. MASK. */ 5219 if (mask 5220 && mask->expr_type == EXPR_CONSTANT 5221 && !mask->value.logical) 5222 return result; 5223 5224 array_ctor = gfc_constructor_first (array->value.constructor); 5225 if (mask && mask->expr_type == EXPR_ARRAY) 5226 mask_ctor = gfc_constructor_first (mask->value.constructor); 5227 else 5228 mask_ctor = NULL__null; 5229 5230 mpz_init_set_si__gmpz_init_set_si (count, 0); 5231 while (array_ctor) 5232 { 5233 mpz_add_ui__gmpz_add_ui (count, count, 1); 5234 a = array_ctor->expr; 5235 array_ctor = gfc_constructor_next (array_ctor); 5236 /* A constant MASK equals .TRUE. here and can be ignored. */ 5237 if (mask_ctor) 5238 { 5239 m = mask_ctor->expr; 5240 mask_ctor = gfc_constructor_next (mask_ctor); 5241 if (!m->value.logical) 5242 continue; 5243 } 5244 if (min_max_choose (a, extremum, sign, back_val) > 0) 5245 mpz_set__gmpz_set (result->value.integer, count); 5246 } 5247 mpz_clear__gmpz_clear (count); 5248 gfc_free_expr (extremum); 5249 return result; 5250} 5251 5252/* Simplify minloc / maxloc in the absence of a dim argument. */ 5253 5254static gfc_expr * 5255simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum, 5256 gfc_expr *array, gfc_expr *mask, int sign, 5257 bool back_val) 5258{ 5259 ssize_t res[GFC_MAX_DIMENSIONS15]; 5260 int i, n; 5261 gfc_constructor *result_ctor, *array_ctor, *mask_ctor; 5262 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5263 sstride[GFC_MAX_DIMENSIONS15]; 5264 gfc_expr *a, *m; 5265 bool continue_loop; 5266 bool ma; 5267 5268 for (i = 0; i<array->rank; i++) 5269 res[i] = -1; 5270 5271 /* Shortcut for constant .FALSE. MASK. */ 5272 if (mask 5273 && mask->expr_type == EXPR_CONSTANT 5274 && !mask->value.logical) 5275 goto finish; 5276 5277 for (i = 0; i < array->rank; i++) 5278 { 5279 count[i] = 0; 5280 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5281 extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]); 5282 if (extent[i] <= 0) 5283 goto finish; 5284 } 5285 5286 continue_loop = true; 5287 array_ctor = gfc_constructor_first (array->value.constructor); 5288 if (mask && mask->rank > 0) 5289 mask_ctor = gfc_constructor_first (mask->value.constructor); 5290 else 5291 mask_ctor = NULL__null; 5292 5293 /* Loop over the array elements (and mask), keeping track of 5294 the indices to return. */ 5295 while (continue_loop) 5296 { 5297 do 5298 { 5299 a = array_ctor->expr; 5300 if (mask_ctor) 5301 { 5302 m = mask_ctor->expr; 5303 ma = m->value.logical; 5304 mask_ctor = gfc_constructor_next (mask_ctor); 5305 } 5306 else 5307 ma = true; 5308 5309 if (ma && min_max_choose (a, extremum, sign, back_val) > 0) 5310 { 5311 for (i = 0; i<array->rank; i++) 5312 res[i] = count[i]; 5313 } 5314 array_ctor = gfc_constructor_next (array_ctor); 5315 count[0] ++; 5316 } while (count[0] != extent[0]); 5317 n = 0; 5318 do 5319 { 5320 /* When we get to the end of a dimension, reset it and increment 5321 the next dimension. */ 5322 count[n] = 0; 5323 n++; 5324 if (n >= array->rank) 5325 { 5326 continue_loop = false; 5327 break; 5328 } 5329 else 5330 count[n] ++; 5331 } while (count[n] == extent[n]); 5332 } 5333 5334 finish: 5335 gfc_free_expr (extremum); 5336 result_ctor = gfc_constructor_first (result->value.constructor); 5337 for (i = 0; i<array->rank; i++) 5338 { 5339 gfc_expr *r_expr; 5340 r_expr = result_ctor->expr; 5341 mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1); 5342 result_ctor = gfc_constructor_next (result_ctor); 5343 } 5344 return result; 5345} 5346 5347/* Helper function for gfc_simplify_minmaxloc - build an array 5348 expression with n elements. */ 5349 5350static gfc_expr * 5351new_array (bt type, int kind, int n, locus *where) 5352{ 5353 gfc_expr *result; 5354 int i; 5355 5356 result = gfc_get_array_expr (type, kind, where); 5357 result->rank = 1; 5358 result->shape = gfc_get_shape(1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 5359 mpz_init_set_si__gmpz_init_set_si (result->shape[0], n); 5360 for (i = 0; i < n; i++) 5361 { 5362 gfc_constructor_append_expr (&result->value.constructor, 5363 gfc_get_constant_expr (type, kind, where), 5364 NULL__null); 5365 } 5366 5367 return result; 5368} 5369 5370/* Simplify minloc and maxloc. This code is mostly identical to 5371 simplify_transformation_to_array. */ 5372 5373static gfc_expr * 5374simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, 5375 gfc_expr *dim, gfc_expr *mask, 5376 gfc_expr *extremum, int sign, bool back_val) 5377{ 5378 mpz_t size; 5379 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5380 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5381 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5382 5383 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5384 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15], 5385 tmpstride[GFC_MAX_DIMENSIONS15]; 5386 5387 /* Shortcut for constant .FALSE. MASK. */ 5388 if (mask 5389 && mask->expr_type == EXPR_CONSTANT 5390 && !mask->value.logical) 5391 return result; 5392 5393 /* Build an indexed table for array element expressions to minimize 5394 linked-list traversal. Masked elements are set to NULL. */ 5395 gfc_array_size (array, &size); 5396 arraysize = mpz_get_ui__gmpz_get_ui (size); 5397 mpz_clear__gmpz_clear (size); 5398 5399 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*))); 5400 5401 array_ctor = gfc_constructor_first (array->value.constructor); 5402 mask_ctor = NULL__null; 5403 if (mask && mask->expr_type == EXPR_ARRAY) 5404 mask_ctor = gfc_constructor_first (mask->value.constructor); 5405 5406 for (i = 0; i < arraysize; ++i) 5407 { 5408 arrayvec[i] = array_ctor->expr; 5409 array_ctor = gfc_constructor_next (array_ctor); 5410 5411 if (mask_ctor) 5412 { 5413 if (!mask_ctor->expr->value.logical) 5414 arrayvec[i] = NULL__null; 5415 5416 mask_ctor = gfc_constructor_next (mask_ctor); 5417 } 5418 } 5419 5420 /* Same for the result expression. */ 5421 gfc_array_size (result, &size); 5422 resultsize = mpz_get_ui__gmpz_get_ui (size); 5423 mpz_clear__gmpz_clear (size); 5424 5425 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*))); 5426 result_ctor = gfc_constructor_first (result->value.constructor); 5427 for (i = 0; i < resultsize; ++i) 5428 { 5429 resultvec[i] = result_ctor->expr; 5430 result_ctor = gfc_constructor_next (result_ctor); 5431 } 5432 5433 gfc_extract_int (dim, &dim_index); 5434 dim_index -= 1; /* zero-base index */ 5435 dim_extent = 0; 5436 dim_stride = 0; 5437 5438 for (i = 0, n = 0; i < array->rank; ++i) 5439 { 5440 count[i] = 0; 5441 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5442 if (i == dim_index) 5443 { 5444 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]); 5445 dim_stride = tmpstride[i]; 5446 continue; 5447 } 5448 5449 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]); 5450 sstride[n] = tmpstride[i]; 5451 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5452 n += 1; 5453 } 5454 5455 done = resultsize <= 0; 5456 base = arrayvec; 5457 dest = resultvec; 5458 while (!done) 5459 { 5460 gfc_expr *ex; 5461 ex = gfc_copy_expr (extremum); 5462 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5463 { 5464 if (*src && min_max_choose (*src, ex, sign, back_val) > 0) 5465 mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1); 5466 } 5467 5468 count[0]++; 5469 base += sstride[0]; 5470 dest += dstride[0]; 5471 gfc_free_expr (ex); 5472 5473 n = 0; 5474 while (!done && count[n] == extent[n]) 5475 { 5476 count[n] = 0; 5477 base -= sstride[n] * extent[n]; 5478 dest -= dstride[n] * extent[n]; 5479 5480 n++; 5481 if (n < result->rank) 5482 { 5483 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5484 times, we'd warn for the last iteration, because the 5485 array index will have already been incremented to the 5486 array sizes, and we can't tell that this must make 5487 the test against result->rank false, because ranks 5488 must not exceed GFC_MAX_DIMENSIONS. */ 5489 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5490 count[n]++; 5491 base += sstride[n]; 5492 dest += dstride[n]; 5493 GCC_DIAGNOSTIC_POP 5494 } 5495 else 5496 done = true; 5497 } 5498 } 5499 5500 /* Place updated expression in result constructor. */ 5501 result_ctor = gfc_constructor_first (result->value.constructor); 5502 for (i = 0; i < resultsize; ++i) 5503 { 5504 result_ctor->expr = resultvec[i]; 5505 result_ctor = gfc_constructor_next (result_ctor); 5506 } 5507 5508 free (arrayvec); 5509 free (resultvec); 5510 free (extremum); 5511 return result; 5512} 5513 5514/* Simplify minloc and maxloc for constant arrays. */ 5515 5516static gfc_expr * 5517gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 5518 gfc_expr *kind, gfc_expr *back, int sign) 5519{ 5520 gfc_expr *result; 5521 gfc_expr *extremum; 5522 int ikind; 5523 int init_val; 5524 bool back_val = false; 5525 5526 if (!is_constant_array_expr (array) 5527 || !gfc_is_constant_expr (dim)) 5528 return NULL__null; 5529 5530 if (mask 5531 && !is_constant_array_expr (mask) 5532 && mask->expr_type != EXPR_CONSTANT) 5533 return NULL__null; 5534 5535 if (kind) 5536 { 5537 if (gfc_extract_int (kind, &ikind, -1)) 5538 return NULL__null; 5539 } 5540 else 5541 ikind = gfc_default_integer_kind; 5542 5543 if (back) 5544 { 5545 if (back->expr_type != EXPR_CONSTANT) 5546 return NULL__null; 5547 5548 back_val = back->value.logical; 5549 } 5550 5551 if (sign < 0) 5552 init_val = INT_MAX2147483647; 5553 else if (sign > 0) 5554 init_val = INT_MIN(-2147483647 -1); 5555 else 5556 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 5556, __FUNCTION__))
; 5557 5558 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); 5559 init_result_expr (extremum, init_val, array); 5560 5561 if (dim) 5562 { 5563 result = transformational_result (array, dim, BT_INTEGER, 5564 ikind, &array->where); 5565 init_result_expr (result, 0, array); 5566 5567 if (array->rank == 1) 5568 return simplify_minmaxloc_to_scalar (result, array, mask, extremum, 5569 sign, back_val); 5570 else 5571 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, 5572 sign, back_val); 5573 } 5574 else 5575 { 5576 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5577 return simplify_minmaxloc_nodim (result, extremum, array, mask, 5578 sign, back_val); 5579 } 5580} 5581 5582gfc_expr * 5583gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5584 gfc_expr *back) 5585{ 5586 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); 5587} 5588 5589gfc_expr * 5590gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5591 gfc_expr *back) 5592{ 5593 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1); 5594} 5595 5596/* Simplify findloc to scalar. Similar to 5597 simplify_minmaxloc_to_scalar. */ 5598 5599static gfc_expr * 5600simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5601 gfc_expr *mask, int back_val) 5602{ 5603 gfc_expr *a, *m; 5604 gfc_constructor *array_ctor, *mask_ctor; 5605 mpz_t count; 5606 5607 mpz_set_si__gmpz_set_si (result->value.integer, 0); 5608 5609 /* Shortcut for constant .FALSE. MASK. */ 5610 if (mask 5611 && mask->expr_type == EXPR_CONSTANT 5612 && !mask->value.logical) 5613 return result; 5614 5615 array_ctor = gfc_constructor_first (array->value.constructor); 5616 if (mask && mask->expr_type == EXPR_ARRAY) 5617 mask_ctor = gfc_constructor_first (mask->value.constructor); 5618 else 5619 mask_ctor = NULL__null; 5620 5621 mpz_init_set_si__gmpz_init_set_si (count, 0); 5622 while (array_ctor) 5623 { 5624 mpz_add_ui__gmpz_add_ui (count, count, 1); 5625 a = array_ctor->expr; 5626 array_ctor = gfc_constructor_next (array_ctor); 5627 /* A constant MASK equals .TRUE. here and can be ignored. */ 5628 if (mask_ctor) 5629 { 5630 m = mask_ctor->expr; 5631 mask_ctor = gfc_constructor_next (mask_ctor); 5632 if (!m->value.logical) 5633 continue; 5634 } 5635 if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5636 { 5637 /* We have a match. If BACK is true, continue so we find 5638 the last one. */ 5639 mpz_set__gmpz_set (result->value.integer, count); 5640 if (!back_val) 5641 break; 5642 } 5643 } 5644 mpz_clear__gmpz_clear (count); 5645 return result; 5646} 5647 5648/* Simplify findloc in the absence of a dim argument. Similar to 5649 simplify_minmaxloc_nodim. */ 5650 5651static gfc_expr * 5652simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array, 5653 gfc_expr *mask, bool back_val) 5654{ 5655 ssize_t res[GFC_MAX_DIMENSIONS15]; 5656 int i, n; 5657 gfc_constructor *result_ctor, *array_ctor, *mask_ctor; 5658 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5659 sstride[GFC_MAX_DIMENSIONS15]; 5660 gfc_expr *a, *m; 5661 bool continue_loop; 5662 bool ma; 5663 5664 for (i = 0; i < array->rank; i++) 5665 res[i] = -1; 5666 5667 /* Shortcut for constant .FALSE. MASK. */ 5668 if (mask 5669 && mask->expr_type == EXPR_CONSTANT 5670 && !mask->value.logical) 5671 goto finish; 5672 5673 for (i = 0; i < array->rank; i++) 5674 { 5675 count[i] = 0; 5676 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5677 extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]); 5678 if (extent[i] <= 0) 5679 goto finish; 5680 } 5681 5682 continue_loop = true; 5683 array_ctor = gfc_constructor_first (array->value.constructor); 5684 if (mask && mask->rank > 0) 5685 mask_ctor = gfc_constructor_first (mask->value.constructor); 5686 else 5687 mask_ctor = NULL__null; 5688 5689 /* Loop over the array elements (and mask), keeping track of 5690 the indices to return. */ 5691 while (continue_loop) 5692 { 5693 do 5694 { 5695 a = array_ctor->expr; 5696 if (mask_ctor) 5697 { 5698 m = mask_ctor->expr; 5699 ma = m->value.logical; 5700 mask_ctor = gfc_constructor_next (mask_ctor); 5701 } 5702 else 5703 ma = true; 5704 5705 if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5706 { 5707 for (i = 0; i < array->rank; i++) 5708 res[i] = count[i]; 5709 if (!back_val) 5710 goto finish; 5711 } 5712 array_ctor = gfc_constructor_next (array_ctor); 5713 count[0] ++; 5714 } while (count[0] != extent[0]); 5715 n = 0; 5716 do 5717 { 5718 /* When we get to the end of a dimension, reset it and increment 5719 the next dimension. */ 5720 count[n] = 0; 5721 n++; 5722 if (n >= array->rank) 5723 { 5724 continue_loop = false; 5725 break; 5726 } 5727 else 5728 count[n] ++; 5729 } while (count[n] == extent[n]); 5730 } 5731 5732finish: 5733 result_ctor = gfc_constructor_first (result->value.constructor); 5734 for (i = 0; i < array->rank; i++) 5735 { 5736 gfc_expr *r_expr; 5737 r_expr = result_ctor->expr; 5738 mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1); 5739 result_ctor = gfc_constructor_next (result_ctor); 5740 } 5741 return result; 5742} 5743 5744 5745/* Simplify findloc to an array. Similar to 5746 simplify_minmaxloc_to_array. */ 5747 5748static gfc_expr * 5749simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5750 gfc_expr *dim, gfc_expr *mask, bool back_val) 5751{ 5752 mpz_t size; 5753 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5754 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5755 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5756 5757 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5758 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15], 5759 tmpstride[GFC_MAX_DIMENSIONS15]; 5760 5761 /* Shortcut for constant .FALSE. MASK. */ 5762 if (mask 5763 && mask->expr_type == EXPR_CONSTANT 5764 && !mask->value.logical) 5765 return result; 5766 5767 /* Build an indexed table for array element expressions to minimize 5768 linked-list traversal. Masked elements are set to NULL. */ 5769 gfc_array_size (array, &size); 5770 arraysize = mpz_get_ui__gmpz_get_ui (size); 5771 mpz_clear__gmpz_clear (size); 5772 5773 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*))); 5774 5775 array_ctor = gfc_constructor_first (array->value.constructor); 5776 mask_ctor = NULL__null; 5777 if (mask && mask->expr_type == EXPR_ARRAY) 5778 mask_ctor = gfc_constructor_first (mask->value.constructor); 5779 5780 for (i = 0; i < arraysize; ++i) 5781 { 5782 arrayvec[i] = array_ctor->expr; 5783 array_ctor = gfc_constructor_next (array_ctor); 5784 5785 if (mask_ctor) 5786 { 5787 if (!mask_ctor->expr->value.logical) 5788 arrayvec[i] = NULL__null; 5789 5790 mask_ctor = gfc_constructor_next (mask_ctor); 5791 } 5792 } 5793 5794 /* Same for the result expression. */ 5795 gfc_array_size (result, &size); 5796 resultsize = mpz_get_ui__gmpz_get_ui (size); 5797 mpz_clear__gmpz_clear (size); 5798 5799 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*))); 5800 result_ctor = gfc_constructor_first (result->value.constructor); 5801 for (i = 0; i < resultsize; ++i) 5802 { 5803 resultvec[i] = result_ctor->expr; 5804 result_ctor = gfc_constructor_next (result_ctor); 5805 } 5806 5807 gfc_extract_int (dim, &dim_index); 5808 5809 dim_index -= 1; /* Zero-base index. */ 5810 dim_extent = 0; 5811 dim_stride = 0; 5812 5813 for (i = 0, n = 0; i < array->rank; ++i) 5814 { 5815 count[i] = 0; 5816 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5817 if (i == dim_index) 5818 { 5819 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]); 5820 dim_stride = tmpstride[i]; 5821 continue; 5822 } 5823 5824 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]); 5825 sstride[n] = tmpstride[i]; 5826 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5827 n += 1; 5828 } 5829 5830 done = resultsize <= 0; 5831 base = arrayvec; 5832 dest = resultvec; 5833 while (!done) 5834 { 5835 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5836 { 5837 if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0) 5838 { 5839 mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1); 5840 if (!back_val) 5841 break; 5842 } 5843 } 5844 5845 count[0]++; 5846 base += sstride[0]; 5847 dest += dstride[0]; 5848 5849 n = 0; 5850 while (!done && count[n] == extent[n]) 5851 { 5852 count[n] = 0; 5853 base -= sstride[n] * extent[n]; 5854 dest -= dstride[n] * extent[n]; 5855 5856 n++; 5857 if (n < result->rank) 5858 { 5859 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5860 times, we'd warn for the last iteration, because the 5861 array index will have already been incremented to the 5862 array sizes, and we can't tell that this must make 5863 the test against result->rank false, because ranks 5864 must not exceed GFC_MAX_DIMENSIONS. */ 5865 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5866 count[n]++; 5867 base += sstride[n]; 5868 dest += dstride[n]; 5869 GCC_DIAGNOSTIC_POP 5870 } 5871 else 5872 done = true; 5873 } 5874 } 5875 5876 /* Place updated expression in result constructor. */ 5877 result_ctor = gfc_constructor_first (result->value.constructor); 5878 for (i = 0; i < resultsize; ++i) 5879 { 5880 result_ctor->expr = resultvec[i]; 5881 result_ctor = gfc_constructor_next (result_ctor); 5882 } 5883 5884 free (arrayvec); 5885 free (resultvec); 5886 return result; 5887} 5888 5889/* Simplify findloc. */ 5890 5891gfc_expr * 5892gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim, 5893 gfc_expr *mask, gfc_expr *kind, gfc_expr *back) 5894{ 5895 gfc_expr *result; 5896 int ikind; 5897 bool back_val = false; 5898 5899 if (!is_constant_array_expr (array) 5900 || !gfc_is_constant_expr (dim)) 5901 return NULL__null; 5902 5903 if (! gfc_is_constant_expr (value)) 5904 return 0; 5905 5906 if (mask 5907 && !is_constant_array_expr (mask) 5908 && mask->expr_type != EXPR_CONSTANT) 5909 return NULL__null; 5910 5911 if (kind) 5912 { 5913 if (gfc_extract_int (kind, &ikind, -1)) 5914 return NULL__null; 5915 } 5916 else 5917 ikind = gfc_default_integer_kind; 5918 5919 if (back) 5920 { 5921 if (back->expr_type != EXPR_CONSTANT) 5922 return NULL__null; 5923 5924 back_val = back->value.logical; 5925 } 5926 5927 if (dim) 5928 { 5929 result = transformational_result (array, dim, BT_INTEGER, 5930 ikind, &array->where); 5931 init_result_expr (result, 0, array); 5932 5933 if (array->rank == 1) 5934 return simplify_findloc_to_scalar (result, array, value, mask, 5935 back_val); 5936 else 5937 return simplify_findloc_to_array (result, array, value, dim, mask, 5938 back_val); 5939 } 5940 else 5941 { 5942 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5943 return simplify_findloc_nodim (result, value, array, mask, back_val); 5944 } 5945 return NULL__null; 5946} 5947 5948gfc_expr * 5949gfc_simplify_maxexponent (gfc_expr *x) 5950{ 5951 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5952 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5953 gfc_real_kinds[i].max_exponent); 5954} 5955 5956 5957gfc_expr * 5958gfc_simplify_minexponent (gfc_expr *x) 5959{ 5960 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5961 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5962 gfc_real_kinds[i].min_exponent); 5963} 5964 5965 5966gfc_expr * 5967gfc_simplify_mod (gfc_expr *a, gfc_expr *p) 5968{ 5969 gfc_expr *result; 5970 int kind; 5971 5972 /* First check p. */ 5973 if (p->expr_type != EXPR_CONSTANT) 5974 return NULL__null; 5975 5976 /* p shall not be 0. */ 5977 switch (p->ts.type) 5978 { 5979 case BT_INTEGER: 5980 if (mpz_cmp_ui (p->value.integer, 0)(__builtin_constant_p (0) && (0) == 0 ? ((p->value
.integer)->_mp_size < 0 ? -1 : (p->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (p->value.integer,0))
== 0) 5981 { 5982 gfc_error ("Argument %qs of MOD at %L shall not be zero", 5983 "P", &p->where); 5984 return &gfc_bad_expr; 5985 } 5986 break; 5987 case BT_REAL: 5988 if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0) 5989 { 5990 gfc_error ("Argument %qs of MOD at %L shall not be zero", 5991 "P", &p->where); 5992 return &gfc_bad_expr; 5993 } 5994 break; 5995 default: 5996 gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); 5997 } 5998 5999 if (a->expr_type != EXPR_CONSTANT) 6000 return NULL__null; 6001 6002 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 6003 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 6004 6005 if (a->ts.type == BT_INTEGER) 6006 mpz_tdiv_r__gmpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); 6007 else 6008 { 6009 gfc_set_model_kind (kind); 6010 mpfr_fmod (result->value.real, a->value.real, p->value.real, 6011 GFC_RND_MODEMPFR_RNDN); 6012 } 6013 6014 return range_check (result, "MOD"); 6015} 6016 6017 6018gfc_expr * 6019gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) 6020{ 6021 gfc_expr *result; 6022 int kind; 6023 6024 /* First check p. */ 6025 if (p->expr_type != EXPR_CONSTANT) 6026 return NULL__null; 6027 6028 /* p shall not be 0. */ 6029 switch (p->ts.type) 6030 { 6031 case BT_INTEGER: 6032 if (mpz_cmp_ui (p->value.integer, 0)(__builtin_constant_p (0) && (0) == 0 ? ((p->value
.integer)->_mp_size < 0 ? -1 : (p->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (p->value.integer,0))
== 0) 6033 { 6034 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 6035 "P", &p->where); 6036 return &gfc_bad_expr; 6037 } 6038 break; 6039 case BT_REAL: 6040 if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0) 6041 { 6042 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 6043 "P", &p->where); 6044 return &gfc_bad_expr; 6045 } 6046 break; 6047 default: 6048 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); 6049 } 6050 6051 if (a->expr_type != EXPR_CONSTANT) 6052 return NULL__null; 6053 6054 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 6055 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 6056 6057 if (a->ts.type == BT_INTEGER) 6058 mpz_fdiv_r__gmpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); 6059 else 6060 { 6061 gfc_set_model_kind (kind); 6062 mpfr_fmod (result->value.real, a->value.real, p->value.real, 6063 GFC_RND_MODEMPFR_RNDN); 6064 if (mpfr_cmp_ui (result->value.real, 0)mpfr_cmp_ui_2exp((result->value.real),(0),0) != 0) 6065 { 6066 if (mpfr_signbit (a->value.real)(((a->value.real)->_mpfr_sign) < 0) != mpfr_signbit (p->value.real)(((p->value.real)->_mpfr_sign) < 0)) 6067 mpfr_add (result->value.real, result->value.real, p->value.real, 6068 GFC_RND_MODEMPFR_RNDN); 6069 } 6070 else 6071 mpfr_copysign (result->value.real, result->value.real,mpfr_set4(result->value.real,result->value.real,MPFR_RNDN
,((p->value.real)->_mpfr_sign))
6072 p->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,result->value.real,MPFR_RNDN
,((p->value.real)->_mpfr_sign))
; 6073 } 6074 6075 return range_check (result, "MODULO"); 6076} 6077 6078 6079gfc_expr * 6080gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) 6081{ 6082 gfc_expr *result; 6083 mpfr_exp_t emin, emax; 6084 int kind; 6085 6086 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 6087 return NULL__null; 6088 6089 result = gfc_copy_expr (x); 6090 6091 /* Save current values of emin and emax. */ 6092 emin = mpfr_get_emin (); 6093 emax = mpfr_get_emax (); 6094 6095 /* Set emin and emax for the current model number. */ 6096 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); 6097 mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent - 6098 mpfr_get_prec(result->value.real)(0 ? ((result->value.real)->_mpfr_prec) : ((result->
value.real)->_mpfr_prec))
+ 1); 6099 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1); 6100 mpfr_check_range (result->value.real, 0, MPFR_RNDU); 6101 6102 if (mpfr_sgn (s->value.real)((s->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? (((s->value.real)->_mpfr_exp
== (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
() : (mpfr_void) 0), 0 : ((s->value.real)->_mpfr_sign)
)
> 0) 6103 { 6104 mpfr_nextabove (result->value.real); 6105 mpfr_subnormalize (result->value.real, 0, MPFR_RNDU); 6106 } 6107 else 6108 { 6109 mpfr_nextbelow (result->value.real); 6110 mpfr_subnormalize (result->value.real, 0, MPFR_RNDD); 6111 } 6112 6113 mpfr_set_emin (emin); 6114 mpfr_set_emax (emax); 6115 6116 /* Only NaN can occur. Do not use range check as it gives an 6117 error for denormal numbers. */ 6118 if (mpfr_nan_p (result->value.real)((result->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t) (
((mpfr_uexp_t) -1) >> 1))))
&& flag_range_checkglobal_options.x_flag_range_check) 6119 { 6120 gfc_error ("Result of NEAREST is NaN at %L", &result->where); 6121 gfc_free_expr (result); 6122 return &gfc_bad_expr; 6123 } 6124 6125 return result; 6126} 6127 6128 6129static gfc_expr * 6130simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) 6131{ 6132 gfc_expr *itrunc, *result; 6133 int kind; 6134 6135 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); 6136 if (kind == -1) 6137 return &gfc_bad_expr; 6138 6139 if (e->expr_type != EXPR_CONSTANT) 6140 return NULL__null; 6141 6142 itrunc = gfc_copy_expr (e); 6143 mpfr_round (itrunc->value.real, e->value.real)mpfr_rint((itrunc->value.real), (e->value.real), MPFR_RNDNA
)
; 6144 6145 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 6146 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); 6147 6148 gfc_free_expr (itrunc); 6149 6150 return range_check (result, name); 6151} 6152 6153 6154gfc_expr * 6155gfc_simplify_new_line (gfc_expr *e) 6156{ 6157 gfc_expr *result; 6158 6159 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, 1); 6160 result->value.character.string[0] = '\n'; 6161 6162 return result; 6163} 6164 6165 6166gfc_expr * 6167gfc_simplify_nint (gfc_expr *e, gfc_expr *k) 6168{ 6169 return simplify_nint ("NINT", e, k); 6170} 6171 6172 6173gfc_expr * 6174gfc_simplify_idnint (gfc_expr *e) 6175{ 6176 return simplify_nint ("IDNINT", e, NULL__null); 6177} 6178 6179static int norm2_scale; 6180 6181static gfc_expr * 6182norm2_add_squared (gfc_expr *result, gfc_expr *e) 6183{ 6184 mpfr_t tmp; 6185 6186 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_REAL && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6186, __FUNCTION__), 0 : 0))
; 6187 gcc_assert (result->ts.type == BT_REAL((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6188, __FUNCTION__), 0 : 0))
6188 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6188, __FUNCTION__), 0 : 0))
; 6189 6190 gfc_set_model_kind (result->ts.kind); 6191 int index = gfc_validate_kind (BT_REAL, result->ts.kind, false); 6192 mpfr_exp_t exp; 6193 if (mpfr_regular_p (result->value.real)((result->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
) 6194 { 6195 exp = mpfr_get_exp (result->value.real)(0 ? ((result->value.real)->_mpfr_exp) : ((result->value
.real)->_mpfr_exp))
; 6196 /* If result is getting close to overflowing, scale down. */ 6197 if (exp >= gfc_real_kinds[index].max_exponent - 4 6198 && norm2_scale <= gfc_real_kinds[index].max_exponent - 2) 6199 { 6200 norm2_scale += 2; 6201 mpfr_div_ui (result->value.real, result->value.real, 16, 6202 GFC_RND_MODEMPFR_RNDN); 6203 } 6204 } 6205 6206 mpfr_init (tmp); 6207 if (mpfr_regular_p (e->value.real)((e->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))))
) 6208 { 6209 exp = mpfr_get_exp (e->value.real)(0 ? ((e->value.real)->_mpfr_exp) : ((e->value.real)
->_mpfr_exp))
; 6210 /* If e**2 would overflow or close to overflowing, scale down. */ 6211 if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2) 6212 { 6213 int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4; 6214 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6215 mpfr_set_exp (tmp, new_scale - norm2_scale); 6216 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6217 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6218 norm2_scale = new_scale; 6219 } 6220 } 6221 if (norm2_scale) 6222 { 6223 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6224 mpfr_set_exp (tmp, norm2_scale); 6225 mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6226 } 6227 else 6228 mpfr_set (tmp, e->value.real, GFC_RND_MODE)mpfr_set4(tmp,e->value.real,MPFR_RNDN,((e->value.real)->
_mpfr_sign))
; 6229 mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODEMPFR_RNDN); 6230 mpfr_add (result->value.real, result->value.real, tmp, 6231 GFC_RND_MODEMPFR_RNDN); 6232 mpfr_clear (tmp); 6233 6234 return result; 6235} 6236 6237 6238static gfc_expr * 6239norm2_do_sqrt (gfc_expr *result, gfc_expr *e) 6240{ 6241 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_REAL && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6241, __FUNCTION__), 0 : 0))
; 6242 gcc_assert (result->ts.type == BT_REAL((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6243, __FUNCTION__), 0 : 0))
6243 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6243, __FUNCTION__), 0 : 0))
; 6244 6245 if (result != e) 6246 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,e->value.real,MPFR_RNDN,((
e->value.real)->_mpfr_sign))
; 6247 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN); 6248 if (norm2_scale && mpfr_regular_p (result->value.real)((result->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
) 6249 { 6250 mpfr_t tmp; 6251 mpfr_init (tmp); 6252 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6253 mpfr_set_exp (tmp, norm2_scale); 6254 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6255 mpfr_clear (tmp); 6256 } 6257 norm2_scale = 0; 6258 6259 return result; 6260} 6261 6262 6263gfc_expr * 6264gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) 6265{ 6266 gfc_expr *result; 6267 bool size_zero; 6268 6269 size_zero = gfc_is_size_zero_array (e); 6270 6271 if (!(is_constant_array_expr (e) || size_zero) 6272 || (dim != NULL__null && !gfc_is_constant_expr (dim))) 6273 return NULL__null; 6274 6275 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); 6276 init_result_expr (result, 0, NULL__null); 6277 6278 if (size_zero) 6279 return result; 6280 6281 norm2_scale = 0; 6282 if (!dim || e->rank == 1) 6283 { 6284 result = simplify_transformation_to_scalar (result, e, NULL__null, 6285 norm2_add_squared); 6286 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN); 6287 if (norm2_scale && mpfr_regular_p (result->value.real)((result->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
) 6288 { 6289 mpfr_t tmp; 6290 mpfr_init (tmp); 6291 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6292 mpfr_set_exp (tmp, norm2_scale); 6293 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6294 mpfr_clear (tmp); 6295 } 6296 norm2_scale = 0; 6297 } 6298 else 6299 result = simplify_transformation_to_array (result, e, dim, NULL__null, 6300 norm2_add_squared, 6301 norm2_do_sqrt); 6302 6303 return result; 6304} 6305 6306 6307gfc_expr * 6308gfc_simplify_not (gfc_expr *e) 6309{ 6310 gfc_expr *result; 6311 6312 if (e->expr_type != EXPR_CONSTANT) 6313 return NULL__null; 6314 6315 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 6316 mpz_com__gmpz_com (result->value.integer, e->value.integer); 6317 6318 return range_check (result, "NOT"); 6319} 6320 6321 6322gfc_expr * 6323gfc_simplify_null (gfc_expr *mold) 6324{ 6325 gfc_expr *result; 6326 6327 if (mold) 6328 { 6329 result = gfc_copy_expr (mold); 6330 result->expr_type = EXPR_NULL; 6331 } 6332 else 6333 result = gfc_get_null_expr (NULL__null); 6334 6335 return result; 6336} 6337 6338 6339gfc_expr * 6340gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED__attribute__ ((__unused__)), gfc_expr *failed) 6341{ 6342 gfc_expr *result; 6343 6344 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE) 6345 { 6346 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 6347 return &gfc_bad_expr; 6348 } 6349 6350 if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_SINGLE) 6351 return NULL__null; 6352 6353 if (failed && failed->expr_type != EXPR_CONSTANT) 6354 return NULL__null; 6355 6356 /* FIXME: gfc_current_locus is wrong. */ 6357 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 6358 &gfc_current_locus); 6359 6360 if (failed && failed->value.logical != 0) 6361 mpz_set_si__gmpz_set_si (result->value.integer, 0); 6362 else 6363 mpz_set_si__gmpz_set_si (result->value.integer, 1); 6364 6365 return result; 6366} 6367 6368 6369gfc_expr * 6370gfc_simplify_or (gfc_expr *x, gfc_expr *y) 6371{ 6372 gfc_expr *result; 6373 int kind; 6374 6375 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 6376 return NULL__null; 6377 6378 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 6379 6380 switch (x->ts.type) 6381 { 6382 case BT_INTEGER: 6383 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 6384 mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer); 6385 return range_check (result, "OR"); 6386 6387 case BT_LOGICAL: 6388 return gfc_get_logical_expr (kind, &x->where, 6389 x->value.logical || y->value.logical); 6390 default: 6391 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6391, __FUNCTION__))
; 6392 } 6393} 6394 6395 6396gfc_expr * 6397gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 6398{ 6399 gfc_expr *result; 6400 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; 6401 6402 if (!is_constant_array_expr (array) 6403 || !is_constant_array_expr (vector) 6404 || (!gfc_is_constant_expr (mask) 6405 && !is_constant_array_expr (mask))) 6406 return NULL__null; 6407 6408 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); 6409 if (array->ts.type == BT_DERIVED) 6410 result->ts.u.derived = array->ts.u.derived; 6411 6412 array_ctor = gfc_constructor_first (array->value.constructor); 6413 vector_ctor = vector 6414 ? gfc_constructor_first (vector->value.constructor) 6415 : NULL__null; 6416 6417 if (mask->expr_type == EXPR_CONSTANT 6418 && mask->value.logical) 6419 { 6420 /* Copy all elements of ARRAY to RESULT. */ 6421 while (array_ctor) 6422 { 6423 gfc_constructor_append_expr (&result->value.constructor, 6424 gfc_copy_expr (array_ctor->expr), 6425 NULL__null); 6426 6427 array_ctor = gfc_constructor_next (array_ctor); 6428 vector_ctor = gfc_constructor_next (vector_ctor); 6429 } 6430 } 6431 else if (mask->expr_type == EXPR_ARRAY) 6432 { 6433 /* Copy only those elements of ARRAY to RESULT whose 6434 MASK equals .TRUE.. */ 6435 mask_ctor = gfc_constructor_first (mask->value.constructor); 6436 while (mask_ctor) 6437 { 6438 if (mask_ctor->expr->value.logical) 6439 { 6440 gfc_constructor_append_expr (&result->value.constructor, 6441 gfc_copy_expr (array_ctor->expr), 6442 NULL__null); 6443 vector_ctor = gfc_constructor_next (vector_ctor); 6444 } 6445 6446 array_ctor = gfc_constructor_next (array_ctor); 6447 mask_ctor = gfc_constructor_next (mask_ctor); 6448 } 6449 } 6450 6451 /* Append any left-over elements from VECTOR to RESULT. */ 6452 while (vector_ctor) 6453 { 6454 gfc_constructor_append_expr (&result->value.constructor, 6455 gfc_copy_expr (vector_ctor->expr), 6456 NULL__null); 6457 vector_ctor = gfc_constructor_next (vector_ctor); 6458 } 6459 6460 result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 6461 gfc_array_size (result, &result->shape[0]); 6462 6463 if (array->ts.type == BT_CHARACTER) 6464 result->ts.u.cl = array->ts.u.cl; 6465 6466 return result; 6467} 6468 6469 6470static gfc_expr * 6471do_xor (gfc_expr *result, gfc_expr *e) 6472{ 6473 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_LOGICAL && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6473, __FUNCTION__), 0 : 0))
; 6474 gcc_assert (result->ts.type == BT_LOGICAL((void)(!(result->ts.type == BT_LOGICAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6475, __FUNCTION__), 0 : 0))
6475 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_LOGICAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6475, __FUNCTION__), 0 : 0))
; 6476 6477 result->value.logical = result->value.logical != e->value.logical; 6478 return result; 6479} 6480 6481 6482gfc_expr * 6483gfc_simplify_is_contiguous (gfc_expr *array) 6484{ 6485 if (gfc_is_simply_contiguous (array, false, true)) 6486 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);