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