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