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