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