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