Bug Summary

File:build/gcc/fortran/simplify.c
Warning:line 2181, column 28
The left operand of '*' is a garbage value

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)
281 return false;
282
283 if (array->expr_type == EXPR_VARIABLE && array->rank > 0
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)
295 return array->value.constructor == NULL__null;
296
297 return false;
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)
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
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 && mask->expr_type == EXPR_ARRAY)
593 mask_ctor = gfc_constructor_first (mask->value.constructor);
594
595 for (i = 0; i < arraysize; ++i)
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)
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)
628 {
629 count[i] = 0;
630 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
631 if (i == dim_index)
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 == 0) ? 1 : dstride[n-1] * extent[n-1];
641 n += 1;
642 }
643
644 done = resultsize <= 0;
645 base = arrayvec;
646 dest = resultvec;
647 while (!done)
648 {
649 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
650 if (*src)
651 *dest = op (*dest, gfc_copy_expr (*src));
652
653 if (post_op)
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 && count[n] == extent[n])
662 {
663 count[n] = 0;
664 base -= sstride[n] * extent[n];
665 dest -= dstride[n] * extent[n];
666
667 n++;
668 if (n < result->rank)
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]++;
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);
709
710 if (!(is_constant_array_expr (array) || size_zero)
711 || !gfc_is_constant_expr (dim))
712 return NULL__null;
713
714 if (mask
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,
720 array->ts.kind, &array->where);
721 init_result_expr (result, init_val, array);
722
723 if (size_zero)
724 return result;
725
726 return !dim || array->rank == 1 ?
727 simplify_transformation_to_scalar (result, array, mask, op) :
728 simplify_transformation_to_array (result, array, dim, mask, op, NULL__null);
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))
1
Assuming the condition is false
2
Taking false branch
2094 return NULL__null;
2095
2096 if (shift->rank > 0)
3
Assuming field 'rank' is <= 0
4
Taking false branch
2097 gfc_simplify_expr (shift, 1);
2098
2099 if (!gfc_is_constant_expr (shift))
5
Assuming the condition is false
6
Taking false branch
2100 return NULL__null;
2101
2102 /* Make dim zero-based. */
2103 if (dim)
7
Assuming 'dim' is non-null
8
Taking true branch
2104 {
2105 if (!gfc_is_constant_expr (dim))
9
Assuming the condition is false
10
Taking false branch
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)
11
Assuming field 'shape' is not equal to NULL
12
Taking false branch
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)
13
Assuming 'arraysize' is not equal to 0
14
Taking false branch
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
14.1
'i' is < 'arraysize'
< arraysize
; i++)
15
Loop condition is true. Entering loop body
16
Assuming 'i' is >= 'arraysize'
17
Loop condition is false. Execution continues on line 2135
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++)
18
Assuming 'd' is < field 'rank'
19
Loop condition is true. Entering loop body
21
Assuming 'd' is >= field 'rank'
22
Loop condition is false. Execution continues on line 2146
2141 {
2142 a_extent[d] = mpz_get_si__gmpz_get_si (array->shape[d]);
2143 a_stride[d] = d
19.1
'd' is equal to 0
== 0 ? 1 : a_stride[d-1] * a_extent[d-1];
20
'?' condition is true
2144 }
2145
2146 if (shift->rank > 0)
23
Assuming field 'rank' is > 0
24
Taking true branch
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++)
25
Assuming 'd' is >= field 'rank'
26
Loop condition is false. Execution continues on line 2163
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;
27
The value 0 is assigned to 'n'
2167 for (d=0; d < array->rank; d++)
28
Loop condition is true. Entering loop body
2168 {
2169 if (d == which)
29
Assuming 'd' is not equal to 'which'
30
Taking false branch
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)
31
Assuming 'shiftvec' is non-null
32
Taking true branch
2181 hs_ex[n] = hstride[n] * extent[n];
33
The left operand of '*' is a garbage value
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);
6487
6488 if (gfc_is_not_contiguous (array))
6489 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
6490
6491 return NULL__null;
6492}
6493
6494
6495gfc_expr *
6496gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
6497{
6498 return simplify_transformation (e, dim, NULL__null, 0, do_xor);
6499}
6500
6501
6502gfc_expr *
6503gfc_simplify_popcnt (gfc_expr *e)
6504{
6505 int res, k;
6506 mpz_t x;
6507
6508 if (e->expr_type != EXPR_CONSTANT)
6509 return NULL__null;
6510
6511 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6512
6513 /* Convert argument to unsigned, then count the '1' bits. */
6514 mpz_init_set__gmpz_init_set (x, e->value.integer);
6515 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
6516 res = mpz_popcount__gmpz_popcount (x);
6517 mpz_clear__gmpz_clear (x);
6518
6519 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6520}
6521
6522
6523gfc_expr *
6524gfc_simplify_poppar (gfc_expr *e)
6525{
6526 gfc_expr *popcnt;
6527 int i;
6528
6529 if (e->expr_type != EXPR_CONSTANT)
6530 return NULL__null;
6531
6532 popcnt = gfc_simplify_popcnt (e);
6533 gcc_assert (popcnt)((void)(!(popcnt) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplif