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