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