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