Bug Summary

File:build/gcc/fortran/simplify.c
Warning:line 2519, column 3
Value stored to 's_len' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name 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 -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib64/clang/11.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/backward -internal-isystem /usr/local/include -internal-isystem /usr/lib64/clang/11.0.0/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -o /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-01-16-135054-17580-1/report-YNtGs6.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))
2094 return NULL__null;
2095
2096 if (shift->rank > 0)
2097 gfc_simplify_expr (shift, 1);
2098
2099 if (!gfc_is_constant_expr (shift))
2100 return NULL__null;
2101
2102 /* Make dim zero-based. */
2103 if (dim)
2104 {
2105 if (!gfc_is_constant_expr (dim))
2106 return NULL__null;
2107 which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1;
2108 }
2109 else
2110 which = 0;
2111
2112 gfc_array_size (array, &size);
2113 arraysize = mpz_get_ui__gmpz_get_ui (size);
2114 mpz_clear__gmpz_clear (size);
2115
2116 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2117 result->shape = gfc_copy_shape (array->shape, array->rank);
2118 result->rank = array->rank;
2119 result->ts.u.derived = array->ts.u.derived;
2120
2121 if (arraysize == 0)
2122 return result;
2123
2124 arrayvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));
2125 array_ctor = gfc_constructor_first (array->value.constructor);
2126 for (i = 0; i < arraysize; i++)
2127 {
2128 arrayvec[i] = array_ctor->expr;
2129 array_ctor = gfc_constructor_next (array_ctor);
2130 }
2131
2132 resultvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));
2133
2134 extent[0] = 1;
2135 count[0] = 0;
2136
2137 for (d=0; d < array->rank; d++)
2138 {
2139 a_extent[d] = mpz_get_si__gmpz_get_si (array->shape[d]);
2140 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2141 }
2142
2143 if (shift->rank > 0)
2144 {
2145 gfc_array_size (shift, &size);
2146 shiftsize = mpz_get_ui__gmpz_get_ui (size);
2147 mpz_clear__gmpz_clear (size);
2148 shiftvec = XCNEWVEC (ssize_t, shiftsize)((ssize_t *) xcalloc ((shiftsize), sizeof (ssize_t)));
2149 shift_ctor = gfc_constructor_first (shift->value.constructor);
2150 for (d = 0; d < shift->rank; d++)
2151 {
2152 h_extent[d] = mpz_get_si__gmpz_get_si (shift->shape[d]);
2153 hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
2154 }
2155 }
2156 else
2157 shiftvec = NULL__null;
2158
2159 /* Shut up compiler */
2160 len = 1;
2161 rsoffset = 1;
2162
2163 n = 0;
2164 for (d=0; d < array->rank; d++)
2165 {
2166 if (d == which)
2167 {
2168 rsoffset = a_stride[d];
2169 len = a_extent[d];
2170 }
2171 else
2172 {
2173 count[n] = 0;
2174 extent[n] = a_extent[d];
2175 sstride[n] = a_stride[d];
2176 ss_ex[n] = sstride[n] * extent[n];
2177 if (shiftvec)
2178 hs_ex[n] = hstride[n] * extent[n];
2179 n++;
2180 }
2181 }
2182 ss_ex[n] = 0;
2183 hs_ex[n] = 0;
2184
2185 if (shiftvec)
2186 {
2187 for (i = 0; i < shiftsize; i++)
2188 {
2189 ssize_t val;
2190 val = mpz_get_si__gmpz_get_si (shift_ctor->expr->value.integer);
2191 val = val % len;
2192 if (val < 0)
2193 val += len;
2194 shiftvec[i] = val;
2195 shift_ctor = gfc_constructor_next (shift_ctor);
2196 }
2197 shift_val = 0;
2198 }
2199 else
2200 {
2201 shift_val = mpz_get_si__gmpz_get_si (shift->value.integer);
2202 shift_val = shift_val % len;
2203 if (shift_val < 0)
2204 shift_val += len;
2205 }
2206
2207 continue_loop = true;
2208 d = array->rank;
2209 rptr = resultvec;
2210 sptr = arrayvec;
2211 hptr = shiftvec;
2212
2213 while (continue_loop)
2214 {
2215 ssize_t sh;
2216 if (shiftvec)
2217 sh = *hptr;
2218 else
2219 sh = shift_val;
2220
2221 src = &sptr[sh * rsoffset];
2222 dest = rptr;
2223 for (n = 0; n < len - sh; n++)
2224 {
2225 *dest = *src;
2226 dest += rsoffset;
2227 src += rsoffset;
2228 }
2229 src = sptr;
2230 for ( n = 0; n < sh; n++)
2231 {
2232 *dest = *src;
2233 dest += rsoffset;
2234 src += rsoffset;
2235 }
2236 rptr += sstride[0];
2237 sptr += sstride[0];
2238 if (shiftvec)
2239 hptr += hstride[0];
2240 count[0]++;
2241 n = 0;
2242 while (count[n] == extent[n])
2243 {
2244 count[n] = 0;
2245 rptr -= ss_ex[n];
2246 sptr -= ss_ex[n];
2247 if (shiftvec)
2248 hptr -= hs_ex[n];
2249 n++;
2250 if (n >= d - 1)
2251 {
2252 continue_loop = false;
2253 break;
2254 }
2255 else
2256 {
2257 count[n]++;
2258 rptr += sstride[n];
2259 sptr += sstride[n];
2260 if (shiftvec)
2261 hptr += hstride[n];
2262 }
2263 }
2264 }
2265
2266 for (i = 0; i < arraysize; i++)
2267 {
2268 gfc_constructor_append_expr (&result->value.constructor,
2269 gfc_copy_expr (resultvec[i]),
2270 NULL__null);
2271 }
2272 return result;
2273}
2274
2275
2276gfc_expr *
2277gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
2278{
2279 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
2280}
2281
2282
2283gfc_expr *
2284gfc_simplify_dble (gfc_expr *e)
2285{
2286 gfc_expr *result = NULL__null;
2287 int tmp1, tmp2;
2288
2289 if (e->expr_type != EXPR_CONSTANT)
2290 return NULL__null;
2291
2292 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2293 warnings. */
2294 tmp1 = warn_conversionglobal_options.x_warn_conversion;
2295 tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
2296 warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;
2297
2298 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
2299
2300 warn_conversionglobal_options.x_warn_conversion = tmp1;
2301 warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;
2302
2303 if (result == &gfc_bad_expr)
2304 return &gfc_bad_expr;
2305
2306 return range_check (result, "DBLE");
2307}
2308
2309
2310gfc_expr *
2311gfc_simplify_digits (gfc_expr *x)
2312{
2313 int i, digits;
2314
2315 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2316
2317 switch (x->ts.type)
2318 {
2319 case BT_INTEGER:
2320 digits = gfc_integer_kinds[i].digits;
2321 break;
2322
2323 case BT_REAL:
2324 case BT_COMPLEX:
2325 digits = gfc_real_kinds[i].digits;
2326 break;
2327
2328 default:
2329 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2329, __FUNCTION__))
;
2330 }
2331
2332 return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, digits);
2333}
2334
2335
2336gfc_expr *
2337gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
2338{
2339 gfc_expr *result;
2340 int kind;
2341
2342 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2343 return NULL__null;
2344
2345 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2346 result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
2347
2348 switch (x->ts.type)
2349 {
2350 case BT_INTEGER:
2351 if (mpz_cmp__gmpz_cmp (x->value.integer, y->value.integer) > 0)
2352 mpz_sub__gmpz_sub (result->value.integer, x->value.integer, y->value.integer);
2353 else
2354 mpz_set_ui__gmpz_set_ui (result->value.integer, 0);
2355
2356 break;
2357
2358 case BT_REAL:
2359 if (mpfr_cmp (x->value.real, y->value.real)mpfr_cmp3(x->value.real, y->value.real, 1) > 0)
2360 mpfr_sub (result->value.real, x->value.real, y->value.real,
2361 GFC_RND_MODEMPFR_RNDN);
2362 else
2363 mpfr_set_ui (result->value.real, 0, GFC_RND_MODEMPFR_RNDN);
2364
2365 break;
2366
2367 default:
2368 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2369 }
2370
2371 return range_check (result, "DIM");
2372}
2373
2374
2375gfc_expr*
2376gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2377{
2378 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2379 REAL, and COMPLEX types and .false. for LOGICAL. */
2380 if (vector_a->shape && mpz_get_si__gmpz_get_si (vector_a->shape[0]) == 0)
2381 {
2382 if (vector_a->ts.type == BT_LOGICAL)
2383 return gfc_get_logical_expr (gfc_default_logical_kind, NULL__null, false);
2384 else
2385 return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 0);
2386 }
2387
2388 if (!is_constant_array_expr (vector_a)
2389 || !is_constant_array_expr (vector_b))
2390 return NULL__null;
2391
2392 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
2393}
2394
2395
2396gfc_expr *
2397gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
2398{
2399 gfc_expr *a1, *a2, *result;
2400
2401 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2402 return NULL__null;
2403
2404 a1 = gfc_real2real (x, gfc_default_double_kind);
2405 a2 = gfc_real2real (y, gfc_default_double_kind);
2406
2407 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
2408 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODEMPFR_RNDN);
2409
2410 gfc_free_expr (a2);
2411 gfc_free_expr (a1);
2412
2413 return range_check (result, "DPROD");
2414}
2415
2416
2417static gfc_expr *
2418simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
2419 bool right)
2420{
2421 gfc_expr *result;
2422 int i, k, size, shift;
2423
2424 if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
2425 || shiftarg->expr_type != EXPR_CONSTANT)
2426 return NULL__null;
2427
2428 k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
2429 size = gfc_integer_kinds[k].bit_size;
2430
2431 gfc_extract_int (shiftarg, &shift);
2432
2433 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2434 if (right)
2435 shift = size - shift;
2436
2437 result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
2438 mpz_set_ui__gmpz_set_ui (result->value.integer, 0);
2439
2440 for (i = 0; i < shift; i++)
2441 if (mpz_tstbit__gmpz_tstbit (arg2->value.integer, size - shift + i))
2442 mpz_setbit__gmpz_setbit (result->value.integer, i);
2443
2444 for (i = 0; i < size - shift; i++)
2445 if (mpz_tstbit__gmpz_tstbit (arg1->value.integer, i))
2446 mpz_setbit__gmpz_setbit (result->value.integer, shift + i);
2447
2448 /* Convert to a signed value. */
2449 gfc_convert_mpz_to_signed (result->value.integer, size);
2450
2451 return result;
2452}
2453
2454
2455gfc_expr *
2456gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2457{
2458 return simplify_dshift (arg1, arg2, shiftarg, true);
2459}
2460
2461
2462gfc_expr *
2463gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2464{
2465 return simplify_dshift (arg1, arg2, shiftarg, false);
2466}
2467
2468
2469gfc_expr *
2470gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
2471 gfc_expr *dim)
2472{
2473 bool temp_boundary;
2474 gfc_expr *bnd;
2475 gfc_expr *result;
2476 int which;
2477 gfc_expr **arrayvec, **resultvec;
2478 gfc_expr **rptr, **sptr;
2479 mpz_t size;
2480 size_t arraysize, i;
2481 gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor;
2482 ssize_t shift_val, len;
2483 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
2484 sstride[GFC_MAX_DIMENSIONS15], a_extent[GFC_MAX_DIMENSIONS15],
2485 a_stride[GFC_MAX_DIMENSIONS15], ss_ex[GFC_MAX_DIMENSIONS15 + 1];
2486 ssize_t rsoffset;
2487 int d, n;
2488 bool continue_loop;
2489 gfc_expr **src, **dest;
2490 size_t s_len;
2491
2492 if (!is_constant_array_expr (array))
2493 return NULL__null;
2494
2495 if (shift->rank > 0)
2496 gfc_simplify_expr (shift, 1);
2497
2498 if (!gfc_is_constant_expr (shift))
2499 return NULL__null;
2500
2501 if (boundary)
2502 {
2503 if (boundary->rank > 0)
2504 gfc_simplify_expr (boundary, 1);
2505
2506 if (!gfc_is_constant_expr (boundary))
2507 return NULL__null;
2508 }
2509
2510 if (dim)
2511 {
2512 if (!gfc_is_constant_expr (dim))
2513 return NULL__null;
2514 which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1;
2515 }
2516 else
2517 which = 0;
2518
2519 s_len = 0;
Value stored to 's_len' is never read
2520 if (boundary == NULL__null)
2521 {
2522 temp_boundary = true;
2523 switch (array->ts.type)
2524 {
2525
2526 case BT_INTEGER:
2527 bnd = gfc_get_int_expr (array->ts.kind, NULL__null, 0);
2528 break;
2529
2530 case BT_LOGICAL:
2531 bnd = gfc_get_logical_expr (array->ts.kind, NULL__null, 0);
2532 break;
2533
2534 case BT_REAL:
2535 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2536 mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODEMPFR_RNDN);
2537 break;
2538
2539 case BT_COMPLEX:
2540 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2541 mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODEMPFR_RNDN);
2542 break;
2543
2544 case BT_CHARACTER:
2545 s_len = mpz_get_ui__gmpz_get_ui (array->ts.u.cl->length->value.integer);
2546 bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL__null, s_len);
2547 break;
2548
2549 default:
2550 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2550, __FUNCTION__))
;
2551
2552 }
2553 }
2554 else
2555 {
2556 temp_boundary = false;
2557 bnd = boundary;
2558 }
2559
2560 gfc_array_size (array, &size);
2561 arraysize = mpz_get_ui__gmpz_get_ui (size);
2562 mpz_clear__gmpz_clear (size);
2563
2564 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2565 result->shape = gfc_copy_shape (array->shape, array->rank);
2566 result->rank = array->rank;
2567 result->ts = array->ts;
2568
2569 if (arraysize == 0)
2570 goto final;
2571
2572 arrayvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));
2573 array_ctor = gfc_constructor_first (array->value.constructor);
2574 for (i = 0; i < arraysize; i++)
2575 {
2576 arrayvec[i] = array_ctor->expr;
2577 array_ctor = gfc_constructor_next (array_ctor);
2578 }
2579
2580 resultvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));
2581
2582 extent[0] = 1;
2583 count[0] = 0;
2584
2585 for (d=0; d < array->rank; d++)
2586 {
2587 a_extent[d] = mpz_get_si__gmpz_get_si (array->shape[d]);
2588 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2589 }
2590
2591 if (shift->rank > 0)
2592 {
2593 shift_ctor = gfc_constructor_first (shift->value.constructor);
2594 shift_val = 0;
2595 }
2596 else
2597 {
2598 shift_ctor = NULL__null;
2599 shift_val = mpz_get_si__gmpz_get_si (shift->value.integer);
2600 }
2601
2602 if (bnd->rank > 0)
2603 bnd_ctor = gfc_constructor_first (bnd->value.constructor);
2604 else
2605 bnd_ctor = NULL__null;
2606
2607 /* Shut up compiler */
2608 len = 1;
2609 rsoffset = 1;
2610
2611 n = 0;
2612 for (d=0; d < array->rank; d++)
2613 {
2614 if (d == which)
2615 {
2616 rsoffset = a_stride[d];
2617 len = a_extent[d];
2618 }
2619 else
2620 {
2621 count[n] = 0;
2622 extent[n] = a_extent[d];
2623 sstride[n] = a_stride[d];
2624 ss_ex[n] = sstride[n] * extent[n];
2625 n++;
2626 }
2627 }
2628 ss_ex[n] = 0;
2629
2630 continue_loop = true;
2631 d = array->rank;
2632 rptr = resultvec;
2633 sptr = arrayvec;
2634
2635 while (continue_loop)
2636 {
2637 ssize_t sh, delta;
2638
2639 if (shift_ctor)
2640 sh = mpz_get_si__gmpz_get_si (shift_ctor->expr->value.integer);
2641 else
2642 sh = shift_val;
2643
2644 if (( sh >= 0 ? sh : -sh ) > len)
2645 {
2646 delta = len;
2647 sh = len;
2648 }
2649 else
2650 delta = (sh >= 0) ? sh: -sh;
2651
2652 if (sh > 0)
2653 {
2654 src = &sptr[delta * rsoffset];
2655 dest = rptr;
2656 }
2657 else
2658 {
2659 src = sptr;
2660 dest = &rptr[delta * rsoffset];
2661 }
2662
2663 for (n = 0; n < len - delta; n++)
2664 {
2665 *dest = *src;
2666 dest += rsoffset;
2667 src += rsoffset;
2668 }
2669
2670 if (sh < 0)
2671 dest = rptr;
2672
2673 n = delta;
2674
2675 if (bnd_ctor)
2676 {
2677 while (n--)
2678 {
2679 *dest = gfc_copy_expr (bnd_ctor->expr);
2680 dest += rsoffset;
2681 }
2682 }
2683 else
2684 {
2685 while (n--)
2686 {
2687 *dest = gfc_copy_expr (bnd);
2688 dest += rsoffset;
2689 }
2690 }
2691 rptr += sstride[0];
2692 sptr += sstride[0];
2693 if (shift_ctor)
2694 shift_ctor = gfc_constructor_next (shift_ctor);
2695
2696 if (bnd_ctor)
2697 bnd_ctor = gfc_constructor_next (bnd_ctor);
2698
2699 count[0]++;
2700 n = 0;
2701 while (count[n] == extent[n])
2702 {
2703 count[n] = 0;
2704 rptr -= ss_ex[n];
2705 sptr -= ss_ex[n];
2706 n++;
2707 if (n >= d - 1)
2708 {
2709 continue_loop = false;
2710 break;
2711 }
2712 else
2713 {
2714 count[n]++;
2715 rptr += sstride[n];
2716 sptr += sstride[n];
2717 }
2718 }
2719 }
2720
2721 for (i = 0; i < arraysize; i++)
2722 {
2723 gfc_constructor_append_expr (&result->value.constructor,
2724 gfc_copy_expr (resultvec[i]),
2725 NULL__null);
2726 }
2727
2728 final:
2729 if (temp_boundary)
2730 gfc_free_expr (bnd);
2731
2732 return result;
2733}
2734
2735gfc_expr *
2736gfc_simplify_erf (gfc_expr *x)
2737{
2738 gfc_expr *result;
2739
2740 if (x->expr_type != EXPR_CONSTANT)
2741 return NULL__null;
2742
2743 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2744 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
2745
2746 return range_check (result, "ERF");
2747}
2748
2749
2750gfc_expr *
2751gfc_simplify_erfc (gfc_expr *x)
2752{
2753 gfc_expr *result;
2754
2755 if (x->expr_type != EXPR_CONSTANT)
2756 return NULL__null;
2757
2758 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2759 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
2760
2761 return range_check (result, "ERFC");
2762}
2763
2764
2765/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2766
2767#define MAX_ITER 200
2768#define ARG_LIMIT 12
2769
2770/* Calculate ERFC_SCALED directly by its definition:
2771
2772 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2773
2774 using a large precision for intermediate results. This is used for all
2775 but large values of the argument. */
2776static void
2777fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2778{
2779 mpfr_prec_t prec;
2780 mpfr_t a, b;
2781
2782 prec = mpfr_get_default_prec ();
2783 mpfr_set_default_prec (10 * prec);
2784
2785 mpfr_init (a);
2786 mpfr_init (b);
2787
2788 mpfr_set (a, arg, GFC_RND_MODE)mpfr_set4(a,arg,MPFR_RNDN,((arg)->_mpfr_sign));
2789 mpfr_sqr (b, a, GFC_RND_MODEMPFR_RNDN);
2790 mpfr_exp (b, b, GFC_RND_MODEMPFR_RNDN);
2791 mpfr_erfc (a, a, GFC_RND_MODEMPFR_RNDN);
2792 mpfr_mul (a, a, b, GFC_RND_MODEMPFR_RNDN);
2793
2794 mpfr_set (res, a, GFC_RND_MODE)mpfr_set4(res,a,MPFR_RNDN,((a)->_mpfr_sign));
2795 mpfr_set_default_prec (prec);
2796
2797 mpfr_clear (a);
2798 mpfr_clear (b);
2799}
2800
2801/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2802
2803 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2804 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2805 / (2 * x**2)**n)
2806
2807 This is used for large values of the argument. Intermediate calculations
2808 are performed with twice the precision. We don't do a fixed number of
2809 iterations of the sum, but stop when it has converged to the required
2810 precision. */
2811static void
2812asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2813{
2814 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2815 mpz_t num;
2816 mpfr_prec_t prec;
2817 unsigned i;
2818
2819 prec = mpfr_get_default_prec ();
2820 mpfr_set_default_prec (2 * prec);
2821
2822 mpfr_init (sum);
2823 mpfr_init (x);
2824 mpfr_init (u);
2825 mpfr_init (v);
2826 mpfr_init (w);
2827 mpz_init__gmpz_init (num);
2828
2829 mpfr_init (oldsum);
2830 mpfr_init (sumtrunc);
2831 mpfr_set_prec (oldsum, prec);
2832 mpfr_set_prec (sumtrunc, prec);
2833
2834 mpfr_set (x, arg, GFC_RND_MODE)mpfr_set4(x,arg,MPFR_RNDN,((arg)->_mpfr_sign));
2835 mpfr_set_ui (sum, 1, GFC_RND_MODEMPFR_RNDN);
2836 mpz_set_ui__gmpz_set_ui (num, 1);
2837
2838 mpfr_set (u, x, GFC_RND_MODE)mpfr_set4(u,x,MPFR_RNDN,((x)->_mpfr_sign));
2839 mpfr_sqr (u, u, GFC_RND_MODEMPFR_RNDN);
2840 mpfr_mul_ui (u, u, 2, GFC_RND_MODEMPFR_RNDN);
2841 mpfr_pow_si (u, u, -1, GFC_RND_MODEMPFR_RNDN);
2842
2843 for (i = 1; i < MAX_ITER; i++)
2844 {
2845 mpfr_set (oldsum, sum, GFC_RND_MODE)mpfr_set4(oldsum,sum,MPFR_RNDN,((sum)->_mpfr_sign));
2846
2847 mpz_mul_ui__gmpz_mul_ui (num, num, 2 * i - 1);
2848 mpz_neg__gmpz_neg (num, num);
2849
2850 mpfr_set (w, u, GFC_RND_MODE)mpfr_set4(w,u,MPFR_RNDN,((u)->_mpfr_sign));
2851 mpfr_pow_ui (w, w, i, GFC_RND_MODEMPFR_RNDN);
2852
2853 mpfr_set_z (v, num, GFC_RND_MODEMPFR_RNDN);
2854 mpfr_mul (v, v, w, GFC_RND_MODEMPFR_RNDN);
2855
2856 mpfr_add (sum, sum, v, GFC_RND_MODEMPFR_RNDN);
2857
2858 mpfr_set (sumtrunc, sum, GFC_RND_MODE)mpfr_set4(sumtrunc,sum,MPFR_RNDN,((sum)->_mpfr_sign));
2859 if (mpfr_cmp (sumtrunc, oldsum)mpfr_cmp3(sumtrunc, oldsum, 1) == 0)
2860 break;
2861 }
2862
2863 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2864 set too low. */
2865 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"
, 2865, __FUNCTION__), 0 : 0))
;
2866
2867 /* Divide by x * sqrt(Pi). */
2868 mpfr_const_pi (u, GFC_RND_MODEMPFR_RNDN);
2869 mpfr_sqrt (u, u, GFC_RND_MODEMPFR_RNDN);
2870 mpfr_mul (u, u, x, GFC_RND_MODEMPFR_RNDN);
2871 mpfr_div (sum, sum, u, GFC_RND_MODEMPFR_RNDN);
2872
2873 mpfr_set (res, sum, GFC_RND_MODE)mpfr_set4(res,sum,MPFR_RNDN,((sum)->_mpfr_sign));
2874 mpfr_set_default_prec (prec);
2875
2876 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL__null);
2877 mpz_clear__gmpz_clear (num);
2878}
2879
2880
2881gfc_expr *
2882gfc_simplify_erfc_scaled (gfc_expr *x)
2883{
2884 gfc_expr *result;
2885
2886 if (x->expr_type != EXPR_CONSTANT)
2887 return NULL__null;
2888
2889 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2890 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2891 asympt_erfc_scaled (result->value.real, x->value.real);
2892 else
2893 fullprec_erfc_scaled (result->value.real, x->value.real);
2894
2895 return range_check (result, "ERFC_SCALED");
2896}
2897
2898#undef MAX_ITER
2899#undef ARG_LIMIT
2900
2901
2902gfc_expr *
2903gfc_simplify_epsilon (gfc_expr *e)
2904{
2905 gfc_expr *result;
2906 int i;
2907
2908 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2909
2910 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2911 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))
;
2912
2913 return range_check (result, "EPSILON");
2914}
2915
2916
2917gfc_expr *
2918gfc_simplify_exp (gfc_expr *x)
2919{
2920 gfc_expr *result;
2921
2922 if (x->expr_type != EXPR_CONSTANT)
2923 return NULL__null;
2924
2925 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2926
2927 switch (x->ts.type)
2928 {
2929 case BT_REAL:
2930 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
2931 break;
2932
2933 case BT_COMPLEX:
2934 gfc_set_model_kind (x->ts.kind);
2935 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
2936 break;
2937
2938 default:
2939 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2940 }
2941
2942 return range_check (result, "EXP");
2943}
2944
2945
2946gfc_expr *
2947gfc_simplify_exponent (gfc_expr *x)
2948{
2949 long int val;
2950 gfc_expr *result;
2951
2952 if (x->expr_type != EXPR_CONSTANT)
2953 return NULL__null;
2954
2955 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2956 &x->where);
2957
2958 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2959 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))))
)
2960 {
2961 int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
2962 mpz_set__gmpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2963 return result;
2964 }
2965
2966 /* EXPONENT(+/- 0.0) = 0 */
2967 if (mpfr_zero_p (x->value.real)((x->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
)
2968 {
2969 mpz_set_ui__gmpz_set_ui (result->value.integer, 0);
2970 return result;
2971 }
2972
2973 gfc_set_model (x->value.real);
2974
2975 val = (long int) mpfr_get_exp (x->value.real)(0 ? ((x->value.real)->_mpfr_exp) : ((x->value.real)
->_mpfr_exp))
;
2976 mpz_set_si__gmpz_set_si (result->value.integer, val);
2977
2978 return range_check (result, "EXPONENT");
2979}
2980
2981
2982gfc_expr *
2983gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
2984 gfc_expr *kind)
2985{
2986 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
2987 {
2988 gfc_current_locus = *gfc_current_intrinsic_where;
2989 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2990 return &gfc_bad_expr;
2991 }
2992
2993 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)
2994 {
2995 gfc_expr *result;
2996 int actual_kind;
2997 if (kind)
2998 gfc_extract_int (kind, &actual_kind);
2999 else
3000 actual_kind = gfc_default_integer_kind;
3001
3002 result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
3003 result->rank = 1;
3004 return result;
3005 }
3006
3007 /* For fcoarray = lib no simplification is possible, because it is not known
3008 what images failed or are stopped at compile time. */
3009 return NULL__null;
3010}
3011
3012
3013gfc_expr *
3014gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3015{
3016 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
3017 {
3018 gfc_current_locus = *gfc_current_intrinsic_where;
3019 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3020 return &gfc_bad_expr;
3021 }
3022
3023 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)
3024 {
3025 gfc_expr *result;
3026 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
3027 result->rank = 0;
3028 return result;
3029 }
3030
3031 /* For fcoarray = lib no simplification is possible, because it is not known
3032 what images failed or are stopped at compile time. */
3033 return NULL__null;
3034}
3035
3036
3037gfc_expr *
3038gfc_simplify_float (gfc_expr *a)
3039{
3040 gfc_expr *result;
3041
3042 if (a->expr_type != EXPR_CONSTANT)
3043 return NULL__null;
3044
3045 result = gfc_int2real (a, gfc_default_real_kind);
3046
3047 return range_check (result, "FLOAT");
3048}
3049
3050
3051static bool
3052is_last_ref_vtab (gfc_expr *e)
3053{
3054 gfc_ref *ref;
3055 gfc_component *comp = NULL__null;
3056
3057 if (e->expr_type != EXPR_VARIABLE)
3058 return false;
3059
3060 for (ref = e->ref; ref; ref = ref->next)
3061 if (ref->type == REF_COMPONENT)
3062 comp = ref->u.c.component;
3063
3064 if (!e->ref || !comp)
3065 return e->symtree->n.sym->attr.vtab;
3066
3067 if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
3068 return true;
3069
3070 return false;
3071}
3072
3073
3074gfc_expr *
3075gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3076{
3077 /* Avoid simplification of resolved symbols. */
3078 if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
3079 return NULL__null;
3080
3081 if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
3082 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3083 gfc_type_is_extension_of (mold->ts.u.derived,
3084 a->ts.u.derived));
3085
3086 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
)
)
3087 return NULL__null;
3088
3089 /* Return .false. if the dynamic type can never be an extension. */
3090 if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
3091 && !gfc_type_is_extension_of
3092 (mold->ts.u.derived->components->ts.u.derived,
3093 a->ts.u.derived->components->ts.u.derived)
3094 && !gfc_type_is_extension_of
3095 (a->ts.u.derived->components->ts.u.derived,
3096 mold->ts.u.derived->components->ts.u.derived))
3097 || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
3098 && !gfc_type_is_extension_of
3099 (mold->ts.u.derived->components->ts.u.derived,
3100 a->ts.u.derived))
3101 || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3102 && !gfc_type_is_extension_of
3103 (mold->ts.u.derived,
3104 a->ts.u.derived->components->ts.u.derived)
3105 && !gfc_type_is_extension_of
3106 (a->ts.u.derived->components->ts.u.derived,
3107 mold->ts.u.derived)))
3108 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3109
3110 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3111 if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3112 && gfc_type_is_extension_of (mold->ts.u.derived,
3113 a->ts.u.derived->components->ts.u.derived))
3114 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
3115
3116 return NULL__null;
3117}
3118
3119
3120gfc_expr *
3121gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
3122{
3123 /* Avoid simplification of resolved symbols. */
3124 if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
3125 return NULL__null;
3126
3127 /* Return .false. if the dynamic type can never be the
3128 same. */
3129 if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
3130 || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
3131 && !gfc_type_compatible (&a->ts, &b->ts)
3132 && !gfc_type_compatible (&b->ts, &a->ts))
3133 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3134
3135 if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
3136 return NULL__null;
3137
3138 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3139 gfc_compare_derived_types (a->ts.u.derived,
3140 b->ts.u.derived));
3141}
3142
3143
3144gfc_expr *
3145gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
3146{
3147 gfc_expr *result;
3148 mpfr_t floor;
3149 int kind;
3150
3151 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
3152 if (kind == -1)
3153 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3154
3155 if (e->expr_type != EXPR_CONSTANT)
3156 return NULL__null;
3157
3158 mpfr_init2 (floor, mpfr_get_prec (e->value.real)(0 ? ((e->value.real)->_mpfr_prec) : ((e->value.real
)->_mpfr_prec))
);
3159 mpfr_floor (floor, e->value.real)mpfr_rint((floor), (e->value.real), MPFR_RNDD);
3160
3161 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3162 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
3163
3164 mpfr_clear (floor);
3165
3166 return range_check (result, "FLOOR");
3167}
3168
3169
3170gfc_expr *
3171gfc_simplify_fraction (gfc_expr *x)
3172{
3173 gfc_expr *result;
3174 mpfr_exp_t e;
3175
3176 if (x->expr_type != EXPR_CONSTANT)
3177 return NULL__null;
3178
3179 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
3180
3181 /* FRACTION(inf) = NaN. */
3182 if (mpfr_inf_p (x->value.real)((x->value.real)->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
)
3183 {
3184 mpfr_set_nan (result->value.real);
3185 return result;
3186 }
3187
3188 /* mpfr_frexp() correctly handles zeros and NaNs. */
3189 mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
3190
3191 return range_check (result, "FRACTION");
3192}
3193
3194
3195gfc_expr *
3196gfc_simplify_gamma (gfc_expr *x)
3197{
3198 gfc_expr *result;
3199
3200 if (x->expr_type != EXPR_CONSTANT)
3201 return NULL__null;
3202
3203 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3204 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
3205
3206 return range_check (result, "GAMMA");
3207}
3208
3209
3210gfc_expr *
3211gfc_simplify_huge (gfc_expr *e)
3212{
3213 gfc_expr *result;
3214 int i;
3215
3216 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3217 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3218
3219 switch (e->ts.type)
3220 {
3221 case BT_INTEGER:
3222 mpz_set__gmpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3223 break;
3224
3225 case BT_REAL:
3226 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))
;
3227 break;
3228
3229 default:
3230 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3230, __FUNCTION__))
;
3231 }
3232
3233 return result;
3234}
3235
3236
3237gfc_expr *
3238gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
3239{
3240 gfc_expr *result;
3241
3242 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3243 return NULL__null;
3244
3245 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3246 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODEMPFR_RNDN);
3247 return range_check (result, "HYPOT");
3248}
3249
3250
3251/* We use the processor's collating sequence, because all
3252 systems that gfortran currently works on are ASCII. */
3253
3254gfc_expr *
3255gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
3256{
3257 gfc_expr *result;
3258 gfc_char_t index;
3259 int k;
3260
3261 if (e->expr_type != EXPR_CONSTANT)
3262 return NULL__null;
3263
3264 if (e->value.character.length != 1)
3265 {
3266 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
3267 return &gfc_bad_expr;
3268 }
3269
3270 index = e->value.character.string[0];
3271
3272 if (warn_surprisingglobal_options.x_warn_surprising && index > 127)
3273 gfc_warning (OPT_Wsurprising,
3274 "Argument of IACHAR function at %L outside of range 0..127",
3275 &e->where);
3276
3277 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
3278 if (k == -1)
3279 return &gfc_bad_expr;
3280
3281 result = gfc_get_int_expr (k, &e->where, index);
3282
3283 return range_check (result, "IACHAR");
3284}
3285
3286
3287static gfc_expr *
3288do_bit_and (gfc_expr *result, gfc_expr *e)
3289{
3290 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"
, 3290, __FUNCTION__), 0 : 0))
;
3291 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"
, 3292, __FUNCTION__), 0 : 0))
3292 && 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"
, 3292, __FUNCTION__), 0 : 0))
;
3293
3294 mpz_and__gmpz_and (result->value.integer, result->value.integer, e->value.integer);
3295 return result;
3296}
3297
3298
3299gfc_expr *
3300gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3301{
3302 return simplify_transformation (array, dim, mask, -1, do_bit_and);
3303}
3304
3305
3306static gfc_expr *
3307do_bit_ior (gfc_expr *result, gfc_expr *e)
3308{
3309 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"
, 3309, __FUNCTION__), 0 : 0))
;
3310 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"
, 3311, __FUNCTION__), 0 : 0))
3311 && 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"
, 3311, __FUNCTION__), 0 : 0))
;
3312
3313 mpz_ior__gmpz_ior (result->value.integer, result->value.integer, e->value.integer);
3314 return result;
3315}
3316
3317
3318gfc_expr *
3319gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3320{
3321 return simplify_transformation (array, dim, mask, 0, do_bit_ior);
3322}
3323
3324
3325gfc_expr *
3326gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
3327{
3328 gfc_expr *result;
3329
3330 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3331 return NULL__null;
3332
3333 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3334 mpz_and__gmpz_and (result->value.integer, x->value.integer, y->value.integer);
3335
3336 return range_check (result, "IAND");
3337}
3338
3339
3340gfc_expr *
3341gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
3342{
3343 gfc_expr *result;
3344 int k, pos;
3345
3346 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3347 return NULL__null;
3348
3349 gfc_extract_int (y, &pos);
3350
3351 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3352
3353 result = gfc_copy_expr (x);
3354
3355 convert_mpz_to_unsigned (result->value.integer,
3356 gfc_integer_kinds[k].bit_size);
3357
3358 mpz_clrbit__gmpz_clrbit (result->value.integer, pos);
3359
3360 gfc_convert_mpz_to_signed (result->value.integer,
3361 gfc_integer_kinds[k].bit_size);
3362
3363 return result;
3364}
3365
3366
3367gfc_expr *
3368gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
3369{
3370 gfc_expr *result;
3371 int pos, len;
3372 int i, k, bitsize;
3373 int *bits;
3374
3375 if (x->expr_type != EXPR_CONSTANT
3376 || y->expr_type != EXPR_CONSTANT
3377 || z->expr_type != EXPR_CONSTANT)
3378 return NULL__null;
3379
3380 gfc_extract_int (y, &pos);
3381 gfc_extract_int (z, &len);
3382
3383 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
3384
3385 bitsize = gfc_integer_kinds[k].bit_size;
3386
3387 if (pos + len > bitsize)
3388 {
3389 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3390 "bit size at %L", &y->where);
3391 return &gfc_bad_expr;
3392 }
3393
3394 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3395 convert_mpz_to_unsigned (result->value.integer,
3396 gfc_integer_kinds[k].bit_size);
3397
3398 bits = XCNEWVEC (int, bitsize)((int *) xcalloc ((bitsize), sizeof (int)));
3399
3400 for (i = 0; i < bitsize; i++)
3401 bits[i] = 0;
3402
3403 for (i = 0; i < len; i++)
3404 bits[i] = mpz_tstbit__gmpz_tstbit (x->value.integer, i + pos);
3405
3406 for (i = 0; i < bitsize; i++)
3407 {
3408 if (bits[i] == 0)
3409 mpz_clrbit__gmpz_clrbit (result->value.integer, i);
3410 else if (bits[i] == 1)
3411 mpz_setbit__gmpz_setbit (result->value.integer, i);
3412 else
3413 gfc_internal_error ("IBITS: Bad bit");
3414 }
3415
3416 free (bits);
3417
3418 gfc_convert_mpz_to_signed (result->value.integer,
3419 gfc_integer_kinds[k].bit_size);
3420
3421 return result;
3422}
3423
3424
3425gfc_expr *
3426gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
3427{
3428 gfc_expr *result;
3429 int k, pos;
3430
3431 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3432 return NULL__null;
3433
3434 gfc_extract_int (y, &pos);
3435
3436 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3437
3438 result = gfc_copy_expr (x);
3439
3440 convert_mpz_to_unsigned (result->value.integer,
3441 gfc_integer_kinds[k].bit_size);
3442
3443 mpz_setbit__gmpz_setbit (result->value.integer, pos);
3444
3445 gfc_convert_mpz_to_signed (result->value.integer,
3446 gfc_integer_kinds[k].bit_size);
3447
3448 return result;
3449}
3450
3451
3452gfc_expr *
3453gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3454{
3455 gfc_expr *result;
3456 gfc_char_t index;
3457 int k;
3458
3459 if (e->expr_type != EXPR_CONSTANT)
3460 return NULL__null;
3461
3462 if (e->value.character.length != 1)
3463 {
3464 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
3465 return &gfc_bad_expr;
3466 }
3467
3468 index = e->value.character.string[0];
3469
3470 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
3471 if (k == -1)
3472 return &gfc_bad_expr;
3473
3474 result = gfc_get_int_expr (k, &e->where, index);
3475
3476 return range_check (result, "ICHAR");
3477}
3478
3479
3480gfc_expr *
3481gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
3482{
3483 gfc_expr *result;
3484
3485 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3486 return NULL__null;
3487
3488 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3489 mpz_xor__gmpz_xor (result->value.integer, x->value.integer, y->value.integer);
3490
3491 return range_check (result, "IEOR");
3492}
3493
3494
3495gfc_expr *
3496gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
3497{
3498 gfc_expr *result;
3499 int back, len, lensub;
3500 int i, j, k, count, index = 0, start;
3501
3502 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
3503 || ( b != NULL__null && b->expr_type != EXPR_CONSTANT))
3504 return NULL__null;
3505
3506 if (b != NULL__null && b->value.logical != 0)
3507 back = 1;
3508 else
3509 back = 0;
3510
3511 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
3512 if (k == -1)
3513 return &gfc_bad_expr;
3514
3515 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
3516
3517 len = x->value.character.length;
3518 lensub = y->value.character.length;
3519
3520 if (len < lensub)
3521 {
3522 mpz_set_si__gmpz_set_si (result->value.integer, 0);
3523 return result;
3524 }
3525
3526 if (back == 0)
3527 {
3528 if (lensub == 0)
3529 {
3530 mpz_set_si__gmpz_set_si (result->value.integer, 1);
3531 return result;
3532 }
3533 else if (lensub == 1)
3534 {
3535 for (i = 0; i < len; i++)
3536 {
3537 for (j = 0; j < lensub; j++)
3538 {
3539 if (y->value.character.string[j]
3540 == x->value.character.string[i])
3541 {
3542 index = i + 1;
3543 goto done;
3544 }
3545 }
3546 }
3547 }
3548 else
3549 {
3550 for (i = 0; i < len; i++)
3551 {
3552 for (j = 0; j < lensub; j++)
3553 {
3554 if (y->value.character.string[j]
3555 == x->value.character.string[i])
3556 {
3557 start = i;
3558 count = 0;
3559
3560 for (k = 0; k < lensub; k++)
3561 {
3562 if (y->value.character.string[k]
3563 == x->value.character.string[k + start])
3564 count++;
3565 }
3566
3567 if (count == lensub)
3568 {
3569 index = start + 1;
3570 goto done;
3571 }
3572 }
3573 }
3574 }
3575 }
3576
3577 }
3578 else
3579 {
3580 if (lensub == 0)
3581 {
3582 mpz_set_si__gmpz_set_si (result->value.integer, len + 1);
3583 return result;
3584 }
3585 else if (lensub == 1)
3586 {
3587 for (i = 0; i < len; i++)
3588 {
3589 for (j = 0; j < lensub; j++)
3590 {
3591 if (y->value.character.string[j]
3592 == x->value.character.string[len - i])
3593 {
3594 index = len - i + 1;
3595 goto done;
3596 }
3597 }
3598 }
3599 }
3600 else
3601 {
3602 for (i = 0; i < len; i++)
3603 {
3604 for (j = 0; j < lensub; j++)
3605 {
3606 if (y->value.character.string[j]
3607 == x->value.character.string[len - i])
3608 {
3609 start = len - i;
3610 if (start <= len - lensub)
3611 {
3612 count = 0;
3613 for (k = 0; k < lensub; k++)
3614 if (y->value.character.string[k]
3615 == x->value.character.string[k + start])
3616 count++;
3617
3618 if (count == lensub)
3619 {
3620 index = start + 1;
3621 goto done;
3622 }
3623 }
3624 else
3625 {
3626 continue;
3627 }
3628 }
3629 }
3630 }
3631 }
3632 }
3633
3634done:
3635 mpz_set_si__gmpz_set_si (result->value.integer, index);
3636 return range_check (result, "INDEX");
3637}
3638
3639
3640static gfc_expr *
3641simplify_intconv (gfc_expr *e, int kind, const char *name)
3642{
3643 gfc_expr *result = NULL__null;
3644 int tmp1, tmp2;
3645
3646 /* Convert BOZ to integer, and return without range checking. */
3647 if (e->ts.type == BT_BOZ)
3648 {
3649 if (!gfc_boz2int (e, kind))
3650 return NULL__null;
3651 result = gfc_copy_expr (e);
3652 return result;
3653 }
3654
3655 if (e->expr_type != EXPR_CONSTANT)
3656 return NULL__null;
3657
3658 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3659 warnings. */
3660 tmp1 = warn_conversionglobal_options.x_warn_conversion;
3661 tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
3662 warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;
3663
3664 result = gfc_convert_constant (e, BT_INTEGER, kind);
3665
3666 warn_conversionglobal_options.x_warn_conversion = tmp1;
3667 warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;
3668
3669 if (result == &gfc_bad_expr)
3670 return &gfc_bad_expr;
3671
3672 return range_check (result, name);
3673}
3674
3675
3676gfc_expr *
3677gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3678{
3679 int kind;
3680
3681 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
3682 if (kind == -1)
3683 return &gfc_bad_expr;
3684
3685 return simplify_intconv (e, kind, "INT");
3686}
3687
3688gfc_expr *
3689gfc_simplify_int2 (gfc_expr *e)
3690{
3691 return simplify_intconv (e, 2, "INT2");
3692}
3693
3694
3695gfc_expr *
3696gfc_simplify_int8 (gfc_expr *e)
3697{
3698 return simplify_intconv (e, 8, "INT8");
3699}
3700
3701
3702gfc_expr *
3703gfc_simplify_long (gfc_expr *e)
3704{
3705 return simplify_intconv (e, 4, "LONG");
3706}
3707
3708
3709gfc_expr *
3710gfc_simplify_ifix (gfc_expr *e)
3711{
3712 gfc_expr *rtrunc, *result;
3713
3714 if (e->expr_type != EXPR_CONSTANT)
3715 return NULL__null;
3716
3717 rtrunc = gfc_copy_expr (e);
3718 mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
)
;
3719
3720 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3721 &e->where);
3722 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3723
3724 gfc_free_expr (rtrunc);
3725
3726 return range_check (result, "IFIX");
3727}
3728
3729
3730gfc_expr *
3731gfc_simplify_idint (gfc_expr *e)
3732{
3733 gfc_expr *rtrunc, *result;
3734
3735 if (e->expr_type != EXPR_CONSTANT)
3736 return NULL__null;
3737
3738 rtrunc = gfc_copy_expr (e);
3739 mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
)
;
3740
3741 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3742 &e->where);
3743 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3744
3745 gfc_free_expr (rtrunc);
3746
3747 return range_check (result, "IDINT");
3748}
3749
3750
3751gfc_expr *
3752gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
3753{
3754 gfc_expr *result;
3755
3756 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3757 return NULL__null;
3758
3759 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3760 mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer);
3761
3762 return range_check (result, "IOR");
3763}
3764
3765
3766static gfc_expr *
3767do_bit_xor (gfc_expr *result, gfc_expr *e)
3768{
3769 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"
, 3769, __FUNCTION__), 0 : 0))
;
3770 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"
, 3771, __FUNCTION__), 0 : 0))
3771 && 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"
, 3771, __FUNCTION__), 0 : 0))
;
3772
3773 mpz_xor__gmpz_xor (result->value.integer, result->value.integer, e->value.integer);
3774 return result;
3775}
3776
3777
3778gfc_expr *
3779gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3780{
3781 return simplify_transformation (array, dim, mask, 0, do_bit_xor);
3782}
3783
3784
3785gfc_expr *
3786gfc_simplify_is_iostat_end (gfc_expr *x)
3787{
3788 if (x->expr_type != EXPR_CONSTANT)
3789 return NULL__null;
3790
3791 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3792 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))
3793 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);
3794}
3795
3796
3797gfc_expr *
3798gfc_simplify_is_iostat_eor (gfc_expr *x)
3799{
3800 if (x->expr_type != EXPR_CONSTANT)
3801 return NULL__null;
3802
3803 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3804 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))
3805 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);
3806}
3807
3808
3809gfc_expr *
3810gfc_simplify_isnan (gfc_expr *x)
3811{
3812 if (x->expr_type != EXPR_CONSTANT)
3813 return NULL__null;
3814
3815 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3816 mpfr_nan_p (x->value.real)((x->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))
);
3817}
3818
3819
3820/* Performs a shift on its first argument. Depending on the last
3821 argument, the shift can be arithmetic, i.e. with filling from the
3822 left like in the SHIFTA intrinsic. */
3823static gfc_expr *
3824simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
3825 bool arithmetic, int direction)
3826{
3827 gfc_expr *result;
3828 int ashift, *bits, i, k, bitsize, shift;
3829
3830 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3831 return NULL__null;
3832
3833 gfc_extract_int (s, &shift);
3834
3835 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
3836 bitsize = gfc_integer_kinds[k].bit_size;
3837
3838 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3839
3840 if (shift == 0)
3841 {
3842 mpz_set__gmpz_set (result->value.integer, e->value.integer);
3843 return result;
3844 }
3845
3846 if (direction > 0 && shift < 0)
3847 {
3848 /* Left shift, as in SHIFTL. */
3849 gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3850 return &gfc_bad_expr;
3851 }
3852 else if (direction < 0)
3853 {
3854 /* Right shift, as in SHIFTR or SHIFTA. */
3855 if (shift < 0)
3856 {
3857 gfc_error ("Second argument of %s is negative at %L",
3858 name, &e->where);
3859 return &gfc_bad_expr;
3860 }
3861
3862 shift = -shift;
3863 }
3864
3865 ashift = (shift >= 0 ? shift : -shift);
3866
3867 if (ashift > bitsize)
3868 {
3869 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3870 "at %L", name, &e->where);
3871 return &gfc_bad_expr;
3872 }
3873
3874 bits = XCNEWVEC (int, bitsize)((int *) xcalloc ((bitsize), sizeof (int)));
3875
3876 for (i = 0; i < bitsize; i++)
3877 bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i);
3878
3879 if (shift > 0)
3880 {
3881 /* Left shift. */
3882 for (i = 0; i < shift; i++)
3883 mpz_clrbit__gmpz_clrbit (result->value.integer, i);
3884
3885 for (i = 0; i < bitsize - shift; i++)
3886 {
3887 if (bits[i] == 0)
3888 mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
3889 else
3890 mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
3891 }
3892 }
3893 else
3894 {
3895 /* Right shift. */
3896 if (arithmetic && bits[bitsize - 1])
3897 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3898 mpz_setbit__gmpz_setbit (result->value.integer, i);
3899 else
3900 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3901 mpz_clrbit__gmpz_clrbit (result->value.integer, i);
3902
3903 for (i = bitsize - 1; i >= ashift; i--)
3904 {
3905 if (bits[i] == 0)
3906 mpz_clrbit__gmpz_clrbit (result->value.integer, i - ashift);
3907 else
3908 mpz_setbit__gmpz_setbit (result->value.integer, i - ashift);
3909 }
3910 }
3911
3912 gfc_convert_mpz_to_signed (result->value.integer, bitsize);
3913 free (bits);
3914
3915 return result;
3916}
3917
3918
3919gfc_expr *
3920gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3921{
3922 return simplify_shift (e, s, "ISHFT", false, 0);
3923}
3924
3925
3926gfc_expr *
3927gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3928{
3929 return simplify_shift (e, s, "LSHIFT", false, 1);
3930}
3931
3932
3933gfc_expr *
3934gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3935{
3936 return simplify_shift (e, s, "RSHIFT", true, -1);
3937}
3938
3939
3940gfc_expr *
3941gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3942{
3943 return simplify_shift (e, s, "SHIFTA", true, -1);
3944}
3945
3946
3947gfc_expr *
3948gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3949{
3950 return simplify_shift (e, s, "SHIFTL", false, 1);
3951}
3952
3953
3954gfc_expr *
3955gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3956{
3957 return simplify_shift (e, s, "SHIFTR", false, -1);
3958}
3959
3960
3961gfc_expr *
3962gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3963{
3964 gfc_expr *result;
3965 int shift, ashift, isize, ssize, delta, k;
3966 int i, *bits;
3967
3968 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3969 return NULL__null;
3970
3971 gfc_extract_int (s, &shift);
3972
3973 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3974 isize = gfc_integer_kinds[k].bit_size;
3975
3976 if (sz != NULL__null)
3977 {
3978 if (sz->expr_type != EXPR_CONSTANT)
3979 return NULL__null;
3980
3981 gfc_extract_int (sz, &ssize);
3982 }
3983 else
3984 ssize = isize;
3985
3986 if (shift >= 0)
3987 ashift = shift;
3988 else
3989 ashift = -shift;
3990
3991 if (ashift > ssize)
3992 {
3993 if (sz == NULL__null)
3994 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3995 "BIT_SIZE of first argument at %C");
3996 else
3997 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3998 "to SIZE at %C");
3999 return &gfc_bad_expr;
4000 }
4001
4002 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4003
4004 mpz_set__gmpz_set (result->value.integer, e->value.integer);
4005
4006 if (shift == 0)
4007 return result;
4008
4009 convert_mpz_to_unsigned (result->value.integer, isize);
4010
4011 bits = XCNEWVEC (int, ssize)((int *) xcalloc ((ssize), sizeof (int)));
4012
4013 for (i = 0; i < ssize; i++)
4014 bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i);
4015
4016 delta = ssize - ashift;
4017
4018 if (shift > 0)
4019 {
4020 for (i = 0; i < delta; i++)
4021 {
4022 if (bits[i] == 0)
4023 mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
4024 else
4025 mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
4026 }
4027
4028 for (i = delta; i < ssize; i++)
4029 {
4030 if (bits[i] == 0)
4031 mpz_clrbit__gmpz_clrbit (result->value.integer, i - delta);
4032 else
4033 mpz_setbit__gmpz_setbit (result->value.integer, i - delta);
4034 }
4035 }
4036 else
4037 {
4038 for (i = 0; i < ashift; i++)
4039 {
4040 if (bits[i] == 0)
4041 mpz_clrbit__gmpz_clrbit (result->value.integer, i + delta);
4042 else
4043 mpz_setbit__gmpz_setbit (result->value.integer, i + delta);
4044 }
4045
4046 for (i = ashift; i < ssize; i++)
4047 {
4048 if (bits[i] == 0)
4049 mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
4050 else
4051 mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
4052 }
4053 }
4054
4055 gfc_convert_mpz_to_signed (result->value.integer, isize);
4056
4057 free (bits);
4058 return result;
4059}
4060
4061
4062gfc_expr *
4063gfc_simplify_kind (gfc_expr *e)
4064{
4065 return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, e->ts.kind);
4066}
4067
4068
4069static gfc_expr *
4070simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
4071 gfc_array_spec *as, gfc_ref *ref, bool coarray)
4072{
4073 gfc_expr *l, *u, *result;
4074 int k;
4075
4076 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4077 gfc_default_integer_kind);
4078 if (k == -1)
4079 return &gfc_bad_expr;
4080
4081 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4082
4083 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4084 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4085 if (!coarray && array->expr_type != EXPR_VARIABLE)
4086 {
4087 if (upper)
4088 {
4089 gfc_expr* dim = result;
4090 mpz_set_si__gmpz_set_si (dim->value.integer, d);
4091
4092 result = simplify_size (array, dim, k);
4093 gfc_free_expr (dim);
4094 if (!result)
4095 goto returnNull;
4096 }
4097 else
4098 mpz_set_si__gmpz_set_si (result->value.integer, 1);
4099
4100 goto done;
4101 }
4102
4103 /* Otherwise, we have a variable expression. */
4104 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"
, 4104, __FUNCTION__), 0 : 0))
;
4105 gcc_assert (as)((void)(!(as) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4105, __FUNCTION__), 0 : 0))
;
4106
4107 if (!gfc_resolve_array_spec (as, 0))
4108 return NULL__null;
4109
4110 /* The last dimension of an assumed-size array is special. */
4111 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4112 || (coarray && d == as->rank + as->corank
4113 && (!upper || flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)))
4114 {
4115 if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
4116 {
4117 gfc_free_expr (result);
4118 return gfc_copy_expr (as->lower[d-1]);
4119 }
4120
4121 goto returnNull;
4122 }
4123
4124 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4125
4126 /* Then, we need to know the extent of the given dimension. */
4127 if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
4128 {
4129 gfc_expr *declared_bound;
4130 int empty_bound;
4131 bool constant_lbound, constant_ubound;
4132
4133 l = as->lower[d-1];
4134 u = as->upper[d-1];
4135
4136 gcc_assert (l != NULL)((void)(!(l != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4136, __FUNCTION__), 0 : 0))
;
4137
4138 constant_lbound = l->expr_type == EXPR_CONSTANT;
4139 constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4140
4141 empty_bound = upper ? 0 : 1;
4142 declared_bound = upper ? u : l;
4143
4144 if ((!upper && !constant_lbound)
4145 || (upper && !constant_ubound))
4146 goto returnNull;
4147
4148 if (!coarray)
4149 {
4150 /* For {L,U}BOUND, the value depends on whether the array
4151 is empty. We can nevertheless simplify if the declared bound
4152 has the same value as that of an empty array, in which case
4153 the result isn't dependent on the array emptyness. */
4154 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)
4155 mpz_set_si__gmpz_set_si (result->value.integer, empty_bound);
4156 else if (!constant_lbound || !constant_ubound)
4157 /* Array emptyness can't be determined, we can't simplify. */
4158 goto returnNull;
4159 else if (mpz_cmp__gmpz_cmp (l->value.integer, u->value.integer) > 0)
4160 mpz_set_si__gmpz_set_si (result->value.integer, empty_bound);
4161 else
4162 mpz_set__gmpz_set (result->value.integer, declared_bound->value.integer);
4163 }
4164 else
4165 mpz_set__gmpz_set (result->value.integer, declared_bound->value.integer);
4166 }
4167 else
4168 {
4169 if (upper)
4170 {
4171 if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL__null))
4172 goto returnNull;
4173 }
4174 else
4175 mpz_set_si__gmpz_set_si (result->value.integer, (long int) 1);
4176 }
4177
4178done:
4179 return range_check (result, upper ? "UBOUND" : "LBOUND");
4180
4181returnNull:
4182 gfc_free_expr (result);
4183 return NULL__null;
4184}
4185
4186
4187static gfc_expr *
4188simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4189{
4190 gfc_ref *ref;
4191 gfc_array_spec *as;
4192 ar_type type = AR_UNKNOWN;
4193 int d;
4194
4195 if (array->ts.type == BT_CLASS)
4196 return NULL__null;
4197
4198 if (array->expr_type != EXPR_VARIABLE)
4199 {
4200 as = NULL__null;
4201 ref = NULL__null;
4202 goto done;
4203 }
4204
4205 /* Do not attempt to resolve if error has already been issued. */
4206 if (array->symtree->n.sym->error)
4207 return NULL__null;
4208
4209 /* Follow any component references. */
4210 as = array->symtree->n.sym->as;
4211 for (ref = array->ref; ref; ref = ref->next)
4212 {
4213 switch (ref->type)
4214 {
4215 case REF_ARRAY:
4216 type = ref->u.ar.type;
4217 switch (ref->u.ar.type)
4218 {
4219 case AR_ELEMENT:
4220 as = NULL__null;
4221 continue;
4222
4223 case AR_FULL:
4224 /* We're done because 'as' has already been set in the
4225 previous iteration. */
4226 goto done;
4227
4228 case AR_UNKNOWN:
4229 return NULL__null;
4230
4231 case AR_SECTION:
4232 as = ref->u.ar.as;
4233 goto done;
4234 }
4235
4236 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4236, __FUNCTION__))
;
4237
4238 case REF_COMPONENT:
4239 as = ref->u.c.component->as;
4240 continue;
4241
4242 case REF_SUBSTRING:
4243 case REF_INQUIRY:
4244 continue;
4245 }
4246 }
4247
4248 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4248, __FUNCTION__))
;
4249
4250 done:
4251
4252 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
4253 || (as->type == AS_ASSUMED_SHAPE && upper)))
4254 return NULL__null;
4255
4256 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"
, 4260, __FUNCTION__), 0 : 0))
4257 || (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"
, 4260, __FUNCTION__), 0 : 0))
4258 && 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"
, 4260, __FUNCTION__), 0 : 0))
4259 && !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"
, 4260, __FUNCTION__), 0 : 0))
4260 && !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"
, 4260, __FUNCTION__), 0 : 0))
;
4261
4262 if (dim == NULL__null)
4263 {
4264 /* Multi-dimensional bounds. */
4265 gfc_expr *bounds[GFC_MAX_DIMENSIONS15];
4266 gfc_expr *e;
4267 int k;
4268
4269 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4270 if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
4271 {
4272 /* An error message will be emitted in
4273 check_assumed_size_reference (resolve.c). */
4274 return &gfc_bad_expr;
4275 }
4276
4277 /* Simplify the bounds for each dimension. */
4278 for (d = 0; d < array->rank; d++)
4279 {
4280 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
4281 false);
4282 if (bounds[d] == NULL__null || bounds[d] == &gfc_bad_expr)
4283 {
4284 int j;
4285
4286 for (j = 0; j < d; j++)
4287 gfc_free_expr (bounds[j]);
4288
4289 if (gfc_seen_div0)
4290 return &gfc_bad_expr;
4291 else
4292 return bounds[d];
4293 }
4294 }
4295
4296 /* Allocate the result expression. */
4297 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4298 gfc_default_integer_kind);
4299 if (k == -1)
4300 return &gfc_bad_expr;
4301
4302 e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
4303
4304 /* The result is a rank 1 array; its size is the rank of the first
4305 argument to {L,U}BOUND. */
4306 e->rank = 1;
4307 e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
4308 mpz_init_set_ui__gmpz_init_set_ui (e->shape[0], array->rank);
4309
4310 /* Create the constructor for this array. */
4311 for (d = 0; d < array->rank; d++)
4312 gfc_constructor_append_expr (&e->value.constructor,
4313 bounds[d], &e->where);
4314
4315 return e;
4316 }
4317 else
4318 {
4319 /* A DIM argument is specified. */
4320 if (dim->expr_type != EXPR_CONSTANT)
4321 return NULL__null;
4322
4323 d = mpz_get_si__gmpz_get_si (dim->value.integer);
4324
4325 if ((d < 1 || d > array->rank)
4326 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
4327 {
4328 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4329 return &gfc_bad_expr;
4330 }
4331
4332 if (as && as->type == AS_ASSUMED_RANK)
4333 return NULL__null;
4334
4335 return simplify_bound_dim (array, kind, d, upper, as, ref, false);
4336 }
4337}
4338
4339
4340static gfc_expr *
4341simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4342{
4343 gfc_ref *ref;
4344 gfc_array_spec *as;
4345 int d;
4346
4347 if (array->expr_type != EXPR_VARIABLE)
4348 return NULL__null;
4349
4350 /* Follow any component references. */
4351 as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
4352 ? array->ts.u.derived->components->as
4353 : array->symtree->n.sym->as;
4354 for (ref = array->ref; ref; ref = ref->next)
4355 {
4356 switch (ref->type)
4357 {
4358 case REF_ARRAY:
4359 switch (ref->u.ar.type)
4360 {
4361 case AR_ELEMENT:
4362 if (ref->u.ar.as->corank > 0)
4363 {
4364 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"
, 4364, __FUNCTION__), 0 : 0))
;
4365 goto done;
4366 }
4367 as = NULL__null;
4368 continue;
4369
4370 case AR_FULL:
4371 /* We're done because 'as' has already been set in the
4372 previous iteration. */
4373 goto done;
4374
4375 case AR_UNKNOWN:
4376 return NULL__null;
4377
4378 case AR_SECTION:
4379 as = ref->u.ar.as;
4380 goto done;
4381 }
4382
4383 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4383, __FUNCTION__))
;
4384
4385 case REF_COMPONENT:
4386 as = ref->u.c.component->as;
4387 continue;
4388
4389 case REF_SUBSTRING:
4390 case REF_INQUIRY:
4391 continue;
4392 }
4393 }
4394
4395 if (!as)
4396 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4396, __FUNCTION__))
;
4397
4398 done:
4399
4400 if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
4401 return NULL__null;
4402
4403 if (dim == NULL__null)
4404 {
4405 /* Multi-dimensional cobounds. */
4406 gfc_expr *bounds[GFC_MAX_DIMENSIONS15];
4407 gfc_expr *e;
4408 int k;
4409
4410 /* Simplify the cobounds for each dimension. */
4411 for (d = 0; d < as->corank; d++)
4412 {
4413 bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
4414 upper, as, ref, true);
4415 if (bounds[d] == NULL__null || bounds[d] == &gfc_bad_expr)
4416 {
4417 int j;
4418
4419 for (j = 0; j < d; j++)
4420 gfc_free_expr (bounds[j]);
4421 return bounds[d];
4422 }
4423 }
4424
4425 /* Allocate the result expression. */
4426 e = gfc_get_expr ();
4427 e->where = array->where;
4428 e->expr_type = EXPR_ARRAY;
4429 e->ts.type = BT_INTEGER;
4430 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
4431 gfc_default_integer_kind);
4432 if (k == -1)
4433 {
4434 gfc_free_expr (e);
4435 return &gfc_bad_expr;
4436 }
4437 e->ts.kind = k;
4438
4439 /* The result is a rank 1 array; its size is the rank of the first
4440 argument to {L,U}COBOUND. */
4441 e->rank = 1;
4442 e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
4443 mpz_init_set_ui__gmpz_init_set_ui (e->shape[0], as->corank);
4444
4445 /* Create the constructor for this array. */
4446 for (d = 0; d < as->corank; d++)
4447 gfc_constructor_append_expr (&e->value.constructor,
4448 bounds[d], &e->where);
4449 return e;
4450 }
4451 else
4452 {
4453 /* A DIM argument is specified. */
4454 if (dim->expr_type != EXPR_CONSTANT)
4455 return NULL__null;
4456
4457 d = mpz_get_si__gmpz_get_si (dim->value.integer);
4458
4459 if (d < 1 || d > as->corank)
4460 {
4461 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4462 return &gfc_bad_expr;
4463 }
4464
4465 return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
4466 }
4467}
4468
4469
4470gfc_expr *
4471gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4472{
4473 return simplify_bound (array, dim, kind, 0);
4474}
4475
4476
4477gfc_expr *
4478gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4479{
4480 return simplify_cobound (array, dim, kind, 0);
4481}
4482
4483gfc_expr *
4484gfc_simplify_leadz (gfc_expr *e)
4485{
4486 unsigned long lz, bs;
4487 int i;
4488
4489 if (e->expr_type != EXPR_CONSTANT)
4490 return NULL__null;
4491
4492 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4493 bs = gfc_integer_kinds[i].bit_size;
4494 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)
4495 lz = bs;
4496 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)
4497 lz = 0;
4498 else
4499 lz = bs - mpz_sizeinbase__gmpz_sizeinbase (e->value.integer, 2);
4500
4501 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4502}
4503
4504
4505gfc_expr *
4506gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
4507{
4508 gfc_expr *result;
4509 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
4510
4511 if (k == -1)
4512 return &gfc_bad_expr;
4513
4514 if (e->expr_type == EXPR_CONSTANT)
4515 {
4516 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4517 mpz_set_si__gmpz_set_si (result->value.integer, e->value.character.length);
4518 return range_check (result, "LEN");
4519 }
4520 else if (e->ts.u.cl != NULL__null && e->ts.u.cl->length != NULL__null
4521 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
4522 && e->ts.u.cl->length->ts.type == BT_INTEGER)
4523 {
4524 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4525 mpz_set__gmpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
4526 return range_check (result, "LEN");
4527 }
4528 else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
4529 && e->symtree->n.sym
4530 && e->symtree->n.sym->ts.type != BT_DERIVED
4531 && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
4532 && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
4533 && e->symtree->n.sym->assoc->target->symtree->n.sym
4534 && 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
)
)
4535
4536 /* The expression in assoc->target points to a ref to the _data component
4537 of the unlimited polymorphic entity. To get the _len component the last
4538 _data ref needs to be stripped and a ref to the _len component added. */
4539 return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
4540 else
4541 return NULL__null;
4542}
4543
4544
4545gfc_expr *
4546gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
4547{
4548 gfc_expr *result;
4549 size_t count, len, i;
4550 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
4551
4552 if (k == -1)
4553 return &gfc_bad_expr;
4554
4555 if (e->expr_type != EXPR_CONSTANT)
4556 return NULL__null;
4557
4558 len = e->value.character.length;
4559 for (count = 0, i = 1; i <= len; i++)
4560 if (e->value.character.string[len - i] == ' ')
4561 count++;
4562 else
4563 break;
4564
4565 result = gfc_get_int_expr (k, &e->where, len - count);
4566 return range_check (result, "LEN_TRIM");
4567}
4568
4569gfc_expr *
4570gfc_simplify_lgamma (gfc_expr *x)
4571{
4572 gfc_expr *result;
4573 int sg;
4574
4575 if (x->expr_type != EXPR_CONSTANT)
4576 return NULL__null;
4577
4578 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4579 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODEMPFR_RNDN);
4580
4581 return range_check (result, "LGAMMA");
4582}
4583
4584
4585gfc_expr *
4586gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4587{
4588 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4589 return NULL__null;
4590
4591 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4592 gfc_compare_string (a, b) >= 0);
4593}
4594
4595
4596gfc_expr *
4597gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4598{
4599 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4600 return NULL__null;
4601
4602 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4603 gfc_compare_string (a, b) > 0);
4604}
4605
4606
4607gfc_expr *
4608gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4609{
4610 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4611 return NULL__null;
4612
4613 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4614 gfc_compare_string (a, b) <= 0);
4615}
4616
4617
4618gfc_expr *
4619gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4620{
4621 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4622 return NULL__null;
4623
4624 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4625 gfc_compare_string (a, b) < 0);
4626}
4627
4628
4629gfc_expr *
4630gfc_simplify_log (gfc_expr *x)
4631{
4632 gfc_expr *result;
4633
4634 if (x->expr_type != EXPR_CONSTANT)
4635 return NULL__null;
4636
4637 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4638
4639 switch (x->ts.type)
4640 {
4641 case BT_REAL:
4642 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)
4643 {
4644 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4645 "to zero", &x->where);
4646 gfc_free_expr (result);
4647 return &gfc_bad_expr;
4648 }
4649
4650 mpfr_log (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
4651 break;
4652
4653 case BT_COMPLEX:
4654 if (mpfr_zero_p (mpc_realref (x->value.complex))((((x->value.complex)->re))->_mpfr_exp == (0 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
4655 && mpfr_zero_p (mpc_imagref (x->value.complex))((((x->value.complex)->im))->_mpfr_exp == (0 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
)
4656 {
4657 gfc_error ("Complex argument of LOG at %L cannot be zero",
4658 &x->where);
4659 gfc_free_expr (result);
4660 return &gfc_bad_expr;
4661 }
4662
4663 gfc_set_model_kind (x->ts.kind);
4664 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
4665 break;
4666
4667 default:
4668 gfc_internal_error ("gfc_simplify_log: bad type");
4669 }
4670
4671 return range_check (result, "LOG");
4672}
4673
4674
4675gfc_expr *
4676gfc_simplify_log10 (gfc_expr *x)
4677{
4678 gfc_expr *result;
4679
4680 if (x->expr_type != EXPR_CONSTANT)
4681 return NULL__null;
4682
4683 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)
4684 {
4685 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4686 "to zero", &x->where);
4687 return &gfc_bad_expr;
4688 }
4689
4690 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4691 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
4692
4693 return range_check (result, "LOG10");
4694}
4695
4696
4697gfc_expr *
4698gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4699{
4700 int kind;
4701
4702 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
4703 if (kind < 0)
4704 return &gfc_bad_expr;
4705
4706 if (e->expr_type != EXPR_CONSTANT)
4707 return NULL__null;
4708
4709 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4710}
4711
4712
4713gfc_expr*
4714gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4715{
4716 gfc_expr *result;
4717 int row, result_rows, col, result_columns;
4718 int stride_a, offset_a, stride_b, offset_b;
4719
4720 if (!is_constant_array_expr (matrix_a)
4721 || !is_constant_array_expr (matrix_b))
4722 return NULL__null;
4723
4724 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4725 if (matrix_a->ts.type != matrix_b->ts.type)
4726 {
4727 gfc_expr e;
4728 e.expr_type = EXPR_OP;
4729 gfc_clear_ts (&e.ts);
4730 e.value.op.op = INTRINSIC_NONE;
4731 e.value.op.op1 = matrix_a;
4732 e.value.op.op2 = matrix_b;
4733 gfc_type_convert_binary (&e, 1);
4734 result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
4735 }
4736 else
4737 {
4738 result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
4739 &matrix_a->where);
4740 }
4741
4742 if (matrix_a->rank == 1 && matrix_b->rank == 2)
4743 {
4744 result_rows = 1;
4745 result_columns = mpz_get_si__gmpz_get_si (matrix_b->shape[1]);
4746 stride_a = 1;
4747 stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]);
4748
4749 result->rank = 1;
4750 result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
4751 mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_columns);
4752 }
4753 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
4754 {
4755 result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4756 result_columns = 1;
4757 stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4758 stride_b = 1;
4759
4760 result->rank = 1;
4761 result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
4762 mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows);
4763 }
4764 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
4765 {
4766 result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4767 result_columns = mpz_get_si__gmpz_get_si (matrix_b->shape[1]);
4768 stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
4769 stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]);
4770
4771 result->rank = 2;
4772 result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
4773 mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows);
4774 mpz_init_set_si__gmpz_init_set_si (result->shape[1], result_columns);
4775 }
4776 else
4777 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4777, __FUNCTION__))
;
4778
4779 offset_b = 0;
4780 for (col = 0; col < result_columns; ++col)
4781 {
4782 offset_a = 0;
4783
4784 for (row = 0; row < result_rows; ++row)
4785 {
4786 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
4787 matrix_b, 1, offset_b, false);
4788 gfc_constructor_append_expr (&result->value.constructor,
4789 e, NULL__null);
4790
4791 offset_a += 1;
4792 }
4793
4794 offset_b += stride_b;
4795 }
4796
4797 return result;
4798}
4799
4800
4801gfc_expr *
4802gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4803{
4804 gfc_expr *result;
4805 int kind, arg, k;
4806
4807 if (i->expr_type != EXPR_CONSTANT)
4808 return NULL__null;
4809
4810 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
4811 if (kind == -1)
4812 return &gfc_bad_expr;
4813 k = gfc_validate_kind (BT_INTEGER, kind, false);
4814
4815 bool fail = gfc_extract_int (i, &arg);
4816 gcc_assert (!fail)((void)(!(!fail) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4816, __FUNCTION__), 0 : 0))
;
4817
4818 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4819
4820 /* MASKR(n) = 2^n - 1 */
4821 mpz_set_ui__gmpz_set_ui (result->value.integer, 1);
4822 mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer, arg);
4823 mpz_sub_ui__gmpz_sub_ui (result->value.integer, result->value.integer, 1);
4824
4825 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4826
4827 return result;
4828}
4829
4830
4831gfc_expr *
4832gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4833{
4834 gfc_expr *result;
4835 int kind, arg, k;
4836 mpz_t z;
4837
4838 if (i->expr_type != EXPR_CONSTANT)
4839 return NULL__null;
4840
4841 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
4842 if (kind == -1)
4843 return &gfc_bad_expr;
4844 k = gfc_validate_kind (BT_INTEGER, kind, false);
4845
4846 bool fail = gfc_extract_int (i, &arg);
4847 gcc_assert (!fail)((void)(!(!fail) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4847, __FUNCTION__), 0 : 0))
;
4848
4849 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4850
4851 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4852 mpz_init_set_ui__gmpz_init_set_ui (z, 1);
4853 mpz_mul_2exp__gmpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
4854 mpz_set_ui__gmpz_set_ui (result->value.integer, 1);
4855 mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer,
4856 gfc_integer_kinds[k].bit_size - arg);
4857 mpz_sub__gmpz_sub (result->value.integer, z, result->value.integer);
4858 mpz_clear__gmpz_clear (z);
4859
4860 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4861
4862 return result;
4863}
4864
4865
4866gfc_expr *
4867gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4868{
4869 gfc_expr * result;
4870 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
4871
4872 if (mask->expr_type == EXPR_CONSTANT)
4873 {
4874 result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
4875 /* Parenthesis is needed to get lower bounds of 1. */
4876 result = gfc_get_parentheses (result);
4877 gfc_simplify_expr (result, 1);
4878 return result;
4879 }
4880
4881 if (!mask->rank || !is_constant_array_expr (mask)
4882 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
4883 return NULL__null;
4884
4885 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
4886 &tsource->where);
4887 if (tsource->ts.type == BT_DERIVED)
4888 result->ts.u.derived = tsource->ts.u.derived;
4889 else if (tsource->ts.type == BT_CHARACTER)
4890 result->ts.u.cl = tsource->ts.u.cl;
4891
4892 tsource_ctor = gfc_constructor_first (tsource->value.constructor);
4893 fsource_ctor = gfc_constructor_first (fsource->value.constructor);
4894 mask_ctor = gfc_constructor_first (mask->value.constructor);
4895
4896 while (mask_ctor)
4897 {
4898 if (mask_ctor->expr->value.logical)
4899 gfc_constructor_append_expr (&result->value.constructor,
4900 gfc_copy_expr (tsource_ctor->expr),
4901 NULL__null);
4902 else
4903 gfc_constructor_append_expr (&result->value.constructor,
4904 gfc_copy_expr (fsource_ctor->expr),
4905 NULL__null);
4906 tsource_ctor = gfc_constructor_next (tsource_ctor);
4907 fsource_ctor = gfc_constructor_next (fsource_ctor);
4908 mask_ctor = gfc_constructor_next (mask_ctor);
4909 }
4910
4911 result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
4912 gfc_array_size (result, &result->shape[0]);
4913
4914 return result;
4915}
4916
4917
4918gfc_expr *
4919gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4920{
4921 mpz_t arg1, arg2, mask;
4922 gfc_expr *result;
4923
4924 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
4925 || mask_expr->expr_type != EXPR_CONSTANT)
4926 return NULL__null;
4927
4928 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4929
4930 /* Convert all argument to unsigned. */
4931 mpz_init_set__gmpz_init_set (arg1, i->value.integer);
4932 mpz_init_set__gmpz_init_set (arg2, j->value.integer);
4933 mpz_init_set__gmpz_init_set (mask, mask_expr->value.integer);
4934
4935 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4936 mpz_and__gmpz_and (arg1, arg1, mask);
4937 mpz_com__gmpz_com (mask, mask);
4938 mpz_and__gmpz_and (arg2, arg2, mask);
4939 mpz_ior__gmpz_ior (result->value.integer, arg1, arg2);
4940
4941 mpz_clear__gmpz_clear (arg1);
4942 mpz_clear__gmpz_clear (arg2);
4943 mpz_clear__gmpz_clear (mask);
4944
4945 return result;
4946}
4947
4948
4949/* Selects between current value and extremum for simplify_min_max
4950 and simplify_minval_maxval. */
4951static int
4952min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
4953{
4954 int ret;
4955
4956 switch (arg->ts.type)
4957 {
4958 case BT_INTEGER:
4959 if (extremum->ts.kind < arg->ts.kind)
4960 extremum->ts.kind = arg->ts.kind;
4961 ret = mpz_cmp__gmpz_cmp (arg->value.integer,
4962 extremum->value.integer) * sign;
4963 if (ret > 0)
4964 mpz_set__gmpz_set (extremum->value.integer, arg->value.integer);
4965 break;
4966
4967 case BT_REAL:
4968 if (extremum->ts.kind < arg->ts.kind)
4969 extremum->ts.kind = arg->ts.kind;
4970 if (mpfr_nan_p (extremum->value.real)((extremum->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
)
4971 {
4972 ret = 1;
4973 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))
;
4974 }
4975 else if (mpfr_nan_p (arg->value.real)((arg->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))))
)
4976 ret = -1;
4977 else
4978 {
4979 ret = mpfr_cmp (arg->value.real, extremum->value.real)mpfr_cmp3(arg->value.real, extremum->value.real, 1) * sign;
4980 if (ret > 0)
4981 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))
;
4982 }
4983 break;
4984
4985 case BT_CHARACTER:
4986#define LENGTH(x) ((x)->value.character.length)
4987#define STRING(x) ((x)->value.character.string)
4988 if (LENGTH (extremum) < LENGTH(arg))
4989 {
4990 gfc_char_t *tmp = STRING(extremum);
4991
4992 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1)((gfc_char_t *) xcalloc ((LENGTH(arg) + 1), sizeof (gfc_char_t
)))
;
4993 memcpy (STRING(extremum), tmp,
4994 LENGTH(extremum) * sizeof (gfc_char_t));
4995 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4996 LENGTH(arg) - LENGTH(extremum));
4997 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
4998 LENGTH(extremum) = LENGTH(arg);
4999 free (tmp);
5000 }
5001 ret = gfc_compare_string (arg, extremum) * sign;
5002 if (ret > 0)
5003 {
5004 free (STRING(extremum));
5005 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1)((gfc_char_t *) xcalloc ((LENGTH(extremum) + 1), sizeof (gfc_char_t
)))
;
5006 memcpy (STRING(extremum), STRING(arg),
5007 LENGTH(arg) * sizeof (gfc_char_t));
5008 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
5009 LENGTH(extremum) - LENGTH(arg));
5010 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
5011 }
5012#undef LENGTH
5013#undef STRING
5014 break;
5015
5016 default:
5017 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5018 }
5019 if (back_val && ret == 0)
5020 ret = 1;
5021
5022 return ret;
5023}
5024
5025
5026/* This function is special since MAX() can take any number of
5027 arguments. The simplified expression is a rewritten version of the
5028 argument list containing at most one constant element. Other
5029 constant elements are deleted. Because the argument list has
5030 already been checked, this function always succeeds. sign is 1 for
5031 MAX(), -1 for MIN(). */
5032
5033static gfc_expr *
5034simplify_min_max (gfc_expr *expr, int sign)
5035{
5036 gfc_actual_arglist *arg, *last, *extremum;
5037 gfc_expr *tmp, *ret;
5038 const char *fname;
5039
5040 last = NULL__null;
5041 extremum = NULL__null;
5042
5043 arg = expr->value.function.actual;
5044
5045 for (; arg; last = arg, arg = arg->next)
5046 {
5047 if (arg->expr->expr_type != EXPR_CONSTANT)
5048 continue;
5049
5050 if (extremum == NULL__null)
5051 {
5052 extremum = arg;
5053 continue;
5054 }
5055
5056 min_max_choose (arg->expr, extremum->expr, sign);
5057
5058 /* Delete the extra constant argument. */
5059 last->next = arg->next;
5060
5061 arg->next = NULL__null;
5062 gfc_free_actual_arglist (arg);
5063 arg = last;
5064 }
5065
5066 /* If there is one value left, replace the function call with the
5067 expression. */
5068 if (expr->value.function.actual->next != NULL__null)
5069 return NULL__null;
5070
5071 /* Handle special cases of specific functions (min|max)1 and
5072 a(min|max)0. */
5073
5074 tmp = expr->value.function.actual->expr;
5075 fname = expr->value.function.isym->name;
5076
5077 if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind4)
5078 && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
5079 {
5080 ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind4);
5081 }
5082 else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind4)
5083 && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
5084 {
5085 ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind4);
5086 }
5087 else
5088 ret = gfc_copy_expr (tmp);
5089
5090 return ret;
5091
5092}
5093
5094
5095gfc_expr *
5096gfc_simplify_min (gfc_expr *e)
5097{
5098 return simplify_min_max (e, -1);
5099}
5100
5101
5102gfc_expr *
5103gfc_simplify_max (gfc_expr *e)
5104{
5105 return simplify_min_max (e, 1);
5106}
5107
5108/* Helper function for gfc_simplify_minval. */
5109
5110static gfc_expr *
5111gfc_min (gfc_expr *op1, gfc_expr *op2)
5112{
5113 min_max_choose (op1, op2, -1);
5114 gfc_free_expr (op1);
5115 return op2;
5116}
5117
5118/* Simplify minval for constant arrays. */
5119
5120gfc_expr *
5121gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5122{
5123 return simplify_transformation (array, dim, mask, INT_MAX2147483647, gfc_min);
5124}
5125
5126/* Helper function for gfc_simplify_maxval. */
5127
5128static gfc_expr *
5129gfc_max (gfc_expr *op1, gfc_expr *op2)
5130{
5131 min_max_choose (op1, op2, 1);
5132 gfc_free_expr (op1);
5133 return op2;
5134}
5135
5136
5137/* Simplify maxval for constant arrays. */
5138
5139gfc_expr *
5140gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5141{
5142 return simplify_transformation (array, dim, mask, INT_MIN(-2147483647 -1), gfc_max);
5143}
5144
5145
5146/* Transform minloc or maxloc of an array, according to MASK,
5147 to the scalar result. This code is mostly identical to
5148 simplify_transformation_to_scalar. */
5149
5150static gfc_expr *
5151simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5152 gfc_expr *extremum, int sign, bool back_val)
5153{
5154 gfc_expr *a, *m;
5155 gfc_constructor *array_ctor, *mask_ctor;
5156 mpz_t count;
5157
5158 mpz_set_si__gmpz_set_si (result->value.integer, 0);
5159
5160
5161 /* Shortcut for constant .FALSE. MASK. */
5162 if (mask
5163 && mask->expr_type == EXPR_CONSTANT
5164 && !mask->value.logical)
5165 return result;
5166
5167 array_ctor = gfc_constructor_first (array->value.constructor);
5168 if (mask && mask->expr_type == EXPR_ARRAY)
5169 mask_ctor = gfc_constructor_first (mask->value.constructor);
5170 else
5171 mask_ctor = NULL__null;
5172
5173 mpz_init_set_si__gmpz_init_set_si (count, 0);
5174 while (array_ctor)
5175 {
5176 mpz_add_ui__gmpz_add_ui (count, count, 1);
5177 a = array_ctor->expr;
5178 array_ctor = gfc_constructor_next (array_ctor);
5179 /* A constant MASK equals .TRUE. here and can be ignored. */
5180 if (mask_ctor)
5181 {
5182 m = mask_ctor->expr;
5183 mask_ctor = gfc_constructor_next (mask_ctor);
5184 if (!m->value.logical)
5185 continue;
5186 }
5187 if (min_max_choose (a, extremum, sign, back_val) > 0)
5188 mpz_set__gmpz_set (result->value.integer, count);
5189 }
5190 mpz_clear__gmpz_clear (count);
5191 gfc_free_expr (extremum);
5192 return result;
5193}
5194
5195/* Simplify minloc / maxloc in the absence of a dim argument. */
5196
5197static gfc_expr *
5198simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5199 gfc_expr *array, gfc_expr *mask, int sign,
5200 bool back_val)
5201{
5202 ssize_t res[GFC_MAX_DIMENSIONS15];
5203 int i, n;
5204 gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5205 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5206 sstride[GFC_MAX_DIMENSIONS15];
5207 gfc_expr *a, *m;
5208 bool continue_loop;
5209 bool ma;
5210
5211 for (i = 0; i<array->rank; i++)
5212 res[i] = -1;
5213
5214 /* Shortcut for constant .FALSE. MASK. */
5215 if (mask
5216 && mask->expr_type == EXPR_CONSTANT
5217 && !mask->value.logical)
5218 goto finish;
5219
5220 for (i = 0; i < array->rank; i++)
5221 {
5222 count[i] = 0;
5223 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5224 extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]);
5225 if (extent[i] <= 0)
5226 goto finish;
5227 }
5228
5229 continue_loop = true;
5230 array_ctor = gfc_constructor_first (array->value.constructor);
5231 if (mask && mask->rank > 0)
5232 mask_ctor = gfc_constructor_first (mask->value.constructor);
5233 else
5234 mask_ctor = NULL__null;
5235
5236 /* Loop over the array elements (and mask), keeping track of
5237 the indices to return. */
5238 while (continue_loop)
5239 {
5240 do
5241 {
5242 a = array_ctor->expr;
5243 if (mask_ctor)
5244 {
5245 m = mask_ctor->expr;
5246 ma = m->value.logical;
5247 mask_ctor = gfc_constructor_next (mask_ctor);
5248 }
5249 else
5250 ma = true;
5251
5252 if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
5253 {
5254 for (i = 0; i<array->rank; i++)
5255 res[i] = count[i];
5256 }
5257 array_ctor = gfc_constructor_next (array_ctor);
5258 count[0] ++;
5259 } while (count[0] != extent[0]);
5260 n = 0;
5261 do
5262 {
5263 /* When we get to the end of a dimension, reset it and increment
5264 the next dimension. */
5265 count[n] = 0;
5266 n++;
5267 if (n >= array->rank)
5268 {
5269 continue_loop = false;
5270 break;
5271 }
5272 else
5273 count[n] ++;
5274 } while (count[n] == extent[n]);
5275 }
5276
5277 finish:
5278 gfc_free_expr (extremum);
5279 result_ctor = gfc_constructor_first (result->value.constructor);
5280 for (i = 0; i<array->rank; i++)
5281 {
5282 gfc_expr *r_expr;
5283 r_expr = result_ctor->expr;
5284 mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1);
5285 result_ctor = gfc_constructor_next (result_ctor);
5286 }
5287 return result;
5288}
5289
5290/* Helper function for gfc_simplify_minmaxloc - build an array
5291 expression with n elements. */
5292
5293static gfc_expr *
5294new_array (bt type, int kind, int n, locus *where)
5295{
5296 gfc_expr *result;
5297 int i;
5298
5299 result = gfc_get_array_expr (type, kind, where);
5300 result->rank = 1;
5301 result->shape = gfc_get_shape(1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
5302 mpz_init_set_si__gmpz_init_set_si (result->shape[0], n);
5303 for (i = 0; i < n; i++)
5304 {
5305 gfc_constructor_append_expr (&result->value.constructor,
5306 gfc_get_constant_expr (type, kind, where),
5307 NULL__null);
5308 }
5309
5310 return result;
5311}
5312
5313/* Simplify minloc and maxloc. This code is mostly identical to
5314 simplify_transformation_to_array. */
5315
5316static gfc_expr *
5317simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
5318 gfc_expr *dim, gfc_expr *mask,
5319 gfc_expr *extremum, int sign, bool back_val)
5320{
5321 mpz_t size;
5322 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5323 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5324 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5325
5326 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5327 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15],
5328 tmpstride[GFC_MAX_DIMENSIONS15];
5329
5330 /* Shortcut for constant .FALSE. MASK. */
5331 if (mask
5332 && mask->expr_type == EXPR_CONSTANT
5333 && !mask->value.logical)
5334 return result;
5335
5336 /* Build an indexed table for array element expressions to minimize
5337 linked-list traversal. Masked elements are set to NULL. */
5338 gfc_array_size (array, &size);
5339 arraysize = mpz_get_ui__gmpz_get_ui (size);
5340 mpz_clear__gmpz_clear (size);
5341
5342 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*)));
5343
5344 array_ctor = gfc_constructor_first (array->value.constructor);
5345 mask_ctor = NULL__null;
5346 if (mask && mask->expr_type == EXPR_ARRAY)
5347 mask_ctor = gfc_constructor_first (mask->value.constructor);
5348
5349 for (i = 0; i < arraysize; ++i)
5350 {
5351 arrayvec[i] = array_ctor->expr;
5352 array_ctor = gfc_constructor_next (array_ctor);
5353
5354 if (mask_ctor)
5355 {
5356 if (!mask_ctor->expr->value.logical)
5357 arrayvec[i] = NULL__null;
5358
5359 mask_ctor = gfc_constructor_next (mask_ctor);
5360 }
5361 }
5362
5363 /* Same for the result expression. */
5364 gfc_array_size (result, &size);
5365 resultsize = mpz_get_ui__gmpz_get_ui (size);
5366 mpz_clear__gmpz_clear (size);
5367
5368 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*)));
5369 result_ctor = gfc_constructor_first (result->value.constructor);
5370 for (i = 0; i < resultsize; ++i)
5371 {
5372 resultvec[i] = result_ctor->expr;
5373 result_ctor = gfc_constructor_next (result_ctor);
5374 }
5375
5376 gfc_extract_int (dim, &dim_index);
5377 dim_index -= 1; /* zero-base index */
5378 dim_extent = 0;
5379 dim_stride = 0;
5380
5381 for (i = 0, n = 0; i < array->rank; ++i)
5382 {
5383 count[i] = 0;
5384 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5385 if (i == dim_index)
5386 {
5387 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]);
5388 dim_stride = tmpstride[i];
5389 continue;
5390 }
5391
5392 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]);
5393 sstride[n] = tmpstride[i];
5394 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5395 n += 1;
5396 }
5397
5398 done = resultsize <= 0;
5399 base = arrayvec;
5400 dest = resultvec;
5401 while (!done)
5402 {
5403 gfc_expr *ex;
5404 ex = gfc_copy_expr (extremum);
5405 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5406 {
5407 if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
5408 mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1);
5409 }
5410
5411 count[0]++;
5412 base += sstride[0];
5413 dest += dstride[0];
5414 gfc_free_expr (ex);
5415
5416 n = 0;
5417 while (!done && count[n] == extent[n])
5418 {
5419 count[n] = 0;
5420 base -= sstride[n] * extent[n];
5421 dest -= dstride[n] * extent[n];
5422
5423 n++;
5424 if (n < result->rank)
5425 {
5426 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5427 times, we'd warn for the last iteration, because the
5428 array index will have already been incremented to the
5429 array sizes, and we can't tell that this must make
5430 the test against result->rank false, because ranks
5431 must not exceed GFC_MAX_DIMENSIONS. */
5432 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5433 count[n]++;
5434 base += sstride[n];
5435 dest += dstride[n];
5436 GCC_DIAGNOSTIC_POP
5437 }
5438 else
5439 done = true;
5440 }
5441 }
5442
5443 /* Place updated expression in result constructor. */
5444 result_ctor = gfc_constructor_first (result->value.constructor);
5445 for (i = 0; i < resultsize; ++i)
5446 {
5447 result_ctor->expr = resultvec[i];
5448 result_ctor = gfc_constructor_next (result_ctor);
5449 }
5450
5451 free (arrayvec);
5452 free (resultvec);
5453 free (extremum);
5454 return result;
5455}
5456
5457/* Simplify minloc and maxloc for constant arrays. */
5458
5459static gfc_expr *
5460gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
5461 gfc_expr *kind, gfc_expr *back, int sign)
5462{
5463 gfc_expr *result;
5464 gfc_expr *extremum;
5465 int ikind;
5466 int init_val;
5467 bool back_val = false;
5468
5469 if (!is_constant_array_expr (array)
5470 || !gfc_is_constant_expr (dim))
5471 return NULL__null;
5472
5473 if (mask
5474 && !is_constant_array_expr (mask)
5475 && mask->expr_type != EXPR_CONSTANT)
5476 return NULL__null;
5477
5478 if (kind)
5479 {
5480 if (gfc_extract_int (kind, &ikind, -1))
5481 return NULL__null;
5482 }
5483 else
5484 ikind = gfc_default_integer_kind;
5485
5486 if (back)
5487 {
5488 if (back->expr_type != EXPR_CONSTANT)
5489 return NULL__null;
5490
5491 back_val = back->value.logical;
5492 }
5493
5494 if (sign < 0)
5495 init_val = INT_MAX2147483647;
5496 else if (sign > 0)
5497 init_val = INT_MIN(-2147483647 -1);
5498 else
5499 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 5499, __FUNCTION__))
;
5500
5501 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
5502 init_result_expr (extremum, init_val, array);
5503
5504 if (dim)
5505 {
5506 result = transformational_result (array, dim, BT_INTEGER,
5507 ikind, &array->where);
5508 init_result_expr (result, 0, array);
5509
5510 if (array->rank == 1)
5511 return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
5512 sign, back_val);
5513 else
5514 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
5515 sign, back_val);
5516 }
5517 else
5518 {
5519 result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5520 return simplify_minmaxloc_nodim (result, extremum, array, mask,
5521 sign, back_val);
5522 }
5523}
5524
5525gfc_expr *
5526gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5527 gfc_expr *back)
5528{
5529 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
5530}
5531
5532gfc_expr *
5533gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5534 gfc_expr *back)
5535{
5536 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
5537}
5538
5539/* Simplify findloc to scalar. Similar to
5540 simplify_minmaxloc_to_scalar. */
5541
5542static gfc_expr *
5543simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5544 gfc_expr *mask, int back_val)
5545{
5546 gfc_expr *a, *m;
5547 gfc_constructor *array_ctor, *mask_ctor;
5548 mpz_t count;
5549
5550 mpz_set_si__gmpz_set_si (result->value.integer, 0);
5551
5552 /* Shortcut for constant .FALSE. MASK. */
5553 if (mask
5554 && mask->expr_type == EXPR_CONSTANT
5555 && !mask->value.logical)
5556 return result;
5557
5558 array_ctor = gfc_constructor_first (array->value.constructor);
5559 if (mask && mask->expr_type == EXPR_ARRAY)
5560 mask_ctor = gfc_constructor_first (mask->value.constructor);
5561 else
5562 mask_ctor = NULL__null;
5563
5564 mpz_init_set_si__gmpz_init_set_si (count, 0);
5565 while (array_ctor)
5566 {
5567 mpz_add_ui__gmpz_add_ui (count, count, 1);
5568 a = array_ctor->expr;
5569 array_ctor = gfc_constructor_next (array_ctor);
5570 /* A constant MASK equals .TRUE. here and can be ignored. */
5571 if (mask_ctor)
5572 {
5573 m = mask_ctor->expr;
5574 mask_ctor = gfc_constructor_next (mask_ctor);
5575 if (!m->value.logical)
5576 continue;
5577 }
5578 if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5579 {
5580 /* We have a match. If BACK is true, continue so we find
5581 the last one. */
5582 mpz_set__gmpz_set (result->value.integer, count);
5583 if (!back_val)
5584 break;
5585 }
5586 }
5587 mpz_clear__gmpz_clear (count);
5588 return result;
5589}
5590
5591/* Simplify findloc in the absence of a dim argument. Similar to
5592 simplify_minmaxloc_nodim. */
5593
5594static gfc_expr *
5595simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
5596 gfc_expr *mask, bool back_val)
5597{
5598 ssize_t res[GFC_MAX_DIMENSIONS15];
5599 int i, n;
5600 gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5601 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5602 sstride[GFC_MAX_DIMENSIONS15];
5603 gfc_expr *a, *m;
5604 bool continue_loop;
5605 bool ma;
5606
5607 for (i = 0; i < array->rank; i++)
5608 res[i] = -1;
5609
5610 /* Shortcut for constant .FALSE. MASK. */
5611 if (mask
5612 && mask->expr_type == EXPR_CONSTANT
5613 && !mask->value.logical)
5614 goto finish;
5615
5616 for (i = 0; i < array->rank; i++)
5617 {
5618 count[i] = 0;
5619 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5620 extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]);
5621 if (extent[i] <= 0)
5622 goto finish;
5623 }
5624
5625 continue_loop = true;
5626 array_ctor = gfc_constructor_first (array->value.constructor);
5627 if (mask && mask->rank > 0)
5628 mask_ctor = gfc_constructor_first (mask->value.constructor);
5629 else
5630 mask_ctor = NULL__null;
5631
5632 /* Loop over the array elements (and mask), keeping track of
5633 the indices to return. */
5634 while (continue_loop)
5635 {
5636 do
5637 {
5638 a = array_ctor->expr;
5639 if (mask_ctor)
5640 {
5641 m = mask_ctor->expr;
5642 ma = m->value.logical;
5643 mask_ctor = gfc_constructor_next (mask_ctor);
5644 }
5645 else
5646 ma = true;
5647
5648 if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5649 {
5650 for (i = 0; i < array->rank; i++)
5651 res[i] = count[i];
5652 if (!back_val)
5653 goto finish;
5654 }
5655 array_ctor = gfc_constructor_next (array_ctor);
5656 count[0] ++;
5657 } while (count[0] != extent[0]);
5658 n = 0;
5659 do
5660 {
5661 /* When we get to the end of a dimension, reset it and increment
5662 the next dimension. */
5663 count[n] = 0;
5664 n++;
5665 if (n >= array->rank)
5666 {
5667 continue_loop = false;
5668 break;
5669 }
5670 else
5671 count[n] ++;
5672 } while (count[n] == extent[n]);
5673 }
5674
5675finish:
5676 result_ctor = gfc_constructor_first (result->value.constructor);
5677 for (i = 0; i < array->rank; i++)
5678 {
5679 gfc_expr *r_expr;
5680 r_expr = result_ctor->expr;
5681 mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1);
5682 result_ctor = gfc_constructor_next (result_ctor);
5683 }
5684 return result;
5685}
5686
5687
5688/* Simplify findloc to an array. Similar to
5689 simplify_minmaxloc_to_array. */
5690
5691static gfc_expr *
5692simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5693 gfc_expr *dim, gfc_expr *mask, bool back_val)
5694{
5695 mpz_t size;
5696 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5697 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5698 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5699
5700 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
5701 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15],
5702 tmpstride[GFC_MAX_DIMENSIONS15];
5703
5704 /* Shortcut for constant .FALSE. MASK. */
5705 if (mask
5706 && mask->expr_type == EXPR_CONSTANT
5707 && !mask->value.logical)
5708 return result;
5709
5710 /* Build an indexed table for array element expressions to minimize
5711 linked-list traversal. Masked elements are set to NULL. */
5712 gfc_array_size (array, &size);
5713 arraysize = mpz_get_ui__gmpz_get_ui (size);
5714 mpz_clear__gmpz_clear (size);
5715
5716 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*)));
5717
5718 array_ctor = gfc_constructor_first (array->value.constructor);
5719 mask_ctor = NULL__null;
5720 if (mask && mask->expr_type == EXPR_ARRAY)
5721 mask_ctor = gfc_constructor_first (mask->value.constructor);
5722
5723 for (i = 0; i < arraysize; ++i)
5724 {
5725 arrayvec[i] = array_ctor->expr;
5726 array_ctor = gfc_constructor_next (array_ctor);
5727
5728 if (mask_ctor)
5729 {
5730 if (!mask_ctor->expr->value.logical)
5731 arrayvec[i] = NULL__null;
5732
5733 mask_ctor = gfc_constructor_next (mask_ctor);
5734 }
5735 }
5736
5737 /* Same for the result expression. */
5738 gfc_array_size (result, &size);
5739 resultsize = mpz_get_ui__gmpz_get_ui (size);
5740 mpz_clear__gmpz_clear (size);
5741
5742 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*)));
5743 result_ctor = gfc_constructor_first (result->value.constructor);
5744 for (i = 0; i < resultsize; ++i)
5745 {
5746 resultvec[i] = result_ctor->expr;
5747 result_ctor = gfc_constructor_next (result_ctor);
5748 }
5749
5750 gfc_extract_int (dim, &dim_index);
5751
5752 dim_index -= 1; /* Zero-base index. */
5753 dim_extent = 0;
5754 dim_stride = 0;
5755
5756 for (i = 0, n = 0; i < array->rank; ++i)
5757 {
5758 count[i] = 0;
5759 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]);
5760 if (i == dim_index)
5761 {
5762 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]);
5763 dim_stride = tmpstride[i];
5764 continue;
5765 }
5766
5767 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]);
5768 sstride[n] = tmpstride[i];
5769 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5770 n += 1;
5771 }
5772
5773 done = resultsize <= 0;
5774 base = arrayvec;
5775 dest = resultvec;
5776 while (!done)
5777 {
5778 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5779 {
5780 if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
5781 {
5782 mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1);
5783 if (!back_val)
5784 break;
5785 }
5786 }
5787
5788 count[0]++;
5789 base += sstride[0];
5790 dest += dstride[0];
5791
5792 n = 0;
5793 while (!done && count[n] == extent[n])
5794 {
5795 count[n] = 0;
5796 base -= sstride[n] * extent[n];
5797 dest -= dstride[n] * extent[n];
5798
5799 n++;
5800 if (n < result->rank)
5801 {
5802 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5803 times, we'd warn for the last iteration, because the
5804 array index will have already been incremented to the
5805 array sizes, and we can't tell that this must make
5806 the test against result->rank false, because ranks
5807 must not exceed GFC_MAX_DIMENSIONS. */
5808 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5809 count[n]++;
5810 base += sstride[n];
5811 dest += dstride[n];
5812 GCC_DIAGNOSTIC_POP
5813 }
5814 else
5815 done = true;
5816 }
5817 }
5818
5819 /* Place updated expression in result constructor. */
5820 result_ctor = gfc_constructor_first (result->value.constructor);
5821 for (i = 0; i < resultsize; ++i)
5822 {
5823 result_ctor->expr = resultvec[i];
5824 result_ctor = gfc_constructor_next (result_ctor);
5825 }
5826
5827 free (arrayvec);
5828 free (resultvec);
5829 return result;
5830}
5831
5832/* Simplify findloc. */
5833
5834gfc_expr *
5835gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
5836 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
5837{
5838 gfc_expr *result;
5839 int ikind;
5840 bool back_val = false;
5841
5842 if (!is_constant_array_expr (array)
5843 || !gfc_is_constant_expr (dim))
5844 return NULL__null;
5845
5846 if (! gfc_is_constant_expr (value))
5847 return 0;
5848
5849 if (mask
5850 && !is_constant_array_expr (mask)
5851 && mask->expr_type != EXPR_CONSTANT)
5852 return NULL__null;
5853
5854 if (kind)
5855 {
5856 if (gfc_extract_int (kind, &ikind, -1))
5857 return NULL__null;
5858 }
5859 else
5860 ikind = gfc_default_integer_kind;
5861
5862 if (back)
5863 {
5864 if (back->expr_type != EXPR_CONSTANT)
5865 return NULL__null;
5866
5867 back_val = back->value.logical;
5868 }
5869
5870 if (dim)
5871 {
5872 result = transformational_result (array, dim, BT_INTEGER,
5873 ikind, &array->where);
5874 init_result_expr (result, 0, array);
5875
5876 if (array->rank == 1)
5877 return simplify_findloc_to_scalar (result, array, value, mask,
5878 back_val);
5879 else
5880 return simplify_findloc_to_array (result, array, value, dim, mask,
5881 back_val);
5882 }
5883 else
5884 {
5885 result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5886 return simplify_findloc_nodim (result, value, array, mask, back_val);
5887 }
5888 return NULL__null;
5889}
5890
5891gfc_expr *
5892gfc_simplify_maxexponent (gfc_expr *x)
5893{
5894 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5895 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5896 gfc_real_kinds[i].max_exponent);
5897}
5898
5899
5900gfc_expr *
5901gfc_simplify_minexponent (gfc_expr *x)
5902{
5903 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5904 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5905 gfc_real_kinds[i].min_exponent);
5906}
5907
5908
5909gfc_expr *
5910gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
5911{
5912 gfc_expr *result;
5913 int kind;
5914
5915 /* First check p. */
5916 if (p->expr_type != EXPR_CONSTANT)
5917 return NULL__null;
5918
5919 /* p shall not be 0. */
5920 switch (p->ts.type)
5921 {
5922 case BT_INTEGER:
5923 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)
5924 {
5925 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5926 "P", &p->where);
5927 return &gfc_bad_expr;
5928 }
5929 break;
5930 case BT_REAL:
5931 if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0)
5932 {
5933 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5934 "P", &p->where);
5935 return &gfc_bad_expr;
5936 }
5937 break;
5938 default:
5939 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
5940 }
5941
5942 if (a->expr_type != EXPR_CONSTANT)
5943 return NULL__null;
5944
5945 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
5946 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
5947
5948 if (a->ts.type == BT_INTEGER)
5949 mpz_tdiv_r__gmpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
5950 else
5951 {
5952 gfc_set_model_kind (kind);
5953 mpfr_fmod (result->value.real, a->value.real, p->value.real,
5954 GFC_RND_MODEMPFR_RNDN);
5955 }
5956
5957 return range_check (result, "MOD");
5958}
5959
5960
5961gfc_expr *
5962gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
5963{
5964 gfc_expr *result;
5965 int kind;
5966
5967 /* First check p. */
5968 if (p->expr_type != EXPR_CONSTANT)
5969 return NULL__null;
5970
5971 /* p shall not be 0. */
5972 switch (p->ts.type)
5973 {
5974 case BT_INTEGER:
5975 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)
5976 {
5977 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5978 "P", &p->where);
5979 return &gfc_bad_expr;
5980 }
5981 break;
5982 case BT_REAL:
5983 if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0)
5984 {
5985 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5986 "P", &p->where);
5987 return &gfc_bad_expr;
5988 }
5989 break;
5990 default:
5991 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
5992 }
5993
5994 if (a->expr_type != EXPR_CONSTANT)
5995 return NULL__null;
5996
5997 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
5998 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
5999
6000 if (a->ts.type == BT_INTEGER)
6001 mpz_fdiv_r__gmpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6002 else
6003 {
6004 gfc_set_model_kind (kind);
6005 mpfr_fmod (result->value.real, a->value.real, p->value.real,
6006 GFC_RND_MODEMPFR_RNDN);
6007 if (mpfr_cmp_ui (result->value.real, 0)mpfr_cmp_ui_2exp((result->value.real),(0),0) != 0)
6008 {
6009 if (mpfr_signbit (a->value.real)(((a->value.real)->_mpfr_sign) < 0) != mpfr_signbit (p->value.real)(((p->value.real)->_mpfr_sign) < 0))
6010 mpfr_add (result->value.real, result->value.real, p->value.real,
6011 GFC_RND_MODEMPFR_RNDN);
6012 }
6013 else
6014 mpfr_copysign (result->value.real, result->value.real,mpfr_set4(result->value.real,result->value.real,MPFR_RNDN
,((p->value.real)->_mpfr_sign))
6015 p->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,result->value.real,MPFR_RNDN
,((p->value.real)->_mpfr_sign))
;
6016 }
6017
6018 return range_check (result, "MODULO");
6019}
6020
6021
6022gfc_expr *
6023gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
6024{
6025 gfc_expr *result;
6026 mpfr_exp_t emin, emax;
6027 int kind;
6028
6029 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
6030 return NULL__null;
6031
6032 result = gfc_copy_expr (x);
6033
6034 /* Save current values of emin and emax. */
6035 emin = mpfr_get_emin ();
6036 emax = mpfr_get_emax ();
6037
6038 /* Set emin and emax for the current model number. */
6039 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
6040 mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
6041 mpfr_get_prec(result->value.real)(0 ? ((result->value.real)->_mpfr_prec) : ((result->
value.real)->_mpfr_prec))
+ 1);
6042 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1);
6043 mpfr_check_range (result->value.real, 0, MPFR_RNDU);
6044
6045 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)
6046 {
6047 mpfr_nextabove (result->value.real);
6048 mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
6049 }
6050 else
6051 {
6052 mpfr_nextbelow (result->value.real);
6053 mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
6054 }
6055
6056 mpfr_set_emin (emin);
6057 mpfr_set_emax (emax);
6058
6059 /* Only NaN can occur. Do not use range check as it gives an
6060 error for denormal numbers. */
6061 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)
6062 {
6063 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
6064 gfc_free_expr (result);
6065 return &gfc_bad_expr;
6066 }
6067
6068 return result;
6069}
6070
6071
6072static gfc_expr *
6073simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
6074{
6075 gfc_expr *itrunc, *result;
6076 int kind;
6077
6078 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
6079 if (kind == -1)
6080 return &gfc_bad_expr;
6081
6082 if (e->expr_type != EXPR_CONSTANT)
6083 return NULL__null;
6084
6085 itrunc = gfc_copy_expr (e);
6086 mpfr_round (itrunc->value.real, e->value.real)mpfr_rint((itrunc->value.real), (e->value.real), MPFR_RNDNA
)
;
6087
6088 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6089 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6090
6091 gfc_free_expr (itrunc);
6092
6093 return range_check (result, name);
6094}
6095
6096
6097gfc_expr *
6098gfc_simplify_new_line (gfc_expr *e)
6099{
6100 gfc_expr *result;
6101
6102 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, 1);
6103 result->value.character.string[0] = '\n';
6104
6105 return result;
6106}
6107
6108
6109gfc_expr *
6110gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6111{
6112 return simplify_nint ("NINT", e, k);
6113}
6114
6115
6116gfc_expr *
6117gfc_simplify_idnint (gfc_expr *e)
6118{
6119 return simplify_nint ("IDNINT", e, NULL__null);
6120}
6121
6122static int norm2_scale;
6123
6124static gfc_expr *
6125norm2_add_squared (gfc_expr *result, gfc_expr *e)
6126{
6127 mpfr_t tmp;
6128
6129 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"
, 6129, __FUNCTION__), 0 : 0))
;
6130 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"
, 6131, __FUNCTION__), 0 : 0))
6131 && 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"
, 6131, __FUNCTION__), 0 : 0))
;
6132
6133 gfc_set_model_kind (result->ts.kind);
6134 int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6135 mpfr_exp_t exp;
6136 if (mpfr_regular_p (result->value.real)((result->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
)
6137 {
6138 exp = mpfr_get_exp (result->value.real)(0 ? ((result->value.real)->_mpfr_exp) : ((result->value
.real)->_mpfr_exp))
;
6139 /* If result is getting close to overflowing, scale down. */
6140 if (exp >= gfc_real_kinds[index].max_exponent - 4
6141 && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6142 {
6143 norm2_scale += 2;
6144 mpfr_div_ui (result->value.real, result->value.real, 16,
6145 GFC_RND_MODEMPFR_RNDN);
6146 }
6147 }
6148
6149 mpfr_init (tmp);
6150 if (mpfr_regular_p (e->value.real)((e->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))))
)
6151 {
6152 exp = mpfr_get_exp (e->value.real)(0 ? ((e->value.real)->_mpfr_exp) : ((e->value.real)
->_mpfr_exp))
;
6153 /* If e**2 would overflow or close to overflowing, scale down. */
6154 if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6155 {
6156 int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6157 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6158 mpfr_set_exp (tmp, new_scale - norm2_scale);
6159 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6160 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6161 norm2_scale = new_scale;
6162 }
6163 }
6164 if (norm2_scale)
6165 {
6166 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6167 mpfr_set_exp (tmp, norm2_scale);
6168 mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6169 }
6170 else
6171 mpfr_set (tmp, e->value.real, GFC_RND_MODE)mpfr_set4(tmp,e->value.real,MPFR_RNDN,((e->value.real)->
_mpfr_sign))
;
6172 mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODEMPFR_RNDN);
6173 mpfr_add (result->value.real, result->value.real, tmp,
6174 GFC_RND_MODEMPFR_RNDN);
6175 mpfr_clear (tmp);
6176
6177 return result;
6178}
6179
6180
6181static gfc_expr *
6182norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
6183{
6184 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"
, 6184, __FUNCTION__), 0 : 0))
;
6185 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"
, 6186, __FUNCTION__), 0 : 0))
6186 && 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"
, 6186, __FUNCTION__), 0 : 0))
;
6187
6188 if (result != e)
6189 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))
;
6190 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN);
6191 if (norm2_scale && mpfr_regular_p (result->value.real)((result->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
)
6192 {
6193 mpfr_t tmp;
6194 mpfr_init (tmp);
6195 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6196 mpfr_set_exp (tmp, norm2_scale);
6197 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6198 mpfr_clear (tmp);
6199 }
6200 norm2_scale = 0;
6201
6202 return result;
6203}
6204
6205
6206gfc_expr *
6207gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6208{
6209 gfc_expr *result;
6210 bool size_zero;
6211
6212 size_zero = gfc_is_size_zero_array (e);
6213
6214 if (!(is_constant_array_expr (e) || size_zero)
6215 || (dim != NULL__null && !gfc_is_constant_expr (dim)))
6216 return NULL__null;
6217
6218 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6219 init_result_expr (result, 0, NULL__null);
6220
6221 if (size_zero)
6222 return result;
6223
6224 norm2_scale = 0;
6225 if (!dim || e->rank == 1)
6226 {
6227 result = simplify_transformation_to_scalar (result, e, NULL__null,
6228 norm2_add_squared);
6229 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN);
6230 if (norm2_scale && mpfr_regular_p (result->value.real)((result->value.real)->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
)
6231 {
6232 mpfr_t tmp;
6233 mpfr_init (tmp);
6234 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN);
6235 mpfr_set_exp (tmp, norm2_scale);
6236 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN);
6237 mpfr_clear (tmp);
6238 }
6239 norm2_scale = 0;
6240 }
6241 else
6242 result = simplify_transformation_to_array (result, e, dim, NULL__null,
6243 norm2_add_squared,
6244 norm2_do_sqrt);
6245
6246 return result;
6247}
6248
6249
6250gfc_expr *
6251gfc_simplify_not (gfc_expr *e)
6252{
6253 gfc_expr *result;
6254
6255 if (e->expr_type != EXPR_CONSTANT)
6256 return NULL__null;
6257
6258 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6259 mpz_com__gmpz_com (result->value.integer, e->value.integer);
6260
6261 return range_check (result, "NOT");
6262}
6263
6264
6265gfc_expr *
6266gfc_simplify_null (gfc_expr *mold)
6267{
6268 gfc_expr *result;
6269
6270 if (mold)
6271 {
6272 result = gfc_copy_expr (mold);
6273 result->expr_type = EXPR_NULL;
6274 }
6275 else
6276 result = gfc_get_null_expr (NULL__null);
6277
6278 return result;
6279}
6280
6281
6282gfc_expr *
6283gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED__attribute__ ((__unused__)), gfc_expr *failed)
6284{
6285 gfc_expr *result;
6286
6287 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
6288 {
6289 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6290 return &gfc_bad_expr;
6291 }
6292
6293 if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_SINGLE)
6294 return NULL__null;
6295
6296 if (failed && failed->expr_type != EXPR_CONSTANT)
6297 return NULL__null;
6298
6299 /* FIXME: gfc_current_locus is wrong. */
6300 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6301 &gfc_current_locus);
6302
6303 if (failed && failed->value.logical != 0)
6304 mpz_set_si__gmpz_set_si (result->value.integer, 0);
6305 else
6306 mpz_set_si__gmpz_set_si (result->value.integer, 1);
6307
6308 return result;
6309}
6310
6311
6312gfc_expr *
6313gfc_simplify_or (gfc_expr *x, gfc_expr *y)
6314{
6315 gfc_expr *result;
6316 int kind;
6317
6318 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6319 return NULL__null;
6320
6321 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6322
6323 switch (x->ts.type)
6324 {
6325 case BT_INTEGER:
6326 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6327 mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer);
6328 return range_check (result, "OR");
6329
6330 case BT_LOGICAL:
6331 return gfc_get_logical_expr (kind, &x->where,
6332 x->value.logical || y->value.logical);
6333 default:
6334 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6334, __FUNCTION__))
;
6335 }
6336}
6337
6338
6339gfc_expr *
6340gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
6341{
6342 gfc_expr *result;
6343 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
6344
6345 if (!is_constant_array_expr (array)
6346 || !is_constant_array_expr (vector)
6347 || (!gfc_is_constant_expr (mask)
6348 && !is_constant_array_expr (mask)))
6349 return NULL__null;
6350
6351 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
6352 if (array->ts.type == BT_DERIVED)
6353 result->ts.u.derived = array->ts.u.derived;
6354
6355 array_ctor = gfc_constructor_first (array->value.constructor);
6356 vector_ctor = vector
6357 ? gfc_constructor_first (vector->value.constructor)
6358 : NULL__null;
6359
6360 if (mask->expr_type == EXPR_CONSTANT
6361 && mask->value.logical)
6362 {
6363 /* Copy all elements of ARRAY to RESULT. */
6364 while (array_ctor)
6365 {
6366 gfc_constructor_append_expr (&result->value.constructor,
6367 gfc_copy_expr (array_ctor->expr),
6368 NULL__null);
6369
6370 array_ctor = gfc_constructor_next (array_ctor);
6371 vector_ctor = gfc_constructor_next (vector_ctor);
6372 }
6373 }
6374 else if (mask->expr_type == EXPR_ARRAY)
6375 {
6376 /* Copy only those elements of ARRAY to RESULT whose
6377 MASK equals .TRUE.. */
6378 mask_ctor = gfc_constructor_first (mask->value.constructor);
6379 while (mask_ctor)
6380 {
6381 if (mask_ctor->expr->value.logical)
6382 {
6383 gfc_constructor_append_expr (&result->value.constructor,
6384 gfc_copy_expr (array_ctor->expr),
6385 NULL__null);
6386 vector_ctor = gfc_constructor_next (vector_ctor);
6387 }
6388
6389 array_ctor = gfc_constructor_next (array_ctor);
6390 mask_ctor = gfc_constructor_next (mask_ctor);
6391 }
6392 }
6393
6394 /* Append any left-over elements from VECTOR to RESULT. */
6395 while (vector_ctor)
6396 {
6397 gfc_constructor_append_expr (&result->value.constructor,
6398 gfc_copy_expr (vector_ctor->expr),
6399 NULL__null);
6400 vector_ctor = gfc_constructor_next (vector_ctor);
6401 }
6402
6403 result->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
6404 gfc_array_size (result, &result->shape[0]);
6405
6406 if (array->ts.type == BT_CHARACTER)
6407 result->ts.u.cl = array->ts.u.cl;
6408
6409 return result;
6410}
6411
6412
6413static gfc_expr *
6414do_xor (gfc_expr *result, gfc_expr *e)
6415{
6416 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"
, 6416, __FUNCTION__), 0 : 0))
;
6417 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"
, 6418, __FUNCTION__), 0 : 0))
6418 && 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"
, 6418, __FUNCTION__), 0 : 0))
;
6419
6420 result->value.logical = result->value.logical != e->value.logical;
6421 return result;
6422}
6423
6424
6425gfc_expr *
6426gfc_simplify_is_contiguous (gfc_expr *array)
6427{
6428 if (gfc_is_simply_contiguous (array, false, true))
6429 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
6430
6431 if (gfc_is_not_contiguous (array))
6432 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
6433
6434 return NULL__null;
6435}
6436
6437
6438gfc_expr *
6439gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
6440{
6441 return simplify_transformation (e, dim, NULL__null, 0, do_xor);
6442}
6443
6444
6445gfc_expr *
6446gfc_simplify_popcnt (gfc_expr *e)
6447{
6448 int res, k;
6449 mpz_t x;
6450
6451 if (e->expr_type != EXPR_CONSTANT)
6452 return NULL__null;
6453
6454 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6455
6456 /* Convert argument to unsigned, then count the '1' bits. */
6457 mpz_init_set__gmpz_init_set (x, e->value.integer);
6458 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
6459 res = mpz_popcount__gmpz_popcount (x);
6460 mpz_clear__gmpz_clear (x);
6461
6462 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6463}
6464
6465
6466gfc_expr *
6467gfc_simplify_poppar (gfc_expr *e)
6468{
6469 gfc_expr *popcnt;
6470 int i;
6471
6472 if (e->expr_type != EXPR_CONSTANT)
6473 return NULL__null;
6474
6475 popcnt = gfc_simplify_popcnt (e);
6476 gcc_assert (popcnt)((void)(!(popcnt) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6476, __FUNCTION__), 0 : 0))
;
6477
6478 bool fail = gfc_extract_int (popcnt, &i);
6479 gcc_assert (!fail)((void)(!(!fail) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6479, __FUNCTION__), 0 : 0))
;
6480
6481 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
6482}
6483
6484
6485gfc_expr *
6486gfc_simplify_precision (gfc_expr *e)
6487{
6488 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6489 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6490 gfc_real_kinds[i].precision);
6491}
6492
6493
6494gfc_expr *
6495gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6496{
6497 return simplify_transformation (array, dim, mask, 1, gfc_multiply);
6498}
6499
6500
6501gfc_expr *
6502gfc_simplify_radix (gfc_expr *e)
6503{
6504 int i;
6505 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6506
6507 switch (e->ts.type)
6508 {
6509 case BT_INTEGER:
6510 i = gfc_integer_kinds[i].radix;
6511 break;
6512
6513 case BT_REAL:
6514 i = gfc_real_kinds[i].radix;
6515 break;
6516
6517 default:
6518 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6518, __FUNCTION__))
;
6519 }
6520
6521 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6522}
6523
6524
6525gfc_expr *
6526gfc_simplify_range (gfc_expr *e)
6527{
6528 int i;
6529 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6530
6531 switch (e->ts.type)
6532 {
6533 case BT_INTEGER:
6534 i = gfc_integer_kinds[i].range;
6535 break;
6536
6537 case BT_REAL:
6538 case BT_COMPLEX:
6539 i = gfc_real_kinds[i].range;
6540 break;
6541
6542 default:
6543 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 6543, __FUNCTION__))
;
6544 }
6545
6546 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6547}
6548
6549
6550gfc_expr *
6551gfc_simplify_rank (gfc_expr *e)
6552{
6553 /* Assumed rank. */
6554 if (e->rank == -1)
6555 return NULL__null;
6556
6557 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
6558}
6559
6560
6561gfc_expr *
6562gfc_simplify_real (gfc_expr *e, gfc_expr *k)
6563{
6564 gfc_expr *result = NULL__null;
6565 int kind, tmp1, tmp2;
6566
6567 /* Convert BOZ to real, and return without range checking. */
6568 if (e->ts.type == BT_BOZ)
6569 {
6570 /* Determine kind for conversion of the BOZ. */
6571 if (k)
6572 gfc_extract_int (k, &kind);
6573 else
6574 kind = gfc_default_real_kind;
6575
6576 if (!gfc_boz2real (e, kind))
6577 return NULL__null;
6578 result = gfc_copy_expr (e);
6579 return result;
6580 }
6581
6582 if (e->ts.type == BT_COMPLEX)
6583 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
6584 else
6585 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
6586
6587 if (kind == -1)
6588 return &gfc_bad_expr;
6589
6590 if (e->expr_type != EXPR_CONSTANT)
6591 return NULL__null;
6592
6593 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6594 warnings. */
6595 tmp1 = warn_conversionglobal_options.x_warn_conversion;
6596 tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
6597 warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;
6598
6599 result = gfc_convert_constant (e, BT_REAL, kind);
6600
6601 warn_conversionglobal_options.x_warn_conversion = tmp1;
6602 warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;
6603
6604 if (result == &gfc_bad_expr)
6605 return &gfc_bad_expr;
6606
6607 return range_check (result, "REAL");
6608}
6609
6610
6611gfc_expr *
6612gfc_simplify_realpart (gfc_expr *e)
6613{
6614 gfc_expr *result;
6615
6616 if (e->expr_type != EXPR_CONSTANT)
6617 return NULL__null;
6618
6619 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6620 mpc_real (result->value.real, e->value.complex, GFC_RND_MODEMPFR_RNDN);
6621
6622 return range_check (result, "REALPART");
6623}
6624
6625gfc_expr *
6626gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
6627{
6628 gfc_expr *result;
6629 gfc_charlen_t len;
6630 mpz_t ncopies;
6631 bool have_length = false;
6632
6633 /* If NCOPIES isn't a constant, there's nothing we can do. */
6634 if (n->expr_type != EXPR_CONSTANT)
6635 return NULL__null;
6636
6637 /* If NCOPIES is negative, it's an error. */
6638 if (mpz_sgn (n->value.integer)((n->value.integer)->_mp_size < 0 ? -1 : (n->value
.integer)->_mp_size > 0)
< 0)
6639 {
6640 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6641 &n->where);