1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2020 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along 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
35 static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false);
36
37 gfc_expr gfc_bad_expr;
38
39 static 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
77 static gfc_expr *
range_check(gfc_expr * result,const char * name)78 range_check (gfc_expr *result, const char *name)
79 {
80 if (result == 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
119 static int
get_kind(bt type,gfc_expr * k,const char * name,int default_kind)120 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
121 {
122 int kind;
123
124 if (k == 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
150 static void
convert_mpz_to_unsigned(mpz_t x,int bitsize)151 convert_mpz_to_unsigned (mpz_t x, int bitsize)
152 {
153 mpz_t mask;
154
155 if (mpz_sgn (x) < 0)
156 {
157 /* Confirm that no bits above the signed range are unset if we
158 are doing range checking. */
159 if (flag_range_check != 0)
160 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
161
162 mpz_init_set_ui (mask, 1);
163 mpz_mul_2exp (mask, mask, bitsize);
164 mpz_sub_ui (mask, mask, 1);
165
166 mpz_and (x, x, mask);
167
168 mpz_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_check != 0)
175 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
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
185 void
gfc_convert_mpz_to_signed(mpz_t x,int bitsize)186 gfc_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_check != 0)
193 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
194
195 if (mpz_tstbit (x, bitsize - 1) == 1)
196 {
197 mpz_init_set_ui (mask, 1);
198 mpz_mul_2exp (mask, mask, bitsize);
199 mpz_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 (x, x);
206 mpz_add_ui (x, x, 1);
207 mpz_and (x, x, mask);
208
209 mpz_neg (x, x);
210
211 mpz_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
219 static bool
is_constant_array_expr(gfc_expr * e)220 is_constant_array_expr (gfc_expr *e)
221 {
222 gfc_constructor *c;
223
224 if (e == NULL)
225 return true;
226
227 if (e->expr_type == EXPR_VARIABLE && e->rank > 0
228 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
229 gfc_simplify_expr (e, 1);
230
231 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
232 return false;
233
234 for (c = gfc_constructor_first (e->value.constructor);
235 c; c = gfc_constructor_next (c))
236 if (c->expr->expr_type != EXPR_CONSTANT
237 && c->expr->expr_type != EXPR_STRUCTURE)
238 return false;
239
240 return true;
241 }
242
243 /* Test for a size zero array. */
244 bool
gfc_is_size_zero_array(gfc_expr * array)245 gfc_is_size_zero_array (gfc_expr *array)
246 {
247
248 if (array->rank == 0)
249 return false;
250
251 if (array->expr_type == EXPR_VARIABLE && array->rank > 0
252 && array->symtree->n.sym->attr.flavor == FL_PARAMETER
253 && array->shape != NULL)
254 {
255 for (int i = 0; i < array->rank; i++)
256 if (mpz_cmp_si (array->shape[i], 0) <= 0)
257 return true;
258
259 return false;
260 }
261
262 if (array->expr_type == EXPR_ARRAY)
263 return array->value.constructor == NULL;
264
265 return false;
266 }
267
268
269 /* Initialize a transformational result expression with a given value. */
270
271 static void
init_result_expr(gfc_expr * e,int init,gfc_expr * array)272 init_result_expr (gfc_expr *e, int init, gfc_expr *array)
273 {
274 if (e && e->expr_type == EXPR_ARRAY)
275 {
276 gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
277 while (ctor)
278 {
279 init_result_expr (ctor->expr, init, array);
280 ctor = gfc_constructor_next (ctor);
281 }
282 }
283 else if (e && e->expr_type == EXPR_CONSTANT)
284 {
285 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
286 HOST_WIDE_INT length;
287 gfc_char_t *string;
288
289 switch (e->ts.type)
290 {
291 case BT_LOGICAL:
292 e->value.logical = (init ? 1 : 0);
293 break;
294
295 case BT_INTEGER:
296 if (init == INT_MIN)
297 mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
298 else if (init == INT_MAX)
299 mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
300 else
301 mpz_set_si (e->value.integer, init);
302 break;
303
304 case BT_REAL:
305 if (init == INT_MIN)
306 {
307 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
308 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
309 }
310 else if (init == INT_MAX)
311 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
312 else
313 mpfr_set_si (e->value.real, init, GFC_RND_MODE);
314 break;
315
316 case BT_COMPLEX:
317 mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
318 break;
319
320 case BT_CHARACTER:
321 if (init == INT_MIN)
322 {
323 gfc_expr *len = gfc_simplify_len (array, NULL);
324 gfc_extract_hwi (len, &length);
325 string = gfc_get_wide_string (length + 1);
326 gfc_wide_memset (string, 0, length);
327 }
328 else if (init == INT_MAX)
329 {
330 gfc_expr *len = gfc_simplify_len (array, NULL);
331 gfc_extract_hwi (len, &length);
332 string = gfc_get_wide_string (length + 1);
333 gfc_wide_memset (string, 255, length);
334 }
335 else
336 {
337 length = 0;
338 string = gfc_get_wide_string (1);
339 }
340
341 string[length] = '\0';
342 e->value.character.length = length;
343 e->value.character.string = string;
344 break;
345
346 default:
347 gcc_unreachable();
348 }
349 }
350 else
351 gcc_unreachable();
352 }
353
354
355 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
356 if conj_a is true, the matrix_a is complex conjugated. */
357
358 static gfc_expr *
compute_dot_product(gfc_expr * matrix_a,int stride_a,int offset_a,gfc_expr * matrix_b,int stride_b,int offset_b,bool conj_a)359 compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
360 gfc_expr *matrix_b, int stride_b, int offset_b,
361 bool conj_a)
362 {
363 gfc_expr *result, *a, *b, *c;
364
365 /* Set result to an INTEGER(1) 0 for numeric types and .false. for
366 LOGICAL. Mixed-mode math in the loop will promote result to the
367 correct type and kind. */
368 if (matrix_a->ts.type == BT_LOGICAL)
369 result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
370 else
371 result = gfc_get_int_expr (1, NULL, 0);
372 result->where = matrix_a->where;
373
374 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
375 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
376 while (a && b)
377 {
378 /* Copying of expressions is required as operands are free'd
379 by the gfc_arith routines. */
380 switch (result->ts.type)
381 {
382 case BT_LOGICAL:
383 result = gfc_or (result,
384 gfc_and (gfc_copy_expr (a),
385 gfc_copy_expr (b)));
386 break;
387
388 case BT_INTEGER:
389 case BT_REAL:
390 case BT_COMPLEX:
391 if (conj_a && a->ts.type == BT_COMPLEX)
392 c = gfc_simplify_conjg (a);
393 else
394 c = gfc_copy_expr (a);
395 result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
396 break;
397
398 default:
399 gcc_unreachable();
400 }
401
402 offset_a += stride_a;
403 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
404
405 offset_b += stride_b;
406 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
407 }
408
409 return result;
410 }
411
412
413 /* Build a result expression for transformational intrinsics,
414 depending on DIM. */
415
416 static gfc_expr *
transformational_result(gfc_expr * array,gfc_expr * dim,bt type,int kind,locus * where)417 transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
418 int kind, locus* where)
419 {
420 gfc_expr *result;
421 int i, nelem;
422
423 if (!dim || array->rank == 1)
424 return gfc_get_constant_expr (type, kind, where);
425
426 result = gfc_get_array_expr (type, kind, where);
427 result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
428 result->rank = array->rank - 1;
429
430 /* gfc_array_size() would count the number of elements in the constructor,
431 we have not built those yet. */
432 nelem = 1;
433 for (i = 0; i < result->rank; ++i)
434 nelem *= mpz_get_ui (result->shape[i]);
435
436 for (i = 0; i < nelem; ++i)
437 {
438 gfc_constructor_append_expr (&result->value.constructor,
439 gfc_get_constant_expr (type, kind, where),
440 NULL);
441 }
442
443 return result;
444 }
445
446
447 typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
448
449 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
450 of COUNT intrinsic is .TRUE..
451
452 Interface and implementation mimics arith functions as
453 gfc_add, gfc_multiply, etc. */
454
455 static gfc_expr *
gfc_count(gfc_expr * op1,gfc_expr * op2)456 gfc_count (gfc_expr *op1, gfc_expr *op2)
457 {
458 gfc_expr *result;
459
460 gcc_assert (op1->ts.type == BT_INTEGER);
461 gcc_assert (op2->ts.type == BT_LOGICAL);
462 gcc_assert (op2->value.logical);
463
464 result = gfc_copy_expr (op1);
465 mpz_add_ui (result->value.integer, result->value.integer, 1);
466
467 gfc_free_expr (op1);
468 gfc_free_expr (op2);
469 return result;
470 }
471
472
473 /* Transforms an ARRAY with operation OP, according to MASK, to a
474 scalar RESULT. E.g. called if
475
476 REAL, PARAMETER :: array(n, m) = ...
477 REAL, PARAMETER :: s = SUM(array)
478
479 where OP == gfc_add(). */
480
481 static gfc_expr *
simplify_transformation_to_scalar(gfc_expr * result,gfc_expr * array,gfc_expr * mask,transformational_op op)482 simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
483 transformational_op op)
484 {
485 gfc_expr *a, *m;
486 gfc_constructor *array_ctor, *mask_ctor;
487
488 /* Shortcut for constant .FALSE. MASK. */
489 if (mask
490 && mask->expr_type == EXPR_CONSTANT
491 && !mask->value.logical)
492 return result;
493
494 array_ctor = gfc_constructor_first (array->value.constructor);
495 mask_ctor = NULL;
496 if (mask && mask->expr_type == EXPR_ARRAY)
497 mask_ctor = gfc_constructor_first (mask->value.constructor);
498
499 while (array_ctor)
500 {
501 a = array_ctor->expr;
502 array_ctor = gfc_constructor_next (array_ctor);
503
504 /* A constant MASK equals .TRUE. here and can be ignored. */
505 if (mask_ctor)
506 {
507 m = mask_ctor->expr;
508 mask_ctor = gfc_constructor_next (mask_ctor);
509 if (!m->value.logical)
510 continue;
511 }
512
513 result = op (result, gfc_copy_expr (a));
514 if (!result)
515 return result;
516 }
517
518 return result;
519 }
520
521 /* Transforms an ARRAY with operation OP, according to MASK, to an
522 array RESULT. E.g. called if
523
524 REAL, PARAMETER :: array(n, m) = ...
525 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
526
527 where OP == gfc_multiply().
528 The result might be post processed using post_op. */
529
530 static gfc_expr *
simplify_transformation_to_array(gfc_expr * result,gfc_expr * array,gfc_expr * dim,gfc_expr * mask,transformational_op op,transformational_op post_op)531 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
532 gfc_expr *mask, transformational_op op,
533 transformational_op post_op)
534 {
535 mpz_t size;
536 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
537 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
538 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
539
540 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
541 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
542 tmpstride[GFC_MAX_DIMENSIONS];
543
544 /* Shortcut for constant .FALSE. MASK. */
545 if (mask
546 && mask->expr_type == EXPR_CONSTANT
547 && !mask->value.logical)
548 return result;
549
550 /* Build an indexed table for array element expressions to minimize
551 linked-list traversal. Masked elements are set to NULL. */
552 gfc_array_size (array, &size);
553 arraysize = mpz_get_ui (size);
554 mpz_clear (size);
555
556 arrayvec = XCNEWVEC (gfc_expr*, arraysize);
557
558 array_ctor = gfc_constructor_first (array->value.constructor);
559 mask_ctor = NULL;
560 if (mask && mask->expr_type == EXPR_ARRAY)
561 mask_ctor = gfc_constructor_first (mask->value.constructor);
562
563 for (i = 0; i < arraysize; ++i)
564 {
565 arrayvec[i] = array_ctor->expr;
566 array_ctor = gfc_constructor_next (array_ctor);
567
568 if (mask_ctor)
569 {
570 if (!mask_ctor->expr->value.logical)
571 arrayvec[i] = NULL;
572
573 mask_ctor = gfc_constructor_next (mask_ctor);
574 }
575 }
576
577 /* Same for the result expression. */
578 gfc_array_size (result, &size);
579 resultsize = mpz_get_ui (size);
580 mpz_clear (size);
581
582 resultvec = XCNEWVEC (gfc_expr*, resultsize);
583 result_ctor = gfc_constructor_first (result->value.constructor);
584 for (i = 0; i < resultsize; ++i)
585 {
586 resultvec[i] = result_ctor->expr;
587 result_ctor = gfc_constructor_next (result_ctor);
588 }
589
590 gfc_extract_int (dim, &dim_index);
591 dim_index -= 1; /* zero-base index */
592 dim_extent = 0;
593 dim_stride = 0;
594
595 for (i = 0, n = 0; i < array->rank; ++i)
596 {
597 count[i] = 0;
598 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
599 if (i == dim_index)
600 {
601 dim_extent = mpz_get_si (array->shape[i]);
602 dim_stride = tmpstride[i];
603 continue;
604 }
605
606 extent[n] = mpz_get_si (array->shape[i]);
607 sstride[n] = tmpstride[i];
608 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
609 n += 1;
610 }
611
612 done = resultsize <= 0;
613 base = arrayvec;
614 dest = resultvec;
615 while (!done)
616 {
617 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
618 if (*src)
619 *dest = op (*dest, gfc_copy_expr (*src));
620
621 if (post_op)
622 *dest = post_op (*dest, *dest);
623
624 count[0]++;
625 base += sstride[0];
626 dest += dstride[0];
627
628 n = 0;
629 while (!done && count[n] == extent[n])
630 {
631 count[n] = 0;
632 base -= sstride[n] * extent[n];
633 dest -= dstride[n] * extent[n];
634
635 n++;
636 if (n < result->rank)
637 {
638 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
639 times, we'd warn for the last iteration, because the
640 array index will have already been incremented to the
641 array sizes, and we can't tell that this must make
642 the test against result->rank false, because ranks
643 must not exceed GFC_MAX_DIMENSIONS. */
644 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
645 count[n]++;
646 base += sstride[n];
647 dest += dstride[n];
648 GCC_DIAGNOSTIC_POP
649 }
650 else
651 done = true;
652 }
653 }
654
655 /* Place updated expression in result constructor. */
656 result_ctor = gfc_constructor_first (result->value.constructor);
657 for (i = 0; i < resultsize; ++i)
658 {
659 result_ctor->expr = resultvec[i];
660 result_ctor = gfc_constructor_next (result_ctor);
661 }
662
663 free (arrayvec);
664 free (resultvec);
665 return result;
666 }
667
668
669 static gfc_expr *
simplify_transformation(gfc_expr * array,gfc_expr * dim,gfc_expr * mask,int init_val,transformational_op op)670 simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
671 int init_val, transformational_op op)
672 {
673 gfc_expr *result;
674 bool size_zero;
675
676 size_zero = gfc_is_size_zero_array (array);
677
678 if (!(is_constant_array_expr (array) || size_zero)
679 || array->shape == NULL
680 || !gfc_is_constant_expr (dim))
681 return NULL;
682
683 if (mask
684 && !is_constant_array_expr (mask)
685 && mask->expr_type != EXPR_CONSTANT)
686 return NULL;
687
688 result = transformational_result (array, dim, array->ts.type,
689 array->ts.kind, &array->where);
690 init_result_expr (result, init_val, array);
691
692 if (size_zero)
693 return result;
694
695 return !dim || array->rank == 1 ?
696 simplify_transformation_to_scalar (result, array, mask, op) :
697 simplify_transformation_to_array (result, array, dim, mask, op, NULL);
698 }
699
700
701 /********************** Simplification functions *****************************/
702
703 gfc_expr *
gfc_simplify_abs(gfc_expr * e)704 gfc_simplify_abs (gfc_expr *e)
705 {
706 gfc_expr *result;
707
708 if (e->expr_type != EXPR_CONSTANT)
709 return NULL;
710
711 switch (e->ts.type)
712 {
713 case BT_INTEGER:
714 result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
715 mpz_abs (result->value.integer, e->value.integer);
716 return range_check (result, "IABS");
717
718 case BT_REAL:
719 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
720 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
721 return range_check (result, "ABS");
722
723 case BT_COMPLEX:
724 gfc_set_model_kind (e->ts.kind);
725 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
726 mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
727 return range_check (result, "CABS");
728
729 default:
730 gfc_internal_error ("gfc_simplify_abs(): Bad type");
731 }
732 }
733
734
735 static gfc_expr *
simplify_achar_char(gfc_expr * e,gfc_expr * k,const char * name,bool ascii)736 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
737 {
738 gfc_expr *result;
739 int kind;
740 bool too_large = false;
741
742 if (e->expr_type != EXPR_CONSTANT)
743 return NULL;
744
745 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
746 if (kind == -1)
747 return &gfc_bad_expr;
748
749 if (mpz_cmp_si (e->value.integer, 0) < 0)
750 {
751 gfc_error ("Argument of %s function at %L is negative", name,
752 &e->where);
753 return &gfc_bad_expr;
754 }
755
756 if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0)
757 gfc_warning (OPT_Wsurprising,
758 "Argument of %s function at %L outside of range [0,127]",
759 name, &e->where);
760
761 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
762 too_large = true;
763 else if (kind == 4)
764 {
765 mpz_t t;
766 mpz_init_set_ui (t, 2);
767 mpz_pow_ui (t, t, 32);
768 mpz_sub_ui (t, t, 1);
769 if (mpz_cmp (e->value.integer, t) > 0)
770 too_large = true;
771 mpz_clear (t);
772 }
773
774 if (too_large)
775 {
776 gfc_error ("Argument of %s function at %L is too large for the "
777 "collating sequence of kind %d", name, &e->where, kind);
778 return &gfc_bad_expr;
779 }
780
781 result = gfc_get_character_expr (kind, &e->where, NULL, 1);
782 result->value.character.string[0] = mpz_get_ui (e->value.integer);
783
784 return result;
785 }
786
787
788
789 /* We use the processor's collating sequence, because all
790 systems that gfortran currently works on are ASCII. */
791
792 gfc_expr *
gfc_simplify_achar(gfc_expr * e,gfc_expr * k)793 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
794 {
795 return simplify_achar_char (e, k, "ACHAR", true);
796 }
797
798
799 gfc_expr *
gfc_simplify_acos(gfc_expr * x)800 gfc_simplify_acos (gfc_expr *x)
801 {
802 gfc_expr *result;
803
804 if (x->expr_type != EXPR_CONSTANT)
805 return NULL;
806
807 switch (x->ts.type)
808 {
809 case BT_REAL:
810 if (mpfr_cmp_si (x->value.real, 1) > 0
811 || mpfr_cmp_si (x->value.real, -1) < 0)
812 {
813 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
814 &x->where);
815 return &gfc_bad_expr;
816 }
817 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
818 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
819 break;
820
821 case BT_COMPLEX:
822 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
823 mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
824 break;
825
826 default:
827 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
828 }
829
830 return range_check (result, "ACOS");
831 }
832
833 gfc_expr *
gfc_simplify_acosh(gfc_expr * x)834 gfc_simplify_acosh (gfc_expr *x)
835 {
836 gfc_expr *result;
837
838 if (x->expr_type != EXPR_CONSTANT)
839 return NULL;
840
841 switch (x->ts.type)
842 {
843 case BT_REAL:
844 if (mpfr_cmp_si (x->value.real, 1) < 0)
845 {
846 gfc_error ("Argument of ACOSH at %L must not be less than 1",
847 &x->where);
848 return &gfc_bad_expr;
849 }
850
851 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
852 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
853 break;
854
855 case BT_COMPLEX:
856 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
857 mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
858 break;
859
860 default:
861 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
862 }
863
864 return range_check (result, "ACOSH");
865 }
866
867 gfc_expr *
gfc_simplify_adjustl(gfc_expr * e)868 gfc_simplify_adjustl (gfc_expr *e)
869 {
870 gfc_expr *result;
871 int count, i, len;
872 gfc_char_t ch;
873
874 if (e->expr_type != EXPR_CONSTANT)
875 return NULL;
876
877 len = e->value.character.length;
878
879 for (count = 0, i = 0; i < len; ++i)
880 {
881 ch = e->value.character.string[i];
882 if (ch != ' ')
883 break;
884 ++count;
885 }
886
887 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
888 for (i = 0; i < len - count; ++i)
889 result->value.character.string[i] = e->value.character.string[count + i];
890
891 return result;
892 }
893
894
895 gfc_expr *
gfc_simplify_adjustr(gfc_expr * e)896 gfc_simplify_adjustr (gfc_expr *e)
897 {
898 gfc_expr *result;
899 int count, i, len;
900 gfc_char_t ch;
901
902 if (e->expr_type != EXPR_CONSTANT)
903 return NULL;
904
905 len = e->value.character.length;
906
907 for (count = 0, i = len - 1; i >= 0; --i)
908 {
909 ch = e->value.character.string[i];
910 if (ch != ' ')
911 break;
912 ++count;
913 }
914
915 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
916 for (i = 0; i < count; ++i)
917 result->value.character.string[i] = ' ';
918
919 for (i = count; i < len; ++i)
920 result->value.character.string[i] = e->value.character.string[i - count];
921
922 return result;
923 }
924
925
926 gfc_expr *
gfc_simplify_aimag(gfc_expr * e)927 gfc_simplify_aimag (gfc_expr *e)
928 {
929 gfc_expr *result;
930
931 if (e->expr_type != EXPR_CONSTANT)
932 return NULL;
933
934 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
935 mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
936
937 return range_check (result, "AIMAG");
938 }
939
940
941 gfc_expr *
gfc_simplify_aint(gfc_expr * e,gfc_expr * k)942 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
943 {
944 gfc_expr *rtrunc, *result;
945 int kind;
946
947 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
948 if (kind == -1)
949 return &gfc_bad_expr;
950
951 if (e->expr_type != EXPR_CONSTANT)
952 return NULL;
953
954 rtrunc = gfc_copy_expr (e);
955 mpfr_trunc (rtrunc->value.real, e->value.real);
956
957 result = gfc_real2real (rtrunc, kind);
958
959 gfc_free_expr (rtrunc);
960
961 return range_check (result, "AINT");
962 }
963
964
965 gfc_expr *
gfc_simplify_all(gfc_expr * mask,gfc_expr * dim)966 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
967 {
968 return simplify_transformation (mask, dim, NULL, true, gfc_and);
969 }
970
971
972 gfc_expr *
gfc_simplify_dint(gfc_expr * e)973 gfc_simplify_dint (gfc_expr *e)
974 {
975 gfc_expr *rtrunc, *result;
976
977 if (e->expr_type != EXPR_CONSTANT)
978 return NULL;
979
980 rtrunc = gfc_copy_expr (e);
981 mpfr_trunc (rtrunc->value.real, e->value.real);
982
983 result = gfc_real2real (rtrunc, gfc_default_double_kind);
984
985 gfc_free_expr (rtrunc);
986
987 return range_check (result, "DINT");
988 }
989
990
991 gfc_expr *
gfc_simplify_dreal(gfc_expr * e)992 gfc_simplify_dreal (gfc_expr *e)
993 {
994 gfc_expr *result = NULL;
995
996 if (e->expr_type != EXPR_CONSTANT)
997 return NULL;
998
999 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1000 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
1001
1002 return range_check (result, "DREAL");
1003 }
1004
1005
1006 gfc_expr *
gfc_simplify_anint(gfc_expr * e,gfc_expr * k)1007 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
1008 {
1009 gfc_expr *result;
1010 int kind;
1011
1012 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
1013 if (kind == -1)
1014 return &gfc_bad_expr;
1015
1016 if (e->expr_type != EXPR_CONSTANT)
1017 return NULL;
1018
1019 result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
1020 mpfr_round (result->value.real, e->value.real);
1021
1022 return range_check (result, "ANINT");
1023 }
1024
1025
1026 gfc_expr *
gfc_simplify_and(gfc_expr * x,gfc_expr * y)1027 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
1028 {
1029 gfc_expr *result;
1030 int kind;
1031
1032 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1033 return NULL;
1034
1035 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1036
1037 switch (x->ts.type)
1038 {
1039 case BT_INTEGER:
1040 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
1041 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1042 return range_check (result, "AND");
1043
1044 case BT_LOGICAL:
1045 return gfc_get_logical_expr (kind, &x->where,
1046 x->value.logical && y->value.logical);
1047
1048 default:
1049 gcc_unreachable ();
1050 }
1051 }
1052
1053
1054 gfc_expr *
gfc_simplify_any(gfc_expr * mask,gfc_expr * dim)1055 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1056 {
1057 return simplify_transformation (mask, dim, NULL, false, gfc_or);
1058 }
1059
1060
1061 gfc_expr *
gfc_simplify_dnint(gfc_expr * e)1062 gfc_simplify_dnint (gfc_expr *e)
1063 {
1064 gfc_expr *result;
1065
1066 if (e->expr_type != EXPR_CONSTANT)
1067 return NULL;
1068
1069 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
1070 mpfr_round (result->value.real, e->value.real);
1071
1072 return range_check (result, "DNINT");
1073 }
1074
1075
1076 gfc_expr *
gfc_simplify_asin(gfc_expr * x)1077 gfc_simplify_asin (gfc_expr *x)
1078 {
1079 gfc_expr *result;
1080
1081 if (x->expr_type != EXPR_CONSTANT)
1082 return NULL;
1083
1084 switch (x->ts.type)
1085 {
1086 case BT_REAL:
1087 if (mpfr_cmp_si (x->value.real, 1) > 0
1088 || mpfr_cmp_si (x->value.real, -1) < 0)
1089 {
1090 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1091 &x->where);
1092 return &gfc_bad_expr;
1093 }
1094 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1095 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1096 break;
1097
1098 case BT_COMPLEX:
1099 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1100 mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1101 break;
1102
1103 default:
1104 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1105 }
1106
1107 return range_check (result, "ASIN");
1108 }
1109
1110
1111 /* Convert radians to degrees, i.e., x * 180 / pi. */
1112
1113 static void
rad2deg(mpfr_t x)1114 rad2deg (mpfr_t x)
1115 {
1116 mpfr_t tmp;
1117
1118 mpfr_init (tmp);
1119 mpfr_const_pi (tmp, GFC_RND_MODE);
1120 mpfr_mul_ui (x, x, 180, GFC_RND_MODE);
1121 mpfr_div (x, x, tmp, GFC_RND_MODE);
1122 mpfr_clear (tmp);
1123 }
1124
1125
1126 /* Simplify ACOSD(X) where the returned value has units of degree. */
1127
1128 gfc_expr *
gfc_simplify_acosd(gfc_expr * x)1129 gfc_simplify_acosd (gfc_expr *x)
1130 {
1131 gfc_expr *result;
1132
1133 if (x->expr_type != EXPR_CONSTANT)
1134 return NULL;
1135
1136 if (mpfr_cmp_si (x->value.real, 1) > 0
1137 || mpfr_cmp_si (x->value.real, -1) < 0)
1138 {
1139 gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
1140 &x->where);
1141 return &gfc_bad_expr;
1142 }
1143
1144 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1145 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
1146 rad2deg (result->value.real);
1147
1148 return range_check (result, "ACOSD");
1149 }
1150
1151
1152 /* Simplify asind (x) where the returned value has units of degree. */
1153
1154 gfc_expr *
gfc_simplify_asind(gfc_expr * x)1155 gfc_simplify_asind (gfc_expr *x)
1156 {
1157 gfc_expr *result;
1158
1159 if (x->expr_type != EXPR_CONSTANT)
1160 return NULL;
1161
1162 if (mpfr_cmp_si (x->value.real, 1) > 0
1163 || mpfr_cmp_si (x->value.real, -1) < 0)
1164 {
1165 gfc_error ("Argument of ASIND at %L must be between -1 and 1",
1166 &x->where);
1167 return &gfc_bad_expr;
1168 }
1169
1170 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1171 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1172 rad2deg (result->value.real);
1173
1174 return range_check (result, "ASIND");
1175 }
1176
1177
1178 /* Simplify atand (x) where the returned value has units of degree. */
1179
1180 gfc_expr *
gfc_simplify_atand(gfc_expr * x)1181 gfc_simplify_atand (gfc_expr *x)
1182 {
1183 gfc_expr *result;
1184
1185 if (x->expr_type != EXPR_CONSTANT)
1186 return NULL;
1187
1188 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1189 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1190 rad2deg (result->value.real);
1191
1192 return range_check (result, "ATAND");
1193 }
1194
1195
1196 gfc_expr *
gfc_simplify_asinh(gfc_expr * x)1197 gfc_simplify_asinh (gfc_expr *x)
1198 {
1199 gfc_expr *result;
1200
1201 if (x->expr_type != EXPR_CONSTANT)
1202 return NULL;
1203
1204 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1205
1206 switch (x->ts.type)
1207 {
1208 case BT_REAL:
1209 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1210 break;
1211
1212 case BT_COMPLEX:
1213 mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1214 break;
1215
1216 default:
1217 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1218 }
1219
1220 return range_check (result, "ASINH");
1221 }
1222
1223
1224 gfc_expr *
gfc_simplify_atan(gfc_expr * x)1225 gfc_simplify_atan (gfc_expr *x)
1226 {
1227 gfc_expr *result;
1228
1229 if (x->expr_type != EXPR_CONSTANT)
1230 return NULL;
1231
1232 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1233
1234 switch (x->ts.type)
1235 {
1236 case BT_REAL:
1237 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1238 break;
1239
1240 case BT_COMPLEX:
1241 mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1242 break;
1243
1244 default:
1245 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1246 }
1247
1248 return range_check (result, "ATAN");
1249 }
1250
1251
1252 gfc_expr *
gfc_simplify_atanh(gfc_expr * x)1253 gfc_simplify_atanh (gfc_expr *x)
1254 {
1255 gfc_expr *result;
1256
1257 if (x->expr_type != EXPR_CONSTANT)
1258 return NULL;
1259
1260 switch (x->ts.type)
1261 {
1262 case BT_REAL:
1263 if (mpfr_cmp_si (x->value.real, 1) >= 0
1264 || mpfr_cmp_si (x->value.real, -1) <= 0)
1265 {
1266 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1267 "to 1", &x->where);
1268 return &gfc_bad_expr;
1269 }
1270 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1271 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1272 break;
1273
1274 case BT_COMPLEX:
1275 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1276 mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1277 break;
1278
1279 default:
1280 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1281 }
1282
1283 return range_check (result, "ATANH");
1284 }
1285
1286
1287 gfc_expr *
gfc_simplify_atan2(gfc_expr * y,gfc_expr * x)1288 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1289 {
1290 gfc_expr *result;
1291
1292 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1293 return NULL;
1294
1295 if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
1296 {
1297 gfc_error ("If first argument of ATAN2 at %L is zero, then the "
1298 "second argument must not be zero", &y->where);
1299 return &gfc_bad_expr;
1300 }
1301
1302 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1303 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1304
1305 return range_check (result, "ATAN2");
1306 }
1307
1308
1309 gfc_expr *
gfc_simplify_bessel_j0(gfc_expr * x)1310 gfc_simplify_bessel_j0 (gfc_expr *x)
1311 {
1312 gfc_expr *result;
1313
1314 if (x->expr_type != EXPR_CONSTANT)
1315 return NULL;
1316
1317 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1318 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1319
1320 return range_check (result, "BESSEL_J0");
1321 }
1322
1323
1324 gfc_expr *
gfc_simplify_bessel_j1(gfc_expr * x)1325 gfc_simplify_bessel_j1 (gfc_expr *x)
1326 {
1327 gfc_expr *result;
1328
1329 if (x->expr_type != EXPR_CONSTANT)
1330 return NULL;
1331
1332 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1333 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1334
1335 return range_check (result, "BESSEL_J1");
1336 }
1337
1338
1339 gfc_expr *
gfc_simplify_bessel_jn(gfc_expr * order,gfc_expr * x)1340 gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1341 {
1342 gfc_expr *result;
1343 long n;
1344
1345 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1346 return NULL;
1347
1348 n = mpz_get_si (order->value.integer);
1349 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1350 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1351
1352 return range_check (result, "BESSEL_JN");
1353 }
1354
1355
1356 /* Simplify transformational form of JN and YN. */
1357
1358 static gfc_expr *
gfc_simplify_bessel_n2(gfc_expr * order1,gfc_expr * order2,gfc_expr * x,bool jn)1359 gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
1360 bool jn)
1361 {
1362 gfc_expr *result;
1363 gfc_expr *e;
1364 long n1, n2;
1365 int i;
1366 mpfr_t x2rev, last1, last2;
1367
1368 if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
1369 || order2->expr_type != EXPR_CONSTANT)
1370 return NULL;
1371
1372 n1 = mpz_get_si (order1->value.integer);
1373 n2 = mpz_get_si (order2->value.integer);
1374 result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
1375 result->rank = 1;
1376 result->shape = gfc_get_shape (1);
1377 mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
1378
1379 if (n2 < n1)
1380 return result;
1381
1382 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1383 YN(N, 0.0) = -Inf. */
1384
1385 if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
1386 {
1387 if (!jn && flag_range_check)
1388 {
1389 gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
1390 gfc_free_expr (result);
1391 return &gfc_bad_expr;
1392 }
1393
1394 if (jn && n1 == 0)
1395 {
1396 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1397 mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
1398 gfc_constructor_append_expr (&result->value.constructor, e,
1399 &x->where);
1400 n1++;
1401 }
1402
1403 for (i = n1; i <= n2; i++)
1404 {
1405 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1406 if (jn)
1407 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
1408 else
1409 mpfr_set_inf (e->value.real, -1);
1410 gfc_constructor_append_expr (&result->value.constructor, e,
1411 &x->where);
1412 }
1413
1414 return result;
1415 }
1416
1417 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1418 are stable for downward recursion and Neumann functions are stable
1419 for upward recursion. It is
1420 x2rev = 2.0/x,
1421 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1422 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1423 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1424
1425 gfc_set_model_kind (x->ts.kind);
1426
1427 /* Get first recursion anchor. */
1428
1429 mpfr_init (last1);
1430 if (jn)
1431 mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
1432 else
1433 mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
1434
1435 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1436 mpfr_set (e->value.real, last1, GFC_RND_MODE);
1437 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1438 {
1439 mpfr_clear (last1);
1440 gfc_free_expr (e);
1441 gfc_free_expr (result);
1442 return &gfc_bad_expr;
1443 }
1444 gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1445
1446 if (n1 == n2)
1447 {
1448 mpfr_clear (last1);
1449 return result;
1450 }
1451
1452 /* Get second recursion anchor. */
1453
1454 mpfr_init (last2);
1455 if (jn)
1456 mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
1457 else
1458 mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
1459
1460 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1461 mpfr_set (e->value.real, last2, GFC_RND_MODE);
1462 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1463 {
1464 mpfr_clear (last1);
1465 mpfr_clear (last2);
1466 gfc_free_expr (e);
1467 gfc_free_expr (result);
1468 return &gfc_bad_expr;
1469 }
1470 if (jn)
1471 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
1472 else
1473 gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1474
1475 if (n1 + 1 == n2)
1476 {
1477 mpfr_clear (last1);
1478 mpfr_clear (last2);
1479 return result;
1480 }
1481
1482 /* Start actual recursion. */
1483
1484 mpfr_init (x2rev);
1485 mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
1486
1487 for (i = 2; i <= n2-n1; i++)
1488 {
1489 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1490
1491 /* Special case: For YN, if the previous N gave -INF, set
1492 also N+1 to -INF. */
1493 if (!jn && !flag_range_check && mpfr_inf_p (last2))
1494 {
1495 mpfr_set_inf (e->value.real, -1);
1496 gfc_constructor_append_expr (&result->value.constructor, e,
1497 &x->where);
1498 continue;
1499 }
1500
1501 mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
1502 GFC_RND_MODE);
1503 mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
1504 mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
1505
1506 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1507 {
1508 /* Range_check frees "e" in that case. */
1509 e = NULL;
1510 goto error;
1511 }
1512
1513 if (jn)
1514 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
1515 -i-1);
1516 else
1517 gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1518
1519 mpfr_set (last1, last2, GFC_RND_MODE);
1520 mpfr_set (last2, e->value.real, GFC_RND_MODE);
1521 }
1522
1523 mpfr_clear (last1);
1524 mpfr_clear (last2);
1525 mpfr_clear (x2rev);
1526 return result;
1527
1528 error:
1529 mpfr_clear (last1);
1530 mpfr_clear (last2);
1531 mpfr_clear (x2rev);
1532 gfc_free_expr (e);
1533 gfc_free_expr (result);
1534 return &gfc_bad_expr;
1535 }
1536
1537
1538 gfc_expr *
gfc_simplify_bessel_jn2(gfc_expr * order1,gfc_expr * order2,gfc_expr * x)1539 gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1540 {
1541 return gfc_simplify_bessel_n2 (order1, order2, x, true);
1542 }
1543
1544
1545 gfc_expr *
gfc_simplify_bessel_y0(gfc_expr * x)1546 gfc_simplify_bessel_y0 (gfc_expr *x)
1547 {
1548 gfc_expr *result;
1549
1550 if (x->expr_type != EXPR_CONSTANT)
1551 return NULL;
1552
1553 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1554 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1555
1556 return range_check (result, "BESSEL_Y0");
1557 }
1558
1559
1560 gfc_expr *
gfc_simplify_bessel_y1(gfc_expr * x)1561 gfc_simplify_bessel_y1 (gfc_expr *x)
1562 {
1563 gfc_expr *result;
1564
1565 if (x->expr_type != EXPR_CONSTANT)
1566 return NULL;
1567
1568 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1569 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1570
1571 return range_check (result, "BESSEL_Y1");
1572 }
1573
1574
1575 gfc_expr *
gfc_simplify_bessel_yn(gfc_expr * order,gfc_expr * x)1576 gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1577 {
1578 gfc_expr *result;
1579 long n;
1580
1581 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1582 return NULL;
1583
1584 n = mpz_get_si (order->value.integer);
1585 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1586 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1587
1588 return range_check (result, "BESSEL_YN");
1589 }
1590
1591
1592 gfc_expr *
gfc_simplify_bessel_yn2(gfc_expr * order1,gfc_expr * order2,gfc_expr * x)1593 gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1594 {
1595 return gfc_simplify_bessel_n2 (order1, order2, x, false);
1596 }
1597
1598
1599 gfc_expr *
gfc_simplify_bit_size(gfc_expr * e)1600 gfc_simplify_bit_size (gfc_expr *e)
1601 {
1602 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1603 return gfc_get_int_expr (e->ts.kind, &e->where,
1604 gfc_integer_kinds[i].bit_size);
1605 }
1606
1607
1608 gfc_expr *
gfc_simplify_btest(gfc_expr * e,gfc_expr * bit)1609 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1610 {
1611 int b;
1612
1613 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1614 return NULL;
1615
1616 if (gfc_extract_int (bit, &b) || b < 0)
1617 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1618
1619 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1620 mpz_tstbit (e->value.integer, b));
1621 }
1622
1623
1624 static int
compare_bitwise(gfc_expr * i,gfc_expr * j)1625 compare_bitwise (gfc_expr *i, gfc_expr *j)
1626 {
1627 mpz_t x, y;
1628 int k, res;
1629
1630 gcc_assert (i->ts.type == BT_INTEGER);
1631 gcc_assert (j->ts.type == BT_INTEGER);
1632
1633 mpz_init_set (x, i->value.integer);
1634 k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
1635 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
1636
1637 mpz_init_set (y, j->value.integer);
1638 k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
1639 convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
1640
1641 res = mpz_cmp (x, y);
1642 mpz_clear (x);
1643 mpz_clear (y);
1644 return res;
1645 }
1646
1647
1648 gfc_expr *
gfc_simplify_bge(gfc_expr * i,gfc_expr * j)1649 gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
1650 {
1651 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1652 return NULL;
1653
1654 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1655 compare_bitwise (i, j) >= 0);
1656 }
1657
1658
1659 gfc_expr *
gfc_simplify_bgt(gfc_expr * i,gfc_expr * j)1660 gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
1661 {
1662 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1663 return NULL;
1664
1665 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1666 compare_bitwise (i, j) > 0);
1667 }
1668
1669
1670 gfc_expr *
gfc_simplify_ble(gfc_expr * i,gfc_expr * j)1671 gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
1672 {
1673 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1674 return NULL;
1675
1676 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1677 compare_bitwise (i, j) <= 0);
1678 }
1679
1680
1681 gfc_expr *
gfc_simplify_blt(gfc_expr * i,gfc_expr * j)1682 gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
1683 {
1684 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1685 return NULL;
1686
1687 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1688 compare_bitwise (i, j) < 0);
1689 }
1690
1691
1692 gfc_expr *
gfc_simplify_ceiling(gfc_expr * e,gfc_expr * k)1693 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1694 {
1695 gfc_expr *ceil, *result;
1696 int kind;
1697
1698 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1699 if (kind == -1)
1700 return &gfc_bad_expr;
1701
1702 if (e->expr_type != EXPR_CONSTANT)
1703 return NULL;
1704
1705 ceil = gfc_copy_expr (e);
1706 mpfr_ceil (ceil->value.real, e->value.real);
1707
1708 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1709 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1710
1711 gfc_free_expr (ceil);
1712
1713 return range_check (result, "CEILING");
1714 }
1715
1716
1717 gfc_expr *
gfc_simplify_char(gfc_expr * e,gfc_expr * k)1718 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1719 {
1720 return simplify_achar_char (e, k, "CHAR", false);
1721 }
1722
1723
1724 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1725
1726 static gfc_expr *
simplify_cmplx(const char * name,gfc_expr * x,gfc_expr * y,int kind)1727 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1728 {
1729 gfc_expr *result;
1730
1731 if (x->expr_type != EXPR_CONSTANT
1732 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1733 return NULL;
1734
1735 result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1736
1737 switch (x->ts.type)
1738 {
1739 case BT_INTEGER:
1740 mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1741 break;
1742
1743 case BT_REAL:
1744 mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1745 break;
1746
1747 case BT_COMPLEX:
1748 mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1749 break;
1750
1751 default:
1752 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1753 }
1754
1755 if (!y)
1756 return range_check (result, name);
1757
1758 switch (y->ts.type)
1759 {
1760 case BT_INTEGER:
1761 mpfr_set_z (mpc_imagref (result->value.complex),
1762 y->value.integer, GFC_RND_MODE);
1763 break;
1764
1765 case BT_REAL:
1766 mpfr_set (mpc_imagref (result->value.complex),
1767 y->value.real, GFC_RND_MODE);
1768 break;
1769
1770 default:
1771 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1772 }
1773
1774 return range_check (result, name);
1775 }
1776
1777
1778 gfc_expr *
gfc_simplify_cmplx(gfc_expr * x,gfc_expr * y,gfc_expr * k)1779 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1780 {
1781 int kind;
1782
1783 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1784 if (kind == -1)
1785 return &gfc_bad_expr;
1786
1787 return simplify_cmplx ("CMPLX", x, y, kind);
1788 }
1789
1790
1791 gfc_expr *
gfc_simplify_complex(gfc_expr * x,gfc_expr * y)1792 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1793 {
1794 int kind;
1795
1796 if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1797 kind = gfc_default_complex_kind;
1798 else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1799 kind = x->ts.kind;
1800 else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1801 kind = y->ts.kind;
1802 else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1803 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1804 else
1805 gcc_unreachable ();
1806
1807 return simplify_cmplx ("COMPLEX", x, y, kind);
1808 }
1809
1810
1811 gfc_expr *
gfc_simplify_conjg(gfc_expr * e)1812 gfc_simplify_conjg (gfc_expr *e)
1813 {
1814 gfc_expr *result;
1815
1816 if (e->expr_type != EXPR_CONSTANT)
1817 return NULL;
1818
1819 result = gfc_copy_expr (e);
1820 mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1821
1822 return range_check (result, "CONJG");
1823 }
1824
1825
1826 /* Simplify atan2d (x) where the unit is degree. */
1827
1828 gfc_expr *
gfc_simplify_atan2d(gfc_expr * y,gfc_expr * x)1829 gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
1830 {
1831 gfc_expr *result;
1832
1833 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1834 return NULL;
1835
1836 if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
1837 {
1838 gfc_error ("If first argument of ATAN2D at %L is zero, then the "
1839 "second argument must not be zero", &y->where);
1840 return &gfc_bad_expr;
1841 }
1842
1843 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1844 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1845 rad2deg (result->value.real);
1846
1847 return range_check (result, "ATAN2D");
1848 }
1849
1850
1851 gfc_expr *
gfc_simplify_cos(gfc_expr * x)1852 gfc_simplify_cos (gfc_expr *x)
1853 {
1854 gfc_expr *result;
1855
1856 if (x->expr_type != EXPR_CONSTANT)
1857 return NULL;
1858
1859 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1860
1861 switch (x->ts.type)
1862 {
1863 case BT_REAL:
1864 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1865 break;
1866
1867 case BT_COMPLEX:
1868 gfc_set_model_kind (x->ts.kind);
1869 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1870 break;
1871
1872 default:
1873 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1874 }
1875
1876 return range_check (result, "COS");
1877 }
1878
1879
1880 static void
deg2rad(mpfr_t x)1881 deg2rad (mpfr_t x)
1882 {
1883 mpfr_t d2r;
1884
1885 mpfr_init (d2r);
1886 mpfr_const_pi (d2r, GFC_RND_MODE);
1887 mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE);
1888 mpfr_mul (x, x, d2r, GFC_RND_MODE);
1889 mpfr_clear (d2r);
1890 }
1891
1892
1893 /* Simplification routines for SIND, COSD, TAND. */
1894 #include "trigd_fe.inc"
1895
1896
1897 /* Simplify COSD(X) where X has the unit of degree. */
1898
1899 gfc_expr *
gfc_simplify_cosd(gfc_expr * x)1900 gfc_simplify_cosd (gfc_expr *x)
1901 {
1902 gfc_expr *result;
1903
1904 if (x->expr_type != EXPR_CONSTANT)
1905 return NULL;
1906
1907 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1908 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1909 simplify_cosd (result->value.real);
1910
1911 return range_check (result, "COSD");
1912 }
1913
1914
1915 /* Simplify SIND(X) where X has the unit of degree. */
1916
1917 gfc_expr *
gfc_simplify_sind(gfc_expr * x)1918 gfc_simplify_sind (gfc_expr *x)
1919 {
1920 gfc_expr *result;
1921
1922 if (x->expr_type != EXPR_CONSTANT)
1923 return NULL;
1924
1925 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1926 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1927 simplify_sind (result->value.real);
1928
1929 return range_check (result, "SIND");
1930 }
1931
1932
1933 /* Simplify TAND(X) where X has the unit of degree. */
1934
1935 gfc_expr *
gfc_simplify_tand(gfc_expr * x)1936 gfc_simplify_tand (gfc_expr *x)
1937 {
1938 gfc_expr *result;
1939
1940 if (x->expr_type != EXPR_CONSTANT)
1941 return NULL;
1942
1943 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1944 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1945 simplify_tand (result->value.real);
1946
1947 return range_check (result, "TAND");
1948 }
1949
1950
1951 /* Simplify COTAND(X) where X has the unit of degree. */
1952
1953 gfc_expr *
gfc_simplify_cotand(gfc_expr * x)1954 gfc_simplify_cotand (gfc_expr *x)
1955 {
1956 gfc_expr *result;
1957
1958 if (x->expr_type != EXPR_CONSTANT)
1959 return NULL;
1960
1961 /* Implement COTAND = -TAND(x+90).
1962 TAND offers correct exact values for multiples of 30 degrees.
1963 This implementation is also compatible with the behavior of some legacy
1964 compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
1965 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1966 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1967 mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE);
1968 simplify_tand (result->value.real);
1969 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
1970
1971 return range_check (result, "COTAND");
1972 }
1973
1974
1975 gfc_expr *
gfc_simplify_cosh(gfc_expr * x)1976 gfc_simplify_cosh (gfc_expr *x)
1977 {
1978 gfc_expr *result;
1979
1980 if (x->expr_type != EXPR_CONSTANT)
1981 return NULL;
1982
1983 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1984
1985 switch (x->ts.type)
1986 {
1987 case BT_REAL:
1988 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1989 break;
1990
1991 case BT_COMPLEX:
1992 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1993 break;
1994
1995 default:
1996 gcc_unreachable ();
1997 }
1998
1999 return range_check (result, "COSH");
2000 }
2001
2002
2003 gfc_expr *
gfc_simplify_count(gfc_expr * mask,gfc_expr * dim,gfc_expr * kind)2004 gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2005 {
2006 gfc_expr *result;
2007 bool size_zero;
2008
2009 size_zero = gfc_is_size_zero_array (mask);
2010
2011 if (!(is_constant_array_expr (mask) || size_zero)
2012 || !gfc_is_constant_expr (dim)
2013 || !gfc_is_constant_expr (kind))
2014 return NULL;
2015
2016 result = transformational_result (mask, dim,
2017 BT_INTEGER,
2018 get_kind (BT_INTEGER, kind, "COUNT",
2019 gfc_default_integer_kind),
2020 &mask->where);
2021
2022 init_result_expr (result, 0, NULL);
2023
2024 if (size_zero)
2025 return result;
2026
2027 /* Passing MASK twice, once as data array, once as mask.
2028 Whenever gfc_count is called, '1' is added to the result. */
2029 return !dim || mask->rank == 1 ?
2030 simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
2031 simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
2032 }
2033
2034 /* Simplification routine for cshift. This works by copying the array
2035 expressions into a one-dimensional array, shuffling the values into another
2036 one-dimensional array and creating the new array expression from this. The
2037 shuffling part is basically taken from the library routine. */
2038
2039 gfc_expr *
gfc_simplify_cshift(gfc_expr * array,gfc_expr * shift,gfc_expr * dim)2040 gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2041 {
2042 gfc_expr *result;
2043 int which;
2044 gfc_expr **arrayvec, **resultvec;
2045 gfc_expr **rptr, **sptr;
2046 mpz_t size;
2047 size_t arraysize, shiftsize, i;
2048 gfc_constructor *array_ctor, *shift_ctor;
2049 ssize_t *shiftvec, *hptr;
2050 ssize_t shift_val, len;
2051 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
2052 hs_ex[GFC_MAX_DIMENSIONS + 1],
2053 hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS],
2054 a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS],
2055 h_extent[GFC_MAX_DIMENSIONS],
2056 ss_ex[GFC_MAX_DIMENSIONS + 1];
2057 ssize_t rsoffset;
2058 int d, n;
2059 bool continue_loop;
2060 gfc_expr **src, **dest;
2061
2062 if (!is_constant_array_expr (array))
2063 return NULL;
2064
2065 if (shift->rank > 0)
2066 gfc_simplify_expr (shift, 1);
2067
2068 if (!gfc_is_constant_expr (shift))
2069 return NULL;
2070
2071 /* Make dim zero-based. */
2072 if (dim)
2073 {
2074 if (!gfc_is_constant_expr (dim))
2075 return NULL;
2076 which = mpz_get_si (dim->value.integer) - 1;
2077 }
2078 else
2079 which = 0;
2080
2081 if (array->shape == NULL)
2082 return NULL;
2083
2084 gfc_array_size (array, &size);
2085 arraysize = mpz_get_ui (size);
2086 mpz_clear (size);
2087
2088 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2089 result->shape = gfc_copy_shape (array->shape, array->rank);
2090 result->rank = array->rank;
2091 result->ts.u.derived = array->ts.u.derived;
2092
2093 if (arraysize == 0)
2094 return result;
2095
2096 arrayvec = XCNEWVEC (gfc_expr *, arraysize);
2097 array_ctor = gfc_constructor_first (array->value.constructor);
2098 for (i = 0; i < arraysize; i++)
2099 {
2100 arrayvec[i] = array_ctor->expr;
2101 array_ctor = gfc_constructor_next (array_ctor);
2102 }
2103
2104 resultvec = XCNEWVEC (gfc_expr *, arraysize);
2105
2106 extent[0] = 1;
2107 count[0] = 0;
2108
2109 for (d=0; d < array->rank; d++)
2110 {
2111 a_extent[d] = mpz_get_si (array->shape[d]);
2112 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2113 }
2114
2115 if (shift->rank > 0)
2116 {
2117 gfc_array_size (shift, &size);
2118 shiftsize = mpz_get_ui (size);
2119 mpz_clear (size);
2120 shiftvec = XCNEWVEC (ssize_t, shiftsize);
2121 shift_ctor = gfc_constructor_first (shift->value.constructor);
2122 for (d = 0; d < shift->rank; d++)
2123 {
2124 h_extent[d] = mpz_get_si (shift->shape[d]);
2125 hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
2126 }
2127 }
2128 else
2129 shiftvec = NULL;
2130
2131 /* Shut up compiler */
2132 len = 1;
2133 rsoffset = 1;
2134
2135 n = 0;
2136 for (d=0; d < array->rank; d++)
2137 {
2138 if (d == which)
2139 {
2140 rsoffset = a_stride[d];
2141 len = a_extent[d];
2142 }
2143 else
2144 {
2145 count[n] = 0;
2146 extent[n] = a_extent[d];
2147 sstride[n] = a_stride[d];
2148 ss_ex[n] = sstride[n] * extent[n];
2149 if (shiftvec)
2150 hs_ex[n] = hstride[n] * extent[n];
2151 n++;
2152 }
2153 }
2154 ss_ex[n] = 0;
2155 hs_ex[n] = 0;
2156
2157 if (shiftvec)
2158 {
2159 for (i = 0; i < shiftsize; i++)
2160 {
2161 ssize_t val;
2162 val = mpz_get_si (shift_ctor->expr->value.integer);
2163 val = val % len;
2164 if (val < 0)
2165 val += len;
2166 shiftvec[i] = val;
2167 shift_ctor = gfc_constructor_next (shift_ctor);
2168 }
2169 shift_val = 0;
2170 }
2171 else
2172 {
2173 shift_val = mpz_get_si (shift->value.integer);
2174 shift_val = shift_val % len;
2175 if (shift_val < 0)
2176 shift_val += len;
2177 }
2178
2179 continue_loop = true;
2180 d = array->rank;
2181 rptr = resultvec;
2182 sptr = arrayvec;
2183 hptr = shiftvec;
2184
2185 while (continue_loop)
2186 {
2187 ssize_t sh;
2188 if (shiftvec)
2189 sh = *hptr;
2190 else
2191 sh = shift_val;
2192
2193 src = &sptr[sh * rsoffset];
2194 dest = rptr;
2195 for (n = 0; n < len - sh; n++)
2196 {
2197 *dest = *src;
2198 dest += rsoffset;
2199 src += rsoffset;
2200 }
2201 src = sptr;
2202 for ( n = 0; n < sh; n++)
2203 {
2204 *dest = *src;
2205 dest += rsoffset;
2206 src += rsoffset;
2207 }
2208 rptr += sstride[0];
2209 sptr += sstride[0];
2210 if (shiftvec)
2211 hptr += hstride[0];
2212 count[0]++;
2213 n = 0;
2214 while (count[n] == extent[n])
2215 {
2216 count[n] = 0;
2217 rptr -= ss_ex[n];
2218 sptr -= ss_ex[n];
2219 if (shiftvec)
2220 hptr -= hs_ex[n];
2221 n++;
2222 if (n >= d - 1)
2223 {
2224 continue_loop = false;
2225 break;
2226 }
2227 else
2228 {
2229 count[n]++;
2230 rptr += sstride[n];
2231 sptr += sstride[n];
2232 if (shiftvec)
2233 hptr += hstride[n];
2234 }
2235 }
2236 }
2237
2238 for (i = 0; i < arraysize; i++)
2239 {
2240 gfc_constructor_append_expr (&result->value.constructor,
2241 gfc_copy_expr (resultvec[i]),
2242 NULL);
2243 }
2244 return result;
2245 }
2246
2247
2248 gfc_expr *
gfc_simplify_dcmplx(gfc_expr * x,gfc_expr * y)2249 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
2250 {
2251 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
2252 }
2253
2254
2255 gfc_expr *
gfc_simplify_dble(gfc_expr * e)2256 gfc_simplify_dble (gfc_expr *e)
2257 {
2258 gfc_expr *result = NULL;
2259 int tmp1, tmp2;
2260
2261 if (e->expr_type != EXPR_CONSTANT)
2262 return NULL;
2263
2264 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2265 warnings. */
2266 tmp1 = warn_conversion;
2267 tmp2 = warn_conversion_extra;
2268 warn_conversion = warn_conversion_extra = 0;
2269
2270 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
2271
2272 warn_conversion = tmp1;
2273 warn_conversion_extra = tmp2;
2274
2275 if (result == &gfc_bad_expr)
2276 return &gfc_bad_expr;
2277
2278 return range_check (result, "DBLE");
2279 }
2280
2281
2282 gfc_expr *
gfc_simplify_digits(gfc_expr * x)2283 gfc_simplify_digits (gfc_expr *x)
2284 {
2285 int i, digits;
2286
2287 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2288
2289 switch (x->ts.type)
2290 {
2291 case BT_INTEGER:
2292 digits = gfc_integer_kinds[i].digits;
2293 break;
2294
2295 case BT_REAL:
2296 case BT_COMPLEX:
2297 digits = gfc_real_kinds[i].digits;
2298 break;
2299
2300 default:
2301 gcc_unreachable ();
2302 }
2303
2304 return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
2305 }
2306
2307
2308 gfc_expr *
gfc_simplify_dim(gfc_expr * x,gfc_expr * y)2309 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
2310 {
2311 gfc_expr *result;
2312 int kind;
2313
2314 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2315 return NULL;
2316
2317 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2318 result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
2319
2320 switch (x->ts.type)
2321 {
2322 case BT_INTEGER:
2323 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
2324 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
2325 else
2326 mpz_set_ui (result->value.integer, 0);
2327
2328 break;
2329
2330 case BT_REAL:
2331 if (mpfr_cmp (x->value.real, y->value.real) > 0)
2332 mpfr_sub (result->value.real, x->value.real, y->value.real,
2333 GFC_RND_MODE);
2334 else
2335 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2336
2337 break;
2338
2339 default:
2340 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2341 }
2342
2343 return range_check (result, "DIM");
2344 }
2345
2346
2347 gfc_expr*
gfc_simplify_dot_product(gfc_expr * vector_a,gfc_expr * vector_b)2348 gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2349 {
2350 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2351 REAL, and COMPLEX types and .false. for LOGICAL. */
2352 if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0)
2353 {
2354 if (vector_a->ts.type == BT_LOGICAL)
2355 return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
2356 else
2357 return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2358 }
2359
2360 if (!is_constant_array_expr (vector_a)
2361 || !is_constant_array_expr (vector_b))
2362 return NULL;
2363
2364 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
2365 }
2366
2367
2368 gfc_expr *
gfc_simplify_dprod(gfc_expr * x,gfc_expr * y)2369 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
2370 {
2371 gfc_expr *a1, *a2, *result;
2372
2373 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2374 return NULL;
2375
2376 a1 = gfc_real2real (x, gfc_default_double_kind);
2377 a2 = gfc_real2real (y, gfc_default_double_kind);
2378
2379 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
2380 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
2381
2382 gfc_free_expr (a2);
2383 gfc_free_expr (a1);
2384
2385 return range_check (result, "DPROD");
2386 }
2387
2388
2389 static gfc_expr *
simplify_dshift(gfc_expr * arg1,gfc_expr * arg2,gfc_expr * shiftarg,bool right)2390 simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
2391 bool right)
2392 {
2393 gfc_expr *result;
2394 int i, k, size, shift;
2395
2396 if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
2397 || shiftarg->expr_type != EXPR_CONSTANT)
2398 return NULL;
2399
2400 k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
2401 size = gfc_integer_kinds[k].bit_size;
2402
2403 gfc_extract_int (shiftarg, &shift);
2404
2405 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2406 if (right)
2407 shift = size - shift;
2408
2409 result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
2410 mpz_set_ui (result->value.integer, 0);
2411
2412 for (i = 0; i < shift; i++)
2413 if (mpz_tstbit (arg2->value.integer, size - shift + i))
2414 mpz_setbit (result->value.integer, i);
2415
2416 for (i = 0; i < size - shift; i++)
2417 if (mpz_tstbit (arg1->value.integer, i))
2418 mpz_setbit (result->value.integer, shift + i);
2419
2420 /* Convert to a signed value. */
2421 gfc_convert_mpz_to_signed (result->value.integer, size);
2422
2423 return result;
2424 }
2425
2426
2427 gfc_expr *
gfc_simplify_dshiftr(gfc_expr * arg1,gfc_expr * arg2,gfc_expr * shiftarg)2428 gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2429 {
2430 return simplify_dshift (arg1, arg2, shiftarg, true);
2431 }
2432
2433
2434 gfc_expr *
gfc_simplify_dshiftl(gfc_expr * arg1,gfc_expr * arg2,gfc_expr * shiftarg)2435 gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2436 {
2437 return simplify_dshift (arg1, arg2, shiftarg, false);
2438 }
2439
2440
2441 gfc_expr *
gfc_simplify_eoshift(gfc_expr * array,gfc_expr * shift,gfc_expr * boundary,gfc_expr * dim)2442 gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
2443 gfc_expr *dim)
2444 {
2445 bool temp_boundary;
2446 gfc_expr *bnd;
2447 gfc_expr *result;
2448 int which;
2449 gfc_expr **arrayvec, **resultvec;
2450 gfc_expr **rptr, **sptr;
2451 mpz_t size;
2452 size_t arraysize, i;
2453 gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor;
2454 ssize_t shift_val, len;
2455 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
2456 sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS],
2457 a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1];
2458 ssize_t rsoffset;
2459 int d, n;
2460 bool continue_loop;
2461 gfc_expr **src, **dest;
2462 size_t s_len;
2463
2464 if (!is_constant_array_expr (array))
2465 return NULL;
2466
2467 if (shift->rank > 0)
2468 gfc_simplify_expr (shift, 1);
2469
2470 if (!gfc_is_constant_expr (shift))
2471 return NULL;
2472
2473 if (boundary)
2474 {
2475 if (boundary->rank > 0)
2476 gfc_simplify_expr (boundary, 1);
2477
2478 if (!gfc_is_constant_expr (boundary))
2479 return NULL;
2480 }
2481
2482 if (dim)
2483 {
2484 if (!gfc_is_constant_expr (dim))
2485 return NULL;
2486 which = mpz_get_si (dim->value.integer) - 1;
2487 }
2488 else
2489 which = 0;
2490
2491 s_len = 0;
2492 if (boundary == NULL)
2493 {
2494 temp_boundary = true;
2495 switch (array->ts.type)
2496 {
2497
2498 case BT_INTEGER:
2499 bnd = gfc_get_int_expr (array->ts.kind, NULL, 0);
2500 break;
2501
2502 case BT_LOGICAL:
2503 bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0);
2504 break;
2505
2506 case BT_REAL:
2507 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2508 mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE);
2509 break;
2510
2511 case BT_COMPLEX:
2512 bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2513 mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE);
2514 break;
2515
2516 case BT_CHARACTER:
2517 s_len = mpz_get_ui (array->ts.u.cl->length->value.integer);
2518 bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len);
2519 break;
2520
2521 default:
2522 gcc_unreachable();
2523
2524 }
2525 }
2526 else
2527 {
2528 temp_boundary = false;
2529 bnd = boundary;
2530 }
2531
2532 gfc_array_size (array, &size);
2533 arraysize = mpz_get_ui (size);
2534 mpz_clear (size);
2535
2536 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2537 result->shape = gfc_copy_shape (array->shape, array->rank);
2538 result->rank = array->rank;
2539 result->ts = array->ts;
2540
2541 if (arraysize == 0)
2542 goto final;
2543
2544 if (array->shape == NULL)
2545 goto final;
2546
2547 arrayvec = XCNEWVEC (gfc_expr *, arraysize);
2548 array_ctor = gfc_constructor_first (array->value.constructor);
2549 for (i = 0; i < arraysize; i++)
2550 {
2551 arrayvec[i] = array_ctor->expr;
2552 array_ctor = gfc_constructor_next (array_ctor);
2553 }
2554
2555 resultvec = XCNEWVEC (gfc_expr *, arraysize);
2556
2557 extent[0] = 1;
2558 count[0] = 0;
2559
2560 for (d=0; d < array->rank; d++)
2561 {
2562 a_extent[d] = mpz_get_si (array->shape[d]);
2563 a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2564 }
2565
2566 if (shift->rank > 0)
2567 {
2568 shift_ctor = gfc_constructor_first (shift->value.constructor);
2569 shift_val = 0;
2570 }
2571 else
2572 {
2573 shift_ctor = NULL;
2574 shift_val = mpz_get_si (shift->value.integer);
2575 }
2576
2577 if (bnd->rank > 0)
2578 bnd_ctor = gfc_constructor_first (bnd->value.constructor);
2579 else
2580 bnd_ctor = NULL;
2581
2582 /* Shut up compiler */
2583 len = 1;
2584 rsoffset = 1;
2585
2586 n = 0;
2587 for (d=0; d < array->rank; d++)
2588 {
2589 if (d == which)
2590 {
2591 rsoffset = a_stride[d];
2592 len = a_extent[d];
2593 }
2594 else
2595 {
2596 count[n] = 0;
2597 extent[n] = a_extent[d];
2598 sstride[n] = a_stride[d];
2599 ss_ex[n] = sstride[n] * extent[n];
2600 n++;
2601 }
2602 }
2603 ss_ex[n] = 0;
2604
2605 continue_loop = true;
2606 d = array->rank;
2607 rptr = resultvec;
2608 sptr = arrayvec;
2609
2610 while (continue_loop)
2611 {
2612 ssize_t sh, delta;
2613
2614 if (shift_ctor)
2615 sh = mpz_get_si (shift_ctor->expr->value.integer);
2616 else
2617 sh = shift_val;
2618
2619 if (( sh >= 0 ? sh : -sh ) > len)
2620 {
2621 delta = len;
2622 sh = len;
2623 }
2624 else
2625 delta = (sh >= 0) ? sh: -sh;
2626
2627 if (sh > 0)
2628 {
2629 src = &sptr[delta * rsoffset];
2630 dest = rptr;
2631 }
2632 else
2633 {
2634 src = sptr;
2635 dest = &rptr[delta * rsoffset];
2636 }
2637
2638 for (n = 0; n < len - delta; n++)
2639 {
2640 *dest = *src;
2641 dest += rsoffset;
2642 src += rsoffset;
2643 }
2644
2645 if (sh < 0)
2646 dest = rptr;
2647
2648 n = delta;
2649
2650 if (bnd_ctor)
2651 {
2652 while (n--)
2653 {
2654 *dest = gfc_copy_expr (bnd_ctor->expr);
2655 dest += rsoffset;
2656 }
2657 }
2658 else
2659 {
2660 while (n--)
2661 {
2662 *dest = gfc_copy_expr (bnd);
2663 dest += rsoffset;
2664 }
2665 }
2666 rptr += sstride[0];
2667 sptr += sstride[0];
2668 if (shift_ctor)
2669 shift_ctor = gfc_constructor_next (shift_ctor);
2670
2671 if (bnd_ctor)
2672 bnd_ctor = gfc_constructor_next (bnd_ctor);
2673
2674 count[0]++;
2675 n = 0;
2676 while (count[n] == extent[n])
2677 {
2678 count[n] = 0;
2679 rptr -= ss_ex[n];
2680 sptr -= ss_ex[n];
2681 n++;
2682 if (n >= d - 1)
2683 {
2684 continue_loop = false;
2685 break;
2686 }
2687 else
2688 {
2689 count[n]++;
2690 rptr += sstride[n];
2691 sptr += sstride[n];
2692 }
2693 }
2694 }
2695
2696 for (i = 0; i < arraysize; i++)
2697 {
2698 gfc_constructor_append_expr (&result->value.constructor,
2699 gfc_copy_expr (resultvec[i]),
2700 NULL);
2701 }
2702
2703 final:
2704 if (temp_boundary)
2705 gfc_free_expr (bnd);
2706
2707 return result;
2708 }
2709
2710 gfc_expr *
gfc_simplify_erf(gfc_expr * x)2711 gfc_simplify_erf (gfc_expr *x)
2712 {
2713 gfc_expr *result;
2714
2715 if (x->expr_type != EXPR_CONSTANT)
2716 return NULL;
2717
2718 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2719 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
2720
2721 return range_check (result, "ERF");
2722 }
2723
2724
2725 gfc_expr *
gfc_simplify_erfc(gfc_expr * x)2726 gfc_simplify_erfc (gfc_expr *x)
2727 {
2728 gfc_expr *result;
2729
2730 if (x->expr_type != EXPR_CONSTANT)
2731 return NULL;
2732
2733 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2734 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
2735
2736 return range_check (result, "ERFC");
2737 }
2738
2739
2740 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2741
2742 #define MAX_ITER 200
2743 #define ARG_LIMIT 12
2744
2745 /* Calculate ERFC_SCALED directly by its definition:
2746
2747 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2748
2749 using a large precision for intermediate results. This is used for all
2750 but large values of the argument. */
2751 static void
fullprec_erfc_scaled(mpfr_t res,mpfr_t arg)2752 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2753 {
2754 mpfr_prec_t prec;
2755 mpfr_t a, b;
2756
2757 prec = mpfr_get_default_prec ();
2758 mpfr_set_default_prec (10 * prec);
2759
2760 mpfr_init (a);
2761 mpfr_init (b);
2762
2763 mpfr_set (a, arg, GFC_RND_MODE);
2764 mpfr_sqr (b, a, GFC_RND_MODE);
2765 mpfr_exp (b, b, GFC_RND_MODE);
2766 mpfr_erfc (a, a, GFC_RND_MODE);
2767 mpfr_mul (a, a, b, GFC_RND_MODE);
2768
2769 mpfr_set (res, a, GFC_RND_MODE);
2770 mpfr_set_default_prec (prec);
2771
2772 mpfr_clear (a);
2773 mpfr_clear (b);
2774 }
2775
2776 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2777
2778 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2779 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2780 / (2 * x**2)**n)
2781
2782 This is used for large values of the argument. Intermediate calculations
2783 are performed with twice the precision. We don't do a fixed number of
2784 iterations of the sum, but stop when it has converged to the required
2785 precision. */
2786 static void
asympt_erfc_scaled(mpfr_t res,mpfr_t arg)2787 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2788 {
2789 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2790 mpz_t num;
2791 mpfr_prec_t prec;
2792 unsigned i;
2793
2794 prec = mpfr_get_default_prec ();
2795 mpfr_set_default_prec (2 * prec);
2796
2797 mpfr_init (sum);
2798 mpfr_init (x);
2799 mpfr_init (u);
2800 mpfr_init (v);
2801 mpfr_init (w);
2802 mpz_init (num);
2803
2804 mpfr_init (oldsum);
2805 mpfr_init (sumtrunc);
2806 mpfr_set_prec (oldsum, prec);
2807 mpfr_set_prec (sumtrunc, prec);
2808
2809 mpfr_set (x, arg, GFC_RND_MODE);
2810 mpfr_set_ui (sum, 1, GFC_RND_MODE);
2811 mpz_set_ui (num, 1);
2812
2813 mpfr_set (u, x, GFC_RND_MODE);
2814 mpfr_sqr (u, u, GFC_RND_MODE);
2815 mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
2816 mpfr_pow_si (u, u, -1, GFC_RND_MODE);
2817
2818 for (i = 1; i < MAX_ITER; i++)
2819 {
2820 mpfr_set (oldsum, sum, GFC_RND_MODE);
2821
2822 mpz_mul_ui (num, num, 2 * i - 1);
2823 mpz_neg (num, num);
2824
2825 mpfr_set (w, u, GFC_RND_MODE);
2826 mpfr_pow_ui (w, w, i, GFC_RND_MODE);
2827
2828 mpfr_set_z (v, num, GFC_RND_MODE);
2829 mpfr_mul (v, v, w, GFC_RND_MODE);
2830
2831 mpfr_add (sum, sum, v, GFC_RND_MODE);
2832
2833 mpfr_set (sumtrunc, sum, GFC_RND_MODE);
2834 if (mpfr_cmp (sumtrunc, oldsum) == 0)
2835 break;
2836 }
2837
2838 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2839 set too low. */
2840 gcc_assert (i < MAX_ITER);
2841
2842 /* Divide by x * sqrt(Pi). */
2843 mpfr_const_pi (u, GFC_RND_MODE);
2844 mpfr_sqrt (u, u, GFC_RND_MODE);
2845 mpfr_mul (u, u, x, GFC_RND_MODE);
2846 mpfr_div (sum, sum, u, GFC_RND_MODE);
2847
2848 mpfr_set (res, sum, GFC_RND_MODE);
2849 mpfr_set_default_prec (prec);
2850
2851 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
2852 mpz_clear (num);
2853 }
2854
2855
2856 gfc_expr *
gfc_simplify_erfc_scaled(gfc_expr * x)2857 gfc_simplify_erfc_scaled (gfc_expr *x)
2858 {
2859 gfc_expr *result;
2860
2861 if (x->expr_type != EXPR_CONSTANT)
2862 return NULL;
2863
2864 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2865 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2866 asympt_erfc_scaled (result->value.real, x->value.real);
2867 else
2868 fullprec_erfc_scaled (result->value.real, x->value.real);
2869
2870 return range_check (result, "ERFC_SCALED");
2871 }
2872
2873 #undef MAX_ITER
2874 #undef ARG_LIMIT
2875
2876
2877 gfc_expr *
gfc_simplify_epsilon(gfc_expr * e)2878 gfc_simplify_epsilon (gfc_expr *e)
2879 {
2880 gfc_expr *result;
2881 int i;
2882
2883 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2884
2885 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2886 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
2887
2888 return range_check (result, "EPSILON");
2889 }
2890
2891
2892 gfc_expr *
gfc_simplify_exp(gfc_expr * x)2893 gfc_simplify_exp (gfc_expr *x)
2894 {
2895 gfc_expr *result;
2896
2897 if (x->expr_type != EXPR_CONSTANT)
2898 return NULL;
2899
2900 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2901
2902 switch (x->ts.type)
2903 {
2904 case BT_REAL:
2905 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
2906 break;
2907
2908 case BT_COMPLEX:
2909 gfc_set_model_kind (x->ts.kind);
2910 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2911 break;
2912
2913 default:
2914 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2915 }
2916
2917 return range_check (result, "EXP");
2918 }
2919
2920
2921 gfc_expr *
gfc_simplify_exponent(gfc_expr * x)2922 gfc_simplify_exponent (gfc_expr *x)
2923 {
2924 long int val;
2925 gfc_expr *result;
2926
2927 if (x->expr_type != EXPR_CONSTANT)
2928 return NULL;
2929
2930 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2931 &x->where);
2932
2933 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2934 if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real))
2935 {
2936 int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
2937 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2938 return result;
2939 }
2940
2941 /* EXPONENT(+/- 0.0) = 0 */
2942 if (mpfr_zero_p (x->value.real))
2943 {
2944 mpz_set_ui (result->value.integer, 0);
2945 return result;
2946 }
2947
2948 gfc_set_model (x->value.real);
2949
2950 val = (long int) mpfr_get_exp (x->value.real);
2951 mpz_set_si (result->value.integer, val);
2952
2953 return range_check (result, "EXPONENT");
2954 }
2955
2956
2957 gfc_expr *
gfc_simplify_failed_or_stopped_images(gfc_expr * team ATTRIBUTE_UNUSED,gfc_expr * kind)2958 gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED,
2959 gfc_expr *kind)
2960 {
2961 if (flag_coarray == GFC_FCOARRAY_NONE)
2962 {
2963 gfc_current_locus = *gfc_current_intrinsic_where;
2964 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2965 return &gfc_bad_expr;
2966 }
2967
2968 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2969 {
2970 gfc_expr *result;
2971 int actual_kind;
2972 if (kind)
2973 gfc_extract_int (kind, &actual_kind);
2974 else
2975 actual_kind = gfc_default_integer_kind;
2976
2977 result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
2978 result->rank = 1;
2979 return result;
2980 }
2981
2982 /* For fcoarray = lib no simplification is possible, because it is not known
2983 what images failed or are stopped at compile time. */
2984 return NULL;
2985 }
2986
2987
2988 gfc_expr *
gfc_simplify_get_team(gfc_expr * level ATTRIBUTE_UNUSED)2989 gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
2990 {
2991 if (flag_coarray == GFC_FCOARRAY_NONE)
2992 {
2993 gfc_current_locus = *gfc_current_intrinsic_where;
2994 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2995 return &gfc_bad_expr;
2996 }
2997
2998 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2999 {
3000 gfc_expr *result;
3001 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
3002 result->rank = 0;
3003 return result;
3004 }
3005
3006 /* For fcoarray = lib no simplification is possible, because it is not known
3007 what images failed or are stopped at compile time. */
3008 return NULL;
3009 }
3010
3011
3012 gfc_expr *
gfc_simplify_float(gfc_expr * a)3013 gfc_simplify_float (gfc_expr *a)
3014 {
3015 gfc_expr *result;
3016
3017 if (a->expr_type != EXPR_CONSTANT)
3018 return NULL;
3019
3020 result = gfc_int2real (a, gfc_default_real_kind);
3021
3022 return range_check (result, "FLOAT");
3023 }
3024
3025
3026 static bool
is_last_ref_vtab(gfc_expr * e)3027 is_last_ref_vtab (gfc_expr *e)
3028 {
3029 gfc_ref *ref;
3030 gfc_component *comp = NULL;
3031
3032 if (e->expr_type != EXPR_VARIABLE)
3033 return false;
3034
3035 for (ref = e->ref; ref; ref = ref->next)
3036 if (ref->type == REF_COMPONENT)
3037 comp = ref->u.c.component;
3038
3039 if (!e->ref || !comp)
3040 return e->symtree->n.sym->attr.vtab;
3041
3042 if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
3043 return true;
3044
3045 return false;
3046 }
3047
3048
3049 gfc_expr *
gfc_simplify_extends_type_of(gfc_expr * a,gfc_expr * mold)3050 gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3051 {
3052 /* Avoid simplification of resolved symbols. */
3053 if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
3054 return NULL;
3055
3056 if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
3057 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3058 gfc_type_is_extension_of (mold->ts.u.derived,
3059 a->ts.u.derived));
3060
3061 if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
3062 return NULL;
3063
3064 if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok)
3065 || (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok))
3066 return NULL;
3067
3068 /* Return .false. if the dynamic type can never be an extension. */
3069 if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
3070 && !gfc_type_is_extension_of
3071 (mold->ts.u.derived->components->ts.u.derived,
3072 a->ts.u.derived->components->ts.u.derived)
3073 && !gfc_type_is_extension_of
3074 (a->ts.u.derived->components->ts.u.derived,
3075 mold->ts.u.derived->components->ts.u.derived))
3076 || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
3077 && !gfc_type_is_extension_of
3078 (mold->ts.u.derived->components->ts.u.derived,
3079 a->ts.u.derived))
3080 || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3081 && !gfc_type_is_extension_of
3082 (mold->ts.u.derived,
3083 a->ts.u.derived->components->ts.u.derived)
3084 && !gfc_type_is_extension_of
3085 (a->ts.u.derived->components->ts.u.derived,
3086 mold->ts.u.derived)))
3087 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3088
3089 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3090 if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3091 && gfc_type_is_extension_of (mold->ts.u.derived,
3092 a->ts.u.derived->components->ts.u.derived))
3093 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
3094
3095 return NULL;
3096 }
3097
3098
3099 gfc_expr *
gfc_simplify_same_type_as(gfc_expr * a,gfc_expr * b)3100 gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
3101 {
3102 /* Avoid simplification of resolved symbols. */
3103 if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
3104 return NULL;
3105
3106 /* Return .false. if the dynamic type can never be the
3107 same. */
3108 if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
3109 || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
3110 && !gfc_type_compatible (&a->ts, &b->ts)
3111 && !gfc_type_compatible (&b->ts, &a->ts))
3112 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3113
3114 if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
3115 return NULL;
3116
3117 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3118 gfc_compare_derived_types (a->ts.u.derived,
3119 b->ts.u.derived));
3120 }
3121
3122
3123 gfc_expr *
gfc_simplify_floor(gfc_expr * e,gfc_expr * k)3124 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
3125 {
3126 gfc_expr *result;
3127 mpfr_t floor;
3128 int kind;
3129
3130 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
3131 if (kind == -1)
3132 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3133
3134 if (e->expr_type != EXPR_CONSTANT)
3135 return NULL;
3136
3137 mpfr_init2 (floor, mpfr_get_prec (e->value.real));
3138 mpfr_floor (floor, e->value.real);
3139
3140 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3141 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
3142
3143 mpfr_clear (floor);
3144
3145 return range_check (result, "FLOOR");
3146 }
3147
3148
3149 gfc_expr *
gfc_simplify_fraction(gfc_expr * x)3150 gfc_simplify_fraction (gfc_expr *x)
3151 {
3152 gfc_expr *result;
3153 mpfr_exp_t e;
3154
3155 if (x->expr_type != EXPR_CONSTANT)
3156 return NULL;
3157
3158 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
3159
3160 /* FRACTION(inf) = NaN. */
3161 if (mpfr_inf_p (x->value.real))
3162 {
3163 mpfr_set_nan (result->value.real);
3164 return result;
3165 }
3166
3167 /* mpfr_frexp() correctly handles zeros and NaNs. */
3168 mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
3169
3170 return range_check (result, "FRACTION");
3171 }
3172
3173
3174 gfc_expr *
gfc_simplify_gamma(gfc_expr * x)3175 gfc_simplify_gamma (gfc_expr *x)
3176 {
3177 gfc_expr *result;
3178
3179 if (x->expr_type != EXPR_CONSTANT)
3180 return NULL;
3181
3182 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3183 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
3184
3185 return range_check (result, "GAMMA");
3186 }
3187
3188
3189 gfc_expr *
gfc_simplify_huge(gfc_expr * e)3190 gfc_simplify_huge (gfc_expr *e)
3191 {
3192 gfc_expr *result;
3193 int i;
3194
3195 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3196 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3197
3198 switch (e->ts.type)
3199 {
3200 case BT_INTEGER:
3201 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3202 break;
3203
3204 case BT_REAL:
3205 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
3206 break;
3207
3208 default:
3209 gcc_unreachable ();
3210 }
3211
3212 return result;
3213 }
3214
3215
3216 gfc_expr *
gfc_simplify_hypot(gfc_expr * x,gfc_expr * y)3217 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
3218 {
3219 gfc_expr *result;
3220
3221 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3222 return NULL;
3223
3224 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3225 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
3226 return range_check (result, "HYPOT");
3227 }
3228
3229
3230 /* We use the processor's collating sequence, because all
3231 systems that gfortran currently works on are ASCII. */
3232
3233 gfc_expr *
gfc_simplify_iachar(gfc_expr * e,gfc_expr * kind)3234 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
3235 {
3236 gfc_expr *result;
3237 gfc_char_t index;
3238 int k;
3239
3240 if (e->expr_type != EXPR_CONSTANT)
3241 return NULL;
3242
3243 if (e->value.character.length != 1)
3244 {
3245 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
3246 return &gfc_bad_expr;
3247 }
3248
3249 index = e->value.character.string[0];
3250
3251 if (warn_surprising && index > 127)
3252 gfc_warning (OPT_Wsurprising,
3253 "Argument of IACHAR function at %L outside of range 0..127",
3254 &e->where);
3255
3256 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
3257 if (k == -1)
3258 return &gfc_bad_expr;
3259
3260 result = gfc_get_int_expr (k, &e->where, index);
3261
3262 return range_check (result, "IACHAR");
3263 }
3264
3265
3266 static gfc_expr *
do_bit_and(gfc_expr * result,gfc_expr * e)3267 do_bit_and (gfc_expr *result, gfc_expr *e)
3268 {
3269 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3270 gcc_assert (result->ts.type == BT_INTEGER
3271 && result->expr_type == EXPR_CONSTANT);
3272
3273 mpz_and (result->value.integer, result->value.integer, e->value.integer);
3274 return result;
3275 }
3276
3277
3278 gfc_expr *
gfc_simplify_iall(gfc_expr * array,gfc_expr * dim,gfc_expr * mask)3279 gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3280 {
3281 return simplify_transformation (array, dim, mask, -1, do_bit_and);
3282 }
3283
3284
3285 static gfc_expr *
do_bit_ior(gfc_expr * result,gfc_expr * e)3286 do_bit_ior (gfc_expr *result, gfc_expr *e)
3287 {
3288 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3289 gcc_assert (result->ts.type == BT_INTEGER
3290 && result->expr_type == EXPR_CONSTANT);
3291
3292 mpz_ior (result->value.integer, result->value.integer, e->value.integer);
3293 return result;
3294 }
3295
3296
3297 gfc_expr *
gfc_simplify_iany(gfc_expr * array,gfc_expr * dim,gfc_expr * mask)3298 gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3299 {
3300 return simplify_transformation (array, dim, mask, 0, do_bit_ior);
3301 }
3302
3303
3304 gfc_expr *
gfc_simplify_iand(gfc_expr * x,gfc_expr * y)3305 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
3306 {
3307 gfc_expr *result;
3308
3309 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3310 return NULL;
3311
3312 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3313 mpz_and (result->value.integer, x->value.integer, y->value.integer);
3314
3315 return range_check (result, "IAND");
3316 }
3317
3318
3319 gfc_expr *
gfc_simplify_ibclr(gfc_expr * x,gfc_expr * y)3320 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
3321 {
3322 gfc_expr *result;
3323 int k, pos;
3324
3325 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3326 return NULL;
3327
3328 gfc_extract_int (y, &pos);
3329
3330 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3331
3332 result = gfc_copy_expr (x);
3333
3334 convert_mpz_to_unsigned (result->value.integer,
3335 gfc_integer_kinds[k].bit_size);
3336
3337 mpz_clrbit (result->value.integer, pos);
3338
3339 gfc_convert_mpz_to_signed (result->value.integer,
3340 gfc_integer_kinds[k].bit_size);
3341
3342 return result;
3343 }
3344
3345
3346 gfc_expr *
gfc_simplify_ibits(gfc_expr * x,gfc_expr * y,gfc_expr * z)3347 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
3348 {
3349 gfc_expr *result;
3350 int pos, len;
3351 int i, k, bitsize;
3352 int *bits;
3353
3354 if (x->expr_type != EXPR_CONSTANT
3355 || y->expr_type != EXPR_CONSTANT
3356 || z->expr_type != EXPR_CONSTANT)
3357 return NULL;
3358
3359 gfc_extract_int (y, &pos);
3360 gfc_extract_int (z, &len);
3361
3362 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
3363
3364 bitsize = gfc_integer_kinds[k].bit_size;
3365
3366 if (pos + len > bitsize)
3367 {
3368 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3369 "bit size at %L", &y->where);
3370 return &gfc_bad_expr;
3371 }
3372
3373 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3374 convert_mpz_to_unsigned (result->value.integer,
3375 gfc_integer_kinds[k].bit_size);
3376
3377 bits = XCNEWVEC (int, bitsize);
3378
3379 for (i = 0; i < bitsize; i++)
3380 bits[i] = 0;
3381
3382 for (i = 0; i < len; i++)
3383 bits[i] = mpz_tstbit (x->value.integer, i + pos);
3384
3385 for (i = 0; i < bitsize; i++)
3386 {
3387 if (bits[i] == 0)
3388 mpz_clrbit (result->value.integer, i);
3389 else if (bits[i] == 1)
3390 mpz_setbit (result->value.integer, i);
3391 else
3392 gfc_internal_error ("IBITS: Bad bit");
3393 }
3394
3395 free (bits);
3396
3397 gfc_convert_mpz_to_signed (result->value.integer,
3398 gfc_integer_kinds[k].bit_size);
3399
3400 return result;
3401 }
3402
3403
3404 gfc_expr *
gfc_simplify_ibset(gfc_expr * x,gfc_expr * y)3405 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
3406 {
3407 gfc_expr *result;
3408 int k, pos;
3409
3410 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3411 return NULL;
3412
3413 gfc_extract_int (y, &pos);
3414
3415 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3416
3417 result = gfc_copy_expr (x);
3418
3419 convert_mpz_to_unsigned (result->value.integer,
3420 gfc_integer_kinds[k].bit_size);
3421
3422 mpz_setbit (result->value.integer, pos);
3423
3424 gfc_convert_mpz_to_signed (result->value.integer,
3425 gfc_integer_kinds[k].bit_size);
3426
3427 return result;
3428 }
3429
3430
3431 gfc_expr *
gfc_simplify_ichar(gfc_expr * e,gfc_expr * kind)3432 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3433 {
3434 gfc_expr *result;
3435 gfc_char_t index;
3436 int k;
3437
3438 if (e->expr_type != EXPR_CONSTANT)
3439 return NULL;
3440
3441 if (e->value.character.length != 1)
3442 {
3443 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
3444 return &gfc_bad_expr;
3445 }
3446
3447 index = e->value.character.string[0];
3448
3449 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
3450 if (k == -1)
3451 return &gfc_bad_expr;
3452
3453 result = gfc_get_int_expr (k, &e->where, index);
3454
3455 return range_check (result, "ICHAR");
3456 }
3457
3458
3459 gfc_expr *
gfc_simplify_ieor(gfc_expr * x,gfc_expr * y)3460 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
3461 {
3462 gfc_expr *result;
3463
3464 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3465 return NULL;
3466
3467 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3468 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
3469
3470 return range_check (result, "IEOR");
3471 }
3472
3473
3474 gfc_expr *
gfc_simplify_index(gfc_expr * x,gfc_expr * y,gfc_expr * b,gfc_expr * kind)3475 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
3476 {
3477 gfc_expr *result;
3478 bool back;
3479 HOST_WIDE_INT len, lensub, start, last, i, index = 0;
3480 int k, delta;
3481
3482 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
3483 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
3484 return NULL;
3485
3486 back = (b != NULL && b->value.logical != 0);
3487
3488 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
3489 if (k == -1)
3490 return &gfc_bad_expr;
3491
3492 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
3493
3494 len = x->value.character.length;
3495 lensub = y->value.character.length;
3496
3497 if (len < lensub)
3498 {
3499 mpz_set_si (result->value.integer, 0);
3500 return result;
3501 }
3502
3503 if (lensub == 0)
3504 {
3505 if (back)
3506 index = len + 1;
3507 else
3508 index = 1;
3509 goto done;
3510 }
3511
3512 if (!back)
3513 {
3514 last = len + 1 - lensub;
3515 start = 0;
3516 delta = 1;
3517 }
3518 else
3519 {
3520 last = -1;
3521 start = len - lensub;
3522 delta = -1;
3523 }
3524
3525 for (; start != last; start += delta)
3526 {
3527 for (i = 0; i < lensub; i++)
3528 {
3529 if (x->value.character.string[start + i]
3530 != y->value.character.string[i])
3531 break;
3532 }
3533 if (i == lensub)
3534 {
3535 index = start + 1;
3536 goto done;
3537 }
3538 }
3539
3540 done:
3541 mpz_set_si (result->value.integer, index);
3542 return range_check (result, "INDEX");
3543 }
3544
3545
3546 static gfc_expr *
simplify_intconv(gfc_expr * e,int kind,const char * name)3547 simplify_intconv (gfc_expr *e, int kind, const char *name)
3548 {
3549 gfc_expr *result = NULL;
3550 int tmp1, tmp2;
3551
3552 /* Convert BOZ to integer, and return without range checking. */
3553 if (e->ts.type == BT_BOZ)
3554 {
3555 if (!gfc_boz2int (e, kind))
3556 return NULL;
3557 result = gfc_copy_expr (e);
3558 return result;
3559 }
3560
3561 if (e->expr_type != EXPR_CONSTANT)
3562 return NULL;
3563
3564 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3565 warnings. */
3566 tmp1 = warn_conversion;
3567 tmp2 = warn_conversion_extra;
3568 warn_conversion = warn_conversion_extra = 0;
3569
3570 result = gfc_convert_constant (e, BT_INTEGER, kind);
3571
3572 warn_conversion = tmp1;
3573 warn_conversion_extra = tmp2;
3574
3575 if (result == &gfc_bad_expr)
3576 return &gfc_bad_expr;
3577
3578 return range_check (result, name);
3579 }
3580
3581
3582 gfc_expr *
gfc_simplify_int(gfc_expr * e,gfc_expr * k)3583 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3584 {
3585 int kind;
3586
3587 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
3588 if (kind == -1)
3589 return &gfc_bad_expr;
3590
3591 return simplify_intconv (e, kind, "INT");
3592 }
3593
3594 gfc_expr *
gfc_simplify_int2(gfc_expr * e)3595 gfc_simplify_int2 (gfc_expr *e)
3596 {
3597 return simplify_intconv (e, 2, "INT2");
3598 }
3599
3600
3601 gfc_expr *
gfc_simplify_int8(gfc_expr * e)3602 gfc_simplify_int8 (gfc_expr *e)
3603 {
3604 return simplify_intconv (e, 8, "INT8");
3605 }
3606
3607
3608 gfc_expr *
gfc_simplify_long(gfc_expr * e)3609 gfc_simplify_long (gfc_expr *e)
3610 {
3611 return simplify_intconv (e, 4, "LONG");
3612 }
3613
3614
3615 gfc_expr *
gfc_simplify_ifix(gfc_expr * e)3616 gfc_simplify_ifix (gfc_expr *e)
3617 {
3618 gfc_expr *rtrunc, *result;
3619
3620 if (e->expr_type != EXPR_CONSTANT)
3621 return NULL;
3622
3623 rtrunc = gfc_copy_expr (e);
3624 mpfr_trunc (rtrunc->value.real, e->value.real);
3625
3626 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3627 &e->where);
3628 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3629
3630 gfc_free_expr (rtrunc);
3631
3632 return range_check (result, "IFIX");
3633 }
3634
3635
3636 gfc_expr *
gfc_simplify_idint(gfc_expr * e)3637 gfc_simplify_idint (gfc_expr *e)
3638 {
3639 gfc_expr *rtrunc, *result;
3640
3641 if (e->expr_type != EXPR_CONSTANT)
3642 return NULL;
3643
3644 rtrunc = gfc_copy_expr (e);
3645 mpfr_trunc (rtrunc->value.real, e->value.real);
3646
3647 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3648 &e->where);
3649 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3650
3651 gfc_free_expr (rtrunc);
3652
3653 return range_check (result, "IDINT");
3654 }
3655
3656
3657 gfc_expr *
gfc_simplify_ior(gfc_expr * x,gfc_expr * y)3658 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
3659 {
3660 gfc_expr *result;
3661
3662 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3663 return NULL;
3664
3665 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3666 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3667
3668 return range_check (result, "IOR");
3669 }
3670
3671
3672 static gfc_expr *
do_bit_xor(gfc_expr * result,gfc_expr * e)3673 do_bit_xor (gfc_expr *result, gfc_expr *e)
3674 {
3675 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3676 gcc_assert (result->ts.type == BT_INTEGER
3677 && result->expr_type == EXPR_CONSTANT);
3678
3679 mpz_xor (result->value.integer, result->value.integer, e->value.integer);
3680 return result;
3681 }
3682
3683
3684 gfc_expr *
gfc_simplify_iparity(gfc_expr * array,gfc_expr * dim,gfc_expr * mask)3685 gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3686 {
3687 return simplify_transformation (array, dim, mask, 0, do_bit_xor);
3688 }
3689
3690
3691 gfc_expr *
gfc_simplify_is_iostat_end(gfc_expr * x)3692 gfc_simplify_is_iostat_end (gfc_expr *x)
3693 {
3694 if (x->expr_type != EXPR_CONSTANT)
3695 return NULL;
3696
3697 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3698 mpz_cmp_si (x->value.integer,
3699 LIBERROR_END) == 0);
3700 }
3701
3702
3703 gfc_expr *
gfc_simplify_is_iostat_eor(gfc_expr * x)3704 gfc_simplify_is_iostat_eor (gfc_expr *x)
3705 {
3706 if (x->expr_type != EXPR_CONSTANT)
3707 return NULL;
3708
3709 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3710 mpz_cmp_si (x->value.integer,
3711 LIBERROR_EOR) == 0);
3712 }
3713
3714
3715 gfc_expr *
gfc_simplify_isnan(gfc_expr * x)3716 gfc_simplify_isnan (gfc_expr *x)
3717 {
3718 if (x->expr_type != EXPR_CONSTANT)
3719 return NULL;
3720
3721 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3722 mpfr_nan_p (x->value.real));
3723 }
3724
3725
3726 /* Performs a shift on its first argument. Depending on the last
3727 argument, the shift can be arithmetic, i.e. with filling from the
3728 left like in the SHIFTA intrinsic. */
3729 static gfc_expr *
simplify_shift(gfc_expr * e,gfc_expr * s,const char * name,bool arithmetic,int direction)3730 simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
3731 bool arithmetic, int direction)
3732 {
3733 gfc_expr *result;
3734 int ashift, *bits, i, k, bitsize, shift;
3735
3736 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3737 return NULL;
3738
3739 gfc_extract_int (s, &shift);
3740
3741 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
3742 bitsize = gfc_integer_kinds[k].bit_size;
3743
3744 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3745
3746 if (shift == 0)
3747 {
3748 mpz_set (result->value.integer, e->value.integer);
3749 return result;
3750 }
3751
3752 if (direction > 0 && shift < 0)
3753 {
3754 /* Left shift, as in SHIFTL. */
3755 gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3756 return &gfc_bad_expr;
3757 }
3758 else if (direction < 0)
3759 {
3760 /* Right shift, as in SHIFTR or SHIFTA. */
3761 if (shift < 0)
3762 {
3763 gfc_error ("Second argument of %s is negative at %L",
3764 name, &e->where);
3765 return &gfc_bad_expr;
3766 }
3767
3768 shift = -shift;
3769 }
3770
3771 ashift = (shift >= 0 ? shift : -shift);
3772
3773 if (ashift > bitsize)
3774 {
3775 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3776 "at %L", name, &e->where);
3777 return &gfc_bad_expr;
3778 }
3779
3780 bits = XCNEWVEC (int, bitsize);
3781
3782 for (i = 0; i < bitsize; i++)
3783 bits[i] = mpz_tstbit (e->value.integer, i);
3784
3785 if (shift > 0)
3786 {
3787 /* Left shift. */
3788 for (i = 0; i < shift; i++)
3789 mpz_clrbit (result->value.integer, i);
3790
3791 for (i = 0; i < bitsize - shift; i++)
3792 {
3793 if (bits[i] == 0)
3794 mpz_clrbit (result->value.integer, i + shift);
3795 else
3796 mpz_setbit (result->value.integer, i + shift);
3797 }
3798 }
3799 else
3800 {
3801 /* Right shift. */
3802 if (arithmetic && bits[bitsize - 1])
3803 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3804 mpz_setbit (result->value.integer, i);
3805 else
3806 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3807 mpz_clrbit (result->value.integer, i);
3808
3809 for (i = bitsize - 1; i >= ashift; i--)
3810 {
3811 if (bits[i] == 0)
3812 mpz_clrbit (result->value.integer, i - ashift);
3813 else
3814 mpz_setbit (result->value.integer, i - ashift);
3815 }
3816 }
3817
3818 gfc_convert_mpz_to_signed (result->value.integer, bitsize);
3819 free (bits);
3820
3821 return result;
3822 }
3823
3824
3825 gfc_expr *
gfc_simplify_ishft(gfc_expr * e,gfc_expr * s)3826 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3827 {
3828 return simplify_shift (e, s, "ISHFT", false, 0);
3829 }
3830
3831
3832 gfc_expr *
gfc_simplify_lshift(gfc_expr * e,gfc_expr * s)3833 gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3834 {
3835 return simplify_shift (e, s, "LSHIFT", false, 1);
3836 }
3837
3838
3839 gfc_expr *
gfc_simplify_rshift(gfc_expr * e,gfc_expr * s)3840 gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3841 {
3842 return simplify_shift (e, s, "RSHIFT", true, -1);
3843 }
3844
3845
3846 gfc_expr *
gfc_simplify_shifta(gfc_expr * e,gfc_expr * s)3847 gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3848 {
3849 return simplify_shift (e, s, "SHIFTA", true, -1);
3850 }
3851
3852
3853 gfc_expr *
gfc_simplify_shiftl(gfc_expr * e,gfc_expr * s)3854 gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3855 {
3856 return simplify_shift (e, s, "SHIFTL", false, 1);
3857 }
3858
3859
3860 gfc_expr *
gfc_simplify_shiftr(gfc_expr * e,gfc_expr * s)3861 gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3862 {
3863 return simplify_shift (e, s, "SHIFTR", false, -1);
3864 }
3865
3866
3867 gfc_expr *
gfc_simplify_ishftc(gfc_expr * e,gfc_expr * s,gfc_expr * sz)3868 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3869 {
3870 gfc_expr *result;
3871 int shift, ashift, isize, ssize, delta, k;
3872 int i, *bits;
3873
3874 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3875 return NULL;
3876
3877 gfc_extract_int (s, &shift);
3878
3879 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3880 isize = gfc_integer_kinds[k].bit_size;
3881
3882 if (sz != NULL)
3883 {
3884 if (sz->expr_type != EXPR_CONSTANT)
3885 return NULL;
3886
3887 gfc_extract_int (sz, &ssize);
3888 }
3889 else
3890 ssize = isize;
3891
3892 if (shift >= 0)
3893 ashift = shift;
3894 else
3895 ashift = -shift;
3896
3897 if (ashift > ssize)
3898 {
3899 if (sz == NULL)
3900 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3901 "BIT_SIZE of first argument at %C");
3902 else
3903 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3904 "to SIZE at %C");
3905 return &gfc_bad_expr;
3906 }
3907
3908 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3909
3910 mpz_set (result->value.integer, e->value.integer);
3911
3912 if (shift == 0)
3913 return result;
3914
3915 convert_mpz_to_unsigned (result->value.integer, isize);
3916
3917 bits = XCNEWVEC (int, ssize);
3918
3919 for (i = 0; i < ssize; i++)
3920 bits[i] = mpz_tstbit (e->value.integer, i);
3921
3922 delta = ssize - ashift;
3923
3924 if (shift > 0)
3925 {
3926 for (i = 0; i < delta; i++)
3927 {
3928 if (bits[i] == 0)
3929 mpz_clrbit (result->value.integer, i + shift);
3930 else
3931 mpz_setbit (result->value.integer, i + shift);
3932 }
3933
3934 for (i = delta; i < ssize; i++)
3935 {
3936 if (bits[i] == 0)
3937 mpz_clrbit (result->value.integer, i - delta);
3938 else
3939 mpz_setbit (result->value.integer, i - delta);
3940 }
3941 }
3942 else
3943 {
3944 for (i = 0; i < ashift; i++)
3945 {
3946 if (bits[i] == 0)
3947 mpz_clrbit (result->value.integer, i + delta);
3948 else
3949 mpz_setbit (result->value.integer, i + delta);
3950 }
3951
3952 for (i = ashift; i < ssize; i++)
3953 {
3954 if (bits[i] == 0)
3955 mpz_clrbit (result->value.integer, i + shift);
3956 else
3957 mpz_setbit (result->value.integer, i + shift);
3958 }
3959 }
3960
3961 gfc_convert_mpz_to_signed (result->value.integer, isize);
3962
3963 free (bits);
3964 return result;
3965 }
3966
3967
3968 gfc_expr *
gfc_simplify_kind(gfc_expr * e)3969 gfc_simplify_kind (gfc_expr *e)
3970 {
3971 return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
3972 }
3973
3974
3975 static gfc_expr *
simplify_bound_dim(gfc_expr * array,gfc_expr * kind,int d,int upper,gfc_array_spec * as,gfc_ref * ref,bool coarray)3976 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
3977 gfc_array_spec *as, gfc_ref *ref, bool coarray)
3978 {
3979 gfc_expr *l, *u, *result;
3980 int k;
3981
3982 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3983 gfc_default_integer_kind);
3984 if (k == -1)
3985 return &gfc_bad_expr;
3986
3987 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3988
3989 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3990 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3991 if (!coarray && array->expr_type != EXPR_VARIABLE)
3992 {
3993 if (upper)
3994 {
3995 gfc_expr* dim = result;
3996 mpz_set_si (dim->value.integer, d);
3997
3998 result = simplify_size (array, dim, k);
3999 gfc_free_expr (dim);
4000 if (!result)
4001 goto returnNull;
4002 }
4003 else
4004 mpz_set_si (result->value.integer, 1);
4005
4006 goto done;
4007 }
4008
4009 /* Otherwise, we have a variable expression. */
4010 gcc_assert (array->expr_type == EXPR_VARIABLE);
4011 gcc_assert (as);
4012
4013 if (!gfc_resolve_array_spec (as, 0))
4014 return NULL;
4015
4016 /* The last dimension of an assumed-size array is special. */
4017 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4018 || (coarray && d == as->rank + as->corank
4019 && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
4020 {
4021 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
4022 {
4023 gfc_free_expr (result);
4024 return gfc_copy_expr (as->lower[d-1]);
4025 }
4026
4027 goto returnNull;
4028 }
4029
4030 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4031
4032 /* Then, we need to know the extent of the given dimension. */
4033 if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
4034 {
4035 gfc_expr *declared_bound;
4036 int empty_bound;
4037 bool constant_lbound, constant_ubound;
4038
4039 l = as->lower[d-1];
4040 u = as->upper[d-1];
4041
4042 gcc_assert (l != NULL);
4043
4044 constant_lbound = l->expr_type == EXPR_CONSTANT;
4045 constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4046
4047 empty_bound = upper ? 0 : 1;
4048 declared_bound = upper ? u : l;
4049
4050 if ((!upper && !constant_lbound)
4051 || (upper && !constant_ubound))
4052 goto returnNull;
4053
4054 if (!coarray)
4055 {
4056 /* For {L,U}BOUND, the value depends on whether the array
4057 is empty. We can nevertheless simplify if the declared bound
4058 has the same value as that of an empty array, in which case
4059 the result isn't dependent on the array emptyness. */
4060 if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
4061 mpz_set_si (result->value.integer, empty_bound);
4062 else if (!constant_lbound || !constant_ubound)
4063 /* Array emptyness can't be determined, we can't simplify. */
4064 goto returnNull;
4065 else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
4066 mpz_set_si (result->value.integer, empty_bound);
4067 else
4068 mpz_set (result->value.integer, declared_bound->value.integer);
4069 }
4070 else
4071 mpz_set (result->value.integer, declared_bound->value.integer);
4072 }
4073 else
4074 {
4075 if (upper)
4076 {
4077 int d2 = 0, cnt = 0;
4078 for (int idx = 0; idx < ref->u.ar.dimen; ++idx)
4079 {
4080 if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
4081 d2++;
4082 else if (cnt < d - 1)
4083 cnt++;
4084 else
4085 break;
4086 }
4087 if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL))
4088 goto returnNull;
4089 }
4090 else
4091 mpz_set_si (result->value.integer, (long int) 1);
4092 }
4093
4094 done:
4095 return range_check (result, upper ? "UBOUND" : "LBOUND");
4096
4097 returnNull:
4098 gfc_free_expr (result);
4099 return NULL;
4100 }
4101
4102
4103 static gfc_expr *
simplify_bound(gfc_expr * array,gfc_expr * dim,gfc_expr * kind,int upper)4104 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4105 {
4106 gfc_ref *ref;
4107 gfc_array_spec *as;
4108 ar_type type = AR_UNKNOWN;
4109 int d;
4110
4111 if (array->ts.type == BT_CLASS)
4112 return NULL;
4113
4114 if (array->expr_type != EXPR_VARIABLE)
4115 {
4116 as = NULL;
4117 ref = NULL;
4118 goto done;
4119 }
4120
4121 /* Do not attempt to resolve if error has already been issued. */
4122 if (array->symtree->n.sym->error)
4123 return NULL;
4124
4125 /* Follow any component references. */
4126 as = array->symtree->n.sym->as;
4127 for (ref = array->ref; ref; ref = ref->next)
4128 {
4129 switch (ref->type)
4130 {
4131 case REF_ARRAY:
4132 type = ref->u.ar.type;
4133 switch (ref->u.ar.type)
4134 {
4135 case AR_ELEMENT:
4136 as = NULL;
4137 continue;
4138
4139 case AR_FULL:
4140 /* We're done because 'as' has already been set in the
4141 previous iteration. */
4142 goto done;
4143
4144 case AR_UNKNOWN:
4145 return NULL;
4146
4147 case AR_SECTION:
4148 as = ref->u.ar.as;
4149 goto done;
4150 }
4151
4152 gcc_unreachable ();
4153
4154 case REF_COMPONENT:
4155 as = ref->u.c.component->as;
4156 continue;
4157
4158 case REF_SUBSTRING:
4159 case REF_INQUIRY:
4160 continue;
4161 }
4162 }
4163
4164 gcc_unreachable ();
4165
4166 done:
4167
4168 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
4169 || (as->type == AS_ASSUMED_SHAPE && upper)))
4170 return NULL;
4171
4172 /* 'array' shall not be an unallocated allocatable variable or a pointer that
4173 is not associated. */
4174 if (array->expr_type == EXPR_VARIABLE
4175 && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer))
4176 return NULL;
4177
4178 gcc_assert (!as
4179 || (as->type != AS_DEFERRED
4180 && array->expr_type == EXPR_VARIABLE
4181 && !gfc_expr_attr (array).allocatable
4182 && !gfc_expr_attr (array).pointer));
4183
4184 if (dim == NULL)
4185 {
4186 /* Multi-dimensional bounds. */
4187 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4188 gfc_expr *e;
4189 int k;
4190
4191 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4192 if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
4193 {
4194 /* An error message will be emitted in
4195 check_assumed_size_reference (resolve.c). */
4196 return &gfc_bad_expr;
4197 }
4198
4199 /* Simplify the bounds for each dimension. */
4200 for (d = 0; d < array->rank; d++)
4201 {
4202 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
4203 false);
4204 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4205 {
4206 int j;
4207
4208 for (j = 0; j < d; j++)
4209 gfc_free_expr (bounds[j]);
4210
4211 if (gfc_seen_div0)
4212 return &gfc_bad_expr;
4213 else
4214 return bounds[d];
4215 }
4216 }
4217
4218 /* Allocate the result expression. */
4219 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4220 gfc_default_integer_kind);
4221 if (k == -1)
4222 return &gfc_bad_expr;
4223
4224 e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
4225
4226 /* The result is a rank 1 array; its size is the rank of the first
4227 argument to {L,U}BOUND. */
4228 e->rank = 1;
4229 e->shape = gfc_get_shape (1);
4230 mpz_init_set_ui (e->shape[0], array->rank);
4231
4232 /* Create the constructor for this array. */
4233 for (d = 0; d < array->rank; d++)
4234 gfc_constructor_append_expr (&e->value.constructor,
4235 bounds[d], &e->where);
4236
4237 return e;
4238 }
4239 else
4240 {
4241 /* A DIM argument is specified. */
4242 if (dim->expr_type != EXPR_CONSTANT)
4243 return NULL;
4244
4245 d = mpz_get_si (dim->value.integer);
4246
4247 if ((d < 1 || d > array->rank)
4248 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
4249 {
4250 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4251 return &gfc_bad_expr;
4252 }
4253
4254 if (as && as->type == AS_ASSUMED_RANK)
4255 return NULL;
4256
4257 return simplify_bound_dim (array, kind, d, upper, as, ref, false);
4258 }
4259 }
4260
4261
4262 static gfc_expr *
simplify_cobound(gfc_expr * array,gfc_expr * dim,gfc_expr * kind,int upper)4263 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4264 {
4265 gfc_ref *ref;
4266 gfc_array_spec *as;
4267 int d;
4268
4269 if (array->expr_type != EXPR_VARIABLE)
4270 return NULL;
4271
4272 /* Follow any component references. */
4273 as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
4274 ? array->ts.u.derived->components->as
4275 : array->symtree->n.sym->as;
4276 for (ref = array->ref; ref; ref = ref->next)
4277 {
4278 switch (ref->type)
4279 {
4280 case REF_ARRAY:
4281 switch (ref->u.ar.type)
4282 {
4283 case AR_ELEMENT:
4284 if (ref->u.ar.as->corank > 0)
4285 {
4286 gcc_assert (as == ref->u.ar.as);
4287 goto done;
4288 }
4289 as = NULL;
4290 continue;
4291
4292 case AR_FULL:
4293 /* We're done because 'as' has already been set in the
4294 previous iteration. */
4295 goto done;
4296
4297 case AR_UNKNOWN:
4298 return NULL;
4299
4300 case AR_SECTION:
4301 as = ref->u.ar.as;
4302 goto done;
4303 }
4304
4305 gcc_unreachable ();
4306
4307 case REF_COMPONENT:
4308 as = ref->u.c.component->as;
4309 continue;
4310
4311 case REF_SUBSTRING:
4312 case REF_INQUIRY:
4313 continue;
4314 }
4315 }
4316
4317 if (!as)
4318 gcc_unreachable ();
4319
4320 done:
4321
4322 if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
4323 return NULL;
4324
4325 if (dim == NULL)
4326 {
4327 /* Multi-dimensional cobounds. */
4328 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4329 gfc_expr *e;
4330 int k;
4331
4332 /* Simplify the cobounds for each dimension. */
4333 for (d = 0; d < as->corank; d++)
4334 {
4335 bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
4336 upper, as, ref, true);
4337 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4338 {
4339 int j;
4340
4341 for (j = 0; j < d; j++)
4342 gfc_free_expr (bounds[j]);
4343 return bounds[d];
4344 }
4345 }
4346
4347 /* Allocate the result expression. */
4348 e = gfc_get_expr ();
4349 e->where = array->where;
4350 e->expr_type = EXPR_ARRAY;
4351 e->ts.type = BT_INTEGER;
4352 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
4353 gfc_default_integer_kind);
4354 if (k == -1)
4355 {
4356 gfc_free_expr (e);
4357 return &gfc_bad_expr;
4358 }
4359 e->ts.kind = k;
4360
4361 /* The result is a rank 1 array; its size is the rank of the first
4362 argument to {L,U}COBOUND. */
4363 e->rank = 1;
4364 e->shape = gfc_get_shape (1);
4365 mpz_init_set_ui (e->shape[0], as->corank);
4366
4367 /* Create the constructor for this array. */
4368 for (d = 0; d < as->corank; d++)
4369 gfc_constructor_append_expr (&e->value.constructor,
4370 bounds[d], &e->where);
4371 return e;
4372 }
4373 else
4374 {
4375 /* A DIM argument is specified. */
4376 if (dim->expr_type != EXPR_CONSTANT)
4377 return NULL;
4378
4379 d = mpz_get_si (dim->value.integer);
4380
4381 if (d < 1 || d > as->corank)
4382 {
4383 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4384 return &gfc_bad_expr;
4385 }
4386
4387 return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
4388 }
4389 }
4390
4391
4392 gfc_expr *
gfc_simplify_lbound(gfc_expr * array,gfc_expr * dim,gfc_expr * kind)4393 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4394 {
4395 return simplify_bound (array, dim, kind, 0);
4396 }
4397
4398
4399 gfc_expr *
gfc_simplify_lcobound(gfc_expr * array,gfc_expr * dim,gfc_expr * kind)4400 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4401 {
4402 return simplify_cobound (array, dim, kind, 0);
4403 }
4404
4405 gfc_expr *
gfc_simplify_leadz(gfc_expr * e)4406 gfc_simplify_leadz (gfc_expr *e)
4407 {
4408 unsigned long lz, bs;
4409 int i;
4410
4411 if (e->expr_type != EXPR_CONSTANT)
4412 return NULL;
4413
4414 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4415 bs = gfc_integer_kinds[i].bit_size;
4416 if (mpz_cmp_si (e->value.integer, 0) == 0)
4417 lz = bs;
4418 else if (mpz_cmp_si (e->value.integer, 0) < 0)
4419 lz = 0;
4420 else
4421 lz = bs - mpz_sizeinbase (e->value.integer, 2);
4422
4423 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4424 }
4425
4426
4427 gfc_expr *
gfc_simplify_len(gfc_expr * e,gfc_expr * kind)4428 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
4429 {
4430 gfc_expr *result;
4431 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
4432
4433 if (k == -1)
4434 return &gfc_bad_expr;
4435
4436 if (e->expr_type == EXPR_CONSTANT)
4437 {
4438 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4439 mpz_set_si (result->value.integer, e->value.character.length);
4440 return range_check (result, "LEN");
4441 }
4442 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
4443 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
4444 && e->ts.u.cl->length->ts.type == BT_INTEGER)
4445 {
4446 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4447 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
4448 return range_check (result, "LEN");
4449 }
4450 else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
4451 && e->symtree->n.sym
4452 && e->symtree->n.sym->ts.type != BT_DERIVED
4453 && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
4454 && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
4455 && e->symtree->n.sym->assoc->target->symtree->n.sym
4456 && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
4457
4458 /* The expression in assoc->target points to a ref to the _data component
4459 of the unlimited polymorphic entity. To get the _len component the last
4460 _data ref needs to be stripped and a ref to the _len component added. */
4461 return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
4462 else
4463 return NULL;
4464 }
4465
4466
4467 gfc_expr *
gfc_simplify_len_trim(gfc_expr * e,gfc_expr * kind)4468 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
4469 {
4470 gfc_expr *result;
4471 size_t count, len, i;
4472 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
4473
4474 if (k == -1)
4475 return &gfc_bad_expr;
4476
4477 if (e->expr_type != EXPR_CONSTANT)
4478 return NULL;
4479
4480 len = e->value.character.length;
4481 for (count = 0, i = 1; i <= len; i++)
4482 if (e->value.character.string[len - i] == ' ')
4483 count++;
4484 else
4485 break;
4486
4487 result = gfc_get_int_expr (k, &e->where, len - count);
4488 return range_check (result, "LEN_TRIM");
4489 }
4490
4491 gfc_expr *
gfc_simplify_lgamma(gfc_expr * x)4492 gfc_simplify_lgamma (gfc_expr *x)
4493 {
4494 gfc_expr *result;
4495 int sg;
4496
4497 if (x->expr_type != EXPR_CONSTANT)
4498 return NULL;
4499
4500 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4501 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
4502
4503 return range_check (result, "LGAMMA");
4504 }
4505
4506
4507 gfc_expr *
gfc_simplify_lge(gfc_expr * a,gfc_expr * b)4508 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4509 {
4510 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4511 return NULL;
4512
4513 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4514 gfc_compare_string (a, b) >= 0);
4515 }
4516
4517
4518 gfc_expr *
gfc_simplify_lgt(gfc_expr * a,gfc_expr * b)4519 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4520 {
4521 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4522 return NULL;
4523
4524 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4525 gfc_compare_string (a, b) > 0);
4526 }
4527
4528
4529 gfc_expr *
gfc_simplify_lle(gfc_expr * a,gfc_expr * b)4530 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4531 {
4532 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4533 return NULL;
4534
4535 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4536 gfc_compare_string (a, b) <= 0);
4537 }
4538
4539
4540 gfc_expr *
gfc_simplify_llt(gfc_expr * a,gfc_expr * b)4541 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4542 {
4543 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4544 return NULL;
4545
4546 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4547 gfc_compare_string (a, b) < 0);
4548 }
4549
4550
4551 gfc_expr *
gfc_simplify_log(gfc_expr * x)4552 gfc_simplify_log (gfc_expr *x)
4553 {
4554 gfc_expr *result;
4555
4556 if (x->expr_type != EXPR_CONSTANT)
4557 return NULL;
4558
4559 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4560
4561 switch (x->ts.type)
4562 {
4563 case BT_REAL:
4564 if (mpfr_sgn (x->value.real) <= 0)
4565 {
4566 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4567 "to zero", &x->where);
4568 gfc_free_expr (result);
4569 return &gfc_bad_expr;
4570 }
4571
4572 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
4573 break;
4574
4575 case BT_COMPLEX:
4576 if (mpfr_zero_p (mpc_realref (x->value.complex))
4577 && mpfr_zero_p (mpc_imagref (x->value.complex)))
4578 {
4579 gfc_error ("Complex argument of LOG at %L cannot be zero",
4580 &x->where);
4581 gfc_free_expr (result);
4582 return &gfc_bad_expr;
4583 }
4584
4585 gfc_set_model_kind (x->ts.kind);
4586 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4587 break;
4588
4589 default:
4590 gfc_internal_error ("gfc_simplify_log: bad type");
4591 }
4592
4593 return range_check (result, "LOG");
4594 }
4595
4596
4597 gfc_expr *
gfc_simplify_log10(gfc_expr * x)4598 gfc_simplify_log10 (gfc_expr *x)
4599 {
4600 gfc_expr *result;
4601
4602 if (x->expr_type != EXPR_CONSTANT)
4603 return NULL;
4604
4605 if (mpfr_sgn (x->value.real) <= 0)
4606 {
4607 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4608 "to zero", &x->where);
4609 return &gfc_bad_expr;
4610 }
4611
4612 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4613 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
4614
4615 return range_check (result, "LOG10");
4616 }
4617
4618
4619 gfc_expr *
gfc_simplify_logical(gfc_expr * e,gfc_expr * k)4620 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4621 {
4622 int kind;
4623
4624 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
4625 if (kind < 0)
4626 return &gfc_bad_expr;
4627
4628 if (e->expr_type != EXPR_CONSTANT)
4629 return NULL;
4630
4631 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4632 }
4633
4634
4635 gfc_expr*
gfc_simplify_matmul(gfc_expr * matrix_a,gfc_expr * matrix_b)4636 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4637 {
4638 gfc_expr *result;
4639 int row, result_rows, col, result_columns;
4640 int stride_a, offset_a, stride_b, offset_b;
4641
4642 if (!is_constant_array_expr (matrix_a)
4643 || !is_constant_array_expr (matrix_b))
4644 return NULL;
4645
4646 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4647 if (matrix_a->ts.type != matrix_b->ts.type)
4648 {
4649 gfc_expr e;
4650 e.expr_type = EXPR_OP;
4651 gfc_clear_ts (&e.ts);
4652 e.value.op.op = INTRINSIC_NONE;
4653 e.value.op.op1 = matrix_a;
4654 e.value.op.op2 = matrix_b;
4655 gfc_type_convert_binary (&e, 1);
4656 result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
4657 }
4658 else
4659 {
4660 result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
4661 &matrix_a->where);
4662 }
4663
4664 if (matrix_a->rank == 1 && matrix_b->rank == 2)
4665 {
4666 result_rows = 1;
4667 result_columns = mpz_get_si (matrix_b->shape[1]);
4668 stride_a = 1;
4669 stride_b = mpz_get_si (matrix_b->shape[0]);
4670
4671 result->rank = 1;
4672 result->shape = gfc_get_shape (result->rank);
4673 mpz_init_set_si (result->shape[0], result_columns);
4674 }
4675 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
4676 {
4677 result_rows = mpz_get_si (matrix_a->shape[0]);
4678 result_columns = 1;
4679 stride_a = mpz_get_si (matrix_a->shape[0]);
4680 stride_b = 1;
4681
4682 result->rank = 1;
4683 result->shape = gfc_get_shape (result->rank);
4684 mpz_init_set_si (result->shape[0], result_rows);
4685 }
4686 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
4687 {
4688 result_rows = mpz_get_si (matrix_a->shape[0]);
4689 result_columns = mpz_get_si (matrix_b->shape[1]);
4690 stride_a = mpz_get_si (matrix_a->shape[0]);
4691 stride_b = mpz_get_si (matrix_b->shape[0]);
4692
4693 result->rank = 2;
4694 result->shape = gfc_get_shape (result->rank);
4695 mpz_init_set_si (result->shape[0], result_rows);
4696 mpz_init_set_si (result->shape[1], result_columns);
4697 }
4698 else
4699 gcc_unreachable();
4700
4701 offset_b = 0;
4702 for (col = 0; col < result_columns; ++col)
4703 {
4704 offset_a = 0;
4705
4706 for (row = 0; row < result_rows; ++row)
4707 {
4708 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
4709 matrix_b, 1, offset_b, false);
4710 gfc_constructor_append_expr (&result->value.constructor,
4711 e, NULL);
4712
4713 offset_a += 1;
4714 }
4715
4716 offset_b += stride_b;
4717 }
4718
4719 return result;
4720 }
4721
4722
4723 gfc_expr *
gfc_simplify_maskr(gfc_expr * i,gfc_expr * kind_arg)4724 gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4725 {
4726 gfc_expr *result;
4727 int kind, arg, k;
4728
4729 if (i->expr_type != EXPR_CONSTANT)
4730 return NULL;
4731
4732 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
4733 if (kind == -1)
4734 return &gfc_bad_expr;
4735 k = gfc_validate_kind (BT_INTEGER, kind, false);
4736
4737 bool fail = gfc_extract_int (i, &arg);
4738 gcc_assert (!fail);
4739
4740 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4741
4742 /* MASKR(n) = 2^n - 1 */
4743 mpz_set_ui (result->value.integer, 1);
4744 mpz_mul_2exp (result->value.integer, result->value.integer, arg);
4745 mpz_sub_ui (result->value.integer, result->value.integer, 1);
4746
4747 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4748
4749 return result;
4750 }
4751
4752
4753 gfc_expr *
gfc_simplify_maskl(gfc_expr * i,gfc_expr * kind_arg)4754 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4755 {
4756 gfc_expr *result;
4757 int kind, arg, k;
4758 mpz_t z;
4759
4760 if (i->expr_type != EXPR_CONSTANT)
4761 return NULL;
4762
4763 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
4764 if (kind == -1)
4765 return &gfc_bad_expr;
4766 k = gfc_validate_kind (BT_INTEGER, kind, false);
4767
4768 bool fail = gfc_extract_int (i, &arg);
4769 gcc_assert (!fail);
4770
4771 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4772
4773 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4774 mpz_init_set_ui (z, 1);
4775 mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
4776 mpz_set_ui (result->value.integer, 1);
4777 mpz_mul_2exp (result->value.integer, result->value.integer,
4778 gfc_integer_kinds[k].bit_size - arg);
4779 mpz_sub (result->value.integer, z, result->value.integer);
4780 mpz_clear (z);
4781
4782 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4783
4784 return result;
4785 }
4786
4787
4788 gfc_expr *
gfc_simplify_merge(gfc_expr * tsource,gfc_expr * fsource,gfc_expr * mask)4789 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4790 {
4791 gfc_expr * result;
4792 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
4793
4794 if (mask->expr_type == EXPR_CONSTANT)
4795 {
4796 result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
4797 /* Parenthesis is needed to get lower bounds of 1. */
4798 result = gfc_get_parentheses (result);
4799 gfc_simplify_expr (result, 1);
4800 return result;
4801 }
4802
4803 if (!mask->rank || !is_constant_array_expr (mask)
4804 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
4805 return NULL;
4806
4807 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
4808 &tsource->where);
4809 if (tsource->ts.type == BT_DERIVED)
4810 result->ts.u.derived = tsource->ts.u.derived;
4811 else if (tsource->ts.type == BT_CHARACTER)
4812 result->ts.u.cl = tsource->ts.u.cl;
4813
4814 tsource_ctor = gfc_constructor_first (tsource->value.constructor);
4815 fsource_ctor = gfc_constructor_first (fsource->value.constructor);
4816 mask_ctor = gfc_constructor_first (mask->value.constructor);
4817
4818 while (mask_ctor)
4819 {
4820 if (mask_ctor->expr->value.logical)
4821 gfc_constructor_append_expr (&result->value.constructor,
4822 gfc_copy_expr (tsource_ctor->expr),
4823 NULL);
4824 else
4825 gfc_constructor_append_expr (&result->value.constructor,
4826 gfc_copy_expr (fsource_ctor->expr),
4827 NULL);
4828 tsource_ctor = gfc_constructor_next (tsource_ctor);
4829 fsource_ctor = gfc_constructor_next (fsource_ctor);
4830 mask_ctor = gfc_constructor_next (mask_ctor);
4831 }
4832
4833 result->shape = gfc_get_shape (1);
4834 gfc_array_size (result, &result->shape[0]);
4835
4836 return result;
4837 }
4838
4839
4840 gfc_expr *
gfc_simplify_merge_bits(gfc_expr * i,gfc_expr * j,gfc_expr * mask_expr)4841 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4842 {
4843 mpz_t arg1, arg2, mask;
4844 gfc_expr *result;
4845
4846 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
4847 || mask_expr->expr_type != EXPR_CONSTANT)
4848 return NULL;
4849
4850 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4851
4852 /* Convert all argument to unsigned. */
4853 mpz_init_set (arg1, i->value.integer);
4854 mpz_init_set (arg2, j->value.integer);
4855 mpz_init_set (mask, mask_expr->value.integer);
4856
4857 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4858 mpz_and (arg1, arg1, mask);
4859 mpz_com (mask, mask);
4860 mpz_and (arg2, arg2, mask);
4861 mpz_ior (result->value.integer, arg1, arg2);
4862
4863 mpz_clear (arg1);
4864 mpz_clear (arg2);
4865 mpz_clear (mask);
4866
4867 return result;
4868 }
4869
4870
4871 /* Selects between current value and extremum for simplify_min_max
4872 and simplify_minval_maxval. */
4873 static int
min_max_choose(gfc_expr * arg,gfc_expr * extremum,int sign,bool back_val)4874 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
4875 {
4876 int ret;
4877
4878 switch (arg->ts.type)
4879 {
4880 case BT_INTEGER:
4881 ret = mpz_cmp (arg->value.integer,
4882 extremum->value.integer) * sign;
4883 if (ret > 0)
4884 mpz_set (extremum->value.integer, arg->value.integer);
4885 break;
4886
4887 case BT_REAL:
4888 if (mpfr_nan_p (extremum->value.real))
4889 {
4890 ret = 1;
4891 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
4892 }
4893 else if (mpfr_nan_p (arg->value.real))
4894 ret = -1;
4895 else
4896 {
4897 ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
4898 if (ret > 0)
4899 mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
4900 }
4901 break;
4902
4903 case BT_CHARACTER:
4904 #define LENGTH(x) ((x)->value.character.length)
4905 #define STRING(x) ((x)->value.character.string)
4906 if (LENGTH (extremum) < LENGTH(arg))
4907 {
4908 gfc_char_t *tmp = STRING(extremum);
4909
4910 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4911 memcpy (STRING(extremum), tmp,
4912 LENGTH(extremum) * sizeof (gfc_char_t));
4913 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4914 LENGTH(arg) - LENGTH(extremum));
4915 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
4916 LENGTH(extremum) = LENGTH(arg);
4917 free (tmp);
4918 }
4919 ret = gfc_compare_string (arg, extremum) * sign;
4920 if (ret > 0)
4921 {
4922 free (STRING(extremum));
4923 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4924 memcpy (STRING(extremum), STRING(arg),
4925 LENGTH(arg) * sizeof (gfc_char_t));
4926 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4927 LENGTH(extremum) - LENGTH(arg));
4928 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
4929 }
4930 #undef LENGTH
4931 #undef STRING
4932 break;
4933
4934 default:
4935 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4936 }
4937 if (back_val && ret == 0)
4938 ret = 1;
4939
4940 return ret;
4941 }
4942
4943
4944 /* This function is special since MAX() can take any number of
4945 arguments. The simplified expression is a rewritten version of the
4946 argument list containing at most one constant element. Other
4947 constant elements are deleted. Because the argument list has
4948 already been checked, this function always succeeds. sign is 1 for
4949 MAX(), -1 for MIN(). */
4950
4951 static gfc_expr *
simplify_min_max(gfc_expr * expr,int sign)4952 simplify_min_max (gfc_expr *expr, int sign)
4953 {
4954 gfc_actual_arglist *arg, *last, *extremum;
4955 gfc_expr *tmp, *ret;
4956 const char *fname;
4957
4958 last = NULL;
4959 extremum = NULL;
4960
4961 arg = expr->value.function.actual;
4962
4963 for (; arg; last = arg, arg = arg->next)
4964 {
4965 if (arg->expr->expr_type != EXPR_CONSTANT)
4966 continue;
4967
4968 if (extremum == NULL)
4969 {
4970 extremum = arg;
4971 continue;
4972 }
4973
4974 min_max_choose (arg->expr, extremum->expr, sign);
4975
4976 /* Delete the extra constant argument. */
4977 last->next = arg->next;
4978
4979 arg->next = NULL;
4980 gfc_free_actual_arglist (arg);
4981 arg = last;
4982 }
4983
4984 /* If there is one value left, replace the function call with the
4985 expression. */
4986 if (expr->value.function.actual->next != NULL)
4987 return NULL;
4988
4989 /* Handle special cases of specific functions (min|max)1 and
4990 a(min|max)0. */
4991
4992 tmp = expr->value.function.actual->expr;
4993 fname = expr->value.function.isym->name;
4994
4995 if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
4996 && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
4997 {
4998 ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
4999 }
5000 else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
5001 && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
5002 {
5003 ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
5004 }
5005 else
5006 ret = gfc_copy_expr (tmp);
5007
5008 return ret;
5009
5010 }
5011
5012
5013 gfc_expr *
gfc_simplify_min(gfc_expr * e)5014 gfc_simplify_min (gfc_expr *e)
5015 {
5016 return simplify_min_max (e, -1);
5017 }
5018
5019
5020 gfc_expr *
gfc_simplify_max(gfc_expr * e)5021 gfc_simplify_max (gfc_expr *e)
5022 {
5023 return simplify_min_max (e, 1);
5024 }
5025
5026 /* Helper function for gfc_simplify_minval. */
5027
5028 static gfc_expr *
gfc_min(gfc_expr * op1,gfc_expr * op2)5029 gfc_min (gfc_expr *op1, gfc_expr *op2)
5030 {
5031 min_max_choose (op1, op2, -1);
5032 gfc_free_expr (op1);
5033 return op2;
5034 }
5035
5036 /* Simplify minval for constant arrays. */
5037
5038 gfc_expr *
gfc_simplify_minval(gfc_expr * array,gfc_expr * dim,gfc_expr * mask)5039 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5040 {
5041 return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
5042 }
5043
5044 /* Helper function for gfc_simplify_maxval. */
5045
5046 static gfc_expr *
gfc_max(gfc_expr * op1,gfc_expr * op2)5047 gfc_max (gfc_expr *op1, gfc_expr *op2)
5048 {
5049 min_max_choose (op1, op2, 1);
5050 gfc_free_expr (op1);
5051 return op2;
5052 }
5053
5054
5055 /* Simplify maxval for constant arrays. */
5056
5057 gfc_expr *
gfc_simplify_maxval(gfc_expr * array,gfc_expr * dim,gfc_expr * mask)5058 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5059 {
5060 return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
5061 }
5062
5063
5064 /* Transform minloc or maxloc of an array, according to MASK,
5065 to the scalar result. This code is mostly identical to
5066 simplify_transformation_to_scalar. */
5067
5068 static gfc_expr *
simplify_minmaxloc_to_scalar(gfc_expr * result,gfc_expr * array,gfc_expr * mask,gfc_expr * extremum,int sign,bool back_val)5069 simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5070 gfc_expr *extremum, int sign, bool back_val)
5071 {
5072 gfc_expr *a, *m;
5073 gfc_constructor *array_ctor, *mask_ctor;
5074 mpz_t count;
5075
5076 mpz_set_si (result->value.integer, 0);
5077
5078
5079 /* Shortcut for constant .FALSE. MASK. */
5080 if (mask
5081 && mask->expr_type == EXPR_CONSTANT
5082 && !mask->value.logical)
5083 return result;
5084
5085 array_ctor = gfc_constructor_first (array->value.constructor);
5086 if (mask && mask->expr_type == EXPR_ARRAY)
5087 mask_ctor = gfc_constructor_first (mask->value.constructor);
5088 else
5089 mask_ctor = NULL;
5090
5091 mpz_init_set_si (count, 0);
5092 while (array_ctor)
5093 {
5094 mpz_add_ui (count, count, 1);
5095 a = array_ctor->expr;
5096 array_ctor = gfc_constructor_next (array_ctor);
5097 /* A constant MASK equals .TRUE. here and can be ignored. */
5098 if (mask_ctor)
5099 {
5100 m = mask_ctor->expr;
5101 mask_ctor = gfc_constructor_next (mask_ctor);
5102 if (!m->value.logical)
5103 continue;
5104 }
5105 if (min_max_choose (a, extremum, sign, back_val) > 0)
5106 mpz_set (result->value.integer, count);
5107 }
5108 mpz_clear (count);
5109 gfc_free_expr (extremum);
5110 return result;
5111 }
5112
5113 /* Simplify minloc / maxloc in the absence of a dim argument. */
5114
5115 static gfc_expr *
simplify_minmaxloc_nodim(gfc_expr * result,gfc_expr * extremum,gfc_expr * array,gfc_expr * mask,int sign,bool back_val)5116 simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5117 gfc_expr *array, gfc_expr *mask, int sign,
5118 bool back_val)
5119 {
5120 ssize_t res[GFC_MAX_DIMENSIONS];
5121 int i, n;
5122 gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5123 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5124 sstride[GFC_MAX_DIMENSIONS];
5125 gfc_expr *a, *m;
5126 bool continue_loop;
5127 bool ma;
5128
5129 for (i = 0; i<array->rank; i++)
5130 res[i] = -1;
5131
5132 /* Shortcut for constant .FALSE. MASK. */
5133 if (mask
5134 && mask->expr_type == EXPR_CONSTANT
5135 && !mask->value.logical)
5136 goto finish;
5137
5138 for (i = 0; i < array->rank; i++)
5139 {
5140 count[i] = 0;
5141 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5142 extent[i] = mpz_get_si (array->shape[i]);
5143 if (extent[i] <= 0)
5144 goto finish;
5145 }
5146
5147 continue_loop = true;
5148 array_ctor = gfc_constructor_first (array->value.constructor);
5149 if (mask && mask->rank > 0)
5150 mask_ctor = gfc_constructor_first (mask->value.constructor);
5151 else
5152 mask_ctor = NULL;
5153
5154 /* Loop over the array elements (and mask), keeping track of
5155 the indices to return. */
5156 while (continue_loop)
5157 {
5158 do
5159 {
5160 a = array_ctor->expr;
5161 if (mask_ctor)
5162 {
5163 m = mask_ctor->expr;
5164 ma = m->value.logical;
5165 mask_ctor = gfc_constructor_next (mask_ctor);
5166 }
5167 else
5168 ma = true;
5169
5170 if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
5171 {
5172 for (i = 0; i<array->rank; i++)
5173 res[i] = count[i];
5174 }
5175 array_ctor = gfc_constructor_next (array_ctor);
5176 count[0] ++;
5177 } while (count[0] != extent[0]);
5178 n = 0;
5179 do
5180 {
5181 /* When we get to the end of a dimension, reset it and increment
5182 the next dimension. */
5183 count[n] = 0;
5184 n++;
5185 if (n >= array->rank)
5186 {
5187 continue_loop = false;
5188 break;
5189 }
5190 else
5191 count[n] ++;
5192 } while (count[n] == extent[n]);
5193 }
5194
5195 finish:
5196 gfc_free_expr (extremum);
5197 result_ctor = gfc_constructor_first (result->value.constructor);
5198 for (i = 0; i<array->rank; i++)
5199 {
5200 gfc_expr *r_expr;
5201 r_expr = result_ctor->expr;
5202 mpz_set_si (r_expr->value.integer, res[i] + 1);
5203 result_ctor = gfc_constructor_next (result_ctor);
5204 }
5205 return result;
5206 }
5207
5208 /* Helper function for gfc_simplify_minmaxloc - build an array
5209 expression with n elements. */
5210
5211 static gfc_expr *
new_array(bt type,int kind,int n,locus * where)5212 new_array (bt type, int kind, int n, locus *where)
5213 {
5214 gfc_expr *result;
5215 int i;
5216
5217 result = gfc_get_array_expr (type, kind, where);
5218 result->rank = 1;
5219 result->shape = gfc_get_shape(1);
5220 mpz_init_set_si (result->shape[0], n);
5221 for (i = 0; i < n; i++)
5222 {
5223 gfc_constructor_append_expr (&result->value.constructor,
5224 gfc_get_constant_expr (type, kind, where),
5225 NULL);
5226 }
5227
5228 return result;
5229 }
5230
5231 /* Simplify minloc and maxloc. This code is mostly identical to
5232 simplify_transformation_to_array. */
5233
5234 static gfc_expr *
simplify_minmaxloc_to_array(gfc_expr * result,gfc_expr * array,gfc_expr * dim,gfc_expr * mask,gfc_expr * extremum,int sign,bool back_val)5235 simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
5236 gfc_expr *dim, gfc_expr *mask,
5237 gfc_expr *extremum, int sign, bool back_val)
5238 {
5239 mpz_t size;
5240 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5241 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5242 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5243
5244 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5245 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5246 tmpstride[GFC_MAX_DIMENSIONS];
5247
5248 /* Shortcut for constant .FALSE. MASK. */
5249 if (mask
5250 && mask->expr_type == EXPR_CONSTANT
5251 && !mask->value.logical)
5252 return result;
5253
5254 /* Build an indexed table for array element expressions to minimize
5255 linked-list traversal. Masked elements are set to NULL. */
5256 gfc_array_size (array, &size);
5257 arraysize = mpz_get_ui (size);
5258 mpz_clear (size);
5259
5260 arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5261
5262 array_ctor = gfc_constructor_first (array->value.constructor);
5263 mask_ctor = NULL;
5264 if (mask && mask->expr_type == EXPR_ARRAY)
5265 mask_ctor = gfc_constructor_first (mask->value.constructor);
5266
5267 for (i = 0; i < arraysize; ++i)
5268 {
5269 arrayvec[i] = array_ctor->expr;
5270 array_ctor = gfc_constructor_next (array_ctor);
5271
5272 if (mask_ctor)
5273 {
5274 if (!mask_ctor->expr->value.logical)
5275 arrayvec[i] = NULL;
5276
5277 mask_ctor = gfc_constructor_next (mask_ctor);
5278 }
5279 }
5280
5281 /* Same for the result expression. */
5282 gfc_array_size (result, &size);
5283 resultsize = mpz_get_ui (size);
5284 mpz_clear (size);
5285
5286 resultvec = XCNEWVEC (gfc_expr*, resultsize);
5287 result_ctor = gfc_constructor_first (result->value.constructor);
5288 for (i = 0; i < resultsize; ++i)
5289 {
5290 resultvec[i] = result_ctor->expr;
5291 result_ctor = gfc_constructor_next (result_ctor);
5292 }
5293
5294 gfc_extract_int (dim, &dim_index);
5295 dim_index -= 1; /* zero-base index */
5296 dim_extent = 0;
5297 dim_stride = 0;
5298
5299 for (i = 0, n = 0; i < array->rank; ++i)
5300 {
5301 count[i] = 0;
5302 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5303 if (i == dim_index)
5304 {
5305 dim_extent = mpz_get_si (array->shape[i]);
5306 dim_stride = tmpstride[i];
5307 continue;
5308 }
5309
5310 extent[n] = mpz_get_si (array->shape[i]);
5311 sstride[n] = tmpstride[i];
5312 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5313 n += 1;
5314 }
5315
5316 done = resultsize <= 0;
5317 base = arrayvec;
5318 dest = resultvec;
5319 while (!done)
5320 {
5321 gfc_expr *ex;
5322 ex = gfc_copy_expr (extremum);
5323 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5324 {
5325 if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
5326 mpz_set_si ((*dest)->value.integer, n + 1);
5327 }
5328
5329 count[0]++;
5330 base += sstride[0];
5331 dest += dstride[0];
5332 gfc_free_expr (ex);
5333
5334 n = 0;
5335 while (!done && count[n] == extent[n])
5336 {
5337 count[n] = 0;
5338 base -= sstride[n] * extent[n];
5339 dest -= dstride[n] * extent[n];
5340
5341 n++;
5342 if (n < result->rank)
5343 {
5344 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5345 times, we'd warn for the last iteration, because the
5346 array index will have already been incremented to the
5347 array sizes, and we can't tell that this must make
5348 the test against result->rank false, because ranks
5349 must not exceed GFC_MAX_DIMENSIONS. */
5350 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5351 count[n]++;
5352 base += sstride[n];
5353 dest += dstride[n];
5354 GCC_DIAGNOSTIC_POP
5355 }
5356 else
5357 done = true;
5358 }
5359 }
5360
5361 /* Place updated expression in result constructor. */
5362 result_ctor = gfc_constructor_first (result->value.constructor);
5363 for (i = 0; i < resultsize; ++i)
5364 {
5365 result_ctor->expr = resultvec[i];
5366 result_ctor = gfc_constructor_next (result_ctor);
5367 }
5368
5369 free (arrayvec);
5370 free (resultvec);
5371 free (extremum);
5372 return result;
5373 }
5374
5375 /* Simplify minloc and maxloc for constant arrays. */
5376
5377 static gfc_expr *
gfc_simplify_minmaxloc(gfc_expr * array,gfc_expr * dim,gfc_expr * mask,gfc_expr * kind,gfc_expr * back,int sign)5378 gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
5379 gfc_expr *kind, gfc_expr *back, int sign)
5380 {
5381 gfc_expr *result;
5382 gfc_expr *extremum;
5383 int ikind;
5384 int init_val;
5385 bool back_val = false;
5386
5387 if (!is_constant_array_expr (array)
5388 || !gfc_is_constant_expr (dim))
5389 return NULL;
5390
5391 if (mask
5392 && !is_constant_array_expr (mask)
5393 && mask->expr_type != EXPR_CONSTANT)
5394 return NULL;
5395
5396 if (kind)
5397 {
5398 if (gfc_extract_int (kind, &ikind, -1))
5399 return NULL;
5400 }
5401 else
5402 ikind = gfc_default_integer_kind;
5403
5404 if (back)
5405 {
5406 if (back->expr_type != EXPR_CONSTANT)
5407 return NULL;
5408
5409 back_val = back->value.logical;
5410 }
5411
5412 if (sign < 0)
5413 init_val = INT_MAX;
5414 else if (sign > 0)
5415 init_val = INT_MIN;
5416 else
5417 gcc_unreachable();
5418
5419 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
5420 init_result_expr (extremum, init_val, array);
5421
5422 if (dim)
5423 {
5424 result = transformational_result (array, dim, BT_INTEGER,
5425 ikind, &array->where);
5426 init_result_expr (result, 0, array);
5427
5428 if (array->rank == 1)
5429 return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
5430 sign, back_val);
5431 else
5432 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
5433 sign, back_val);
5434 }
5435 else
5436 {
5437 result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5438 return simplify_minmaxloc_nodim (result, extremum, array, mask,
5439 sign, back_val);
5440 }
5441 }
5442
5443 gfc_expr *
gfc_simplify_minloc(gfc_expr * array,gfc_expr * dim,gfc_expr * mask,gfc_expr * kind,gfc_expr * back)5444 gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5445 gfc_expr *back)
5446 {
5447 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
5448 }
5449
5450 gfc_expr *
gfc_simplify_maxloc(gfc_expr * array,gfc_expr * dim,gfc_expr * mask,gfc_expr * kind,gfc_expr * back)5451 gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5452 gfc_expr *back)
5453 {
5454 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
5455 }
5456
5457 /* Simplify findloc to scalar. Similar to
5458 simplify_minmaxloc_to_scalar. */
5459
5460 static gfc_expr *
simplify_findloc_to_scalar(gfc_expr * result,gfc_expr * array,gfc_expr * value,gfc_expr * mask,int back_val)5461 simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5462 gfc_expr *mask, int back_val)
5463 {
5464 gfc_expr *a, *m;
5465 gfc_constructor *array_ctor, *mask_ctor;
5466 mpz_t count;
5467
5468 mpz_set_si (result->value.integer, 0);
5469
5470 /* Shortcut for constant .FALSE. MASK. */
5471 if (mask
5472 && mask->expr_type == EXPR_CONSTANT
5473 && !mask->value.logical)
5474 return result;
5475
5476 array_ctor = gfc_constructor_first (array->value.constructor);
5477 if (mask && mask->expr_type == EXPR_ARRAY)
5478 mask_ctor = gfc_constructor_first (mask->value.constructor);
5479 else
5480 mask_ctor = NULL;
5481
5482 mpz_init_set_si (count, 0);
5483 while (array_ctor)
5484 {
5485 mpz_add_ui (count, count, 1);
5486 a = array_ctor->expr;
5487 array_ctor = gfc_constructor_next (array_ctor);
5488 /* A constant MASK equals .TRUE. here and can be ignored. */
5489 if (mask_ctor)
5490 {
5491 m = mask_ctor->expr;
5492 mask_ctor = gfc_constructor_next (mask_ctor);
5493 if (!m->value.logical)
5494 continue;
5495 }
5496 if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5497 {
5498 /* We have a match. If BACK is true, continue so we find
5499 the last one. */
5500 mpz_set (result->value.integer, count);
5501 if (!back_val)
5502 break;
5503 }
5504 }
5505 mpz_clear (count);
5506 return result;
5507 }
5508
5509 /* Simplify findloc in the absence of a dim argument. Similar to
5510 simplify_minmaxloc_nodim. */
5511
5512 static gfc_expr *
simplify_findloc_nodim(gfc_expr * result,gfc_expr * value,gfc_expr * array,gfc_expr * mask,bool back_val)5513 simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
5514 gfc_expr *mask, bool back_val)
5515 {
5516 ssize_t res[GFC_MAX_DIMENSIONS];
5517 int i, n;
5518 gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5519 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5520 sstride[GFC_MAX_DIMENSIONS];
5521 gfc_expr *a, *m;
5522 bool continue_loop;
5523 bool ma;
5524
5525 for (i = 0; i < array->rank; i++)
5526 res[i] = -1;
5527
5528 /* Shortcut for constant .FALSE. MASK. */
5529 if (mask
5530 && mask->expr_type == EXPR_CONSTANT
5531 && !mask->value.logical)
5532 goto finish;
5533
5534 for (i = 0; i < array->rank; i++)
5535 {
5536 count[i] = 0;
5537 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5538 extent[i] = mpz_get_si (array->shape[i]);
5539 if (extent[i] <= 0)
5540 goto finish;
5541 }
5542
5543 continue_loop = true;
5544 array_ctor = gfc_constructor_first (array->value.constructor);
5545 if (mask && mask->rank > 0)
5546 mask_ctor = gfc_constructor_first (mask->value.constructor);
5547 else
5548 mask_ctor = NULL;
5549
5550 /* Loop over the array elements (and mask), keeping track of
5551 the indices to return. */
5552 while (continue_loop)
5553 {
5554 do
5555 {
5556 a = array_ctor->expr;
5557 if (mask_ctor)
5558 {
5559 m = mask_ctor->expr;
5560 ma = m->value.logical;
5561 mask_ctor = gfc_constructor_next (mask_ctor);
5562 }
5563 else
5564 ma = true;
5565
5566 if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5567 {
5568 for (i = 0; i < array->rank; i++)
5569 res[i] = count[i];
5570 if (!back_val)
5571 goto finish;
5572 }
5573 array_ctor = gfc_constructor_next (array_ctor);
5574 count[0] ++;
5575 } while (count[0] != extent[0]);
5576 n = 0;
5577 do
5578 {
5579 /* When we get to the end of a dimension, reset it and increment
5580 the next dimension. */
5581 count[n] = 0;
5582 n++;
5583 if (n >= array->rank)
5584 {
5585 continue_loop = false;
5586 break;
5587 }
5588 else
5589 count[n] ++;
5590 } while (count[n] == extent[n]);
5591 }
5592
5593 finish:
5594 result_ctor = gfc_constructor_first (result->value.constructor);
5595 for (i = 0; i < array->rank; i++)
5596 {
5597 gfc_expr *r_expr;
5598 r_expr = result_ctor->expr;
5599 mpz_set_si (r_expr->value.integer, res[i] + 1);
5600 result_ctor = gfc_constructor_next (result_ctor);
5601 }
5602 return result;
5603 }
5604
5605
5606 /* Simplify findloc to an array. Similar to
5607 simplify_minmaxloc_to_array. */
5608
5609 static gfc_expr *
simplify_findloc_to_array(gfc_expr * result,gfc_expr * array,gfc_expr * value,gfc_expr * dim,gfc_expr * mask,bool back_val)5610 simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5611 gfc_expr *dim, gfc_expr *mask, bool back_val)
5612 {
5613 mpz_t size;
5614 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5615 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5616 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5617
5618 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5619 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5620 tmpstride[GFC_MAX_DIMENSIONS];
5621
5622 /* Shortcut for constant .FALSE. MASK. */
5623 if (mask
5624 && mask->expr_type == EXPR_CONSTANT
5625 && !mask->value.logical)
5626 return result;
5627
5628 /* Build an indexed table for array element expressions to minimize
5629 linked-list traversal. Masked elements are set to NULL. */
5630 gfc_array_size (array, &size);
5631 arraysize = mpz_get_ui (size);
5632 mpz_clear (size);
5633
5634 arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5635
5636 array_ctor = gfc_constructor_first (array->value.constructor);
5637 mask_ctor = NULL;
5638 if (mask && mask->expr_type == EXPR_ARRAY)
5639 mask_ctor = gfc_constructor_first (mask->value.constructor);
5640
5641 for (i = 0; i < arraysize; ++i)
5642 {
5643 arrayvec[i] = array_ctor->expr;
5644 array_ctor = gfc_constructor_next (array_ctor);
5645
5646 if (mask_ctor)
5647 {
5648 if (!mask_ctor->expr->value.logical)
5649 arrayvec[i] = NULL;
5650
5651 mask_ctor = gfc_constructor_next (mask_ctor);
5652 }
5653 }
5654
5655 /* Same for the result expression. */
5656 gfc_array_size (result, &size);
5657 resultsize = mpz_get_ui (size);
5658 mpz_clear (size);
5659
5660 resultvec = XCNEWVEC (gfc_expr*, resultsize);
5661 result_ctor = gfc_constructor_first (result->value.constructor);
5662 for (i = 0; i < resultsize; ++i)
5663 {
5664 resultvec[i] = result_ctor->expr;
5665 result_ctor = gfc_constructor_next (result_ctor);
5666 }
5667
5668 gfc_extract_int (dim, &dim_index);
5669
5670 dim_index -= 1; /* Zero-base index. */
5671 dim_extent = 0;
5672 dim_stride = 0;
5673
5674 for (i = 0, n = 0; i < array->rank; ++i)
5675 {
5676 count[i] = 0;
5677 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5678 if (i == dim_index)
5679 {
5680 dim_extent = mpz_get_si (array->shape[i]);
5681 dim_stride = tmpstride[i];
5682 continue;
5683 }
5684
5685 extent[n] = mpz_get_si (array->shape[i]);
5686 sstride[n] = tmpstride[i];
5687 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5688 n += 1;
5689 }
5690
5691 done = resultsize <= 0;
5692 base = arrayvec;
5693 dest = resultvec;
5694 while (!done)
5695 {
5696 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5697 {
5698 if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
5699 {
5700 mpz_set_si ((*dest)->value.integer, n + 1);
5701 if (!back_val)
5702 break;
5703 }
5704 }
5705
5706 count[0]++;
5707 base += sstride[0];
5708 dest += dstride[0];
5709
5710 n = 0;
5711 while (!done && count[n] == extent[n])
5712 {
5713 count[n] = 0;
5714 base -= sstride[n] * extent[n];
5715 dest -= dstride[n] * extent[n];
5716
5717 n++;
5718 if (n < result->rank)
5719 {
5720 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5721 times, we'd warn for the last iteration, because the
5722 array index will have already been incremented to the
5723 array sizes, and we can't tell that this must make
5724 the test against result->rank false, because ranks
5725 must not exceed GFC_MAX_DIMENSIONS. */
5726 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5727 count[n]++;
5728 base += sstride[n];
5729 dest += dstride[n];
5730 GCC_DIAGNOSTIC_POP
5731 }
5732 else
5733 done = true;
5734 }
5735 }
5736
5737 /* Place updated expression in result constructor. */
5738 result_ctor = gfc_constructor_first (result->value.constructor);
5739 for (i = 0; i < resultsize; ++i)
5740 {
5741 result_ctor->expr = resultvec[i];
5742 result_ctor = gfc_constructor_next (result_ctor);
5743 }
5744
5745 free (arrayvec);
5746 free (resultvec);
5747 return result;
5748 }
5749
5750 /* Simplify findloc. */
5751
5752 gfc_expr *
gfc_simplify_findloc(gfc_expr * array,gfc_expr * value,gfc_expr * dim,gfc_expr * mask,gfc_expr * kind,gfc_expr * back)5753 gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
5754 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
5755 {
5756 gfc_expr *result;
5757 int ikind;
5758 bool back_val = false;
5759
5760 if (!is_constant_array_expr (array)
5761 || array->shape == NULL
5762 || !gfc_is_constant_expr (dim))
5763 return NULL;
5764
5765 if (! gfc_is_constant_expr (value))
5766 return 0;
5767
5768 if (mask
5769 && !is_constant_array_expr (mask)
5770 && mask->expr_type != EXPR_CONSTANT)
5771 return NULL;
5772
5773 if (kind)
5774 {
5775 if (gfc_extract_int (kind, &ikind, -1))
5776 return NULL;
5777 }
5778 else
5779 ikind = gfc_default_integer_kind;
5780
5781 if (back)
5782 {
5783 if (back->expr_type != EXPR_CONSTANT)
5784 return NULL;
5785
5786 back_val = back->value.logical;
5787 }
5788
5789 if (dim)
5790 {
5791 result = transformational_result (array, dim, BT_INTEGER,
5792 ikind, &array->where);
5793 init_result_expr (result, 0, array);
5794
5795 if (array->rank == 1)
5796 return simplify_findloc_to_scalar (result, array, value, mask,
5797 back_val);
5798 else
5799 return simplify_findloc_to_array (result, array, value, dim, mask,
5800 back_val);
5801 }
5802 else
5803 {
5804 result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5805 return simplify_findloc_nodim (result, value, array, mask, back_val);
5806 }
5807 return NULL;
5808 }
5809
5810 gfc_expr *
gfc_simplify_maxexponent(gfc_expr * x)5811 gfc_simplify_maxexponent (gfc_expr *x)
5812 {
5813 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5814 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5815 gfc_real_kinds[i].max_exponent);
5816 }
5817
5818
5819 gfc_expr *
gfc_simplify_minexponent(gfc_expr * x)5820 gfc_simplify_minexponent (gfc_expr *x)
5821 {
5822 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5823 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5824 gfc_real_kinds[i].min_exponent);
5825 }
5826
5827
5828 gfc_expr *
gfc_simplify_mod(gfc_expr * a,gfc_expr * p)5829 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
5830 {
5831 gfc_expr *result;
5832 int kind;
5833
5834 /* First check p. */
5835 if (p->expr_type != EXPR_CONSTANT)
5836 return NULL;
5837
5838 /* p shall not be 0. */
5839 switch (p->ts.type)
5840 {
5841 case BT_INTEGER:
5842 if (mpz_cmp_ui (p->value.integer, 0) == 0)
5843 {
5844 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5845 "P", &p->where);
5846 return &gfc_bad_expr;
5847 }
5848 break;
5849 case BT_REAL:
5850 if (mpfr_cmp_ui (p->value.real, 0) == 0)
5851 {
5852 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5853 "P", &p->where);
5854 return &gfc_bad_expr;
5855 }
5856 break;
5857 default:
5858 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
5859 }
5860
5861 if (a->expr_type != EXPR_CONSTANT)
5862 return NULL;
5863
5864 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
5865 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
5866
5867 if (a->ts.type == BT_INTEGER)
5868 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
5869 else
5870 {
5871 gfc_set_model_kind (kind);
5872 mpfr_fmod (result->value.real, a->value.real, p->value.real,
5873 GFC_RND_MODE);
5874 }
5875
5876 return range_check (result, "MOD");
5877 }
5878
5879
5880 gfc_expr *
gfc_simplify_modulo(gfc_expr * a,gfc_expr * p)5881 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
5882 {
5883 gfc_expr *result;
5884 int kind;
5885
5886 /* First check p. */
5887 if (p->expr_type != EXPR_CONSTANT)
5888 return NULL;
5889
5890 /* p shall not be 0. */
5891 switch (p->ts.type)
5892 {
5893 case BT_INTEGER:
5894 if (mpz_cmp_ui (p->value.integer, 0) == 0)
5895 {
5896 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5897 "P", &p->where);
5898 return &gfc_bad_expr;
5899 }
5900 break;
5901 case BT_REAL:
5902 if (mpfr_cmp_ui (p->value.real, 0) == 0)
5903 {
5904 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5905 "P", &p->where);
5906 return &gfc_bad_expr;
5907 }
5908 break;
5909 default:
5910 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
5911 }
5912
5913 if (a->expr_type != EXPR_CONSTANT)
5914 return NULL;
5915
5916 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
5917 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
5918
5919 if (a->ts.type == BT_INTEGER)
5920 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
5921 else
5922 {
5923 gfc_set_model_kind (kind);
5924 mpfr_fmod (result->value.real, a->value.real, p->value.real,
5925 GFC_RND_MODE);
5926 if (mpfr_cmp_ui (result->value.real, 0) != 0)
5927 {
5928 if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
5929 mpfr_add (result->value.real, result->value.real, p->value.real,
5930 GFC_RND_MODE);
5931 }
5932 else
5933 mpfr_copysign (result->value.real, result->value.real,
5934 p->value.real, GFC_RND_MODE);
5935 }
5936
5937 return range_check (result, "MODULO");
5938 }
5939
5940
5941 gfc_expr *
gfc_simplify_nearest(gfc_expr * x,gfc_expr * s)5942 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
5943 {
5944 gfc_expr *result;
5945 mpfr_exp_t emin, emax;
5946 int kind;
5947
5948 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
5949 return NULL;
5950
5951 result = gfc_copy_expr (x);
5952
5953 /* Save current values of emin and emax. */
5954 emin = mpfr_get_emin ();
5955 emax = mpfr_get_emax ();
5956
5957 /* Set emin and emax for the current model number. */
5958 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
5959 mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
5960 mpfr_get_prec(result->value.real) + 1);
5961 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent);
5962 mpfr_check_range (result->value.real, 0, MPFR_RNDU);
5963
5964 if (mpfr_sgn (s->value.real) > 0)
5965 {
5966 mpfr_nextabove (result->value.real);
5967 mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
5968 }
5969 else
5970 {
5971 mpfr_nextbelow (result->value.real);
5972 mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
5973 }
5974
5975 mpfr_set_emin (emin);
5976 mpfr_set_emax (emax);
5977
5978 /* Only NaN can occur. Do not use range check as it gives an
5979 error for denormal numbers. */
5980 if (mpfr_nan_p (result->value.real) && flag_range_check)
5981 {
5982 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
5983 gfc_free_expr (result);
5984 return &gfc_bad_expr;
5985 }
5986
5987 return result;
5988 }
5989
5990
5991 static gfc_expr *
simplify_nint(const char * name,gfc_expr * e,gfc_expr * k)5992 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
5993 {
5994 gfc_expr *itrunc, *result;
5995 int kind;
5996
5997 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
5998 if (kind == -1)
5999 return &gfc_bad_expr;
6000
6001 if (e->expr_type != EXPR_CONSTANT)
6002 return NULL;
6003
6004 itrunc = gfc_copy_expr (e);
6005 mpfr_round (itrunc->value.real, e->value.real);
6006
6007 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6008 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6009
6010 gfc_free_expr (itrunc);
6011
6012 return range_check (result, name);
6013 }
6014
6015
6016 gfc_expr *
gfc_simplify_new_line(gfc_expr * e)6017 gfc_simplify_new_line (gfc_expr *e)
6018 {
6019 gfc_expr *result;
6020
6021 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
6022 result->value.character.string[0] = '\n';
6023
6024 return result;
6025 }
6026
6027
6028 gfc_expr *
gfc_simplify_nint(gfc_expr * e,gfc_expr * k)6029 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6030 {
6031 return simplify_nint ("NINT", e, k);
6032 }
6033
6034
6035 gfc_expr *
gfc_simplify_idnint(gfc_expr * e)6036 gfc_simplify_idnint (gfc_expr *e)
6037 {
6038 return simplify_nint ("IDNINT", e, NULL);
6039 }
6040
6041 static int norm2_scale;
6042
6043 static gfc_expr *
norm2_add_squared(gfc_expr * result,gfc_expr * e)6044 norm2_add_squared (gfc_expr *result, gfc_expr *e)
6045 {
6046 mpfr_t tmp;
6047
6048 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6049 gcc_assert (result->ts.type == BT_REAL
6050 && result->expr_type == EXPR_CONSTANT);
6051
6052 gfc_set_model_kind (result->ts.kind);
6053 int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6054 mpfr_exp_t exp;
6055 if (mpfr_regular_p (result->value.real))
6056 {
6057 exp = mpfr_get_exp (result->value.real);
6058 /* If result is getting close to overflowing, scale down. */
6059 if (exp >= gfc_real_kinds[index].max_exponent - 4
6060 && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6061 {
6062 norm2_scale += 2;
6063 mpfr_div_ui (result->value.real, result->value.real, 16,
6064 GFC_RND_MODE);
6065 }
6066 }
6067
6068 mpfr_init (tmp);
6069 if (mpfr_regular_p (e->value.real))
6070 {
6071 exp = mpfr_get_exp (e->value.real);
6072 /* If e**2 would overflow or close to overflowing, scale down. */
6073 if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6074 {
6075 int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6076 mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6077 mpfr_set_exp (tmp, new_scale - norm2_scale);
6078 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6079 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6080 norm2_scale = new_scale;
6081 }
6082 }
6083 if (norm2_scale)
6084 {
6085 mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6086 mpfr_set_exp (tmp, norm2_scale);
6087 mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
6088 }
6089 else
6090 mpfr_set (tmp, e->value.real, GFC_RND_MODE);
6091 mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
6092 mpfr_add (result->value.real, result->value.real, tmp,
6093 GFC_RND_MODE);
6094 mpfr_clear (tmp);
6095
6096 return result;
6097 }
6098
6099
6100 static gfc_expr *
norm2_do_sqrt(gfc_expr * result,gfc_expr * e)6101 norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
6102 {
6103 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6104 gcc_assert (result->ts.type == BT_REAL
6105 && result->expr_type == EXPR_CONSTANT);
6106
6107 if (result != e)
6108 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
6109 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6110 if (norm2_scale && mpfr_regular_p (result->value.real))
6111 {
6112 mpfr_t tmp;
6113 mpfr_init (tmp);
6114 mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6115 mpfr_set_exp (tmp, norm2_scale);
6116 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6117 mpfr_clear (tmp);
6118 }
6119 norm2_scale = 0;
6120
6121 return result;
6122 }
6123
6124
6125 gfc_expr *
gfc_simplify_norm2(gfc_expr * e,gfc_expr * dim)6126 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6127 {
6128 gfc_expr *result;
6129 bool size_zero;
6130
6131 size_zero = gfc_is_size_zero_array (e);
6132
6133 if (!(is_constant_array_expr (e) || size_zero)
6134 || (dim != NULL && !gfc_is_constant_expr (dim)))
6135 return NULL;
6136
6137 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6138 init_result_expr (result, 0, NULL);
6139
6140 if (size_zero)
6141 return result;
6142
6143 norm2_scale = 0;
6144 if (!dim || e->rank == 1)
6145 {
6146 result = simplify_transformation_to_scalar (result, e, NULL,
6147 norm2_add_squared);
6148 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6149 if (norm2_scale && mpfr_regular_p (result->value.real))
6150 {
6151 mpfr_t tmp;
6152 mpfr_init (tmp);
6153 mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6154 mpfr_set_exp (tmp, norm2_scale);
6155 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6156 mpfr_clear (tmp);
6157 }
6158 norm2_scale = 0;
6159 }
6160 else
6161 result = simplify_transformation_to_array (result, e, dim, NULL,
6162 norm2_add_squared,
6163 norm2_do_sqrt);
6164
6165 return result;
6166 }
6167
6168
6169 gfc_expr *
gfc_simplify_not(gfc_expr * e)6170 gfc_simplify_not (gfc_expr *e)
6171 {
6172 gfc_expr *result;
6173
6174 if (e->expr_type != EXPR_CONSTANT)
6175 return NULL;
6176
6177 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6178 mpz_com (result->value.integer, e->value.integer);
6179
6180 return range_check (result, "NOT");
6181 }
6182
6183
6184 gfc_expr *
gfc_simplify_null(gfc_expr * mold)6185 gfc_simplify_null (gfc_expr *mold)
6186 {
6187 gfc_expr *result;
6188
6189 if (mold)
6190 {
6191 result = gfc_copy_expr (mold);
6192 result->expr_type = EXPR_NULL;
6193 }
6194 else
6195 result = gfc_get_null_expr (NULL);
6196
6197 return result;
6198 }
6199
6200
6201 gfc_expr *
gfc_simplify_num_images(gfc_expr * distance ATTRIBUTE_UNUSED,gfc_expr * failed)6202 gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
6203 {
6204 gfc_expr *result;
6205
6206 if (flag_coarray == GFC_FCOARRAY_NONE)
6207 {
6208 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6209 return &gfc_bad_expr;
6210 }
6211
6212 if (flag_coarray != GFC_FCOARRAY_SINGLE)
6213 return NULL;
6214
6215 if (failed && failed->expr_type != EXPR_CONSTANT)
6216 return NULL;
6217
6218 /* FIXME: gfc_current_locus is wrong. */
6219 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6220 &gfc_current_locus);
6221
6222 if (failed && failed->value.logical != 0)
6223 mpz_set_si (result->value.integer, 0);
6224 else
6225 mpz_set_si (result->value.integer, 1);
6226
6227 return result;
6228 }
6229
6230
6231 gfc_expr *
gfc_simplify_or(gfc_expr * x,gfc_expr * y)6232 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
6233 {
6234 gfc_expr *result;
6235 int kind;
6236
6237 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6238 return NULL;
6239
6240 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6241
6242 switch (x->ts.type)
6243 {
6244 case BT_INTEGER:
6245 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6246 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
6247 return range_check (result, "OR");
6248
6249 case BT_LOGICAL:
6250 return gfc_get_logical_expr (kind, &x->where,
6251 x->value.logical || y->value.logical);
6252 default:
6253 gcc_unreachable();
6254 }
6255 }
6256
6257
6258 gfc_expr *
gfc_simplify_pack(gfc_expr * array,gfc_expr * mask,gfc_expr * vector)6259 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
6260 {
6261 gfc_expr *result;
6262 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
6263
6264 if (!is_constant_array_expr (array)
6265 || !is_constant_array_expr (vector)
6266 || (!gfc_is_constant_expr (mask)
6267 && !is_constant_array_expr (mask)))
6268 return NULL;
6269
6270 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
6271 if (array->ts.type == BT_DERIVED)
6272 result->ts.u.derived = array->ts.u.derived;
6273
6274 array_ctor = gfc_constructor_first (array->value.constructor);
6275 vector_ctor = vector
6276 ? gfc_constructor_first (vector->value.constructor)
6277 : NULL;
6278
6279 if (mask->expr_type == EXPR_CONSTANT
6280 && mask->value.logical)
6281 {
6282 /* Copy all elements of ARRAY to RESULT. */
6283 while (array_ctor)
6284 {
6285 gfc_constructor_append_expr (&result->value.constructor,
6286 gfc_copy_expr (array_ctor->expr),
6287 NULL);
6288
6289 array_ctor = gfc_constructor_next (array_ctor);
6290 vector_ctor = gfc_constructor_next (vector_ctor);
6291 }
6292 }
6293 else if (mask->expr_type == EXPR_ARRAY)
6294 {
6295 /* Copy only those elements of ARRAY to RESULT whose
6296 MASK equals .TRUE.. */
6297 mask_ctor = gfc_constructor_first (mask->value.constructor);
6298 while (mask_ctor && array_ctor)
6299 {
6300 if (mask_ctor->expr->value.logical)
6301 {
6302 gfc_constructor_append_expr (&result->value.constructor,
6303 gfc_copy_expr (array_ctor->expr),
6304 NULL);
6305 vector_ctor = gfc_constructor_next (vector_ctor);
6306 }
6307
6308 array_ctor = gfc_constructor_next (array_ctor);
6309 mask_ctor = gfc_constructor_next (mask_ctor);
6310 }
6311 }
6312
6313 /* Append any left-over elements from VECTOR to RESULT. */
6314 while (vector_ctor)
6315 {
6316 gfc_constructor_append_expr (&result->value.constructor,
6317 gfc_copy_expr (vector_ctor->expr),
6318 NULL);
6319 vector_ctor = gfc_constructor_next (vector_ctor);
6320 }
6321
6322 result->shape = gfc_get_shape (1);
6323 gfc_array_size (result, &result->shape[0]);
6324
6325 if (array->ts.type == BT_CHARACTER)
6326 result->ts.u.cl = array->ts.u.cl;
6327
6328 return result;
6329 }
6330
6331
6332 static gfc_expr *
do_xor(gfc_expr * result,gfc_expr * e)6333 do_xor (gfc_expr *result, gfc_expr *e)
6334 {
6335 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
6336 gcc_assert (result->ts.type == BT_LOGICAL
6337 && result->expr_type == EXPR_CONSTANT);
6338
6339 result->value.logical = result->value.logical != e->value.logical;
6340 return result;
6341 }
6342
6343
6344 gfc_expr *
gfc_simplify_is_contiguous(gfc_expr * array)6345 gfc_simplify_is_contiguous (gfc_expr *array)
6346 {
6347 if (gfc_is_simply_contiguous (array, false, true))
6348 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
6349
6350 if (gfc_is_not_contiguous (array))
6351 return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
6352
6353 return NULL;
6354 }
6355
6356
6357 gfc_expr *
gfc_simplify_parity(gfc_expr * e,gfc_expr * dim)6358 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
6359 {
6360 return simplify_transformation (e, dim, NULL, 0, do_xor);
6361 }
6362
6363
6364 gfc_expr *
gfc_simplify_popcnt(gfc_expr * e)6365 gfc_simplify_popcnt (gfc_expr *e)
6366 {
6367 int res, k;
6368 mpz_t x;
6369
6370 if (e->expr_type != EXPR_CONSTANT)
6371 return NULL;
6372
6373 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6374
6375 /* Convert argument to unsigned, then count the '1' bits. */
6376 mpz_init_set (x, e->value.integer);
6377 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
6378 res = mpz_popcount (x);
6379 mpz_clear (x);
6380
6381 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6382 }
6383
6384
6385 gfc_expr *
gfc_simplify_poppar(gfc_expr * e)6386 gfc_simplify_poppar (gfc_expr *e)
6387 {
6388 gfc_expr *popcnt;
6389 int i;
6390
6391 if (e->expr_type != EXPR_CONSTANT)
6392 return NULL;
6393
6394 popcnt = gfc_simplify_popcnt (e);
6395 gcc_assert (popcnt);
6396
6397 bool fail = gfc_extract_int (popcnt, &i);
6398 gcc_assert (!fail);
6399
6400 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
6401 }
6402
6403
6404 gfc_expr *
gfc_simplify_precision(gfc_expr * e)6405 gfc_simplify_precision (gfc_expr *e)
6406 {
6407 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6408 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6409 gfc_real_kinds[i].precision);
6410 }
6411
6412
6413 gfc_expr *
gfc_simplify_product(gfc_expr * array,gfc_expr * dim,gfc_expr * mask)6414 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6415 {
6416 return simplify_transformation (array, dim, mask, 1, gfc_multiply);
6417 }
6418
6419
6420 gfc_expr *
gfc_simplify_radix(gfc_expr * e)6421 gfc_simplify_radix (gfc_expr *e)
6422 {
6423 int i;
6424 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6425
6426 switch (e->ts.type)
6427 {
6428 case BT_INTEGER:
6429 i = gfc_integer_kinds[i].radix;
6430 break;
6431
6432 case BT_REAL:
6433 i = gfc_real_kinds[i].radix;
6434 break;
6435
6436 default:
6437 gcc_unreachable ();
6438 }
6439
6440 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6441 }
6442
6443
6444 gfc_expr *
gfc_simplify_range(gfc_expr * e)6445 gfc_simplify_range (gfc_expr *e)
6446 {
6447 int i;
6448 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6449
6450 switch (e->ts.type)
6451 {
6452 case BT_INTEGER:
6453 i = gfc_integer_kinds[i].range;
6454 break;
6455
6456 case BT_REAL:
6457 case BT_COMPLEX:
6458 i = gfc_real_kinds[i].range;
6459 break;
6460
6461 default:
6462 gcc_unreachable ();
6463 }
6464
6465 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6466 }
6467
6468
6469 gfc_expr *
gfc_simplify_rank(gfc_expr * e)6470 gfc_simplify_rank (gfc_expr *e)
6471 {
6472 /* Assumed rank. */
6473 if (e->rank == -1)
6474 return NULL;
6475
6476 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
6477 }
6478
6479
6480 gfc_expr *
gfc_simplify_real(gfc_expr * e,gfc_expr * k)6481 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
6482 {
6483 gfc_expr *result = NULL;
6484 int kind, tmp1, tmp2;
6485
6486 /* Convert BOZ to real, and return without range checking. */
6487 if (e->ts.type == BT_BOZ)
6488 {
6489 /* Determine kind for conversion of the BOZ. */
6490 if (k)
6491 gfc_extract_int (k, &kind);
6492 else
6493 kind = gfc_default_real_kind;
6494
6495 if (!gfc_boz2real (e, kind))
6496 return NULL;
6497 result = gfc_copy_expr (e);
6498 return result;
6499 }
6500
6501 if (e->ts.type == BT_COMPLEX)
6502 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
6503 else
6504 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
6505
6506 if (kind == -1)
6507 return &gfc_bad_expr;
6508
6509 if (e->expr_type != EXPR_CONSTANT)
6510 return NULL;
6511
6512 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6513 warnings. */
6514 tmp1 = warn_conversion;
6515 tmp2 = warn_conversion_extra;
6516 warn_conversion = warn_conversion_extra = 0;
6517
6518 result = gfc_convert_constant (e, BT_REAL, kind);
6519
6520 warn_conversion = tmp1;
6521 warn_conversion_extra = tmp2;
6522
6523 if (result == &gfc_bad_expr)
6524 return &gfc_bad_expr;
6525
6526 return range_check (result, "REAL");
6527 }
6528
6529
6530 gfc_expr *
gfc_simplify_realpart(gfc_expr * e)6531 gfc_simplify_realpart (gfc_expr *e)
6532 {
6533 gfc_expr *result;
6534
6535 if (e->expr_type != EXPR_CONSTANT)
6536 return NULL;
6537
6538 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6539 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
6540
6541 return range_check (result, "REALPART");
6542 }
6543
6544 gfc_expr *
gfc_simplify_repeat(gfc_expr * e,gfc_expr * n)6545 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
6546 {
6547 gfc_expr *result;
6548 gfc_charlen_t len;
6549 mpz_t ncopies;
6550 bool have_length = false;
6551
6552 /* If NCOPIES isn't a constant, there's nothing we can do. */
6553 if (n->expr_type != EXPR_CONSTANT)
6554 return NULL;
6555
6556 /* If NCOPIES is negative, it's an error. */
6557 if (mpz_sgn (n->value.integer) < 0)
6558 {
6559 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6560 &n->where);
6561 return &gfc_bad_expr;
6562 }
6563
6564 /* If we don't know the character length, we can do no more. */
6565 if (e->ts.u.cl && e->ts.u.cl->length
6566 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6567 {
6568 len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
6569 have_length = true;
6570 }
6571 else if (e->expr_type == EXPR_CONSTANT
6572 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
6573 {
6574 len = e->value.character.length;
6575 }
6576 else
6577 return NULL;
6578
6579 /* If the source length is 0, any value of NCOPIES is valid
6580 and everything behaves as if NCOPIES == 0. */
6581 mpz_init (ncopies);
6582 if (len == 0)
6583 mpz_set_ui (ncopies, 0);
6584 else
6585 mpz_set (ncopies, n->value.integer);
6586
6587 /* Check that NCOPIES isn't too large. */
6588 if (len)
6589 {
6590 mpz_t max, mlen;
6591 int i;
6592
6593 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6594 mpz_init (max);
6595 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
6596
6597 if (have_length)
6598 {
6599 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
6600 e->ts.u.cl->length->value.integer);
6601 }
6602 else
6603 {
6604 mpz_init (mlen);
6605 gfc_mpz_set_hwi (mlen, len);
6606 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
6607 mpz_clear (mlen);
6608 }
6609
6610 /* The check itself. */
6611 if (mpz_cmp (ncopies, max) > 0)
6612 {
6613 mpz_clear (max);
6614 mpz_clear (ncopies);
6615 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6616 &n->where);
6617 return &gfc_bad_expr;
6618 }
6619
6620 mpz_clear (max);
6621 }
6622 mpz_clear (ncopies);
6623
6624 /* For further simplification, we need the character string to be
6625 constant. */
6626 if (e->expr_type != EXPR_CONSTANT)
6627 return NULL;
6628
6629 HOST_WIDE_INT ncop;
6630 if (len ||
6631 (e->ts.u.cl->length &&
6632 mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
6633 {
6634 bool fail = gfc_extract_hwi (n, &ncop);
6635 gcc_assert (!fail);
6636 }
6637 else
6638 ncop = 0;
6639
6640 if (ncop == 0)
6641 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
6642
6643 len = e->value.character.length;
6644 gfc_charlen_t nlen = ncop * len;
6645
6646 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6647 (2**28 elements * 4 bytes (wide chars) per element) defer to
6648 runtime instead of consuming (unbounded) memory and CPU at
6649 compile time. */
6650 if (nlen > 268435456)
6651 {
6652 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6653 " deferred to runtime, expect bugs", &e->where);
6654 return NULL;
6655 }
6656
6657 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
6658 for (size_t i = 0; i < (size_t) ncop; i++)
6659 for (size_t j = 0; j < (size_t) len; j++)
6660 result->value.character.string[j+i*len]= e->value.character.string[j];
6661
6662 result->value.character.string[nlen] = '\0'; /* For debugger */
6663 return result;
6664 }
6665
6666
6667 /* This one is a bear, but mainly has to do with shuffling elements. */
6668
6669 gfc_expr *
gfc_simplify_reshape(gfc_expr * source,gfc_expr * shape_exp,gfc_expr * pad,gfc_expr * order_exp)6670 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
6671 gfc_expr *pad, gfc_expr *order_exp)
6672 {
6673 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
6674 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
6675 mpz_t index, size;
6676 unsigned long j;
6677 size_t nsource;
6678 gfc_expr *e, *result;
6679
6680 /* Check that argument expression types are OK. */
6681 if (!is_constant_array_expr (source)
6682 || !is_constant_array_expr (shape_exp)
6683 || !is_constant_array_expr (pad)
6684 || !is_constant_array_expr (order_exp))
6685 return NULL;
6686
6687 if (source->shape == NULL)
6688 return NULL;
6689
6690 /* Proceed with simplification, unpacking the array. */
6691
6692 mpz_init (index);
6693 rank = 0;
6694
6695 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
6696 x[i] = 0;
6697
6698 for (;;)
6699 {
6700 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
6701 if (e == NULL)
6702 break;
6703
6704 gfc_extract_int (e, &shape[rank]);
6705
6706 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
6707 if (shape[rank] < 0)
6708 {
6709 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6710 "negative value %d for dimension %d",
6711 &shape_exp->where, shape[rank], rank+1);
6712 return &gfc_bad_expr;
6713 }
6714
6715 rank++;
6716 }
6717
6718 gcc_assert (rank > 0);
6719
6720 /* Now unpack the order array if present. */
6721 if (order_exp == NULL)
6722 {
6723 for (i = 0; i < rank; i++)
6724 order[i] = i;
6725 }
6726 else
6727 {
6728 mpz_t size;
6729 int order_size, shape_size;
6730
6731 if (order_exp->rank != shape_exp->rank)
6732 {
6733 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6734 &order_exp->where, &shape_exp->where);
6735 return &gfc_bad_expr;
6736 }
6737
6738 gfc_array_size (shape_exp, &size);
6739 shape_size = mpz_get_ui (size);
6740 mpz_clear (size);
6741 gfc_array_size (order_exp, &size);
6742 order_size = mpz_get_ui (size);
6743 mpz_clear (size);
6744 if (order_size != shape_size)
6745 {
6746 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6747 &order_exp->where, &shape_exp->where);
6748 return &gfc_bad_expr;
6749 }
6750
6751 for (i = 0; i < rank; i++)
6752 {
6753 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
6754 gcc_assert (e);
6755
6756 gfc_extract_int (e, &order[i]);
6757
6758 if (order[i] < 1 || order[i] > rank)
6759 {
6760 gfc_error ("Element with a value of %d in ORDER at %L must be "
6761 "in the range [1, ..., %d] for the RESHAPE intrinsic "
6762 "near %L", order[i], &order_exp->where, rank,
6763 &shape_exp->where);
6764 return &gfc_bad_expr;
6765 }
6766
6767 order[i]--;
6768 if (x[order[i]] != 0)
6769 {
6770 gfc_error ("ORDER at %L is not a permutation of the size of "
6771 "SHAPE at %L", &order_exp->where, &shape_exp->where);
6772 return &gfc_bad_expr;
6773 }
6774 x[order[i]] = 1;
6775 }
6776 }
6777
6778 /* Count the elements in the source and padding arrays. */
6779
6780 npad = 0;
6781 if (pad != NULL)
6782 {
6783 gfc_array_size (pad, &size);
6784 npad = mpz_get_ui (size);
6785 mpz_clear (size);
6786 }
6787
6788 gfc_array_size (source, &size);
6789 nsource = mpz_get_ui (size);
6790 mpz_clear (size);
6791
6792 /* If it weren't for that pesky permutation we could just loop
6793 through the source and round out any shortage with pad elements.
6794 But no, someone just had to have the compiler do something the
6795 user should be doing. */
6796
6797 for (i = 0; i < rank; i++)
6798 x[i] = 0;
6799
6800 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
6801 &source->where);
6802 if (source->ts.type == BT_DERIVED)
6803 result->ts.u.derived = source->ts.u.derived;
6804 result->rank = rank;
6805 result->shape = gfc_get_shape (rank);
6806 for (i = 0; i < rank; i++)
6807 mpz_init_set_ui (result->shape[i], shape[i]);
6808
6809 while (nsource > 0 || npad > 0)
6810 {
6811 /* Figure out which element to extract. */
6812 mpz_set_ui (index, 0);
6813
6814 for (i = rank - 1; i >= 0; i--)
6815 {
6816 mpz_add_ui (index, index, x[order[i]]);
6817 if (i != 0)
6818 mpz_mul_ui (index, index, shape[order[i - 1]]);
6819 }
6820
6821 if (mpz_cmp_ui (index, INT_MAX) > 0)
6822 gfc_internal_error ("Reshaped array too large at %C");
6823
6824 j = mpz_get_ui (index);
6825
6826 if (j < nsource)
6827 e = gfc_constructor_lookup_expr (source->value.constructor, j);
6828 else
6829 {
6830 if (npad <= 0)
6831 {
6832 mpz_clear (index);
6833 return NULL;
6834 }
6835 j = j - nsource;
6836 j = j % npad;
6837 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
6838 }
6839 gcc_assert (e);
6840
6841 gfc_constructor_append_expr (&result->value.constructor,
6842 gfc_copy_expr (e), &e->where);
6843
6844 /* Calculate the next element. */
6845 i = 0;
6846
6847 inc:
6848 if (++x[i] < shape[i])
6849 continue;
6850 x[i++] = 0;
6851 if (i < rank)
6852 goto inc;
6853
6854 break;
6855 }
6856
6857 mpz_clear (index);
6858
6859 return result;
6860 }
6861
6862
6863 gfc_expr *
gfc_simplify_rrspacing(gfc_expr * x)6864 gfc_simplify_rrspacing (gfc_expr *x)
6865 {
6866 gfc_expr *result;
6867 int i;
6868 long int e, p;
6869
6870 if (x->expr_type != EXPR_CONSTANT)
6871 return NULL;
6872
6873 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6874
6875 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6876
6877 /* RRSPACING(+/- 0.0) = 0.0 */
6878 if (mpfr_zero_p (x->value.real))
6879 {
6880 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6881 return result;
6882 }
6883
6884 /* RRSPACING(inf) = NaN */
6885 if (mpfr_inf_p (x->value.real))
6886 {
6887 mpfr_set_nan (result->value.real);
6888 return result;
6889 }
6890
6891 /* RRSPACING(NaN) = same NaN */
6892 if (mpfr_nan_p (x->value.real))
6893 {
6894 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
6895 return result;
6896 }
6897
6898 /* | x * 2**(-e) | * 2**p. */
6899 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
6900 e = - (long int) mpfr_get_exp (x->value.real);
6901 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
6902
6903 p = (long int) gfc_real_kinds[i].digits;
6904 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
6905
6906 return range_check (result, "RRSPACING");
6907 }
6908
6909
6910 gfc_expr *
gfc_simplify_scale(gfc_expr * x,gfc_expr * i)6911 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
6912 {
6913 int k, neg_flag, power, exp_range;
6914 mpfr_t scale, radix;
6915 gfc_expr *result;
6916
6917 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
6918 return NULL;
6919
6920 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6921
6922 if (mpfr_zero_p (x->value.real))
6923 {
6924 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6925 return result;
6926 }
6927
6928 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6929
6930 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
6931
6932 /* This check filters out values of i that would overflow an int. */
6933 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
6934 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
6935 {
6936 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
6937 gfc_free_expr (result);
6938 return &gfc_bad_expr;
6939 }
6940
6941 /* Compute scale = radix ** power. */
6942 power = mpz_get_si (i->value.integer);
6943
6944 if (power >= 0)
6945 neg_flag = 0;
6946 else
6947 {
6948 neg_flag = 1;
6949 power = -power;
6950 }
6951
6952 gfc_set_model_kind (x->ts.kind);
6953 mpfr_init (scale);
6954 mpfr_init (radix);
6955 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
6956 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
6957
6958 if (neg_flag)
6959 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
6960 else
6961 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
6962
6963 mpfr_clears (scale, radix, NULL);
6964
6965 return range_check (result, "SCALE");
6966 }
6967
6968
6969 /* Variants of strspn and strcspn that operate on wide characters. */
6970
6971 static size_t
wide_strspn(const gfc_char_t * s1,const gfc_char_t * s2)6972 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
6973 {
6974 size_t i = 0;
6975 const gfc_char_t *c;
6976
6977 while (s1[i])
6978 {
6979 for (c = s2; *c; c++)
6980 {
6981 if (s1[i] == *c)
6982 break;
6983 }
6984 if (*c == '\0')
6985 break;
6986 i++;
6987 }
6988
6989 return i;
6990 }
6991
6992 static size_t
wide_strcspn(const gfc_char_t * s1,const gfc_char_t * s2)6993 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
6994 {
6995 size_t i = 0;
6996 const gfc_char_t *c;
6997
6998 while (s1[i])
6999 {
7000 for (c = s2; *c; c++)
7001 {
7002 if (s1[i] == *c)
7003 break;
7004 }
7005 if (*c)
7006 break;
7007 i++;
7008 }
7009
7010 return i;
7011 }
7012
7013
7014 gfc_expr *
gfc_simplify_scan(gfc_expr * e,gfc_expr * c,gfc_expr * b,gfc_expr * kind)7015 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
7016 {
7017 gfc_expr *result;
7018 int back;
7019 size_t i;
7020 size_t indx, len, lenc;
7021 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
7022
7023 if (k == -1)
7024 return &gfc_bad_expr;
7025
7026 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
7027 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
7028 return NULL;
7029
7030 if (b != NULL && b->value.logical != 0)
7031 back = 1;
7032 else
7033 back = 0;
7034
7035 len = e->value.character.length;
7036 lenc = c->value.character.length;
7037
7038 if (len == 0 || lenc == 0)
7039 {
7040 indx = 0;
7041 }
7042 else
7043 {
7044 if (back == 0)
7045 {
7046 indx = wide_strcspn (e->value.character.string,
7047 c->value.character.string) + 1;
7048 if (indx > len)
7049 indx = 0;
7050 }
7051 else
7052 for (indx = len; indx > 0; indx--)
7053 {
7054 for (i = 0; i < lenc; i++)
7055 {
7056 if (c->value.character.string[i]
7057 == e->value.character.string[indx - 1])
7058 break;
7059 }
7060 if (i < lenc)
7061 break;
7062 }
7063 }
7064
7065 result = gfc_get_int_expr (k, &e->where, indx);
7066 return range_check (result, "SCAN");
7067 }
7068
7069
7070 gfc_expr *
gfc_simplify_selected_char_kind(gfc_expr * e)7071 gfc_simplify_selected_char_kind (gfc_expr *e)
7072 {
7073 int kind;
7074
7075 if (e->expr_type != EXPR_CONSTANT)
7076 return NULL;
7077
7078 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
7079 || gfc_compare_with_Cstring (e, "default", false) == 0)
7080 kind = 1;
7081 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
7082 kind = 4;
7083 else
7084 kind = -1;
7085
7086 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7087 }
7088
7089
7090 gfc_expr *
gfc_simplify_selected_int_kind(gfc_expr * e)7091 gfc_simplify_selected_int_kind (gfc_expr *e)
7092 {
7093 int i, kind, range;
7094
7095 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
7096 return NULL;
7097
7098 kind = INT_MAX;
7099
7100 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
7101 if (gfc_integer_kinds[i].range >= range
7102 && gfc_integer_kinds[i].kind < kind)
7103 kind = gfc_integer_kinds[i].kind;
7104
7105 if (kind == INT_MAX)
7106 kind = -1;
7107
7108 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7109 }
7110
7111
7112 gfc_expr *
gfc_simplify_selected_real_kind(gfc_expr * p,gfc_expr * q,gfc_expr * rdx)7113 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
7114 {
7115 int range, precision, radix, i, kind, found_precision, found_range,
7116 found_radix;
7117 locus *loc = &gfc_current_locus;
7118
7119 if (p == NULL)
7120 precision = 0;
7121 else
7122 {
7123 if (p->expr_type != EXPR_CONSTANT
7124 || gfc_extract_int (p, &precision))
7125 return NULL;
7126 loc = &p->where;
7127 }
7128
7129 if (q == NULL)
7130 range = 0;
7131 else
7132 {
7133 if (q->expr_type != EXPR_CONSTANT
7134 || gfc_extract_int (q, &range))
7135 return NULL;
7136
7137 if (!loc)
7138 loc = &q->where;
7139 }
7140
7141 if (rdx == NULL)
7142 radix = 0;
7143 else
7144 {
7145 if (rdx->expr_type != EXPR_CONSTANT
7146 || gfc_extract_int (rdx, &radix))
7147 return NULL;
7148
7149 if (!loc)
7150 loc = &rdx->where;
7151 }
7152
7153 kind = INT_MAX;
7154 found_precision = 0;
7155 found_range = 0;
7156 found_radix = 0;
7157
7158 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
7159 {
7160 if (gfc_real_kinds[i].precision >= precision)
7161 found_precision = 1;
7162
7163 if (gfc_real_kinds[i].range >= range)
7164 found_range = 1;
7165
7166 if (radix == 0 || gfc_real_kinds[i].radix == radix)
7167 found_radix = 1;
7168
7169 if (gfc_real_kinds[i].precision >= precision
7170 && gfc_real_kinds[i].range >= range
7171 && (radix == 0 || gfc_real_kinds[i].radix == radix)
7172 && gfc_real_kinds[i].kind < kind)
7173 kind = gfc_real_kinds[i].kind;
7174 }
7175
7176 if (kind == INT_MAX)
7177 {
7178 if (found_radix && found_range && !found_precision)
7179 kind = -1;
7180 else if (found_radix && found_precision && !found_range)
7181 kind = -2;
7182 else if (found_radix && !found_precision && !found_range)
7183 kind = -3;
7184 else if (found_radix)
7185 kind = -4;
7186 else
7187 kind = -5;
7188 }
7189
7190 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
7191 }
7192
7193
7194 gfc_expr *
gfc_simplify_set_exponent(gfc_expr * x,gfc_expr * i)7195 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
7196 {
7197 gfc_expr *result;
7198 mpfr_t exp, absv, log2, pow2, frac;
7199 long exp2;
7200
7201 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7202 return NULL;
7203
7204 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7205
7206 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7207 SET_EXPONENT (NaN) = same NaN */
7208 if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
7209 {
7210 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7211 return result;
7212 }
7213
7214 /* SET_EXPONENT (inf) = NaN */
7215 if (mpfr_inf_p (x->value.real))
7216 {
7217 mpfr_set_nan (result->value.real);
7218 return result;
7219 }
7220
7221 gfc_set_model_kind (x->ts.kind);
7222 mpfr_init (absv);
7223 mpfr_init (log2);
7224 mpfr_init (exp);
7225 mpfr_init (pow2);
7226 mpfr_init (frac);
7227
7228 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
7229 mpfr_log2 (log2, absv, GFC_RND_MODE);
7230
7231 mpfr_floor (log2, log2);
7232 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
7233
7234 /* Old exponent value, and fraction. */
7235 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
7236
7237 mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE);
7238
7239 /* New exponent. */
7240 exp2 = mpz_get_si (i->value.integer);
7241 mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE);
7242
7243 mpfr_clears (absv, log2, exp, pow2, frac, NULL);
7244
7245 return range_check (result, "SET_EXPONENT");
7246 }
7247
7248
7249 gfc_expr *
gfc_simplify_shape(gfc_expr * source,gfc_expr * kind)7250 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
7251 {
7252 mpz_t shape[GFC_MAX_DIMENSIONS];
7253 gfc_expr *result, *e, *f;
7254 gfc_array_ref *ar;
7255 int n;
7256 bool t;
7257 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
7258
7259 if (source->rank == -1)
7260 return NULL;
7261
7262 result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
7263 result->shape = gfc_get_shape (1);
7264 mpz_init (result->shape[0]);
7265
7266 if (source->rank == 0)
7267 return result;
7268
7269 if (source->expr_type == EXPR_VARIABLE)
7270 {
7271 ar = gfc_find_array_ref (source);
7272 t = gfc_array_ref_shape (ar, shape);
7273 }
7274 else if (source->shape)
7275 {
7276 t = true;
7277 for (n = 0; n < source->rank; n++)
7278 {
7279 mpz_init (shape[n]);
7280 mpz_set (shape[n], source->shape[n]);
7281 }
7282 }
7283 else
7284 t = false;
7285
7286 for (n = 0; n < source->rank; n++)
7287 {
7288 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
7289
7290 if (t)
7291 mpz_set (e->value.integer, shape[n]);
7292 else
7293 {
7294 mpz_set_ui (e->value.integer, n + 1);
7295
7296 f = simplify_size (source, e, k);
7297 gfc_free_expr (e);
7298 if (f == NULL)
7299 {
7300 gfc_free_expr (result);
7301 return NULL;
7302 }
7303 else
7304 e = f;
7305 }
7306
7307 if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
7308 {
7309 gfc_free_expr (result);
7310 if (t)
7311 gfc_clear_shape (shape, source->rank);
7312 return &gfc_bad_expr;
7313 }
7314
7315 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
7316 }
7317
7318 if (t)
7319 gfc_clear_shape (shape, source->rank);
7320
7321 mpz_set_si (result->shape[0], source->rank);
7322
7323 return result;
7324 }
7325
7326
7327 static gfc_expr *
simplify_size(gfc_expr * array,gfc_expr * dim,int k)7328 simplify_size (gfc_expr *array, gfc_expr *dim, int k)
7329 {
7330 mpz_t size;
7331 gfc_expr *return_value;
7332 int d;
7333 gfc_ref *ref;
7334
7335 /* For unary operations, the size of the result is given by the size
7336 of the operand. For binary ones, it's the size of the first operand
7337 unless it is scalar, then it is the size of the second. */
7338 if (array->expr_type == EXPR_OP && !array->value.op.uop)
7339 {
7340 gfc_expr* replacement;
7341 gfc_expr* simplified;
7342
7343 switch (array->value.op.op)
7344 {
7345 /* Unary operations. */
7346 case INTRINSIC_NOT:
7347 case INTRINSIC_UPLUS:
7348 case INTRINSIC_UMINUS:
7349 case INTRINSIC_PARENTHESES:
7350 replacement = array->value.op.op1;
7351 break;
7352
7353 /* Binary operations. If any one of the operands is scalar, take
7354 the other one's size. If both of them are arrays, it does not
7355 matter -- try to find one with known shape, if possible. */
7356 default:
7357 if (array->value.op.op1->rank == 0)
7358 replacement = array->value.op.op2;
7359 else if (array->value.op.op2->rank == 0)
7360 replacement = array->value.op.op1;
7361 else
7362 {
7363 simplified = simplify_size (array->value.op.op1, dim, k);
7364 if (simplified)
7365 return simplified;
7366
7367 replacement = array->value.op.op2;
7368 }
7369 break;
7370 }
7371
7372 /* Try to reduce it directly if possible. */
7373 simplified = simplify_size (replacement, dim, k);
7374
7375 /* Otherwise, we build a new SIZE call. This is hopefully at least
7376 simpler than the original one. */
7377 if (!simplified)
7378 {
7379 gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
7380 simplified = gfc_build_intrinsic_call (gfc_current_ns,
7381 GFC_ISYM_SIZE, "size",
7382 array->where, 3,
7383 gfc_copy_expr (replacement),
7384 gfc_copy_expr (dim),
7385 kind);
7386 }
7387 return simplified;
7388 }
7389
7390 for (ref = array->ref; ref; ref = ref->next)
7391 if (ref->type == REF_ARRAY && ref->u.ar.as
7392 && !gfc_resolve_array_spec (ref->u.ar.as, 0))
7393 return NULL;
7394
7395 if (dim == NULL)
7396 {
7397 if (!gfc_array_size (array, &size))
7398 return NULL;
7399 }
7400 else
7401 {
7402 if (dim->expr_type != EXPR_CONSTANT)
7403 return NULL;
7404
7405 d = mpz_get_ui (dim->value.integer) - 1;
7406 if (!gfc_array_dimen_size (array, d, &size))
7407 return NULL;
7408 }
7409
7410 return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
7411 mpz_set (return_value->value.integer, size);
7412 mpz_clear (size);
7413
7414 return return_value;
7415 }
7416
7417
7418 gfc_expr *
gfc_simplify_size(gfc_expr * array,gfc_expr * dim,gfc_expr * kind)7419 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
7420 {
7421 gfc_expr *result;
7422 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
7423
7424 if (k == -1)
7425 return &gfc_bad_expr;
7426
7427 result = simplify_size (array, dim, k);
7428 if (result == NULL || result == &gfc_bad_expr)
7429 return result;
7430
7431 return range_check (result, "SIZE");
7432 }
7433
7434
7435 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7436 multiplied by the array size. */
7437
7438 gfc_expr *
gfc_simplify_sizeof(gfc_expr * x)7439 gfc_simplify_sizeof (gfc_expr *x)
7440 {
7441 gfc_expr *result = NULL;
7442 mpz_t array_size;
7443 size_t res_size;
7444
7445 if (x->ts.type == BT_CLASS || x->ts.deferred)
7446 return NULL;
7447
7448 if (x->ts.type == BT_CHARACTER
7449 && (!x->ts.u.cl || !x->ts.u.cl->length
7450 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7451 return NULL;
7452
7453 if (x->rank && x->expr_type != EXPR_ARRAY
7454 && !gfc_array_size (x, &array_size))
7455 return NULL;
7456
7457 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
7458 &x->where);
7459 gfc_target_expr_size (x, &res_size);
7460 mpz_set_si (result->value.integer, res_size);
7461
7462 return result;
7463 }
7464
7465
7466 /* STORAGE_SIZE returns the size in bits of a single array element. */
7467
7468 gfc_expr *
gfc_simplify_storage_size(gfc_expr * x,gfc_expr * kind)7469 gfc_simplify_storage_size (gfc_expr *x,
7470 gfc_expr *kind)
7471 {
7472 gfc_expr *result = NULL;
7473 int k;
7474 size_t siz;
7475
7476 if (x->ts.type == BT_CLASS || x->ts.deferred)
7477 return NULL;
7478
7479 if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
7480 && (!x->ts.u.cl || !x->ts.u.cl->length
7481 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7482 return NULL;
7483
7484 k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
7485 if (k == -1)
7486 return &gfc_bad_expr;
7487
7488 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
7489
7490 gfc_element_size (x, &siz);
7491 mpz_set_si (result->value.integer, siz);
7492 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
7493
7494 return range_check (result, "STORAGE_SIZE");
7495 }
7496
7497
7498 gfc_expr *
gfc_simplify_sign(gfc_expr * x,gfc_expr * y)7499 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
7500 {
7501 gfc_expr *result;
7502
7503 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
7504 return NULL;
7505
7506 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7507
7508 switch (x->ts.type)
7509 {
7510 case BT_INTEGER:
7511 mpz_abs (result->value.integer, x->value.integer);
7512 if (mpz_sgn (y->value.integer) < 0)
7513 mpz_neg (result->value.integer, result->value.integer);
7514 break;
7515
7516 case BT_REAL:
7517 if (flag_sign_zero)
7518 mpfr_copysign (result->value.real, x->value.real, y->value.real,
7519 GFC_RND_MODE);
7520 else
7521 mpfr_setsign (result->value.real, x->value.real,
7522 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
7523 break;
7524
7525 default:
7526 gfc_internal_error ("Bad type in gfc_simplify_sign");
7527 }
7528
7529 return result;
7530 }
7531
7532
7533 gfc_expr *
gfc_simplify_sin(gfc_expr * x)7534 gfc_simplify_sin (gfc_expr *x)
7535 {
7536 gfc_expr *result;
7537
7538 if (x->expr_type != EXPR_CONSTANT)
7539 return NULL;
7540
7541 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7542
7543 switch (x->ts.type)
7544 {
7545 case BT_REAL:
7546 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
7547 break;
7548
7549 case BT_COMPLEX:
7550 gfc_set_model (x->value.real);
7551 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7552 break;
7553
7554 default:
7555 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7556 }
7557
7558 return range_check (result, "SIN");
7559 }
7560
7561
7562 gfc_expr *
gfc_simplify_sinh(gfc_expr * x)7563 gfc_simplify_sinh (gfc_expr *x)
7564 {
7565 gfc_expr *result;
7566
7567 if (x->expr_type != EXPR_CONSTANT)
7568 return NULL;
7569
7570 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7571
7572 switch (x->ts.type)
7573 {
7574 case BT_REAL:
7575 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
7576 break;
7577
7578 case BT_COMPLEX:
7579 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7580 break;
7581
7582 default:
7583 gcc_unreachable ();
7584 }
7585
7586 return range_check (result, "SINH");
7587 }
7588
7589
7590 /* The argument is always a double precision real that is converted to
7591 single precision. TODO: Rounding! */
7592
7593 gfc_expr *
gfc_simplify_sngl(gfc_expr * a)7594 gfc_simplify_sngl (gfc_expr *a)
7595 {
7596 gfc_expr *result;
7597 int tmp1, tmp2;
7598
7599 if (a->expr_type != EXPR_CONSTANT)
7600 return NULL;
7601
7602 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7603 warnings. */
7604 tmp1 = warn_conversion;
7605 tmp2 = warn_conversion_extra;
7606 warn_conversion = warn_conversion_extra = 0;
7607
7608 result = gfc_real2real (a, gfc_default_real_kind);
7609
7610 warn_conversion = tmp1;
7611 warn_conversion_extra = tmp2;
7612
7613 return range_check (result, "SNGL");
7614 }
7615
7616
7617 gfc_expr *
gfc_simplify_spacing(gfc_expr * x)7618 gfc_simplify_spacing (gfc_expr *x)
7619 {
7620 gfc_expr *result;
7621 int i;
7622 long int en, ep;
7623
7624 if (x->expr_type != EXPR_CONSTANT)
7625 return NULL;
7626
7627 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7628 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7629
7630 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7631 if (mpfr_zero_p (x->value.real))
7632 {
7633 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
7634 return result;
7635 }
7636
7637 /* SPACING(inf) = NaN */
7638 if (mpfr_inf_p (x->value.real))
7639 {
7640 mpfr_set_nan (result->value.real);
7641 return result;
7642 }
7643
7644 /* SPACING(NaN) = same NaN */
7645 if (mpfr_nan_p (x->value.real))
7646 {
7647 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7648 return result;
7649 }
7650
7651 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7652 are the radix, exponent of x, and precision. This excludes the
7653 possibility of subnormal numbers. Fortran 2003 states the result is
7654 b**max(e - p, emin - 1). */
7655
7656 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
7657 en = (long int) gfc_real_kinds[i].min_exponent - 1;
7658 en = en > ep ? en : ep;
7659
7660 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
7661 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
7662
7663 return range_check (result, "SPACING");
7664 }
7665
7666
7667 gfc_expr *
gfc_simplify_spread(gfc_expr * source,gfc_expr * dim_expr,gfc_expr * ncopies_expr)7668 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
7669 {
7670 gfc_expr *result = NULL;
7671 int nelem, i, j, dim, ncopies;
7672 mpz_t size;
7673
7674 if ((!gfc_is_constant_expr (source)
7675 && !is_constant_array_expr (source))
7676 || !gfc_is_constant_expr (dim_expr)
7677 || !gfc_is_constant_expr (ncopies_expr))
7678 return NULL;
7679
7680 gcc_assert (dim_expr->ts.type == BT_INTEGER);
7681 gfc_extract_int (dim_expr, &dim);
7682 dim -= 1; /* zero-base DIM */
7683
7684 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
7685 gfc_extract_int (ncopies_expr, &ncopies);
7686 ncopies = MAX (ncopies, 0);
7687
7688 /* Do not allow the array size to exceed the limit for an array
7689 constructor. */
7690 if (source->expr_type == EXPR_ARRAY)
7691 {
7692 if (!gfc_array_size (source, &size))
7693 gfc_internal_error ("Failure getting length of a constant array.");
7694 }
7695 else
7696 mpz_init_set_ui (size, 1);
7697
7698 nelem = mpz_get_si (size) * ncopies;
7699 if (nelem > flag_max_array_constructor)
7700 {
7701 if (gfc_init_expr_flag)
7702 {
7703 gfc_error ("The number of elements (%d) in the array constructor "
7704 "at %L requires an increase of the allowed %d upper "
7705 "limit. See %<-fmax-array-constructor%> option.",
7706 nelem, &source->where, flag_max_array_constructor);
7707 return &gfc_bad_expr;
7708 }
7709 else
7710 return NULL;
7711 }
7712
7713 if (source->expr_type == EXPR_CONSTANT
7714 || source->expr_type == EXPR_STRUCTURE)
7715 {
7716 gcc_assert (dim == 0);
7717
7718 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7719 &source->where);
7720 if (source->ts.type == BT_DERIVED)
7721 result->ts.u.derived = source->ts.u.derived;
7722 result->rank = 1;
7723 result->shape = gfc_get_shape (result->rank);
7724 mpz_init_set_si (result->shape[0], ncopies);
7725
7726 for (i = 0; i < ncopies; ++i)
7727 gfc_constructor_append_expr (&result->value.constructor,
7728 gfc_copy_expr (source), NULL);
7729 }
7730 else if (source->expr_type == EXPR_ARRAY)
7731 {
7732 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
7733 gfc_constructor *source_ctor;
7734
7735 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
7736 gcc_assert (dim >= 0 && dim <= source->rank);
7737
7738 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7739 &source->where);
7740 if (source->ts.type == BT_DERIVED)
7741 result->ts.u.derived = source->ts.u.derived;
7742 result->rank = source->rank + 1;
7743 result->shape = gfc_get_shape (result->rank);
7744
7745 for (i = 0, j = 0; i < result->rank; ++i)
7746 {
7747 if (i != dim)
7748 mpz_init_set (result->shape[i], source->shape[j++]);
7749 else
7750 mpz_init_set_si (result->shape[i], ncopies);
7751
7752 extent[i] = mpz_get_si (result->shape[i]);
7753 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
7754 }
7755
7756 offset = 0;
7757 for (source_ctor = gfc_constructor_first (source->value.constructor);
7758 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
7759 {
7760 for (i = 0; i < ncopies; ++i)
7761 gfc_constructor_insert_expr (&result->value.constructor,
7762 gfc_copy_expr (source_ctor->expr),
7763 NULL, offset + i * rstride[dim]);
7764
7765 offset += (dim == 0 ? ncopies : 1);
7766 }
7767 }
7768 else
7769 {
7770 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7771 return &gfc_bad_expr;
7772 }
7773
7774 if (source->ts.type == BT_CHARACTER)
7775 result->ts.u.cl = source->ts.u.cl;
7776
7777 return result;
7778 }
7779
7780
7781 gfc_expr *
gfc_simplify_sqrt(gfc_expr * e)7782 gfc_simplify_sqrt (gfc_expr *e)
7783 {
7784 gfc_expr *result = NULL;
7785
7786 if (e->expr_type != EXPR_CONSTANT)
7787 return NULL;
7788
7789 switch (e->ts.type)
7790 {
7791 case BT_REAL:
7792 if (mpfr_cmp_si (e->value.real, 0) < 0)
7793 {
7794 gfc_error ("Argument of SQRT at %L has a negative value",
7795 &e->where);
7796 return &gfc_bad_expr;
7797 }
7798 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
7799 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
7800 break;
7801
7802 case BT_COMPLEX:
7803 gfc_set_model (e->value.real);
7804
7805 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
7806 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
7807 break;
7808
7809 default:
7810 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
7811 }
7812
7813 return range_check (result, "SQRT");
7814 }
7815
7816
7817 gfc_expr *
gfc_simplify_sum(gfc_expr * array,gfc_expr * dim,gfc_expr * mask)7818 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
7819 {
7820 return simplify_transformation (array, dim, mask, 0, gfc_add);
7821 }
7822
7823
7824 /* Simplify COTAN(X) where X has the unit of radian. */
7825
7826 gfc_expr *
gfc_simplify_cotan(gfc_expr * x)7827 gfc_simplify_cotan (gfc_expr *x)
7828 {
7829 gfc_expr *result;
7830 mpc_t swp, *val;
7831
7832 if (x->expr_type != EXPR_CONSTANT)
7833 return NULL;
7834
7835 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7836
7837 switch (x->ts.type)
7838 {
7839 case BT_REAL:
7840 mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
7841 break;
7842
7843 case BT_COMPLEX:
7844 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
7845 val = &result->value.complex;
7846 mpc_init2 (swp, mpfr_get_default_prec ());
7847 mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE,
7848 GFC_MPC_RND_MODE);
7849 mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
7850 mpc_clear (swp);
7851 break;
7852
7853 default:
7854 gcc_unreachable ();
7855 }
7856
7857 return range_check (result, "COTAN");
7858 }
7859
7860
7861 gfc_expr *
gfc_simplify_tan(gfc_expr * x)7862 gfc_simplify_tan (gfc_expr *x)
7863 {
7864 gfc_expr *result;
7865
7866 if (x->expr_type != EXPR_CONSTANT)
7867 return NULL;
7868
7869 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7870
7871 switch (x->ts.type)
7872 {
7873 case BT_REAL:
7874 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
7875 break;
7876
7877 case BT_COMPLEX:
7878 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7879 break;
7880
7881 default:
7882 gcc_unreachable ();
7883 }
7884
7885 return range_check (result, "TAN");
7886 }
7887
7888
7889 gfc_expr *
gfc_simplify_tanh(gfc_expr * x)7890 gfc_simplify_tanh (gfc_expr *x)
7891 {
7892 gfc_expr *result;
7893
7894 if (x->expr_type != EXPR_CONSTANT)
7895 return NULL;
7896
7897 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7898
7899 switch (x->ts.type)
7900 {
7901 case BT_REAL:
7902 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
7903 break;
7904
7905 case BT_COMPLEX:
7906 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7907 break;
7908
7909 default:
7910 gcc_unreachable ();
7911 }
7912
7913 return range_check (result, "TANH");
7914 }
7915
7916
7917 gfc_expr *
gfc_simplify_tiny(gfc_expr * e)7918 gfc_simplify_tiny (gfc_expr *e)
7919 {
7920 gfc_expr *result;
7921 int i;
7922
7923 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
7924
7925 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
7926 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
7927
7928 return result;
7929 }
7930
7931
7932 gfc_expr *
gfc_simplify_trailz(gfc_expr * e)7933 gfc_simplify_trailz (gfc_expr *e)
7934 {
7935 unsigned long tz, bs;
7936 int i;
7937
7938 if (e->expr_type != EXPR_CONSTANT)
7939 return NULL;
7940
7941 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7942 bs = gfc_integer_kinds[i].bit_size;
7943 tz = mpz_scan1 (e->value.integer, 0);
7944
7945 return gfc_get_int_expr (gfc_default_integer_kind,
7946 &e->where, MIN (tz, bs));
7947 }
7948
7949
7950 gfc_expr *
gfc_simplify_transfer(gfc_expr * source,gfc_expr * mold,gfc_expr * size)7951 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
7952 {
7953 gfc_expr *result;
7954 gfc_expr *mold_element;
7955 size_t source_size;
7956 size_t result_size;
7957 size_t buffer_size;
7958 mpz_t tmp;
7959 unsigned char *buffer;
7960 size_t result_length;
7961
7962 if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size))
7963 return NULL;
7964
7965 if (!gfc_resolve_expr (mold))
7966 return NULL;
7967 if (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
7968 return NULL;
7969
7970 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
7971 &result_size, &result_length))
7972 return NULL;
7973
7974 /* Calculate the size of the source. */
7975 if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp))
7976 gfc_internal_error ("Failure getting length of a constant array.");
7977
7978 /* Create an empty new expression with the appropriate characteristics. */
7979 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
7980 &source->where);
7981 result->ts = mold->ts;
7982
7983 mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor)
7984 ? gfc_constructor_first (mold->value.constructor)->expr
7985 : mold;
7986
7987 /* Set result character length, if needed. Note that this needs to be
7988 set even for array expressions, in order to pass this information into
7989 gfc_target_interpret_expr. */
7990 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
7991 {
7992 result->value.character.length = mold_element->value.character.length;
7993
7994 /* Let the typespec of the result inherit the string length.
7995 This is crucial if a resulting array has size zero. */
7996 if (mold_element->ts.u.cl->length)
7997 result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length);
7998 else
7999 result->ts.u.cl->length =
8000 gfc_get_int_expr (gfc_charlen_int_kind, NULL,
8001 mold_element->value.character.length);
8002 }
8003
8004 /* Set the number of elements in the result, and determine its size. */
8005
8006 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
8007 {
8008 result->expr_type = EXPR_ARRAY;
8009 result->rank = 1;
8010 result->shape = gfc_get_shape (1);
8011 mpz_init_set_ui (result->shape[0], result_length);
8012 }
8013 else
8014 result->rank = 0;
8015
8016 /* Allocate the buffer to store the binary version of the source. */
8017 buffer_size = MAX (source_size, result_size);
8018 buffer = (unsigned char*)alloca (buffer_size);
8019 memset (buffer, 0, buffer_size);
8020
8021 /* Now write source to the buffer. */
8022 gfc_target_encode_expr (source, buffer, buffer_size);
8023
8024 /* And read the buffer back into the new expression. */
8025 gfc_target_interpret_expr (buffer, buffer_size, result, false);
8026
8027 return result;
8028 }
8029
8030
8031 gfc_expr *
gfc_simplify_transpose(gfc_expr * matrix)8032 gfc_simplify_transpose (gfc_expr *matrix)
8033 {
8034 int row, matrix_rows, col, matrix_cols;
8035 gfc_expr *result;
8036
8037 if (!is_constant_array_expr (matrix))
8038 return NULL;
8039
8040 gcc_assert (matrix->rank == 2);
8041
8042 if (matrix->shape == NULL)
8043 return NULL;
8044
8045 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
8046 &matrix->where);
8047 result->rank = 2;
8048 result->shape = gfc_get_shape (result->rank);
8049 mpz_init_set (result->shape[0], matrix->shape[1]);
8050 mpz_init_set (result->shape[1], matrix->shape[0]);
8051
8052 if (matrix->ts.type == BT_CHARACTER)
8053 result->ts.u.cl = matrix->ts.u.cl;
8054 else if (matrix->ts.type == BT_DERIVED)
8055 result->ts.u.derived = matrix->ts.u.derived;
8056
8057 matrix_rows = mpz_get_si (matrix->shape[0]);
8058 matrix_cols = mpz_get_si (matrix->shape[1]);
8059 for (row = 0; row < matrix_rows; ++row)
8060 for (col = 0; col < matrix_cols; ++col)
8061 {
8062 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
8063 col * matrix_rows + row);
8064 gfc_constructor_insert_expr (&result->value.constructor,
8065 gfc_copy_expr (e), &matrix->where,
8066 row * matrix_cols + col);
8067 }
8068
8069 return result;
8070 }
8071
8072
8073 gfc_expr *
gfc_simplify_trim(gfc_expr * e)8074 gfc_simplify_trim (gfc_expr *e)
8075 {
8076 gfc_expr *result;
8077 int count, i, len, lentrim;
8078
8079 if (e->expr_type != EXPR_CONSTANT)
8080 return NULL;
8081
8082 len = e->value.character.length;
8083 for (count = 0, i = 1; i <= len; ++i)
8084 {
8085 if (e->value.character.string[len - i] == ' ')
8086 count++;
8087 else
8088 break;
8089 }
8090
8091 lentrim = len - count;
8092
8093 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
8094 for (i = 0; i < lentrim; i++)
8095 result->value.character.string[i] = e->value.character.string[i];
8096
8097 return result;
8098 }
8099
8100
8101 gfc_expr *
gfc_simplify_image_index(gfc_expr * coarray,gfc_expr * sub)8102 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
8103 {
8104 gfc_expr *result;
8105 gfc_ref *ref;
8106 gfc_array_spec *as;
8107 gfc_constructor *sub_cons;
8108 bool first_image;
8109 int d;
8110
8111 if (!is_constant_array_expr (sub))
8112 return NULL;
8113
8114 /* Follow any component references. */
8115 as = coarray->symtree->n.sym->as;
8116 for (ref = coarray->ref; ref; ref = ref->next)
8117 if (ref->type == REF_COMPONENT)
8118 as = ref->u.ar.as;
8119
8120 if (as->type == AS_DEFERRED)
8121 return NULL;
8122
8123 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
8124 the cosubscript addresses the first image. */
8125
8126 sub_cons = gfc_constructor_first (sub->value.constructor);
8127 first_image = true;
8128
8129 for (d = 1; d <= as->corank; d++)
8130 {
8131 gfc_expr *ca_bound;
8132 int cmp;
8133
8134 gcc_assert (sub_cons != NULL);
8135
8136 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
8137 NULL, true);
8138 if (ca_bound == NULL)
8139 return NULL;
8140
8141 if (ca_bound == &gfc_bad_expr)
8142 return ca_bound;
8143
8144 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
8145
8146 if (cmp == 0)
8147 {
8148 gfc_free_expr (ca_bound);
8149 sub_cons = gfc_constructor_next (sub_cons);
8150 continue;
8151 }
8152
8153 first_image = false;
8154
8155 if (cmp > 0)
8156 {
8157 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8158 "SUB has %ld and COARRAY lower bound is %ld)",
8159 &coarray->where, d,
8160 mpz_get_si (sub_cons->expr->value.integer),
8161 mpz_get_si (ca_bound->value.integer));
8162 gfc_free_expr (ca_bound);
8163 return &gfc_bad_expr;
8164 }
8165
8166 gfc_free_expr (ca_bound);
8167
8168 /* Check whether upperbound is valid for the multi-images case. */
8169 if (d < as->corank)
8170 {
8171 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
8172 NULL, true);
8173 if (ca_bound == &gfc_bad_expr)
8174 return ca_bound;
8175
8176 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
8177 && mpz_cmp (ca_bound->value.integer,
8178 sub_cons->expr->value.integer) < 0)
8179 {
8180 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8181 "SUB has %ld and COARRAY upper bound is %ld)",
8182 &coarray->where, d,
8183 mpz_get_si (sub_cons->expr->value.integer),
8184 mpz_get_si (ca_bound->value.integer));
8185 gfc_free_expr (ca_bound);
8186 return &gfc_bad_expr;
8187 }
8188
8189 if (ca_bound)
8190 gfc_free_expr (ca_bound);
8191 }
8192
8193 sub_cons = gfc_constructor_next (sub_cons);
8194 }
8195
8196 gcc_assert (sub_cons == NULL);
8197
8198 if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
8199 return NULL;
8200
8201 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8202 &gfc_current_locus);
8203 if (first_image)
8204 mpz_set_si (result->value.integer, 1);
8205 else
8206 mpz_set_si (result->value.integer, 0);
8207
8208 return result;
8209 }
8210
8211 gfc_expr *
gfc_simplify_image_status(gfc_expr * image,gfc_expr * team ATTRIBUTE_UNUSED)8212 gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
8213 {
8214 if (flag_coarray == GFC_FCOARRAY_NONE)
8215 {
8216 gfc_current_locus = *gfc_current_intrinsic_where;
8217 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8218 return &gfc_bad_expr;
8219 }
8220
8221 /* Simplification is possible for fcoarray = single only. For all other modes
8222 the result depends on runtime conditions. */
8223 if (flag_coarray != GFC_FCOARRAY_SINGLE)
8224 return NULL;
8225
8226 if (gfc_is_constant_expr (image))
8227 {
8228 gfc_expr *result;
8229 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8230 &image->where);
8231 if (mpz_get_si (image->value.integer) == 1)
8232 mpz_set_si (result->value.integer, 0);
8233 else
8234 mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE);
8235 return result;
8236 }
8237 else
8238 return NULL;
8239 }
8240
8241
8242 gfc_expr *
gfc_simplify_this_image(gfc_expr * coarray,gfc_expr * dim,gfc_expr * distance ATTRIBUTE_UNUSED)8243 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
8244 gfc_expr *distance ATTRIBUTE_UNUSED)
8245 {
8246 if (flag_coarray != GFC_FCOARRAY_SINGLE)
8247 return NULL;
8248
8249 /* If no coarray argument has been passed or when the first argument
8250 is actually a distance argment. */
8251 if (coarray == NULL || !gfc_is_coarray (coarray))
8252 {
8253 gfc_expr *result;
8254 /* FIXME: gfc_current_locus is wrong. */
8255 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8256 &gfc_current_locus);
8257 mpz_set_si (result->value.integer, 1);
8258 return result;
8259 }
8260
8261 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8262 return simplify_cobound (coarray, dim, NULL, 0);
8263 }
8264
8265
8266 gfc_expr *
gfc_simplify_ubound(gfc_expr * array,gfc_expr * dim,gfc_expr * kind)8267 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8268 {
8269 return simplify_bound (array, dim, kind, 1);
8270 }
8271
8272 gfc_expr *
gfc_simplify_ucobound(gfc_expr * array,gfc_expr * dim,gfc_expr * kind)8273 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8274 {
8275 return simplify_cobound (array, dim, kind, 1);
8276 }
8277
8278
8279 gfc_expr *
gfc_simplify_unpack(gfc_expr * vector,gfc_expr * mask,gfc_expr * field)8280 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
8281 {
8282 gfc_expr *result, *e;
8283 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
8284
8285 if (!is_constant_array_expr (vector)
8286 || !is_constant_array_expr (mask)
8287 || (!gfc_is_constant_expr (field)
8288 && !is_constant_array_expr (field)))
8289 return NULL;
8290
8291 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
8292 &vector->where);
8293 if (vector->ts.type == BT_DERIVED)
8294 result->ts.u.derived = vector->ts.u.derived;
8295 result->rank = mask->rank;
8296 result->shape = gfc_copy_shape (mask->shape, mask->rank);
8297
8298 if (vector->ts.type == BT_CHARACTER)
8299 result->ts.u.cl = vector->ts.u.cl;
8300
8301 vector_ctor = gfc_constructor_first (vector->value.constructor);
8302 mask_ctor = gfc_constructor_first (mask->value.constructor);
8303 field_ctor
8304 = field->expr_type == EXPR_ARRAY
8305 ? gfc_constructor_first (field->value.constructor)
8306 : NULL;
8307
8308 while (mask_ctor)
8309 {
8310 if (mask_ctor->expr->value.logical)
8311 {
8312 if (vector_ctor)
8313 {
8314 e = gfc_copy_expr (vector_ctor->expr);
8315 vector_ctor = gfc_constructor_next (vector_ctor);
8316 }
8317 else
8318 {
8319 gfc_free_expr (result);
8320 return NULL;
8321 }
8322 }
8323 else if (field->expr_type == EXPR_ARRAY)
8324 e = gfc_copy_expr (field_ctor->expr);
8325 else
8326 e = gfc_copy_expr (field);
8327
8328 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
8329
8330 mask_ctor = gfc_constructor_next (mask_ctor);
8331 field_ctor = gfc_constructor_next (field_ctor);
8332 }
8333
8334 return result;
8335 }
8336
8337
8338 gfc_expr *
gfc_simplify_verify(gfc_expr * s,gfc_expr * set,gfc_expr * b,gfc_expr * kind)8339 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
8340 {
8341 gfc_expr *result;
8342 int back;
8343 size_t index, len, lenset;
8344 size_t i;
8345 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
8346
8347 if (k == -1)
8348 return &gfc_bad_expr;
8349
8350 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
8351 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
8352 return NULL;
8353
8354 if (b != NULL && b->value.logical != 0)
8355 back = 1;
8356 else
8357 back = 0;
8358
8359 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
8360
8361 len = s->value.character.length;
8362 lenset = set->value.character.length;
8363
8364 if (len == 0)
8365 {
8366 mpz_set_ui (result->value.integer, 0);
8367 return result;
8368 }
8369
8370 if (back == 0)
8371 {
8372 if (lenset == 0)
8373 {
8374 mpz_set_ui (result->value.integer, 1);
8375 return result;
8376 }
8377
8378 index = wide_strspn (s->value.character.string,
8379 set->value.character.string) + 1;
8380 if (index > len)
8381 index = 0;
8382
8383 }
8384 else
8385 {
8386 if (lenset == 0)
8387 {
8388 mpz_set_ui (result->value.integer, len);
8389 return result;
8390 }
8391 for (index = len; index > 0; index --)
8392 {
8393 for (i = 0; i < lenset; i++)
8394 {
8395 if (s->value.character.string[index - 1]
8396 == set->value.character.string[i])
8397 break;
8398 }
8399 if (i == lenset)
8400 break;
8401 }
8402 }
8403
8404 mpz_set_ui (result->value.integer, index);
8405 return result;
8406 }
8407
8408
8409 gfc_expr *
gfc_simplify_xor(gfc_expr * x,gfc_expr * y)8410 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
8411 {
8412 gfc_expr *result;
8413 int kind;
8414
8415 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
8416 return NULL;
8417
8418 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
8419
8420 switch (x->ts.type)
8421 {
8422 case BT_INTEGER:
8423 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
8424 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
8425 return range_check (result, "XOR");
8426
8427 case BT_LOGICAL:
8428 return gfc_get_logical_expr (kind, &x->where,
8429 (x->value.logical && !y->value.logical)
8430 || (!x->value.logical && y->value.logical));
8431
8432 default:
8433 gcc_unreachable ();
8434 }
8435 }
8436
8437
8438 /****************** Constant simplification *****************/
8439
8440 /* Master function to convert one constant to another. While this is
8441 used as a simplification function, it requires the destination type
8442 and kind information which is supplied by a special case in
8443 do_simplify(). */
8444
8445 gfc_expr *
gfc_convert_constant(gfc_expr * e,bt type,int kind)8446 gfc_convert_constant (gfc_expr *e, bt type, int kind)
8447 {
8448 gfc_expr *result, *(*f) (gfc_expr *, int);
8449 gfc_constructor *c, *t;
8450
8451 switch (e->ts.type)
8452 {
8453 case BT_INTEGER:
8454 switch (type)
8455 {
8456 case BT_INTEGER:
8457 f = gfc_int2int;
8458 break;
8459 case BT_REAL:
8460 f = gfc_int2real;
8461 break;
8462 case BT_COMPLEX:
8463 f = gfc_int2complex;
8464 break;
8465 case BT_LOGICAL:
8466 f = gfc_int2log;
8467 break;
8468 default:
8469 goto oops;
8470 }
8471 break;
8472
8473 case BT_REAL:
8474 switch (type)
8475 {
8476 case BT_INTEGER:
8477 f = gfc_real2int;
8478 break;
8479 case BT_REAL:
8480 f = gfc_real2real;
8481 break;
8482 case BT_COMPLEX:
8483 f = gfc_real2complex;
8484 break;
8485 default:
8486 goto oops;
8487 }
8488 break;
8489
8490 case BT_COMPLEX:
8491 switch (type)
8492 {
8493 case BT_INTEGER:
8494 f = gfc_complex2int;
8495 break;
8496 case BT_REAL:
8497 f = gfc_complex2real;
8498 break;
8499 case BT_COMPLEX:
8500 f = gfc_complex2complex;
8501 break;
8502
8503 default:
8504 goto oops;
8505 }
8506 break;
8507
8508 case BT_LOGICAL:
8509 switch (type)
8510 {
8511 case BT_INTEGER:
8512 f = gfc_log2int;
8513 break;
8514 case BT_LOGICAL:
8515 f = gfc_log2log;
8516 break;
8517 default:
8518 goto oops;
8519 }
8520 break;
8521
8522 case BT_HOLLERITH:
8523 switch (type)
8524 {
8525 case BT_INTEGER:
8526 f = gfc_hollerith2int;
8527 break;
8528
8529 case BT_REAL:
8530 f = gfc_hollerith2real;
8531 break;
8532
8533 case BT_COMPLEX:
8534 f = gfc_hollerith2complex;
8535 break;
8536
8537 case BT_CHARACTER:
8538 f = gfc_hollerith2character;
8539 break;
8540
8541 case BT_LOGICAL:
8542 f = gfc_hollerith2logical;
8543 break;
8544
8545 default:
8546 goto oops;
8547 }
8548 break;
8549
8550 case BT_CHARACTER:
8551 switch (type)
8552 {
8553 case BT_INTEGER:
8554 f = gfc_character2int;
8555 break;
8556
8557 case BT_REAL:
8558 f = gfc_character2real;
8559 break;
8560
8561 case BT_COMPLEX:
8562 f = gfc_character2complex;
8563 break;
8564
8565 case BT_CHARACTER:
8566 f = gfc_character2character;
8567 break;
8568
8569 case BT_LOGICAL:
8570 f = gfc_character2logical;
8571 break;
8572
8573 default:
8574 goto oops;
8575 }
8576 break;
8577
8578 default:
8579 oops:
8580 return &gfc_bad_expr;
8581 }
8582
8583 result = NULL;
8584
8585 switch (e->expr_type)
8586 {
8587 case EXPR_CONSTANT:
8588 result = f (e, kind);
8589 if (result == NULL)
8590 return &gfc_bad_expr;
8591 break;
8592
8593 case EXPR_ARRAY:
8594 if (!gfc_is_constant_expr (e))
8595 break;
8596
8597 result = gfc_get_array_expr (type, kind, &e->where);
8598 result->shape = gfc_copy_shape (e->shape, e->rank);
8599 result->rank = e->rank;
8600
8601 for (c = gfc_constructor_first (e->value.constructor);
8602 c; c = gfc_constructor_next (c))
8603 {
8604 gfc_expr *tmp;
8605 if (c->iterator == NULL)
8606 {
8607 if (c->expr->expr_type == EXPR_ARRAY)
8608 tmp = gfc_convert_constant (c->expr, type, kind);
8609 else if (c->expr->expr_type == EXPR_OP)
8610 {
8611 if (!gfc_simplify_expr (c->expr, 1))
8612 return &gfc_bad_expr;
8613 tmp = f (c->expr, kind);
8614 }
8615 else
8616 tmp = f (c->expr, kind);
8617 }
8618 else
8619 tmp = gfc_convert_constant (c->expr, type, kind);
8620
8621 if (tmp == NULL || tmp == &gfc_bad_expr)
8622 {
8623 gfc_free_expr (result);
8624 return NULL;
8625 }
8626
8627 t = gfc_constructor_append_expr (&result->value.constructor,
8628 tmp, &c->where);
8629 if (c->iterator)
8630 t->iterator = gfc_copy_iterator (c->iterator);
8631 }
8632
8633 break;
8634
8635 default:
8636 break;
8637 }
8638
8639 return result;
8640 }
8641
8642
8643 /* Function for converting character constants. */
8644 gfc_expr *
gfc_convert_char_constant(gfc_expr * e,bt type ATTRIBUTE_UNUSED,int kind)8645 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
8646 {
8647 gfc_expr *result;
8648 int i;
8649
8650 if (!gfc_is_constant_expr (e))
8651 return NULL;
8652
8653 if (e->expr_type == EXPR_CONSTANT)
8654 {
8655 /* Simple case of a scalar. */
8656 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
8657 if (result == NULL)
8658 return &gfc_bad_expr;
8659
8660 result->value.character.length = e->value.character.length;
8661 result->value.character.string
8662 = gfc_get_wide_string (e->value.character.length + 1);
8663 memcpy (result->value.character.string, e->value.character.string,
8664 (e->value.character.length + 1) * sizeof (gfc_char_t));
8665
8666 /* Check we only have values representable in the destination kind. */
8667 for (i = 0; i < result->value.character.length; i++)
8668 if (!gfc_check_character_range (result->value.character.string[i],
8669 kind))
8670 {
8671 gfc_error ("Character %qs in string at %L cannot be converted "
8672 "into character kind %d",
8673 gfc_print_wide_char (result->value.character.string[i]),
8674 &e->where, kind);
8675 gfc_free_expr (result);
8676 return &gfc_bad_expr;
8677 }
8678
8679 return result;
8680 }
8681 else if (e->expr_type == EXPR_ARRAY)
8682 {
8683 /* For an array constructor, we convert each constructor element. */
8684 gfc_constructor *c;
8685
8686 result = gfc_get_array_expr (type, kind, &e->where);
8687 result->shape = gfc_copy_shape (e->shape, e->rank);
8688 result->rank = e->rank;
8689 result->ts.u.cl = e->ts.u.cl;
8690
8691 for (c = gfc_constructor_first (e->value.constructor);
8692 c; c = gfc_constructor_next (c))
8693 {
8694 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
8695 if (tmp == &gfc_bad_expr)
8696 {
8697 gfc_free_expr (result);
8698 return &gfc_bad_expr;
8699 }
8700
8701 if (tmp == NULL)
8702 {
8703 gfc_free_expr (result);
8704 return NULL;
8705 }
8706
8707 gfc_constructor_append_expr (&result->value.constructor,
8708 tmp, &c->where);
8709 }
8710
8711 return result;
8712 }
8713 else
8714 return NULL;
8715 }
8716
8717
8718 gfc_expr *
gfc_simplify_compiler_options(void)8719 gfc_simplify_compiler_options (void)
8720 {
8721 char *str;
8722 gfc_expr *result;
8723
8724 str = gfc_get_option_string ();
8725 result = gfc_get_character_expr (gfc_default_character_kind,
8726 &gfc_current_locus, str, strlen (str));
8727 free (str);
8728 return result;
8729 }
8730
8731
8732 gfc_expr *
gfc_simplify_compiler_version(void)8733 gfc_simplify_compiler_version (void)
8734 {
8735 char *buffer;
8736 size_t len;
8737
8738 len = strlen ("GCC version ") + strlen (version_string);
8739 buffer = XALLOCAVEC (char, len + 1);
8740 snprintf (buffer, len + 1, "GCC version %s", version_string);
8741 return gfc_get_character_expr (gfc_default_character_kind,
8742 &gfc_current_locus, buffer, len);
8743 }
8744
8745 /* Simplification routines for intrinsics of IEEE modules. */
8746
8747 gfc_expr *
simplify_ieee_selected_real_kind(gfc_expr * expr)8748 simplify_ieee_selected_real_kind (gfc_expr *expr)
8749 {
8750 gfc_actual_arglist *arg;
8751 gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
8752
8753 arg = expr->value.function.actual;
8754 p = arg->expr;
8755 if (arg->next)
8756 {
8757 q = arg->next->expr;
8758 if (arg->next->next)
8759 rdx = arg->next->next->expr;
8760 }
8761
8762 /* Currently, if IEEE is supported and this module is built, it means
8763 all our floating-point types conform to IEEE. Hence, we simply handle
8764 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8765 return gfc_simplify_selected_real_kind (p, q, rdx);
8766 }
8767
8768 gfc_expr *
simplify_ieee_support(gfc_expr * expr)8769 simplify_ieee_support (gfc_expr *expr)
8770 {
8771 /* We consider that if the IEEE modules are loaded, we have full support
8772 for flags, halting and rounding, which are the three functions
8773 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8774 expressions. One day, we will need libgfortran to detect support and
8775 communicate it back to us, allowing for partial support. */
8776
8777 return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
8778 true);
8779 }
8780
8781 bool
matches_ieee_function_name(gfc_symbol * sym,const char * name)8782 matches_ieee_function_name (gfc_symbol *sym, const char *name)
8783 {
8784 int n = strlen(name);
8785
8786 if (!strncmp(sym->name, name, n))
8787 return true;
8788
8789 /* If a generic was used and renamed, we need more work to find out.
8790 Compare the specific name. */
8791 if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
8792 return true;
8793
8794 return false;
8795 }
8796
8797 gfc_expr *
gfc_simplify_ieee_functions(gfc_expr * expr)8798 gfc_simplify_ieee_functions (gfc_expr *expr)
8799 {
8800 gfc_symbol* sym = expr->symtree->n.sym;
8801
8802 if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
8803 return simplify_ieee_selected_real_kind (expr);
8804 else if (matches_ieee_function_name(sym, "ieee_support_flag")
8805 || matches_ieee_function_name(sym, "ieee_support_halting")
8806 || matches_ieee_function_name(sym, "ieee_support_rounding"))
8807 return simplify_ieee_support (expr);
8808 else
8809 return NULL;
8810 }
8811