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