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