?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2011-03-27 Tobias Burnus <burnus@net-b.de>
[official-gcc.git] / gcc / fortran / simplify.c
blob69edad8e0b5a13f19229c2adc5a997954100ccde
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 = (gfc_expr**) gfc_getmem (sizeof (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 = (gfc_expr**) gfc_getmem (sizeof (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 gfc_free (arrayvec);
620 gfc_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 gfc_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 gfc_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 gfc_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 {
3303 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
3304 {
3305 gfc_free_expr (result);
3306 return gfc_copy_expr (as->lower[d-1]);
3307 }
3308
3309 goto returnNull;
3310 }
3311
3312 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3313
3314 /* Then, we need to know the extent of the given dimension. */
3315 if (coarray || ref->u.ar.type == AR_FULL)
3316 {
3317 l = as->lower[d-1];
3318 u = as->upper[d-1];
3319
3320 if (l->expr_type != EXPR_CONSTANT || u == NULL
3321 || u->expr_type != EXPR_CONSTANT)
3322 goto returnNull;
3323
3324 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
3325 {
3326 /* Zero extent. */
3327 if (upper)
3328 mpz_set_si (result->value.integer, 0);
3329 else
3330 mpz_set_si (result->value.integer, 1);
3331 }
3332 else
3333 {
3334 /* Nonzero extent. */
3335 if (upper)
3336 mpz_set (result->value.integer, u->value.integer);
3337 else
3338 mpz_set (result->value.integer, l->value.integer);
3339 }
3340 }
3341 else
3342 {
3343 if (upper)
3344 {
3345 if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL)
3346 != SUCCESS)
3347 goto returnNull;
3348 }
3349 else
3350 mpz_set_si (result->value.integer, (long int) 1);
3351 }
3352
3353 done:
3354 return range_check (result, upper ? "UBOUND" : "LBOUND");
3355
3356 returnNull:
3357 gfc_free_expr (result);
3358 return NULL;
3359 }
3360
3361
3362 static gfc_expr *
3363 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3364 {
3365 gfc_ref *ref;
3366 gfc_array_spec *as;
3367 int d;
3368
3369 if (array->expr_type != EXPR_VARIABLE)
3370 {
3371 as = NULL;
3372 ref = NULL;
3373 goto done;
3374 }
3375
3376 /* Follow any component references. */
3377 as = array->symtree->n.sym->as;
3378 for (ref = array->ref; ref; ref = ref->next)
3379 {
3380 switch (ref->type)
3381 {
3382 case REF_ARRAY:
3383 switch (ref->u.ar.type)
3384 {
3385 case AR_ELEMENT:
3386 as = NULL;
3387 continue;
3388
3389 case AR_FULL:
3390 /* We're done because 'as' has already been set in the
3391 previous iteration. */
3392 if (!ref->next)
3393 goto done;
3394
3395 /* Fall through. */
3396
3397 case AR_UNKNOWN:
3398 return NULL;
3399
3400 case AR_SECTION:
3401 as = ref->u.ar.as;
3402 goto done;
3403 }
3404
3405 gcc_unreachable ();
3406
3407 case REF_COMPONENT:
3408 as = ref->u.c.component->as;
3409 continue;
3410
3411 case REF_SUBSTRING:
3412 continue;
3413 }
3414 }
3415
3416 gcc_unreachable ();
3417
3418 done:
3419
3420 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
3421 return NULL;
3422
3423 if (dim == NULL)
3424 {
3425 /* Multi-dimensional bounds. */
3426 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3427 gfc_expr *e;
3428 int k;
3429
3430 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3431 if (upper && as && as->type == AS_ASSUMED_SIZE)
3432 {
3433 /* An error message will be emitted in
3434 check_assumed_size_reference (resolve.c). */
3435 return &gfc_bad_expr;
3436 }
3437
3438 /* Simplify the bounds for each dimension. */
3439 for (d = 0; d < array->rank; d++)
3440 {
3441 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
3442 false);
3443 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3444 {
3445 int j;
3446
3447 for (j = 0; j < d; j++)
3448 gfc_free_expr (bounds[j]);
3449 return bounds[d];
3450 }
3451 }
3452
3453 /* Allocate the result expression. */
3454 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3455 gfc_default_integer_kind);
3456 if (k == -1)
3457 return &gfc_bad_expr;
3458
3459 e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
3460
3461 /* The result is a rank 1 array; its size is the rank of the first
3462 argument to {L,U}BOUND. */
3463 e->rank = 1;
3464 e->shape = gfc_get_shape (1);
3465 mpz_init_set_ui (e->shape[0], array->rank);
3466
3467 /* Create the constructor for this array. */
3468 for (d = 0; d < array->rank; d++)
3469 gfc_constructor_append_expr (&e->value.constructor,
3470 bounds[d], &e->where);
3471
3472 return e;
3473 }
3474 else
3475 {
3476 /* A DIM argument is specified. */
3477 if (dim->expr_type != EXPR_CONSTANT)
3478 return NULL;
3479
3480 d = mpz_get_si (dim->value.integer);
3481
3482 if (d < 1 || d > array->rank
3483 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
3484 {
3485 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3486 return &gfc_bad_expr;
3487 }
3488
3489 return simplify_bound_dim (array, kind, d, upper, as, ref, false);
3490 }
3491 }
3492
3493
3494 static gfc_expr *
3495 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3496 {
3497 gfc_ref *ref;
3498 gfc_array_spec *as;
3499 int d;
3500
3501 if (array->expr_type != EXPR_VARIABLE)
3502 return NULL;
3503
3504 /* Follow any component references. */
3505 as = array->symtree->n.sym->as;
3506 for (ref = array->ref; ref; ref = ref->next)
3507 {
3508 switch (ref->type)
3509 {
3510 case REF_ARRAY:
3511 switch (ref->u.ar.type)
3512 {
3513 case AR_ELEMENT:
3514 if (ref->next == NULL)
3515 {
3516 gcc_assert (ref->u.ar.as->corank > 0
3517 && ref->u.ar.as->rank == 0);
3518 as = ref->u.ar.as;
3519 goto done;
3520 }
3521 as = NULL;
3522 continue;
3523
3524 case AR_FULL:
3525 /* We're done because 'as' has already been set in the
3526 previous iteration. */
3527 if (!ref->next)
3528 goto done;
3529
3530 /* Fall through. */
3531
3532 case AR_UNKNOWN:
3533 return NULL;
3534
3535 case AR_SECTION:
3536 as = ref->u.ar.as;
3537 goto done;
3538 }
3539
3540 gcc_unreachable ();
3541
3542 case REF_COMPONENT:
3543 as = ref->u.c.component->as;
3544 continue;
3545
3546 case REF_SUBSTRING:
3547 continue;
3548 }
3549 }
3550
3551 gcc_unreachable ();
3552
3553 done:
3554
3555 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
3556 return NULL;
3557
3558 if (dim == NULL)
3559 {
3560 /* Multi-dimensional cobounds. */
3561 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3562 gfc_expr *e;
3563 int k;
3564
3565 /* Simplify the cobounds for each dimension. */
3566 for (d = 0; d < as->corank; d++)
3567 {
3568 bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
3569 upper, as, ref, true);
3570 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3571 {
3572 int j;
3573
3574 for (j = 0; j < d; j++)
3575 gfc_free_expr (bounds[j]);
3576 return bounds[d];
3577 }
3578 }
3579
3580 /* Allocate the result expression. */
3581 e = gfc_get_expr ();
3582 e->where = array->where;
3583 e->expr_type = EXPR_ARRAY;
3584 e->ts.type = BT_INTEGER;
3585 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3586 gfc_default_integer_kind);
3587 if (k == -1)
3588 {
3589 gfc_free_expr (e);
3590 return &gfc_bad_expr;
3591 }
3592 e->ts.kind = k;
3593
3594 /* The result is a rank 1 array; its size is the rank of the first
3595 argument to {L,U}COBOUND. */
3596 e->rank = 1;
3597 e->shape = gfc_get_shape (1);
3598 mpz_init_set_ui (e->shape[0], as->corank);
3599
3600 /* Create the constructor for this array. */
3601 for (d = 0; d < as->corank; d++)
3602 gfc_constructor_append_expr (&e->value.constructor,
3603 bounds[d], &e->where);
3604 return e;
3605 }
3606 else
3607 {
3608 /* A DIM argument is specified. */
3609 if (dim->expr_type != EXPR_CONSTANT)
3610 return NULL;
3611
3612 d = mpz_get_si (dim->value.integer);
3613
3614 if (d < 1 || d > as->corank)
3615 {
3616 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3617 return &gfc_bad_expr;
3618 }
3619
3620 return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
3621 }
3622 }
3623
3624
3625 gfc_expr *
3626 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3627 {
3628 return simplify_bound (array, dim, kind, 0);
3629 }
3630
3631
3632 gfc_expr *
3633 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3634 {
3635 gfc_expr *e;
3636 /* return simplify_cobound (array, dim, kind, 0);*/
3637
3638 e = simplify_cobound (array, dim, kind, 0);
3639 if (e != NULL)
3640 return e;
3641
3642 gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
3643 "cobounds at %L", &array->where);
3644 return &gfc_bad_expr;
3645 }
3646
3647 gfc_expr *
3648 gfc_simplify_leadz (gfc_expr *e)
3649 {
3650 unsigned long lz, bs;
3651 int i;
3652
3653 if (e->expr_type != EXPR_CONSTANT)
3654 return NULL;
3655
3656 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3657 bs = gfc_integer_kinds[i].bit_size;
3658 if (mpz_cmp_si (e->value.integer, 0) == 0)
3659 lz = bs;
3660 else if (mpz_cmp_si (e->value.integer, 0) < 0)
3661 lz = 0;
3662 else
3663 lz = bs - mpz_sizeinbase (e->value.integer, 2);
3664
3665 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3666 }
3667
3668
3669 gfc_expr *
3670 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3671 {
3672 gfc_expr *result;
3673 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3674
3675 if (k == -1)
3676 return &gfc_bad_expr;
3677
3678 if (e->expr_type == EXPR_CONSTANT)
3679 {
3680 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3681 mpz_set_si (result->value.integer, e->value.character.length);
3682 return range_check (result, "LEN");
3683 }
3684 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3685 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3686 && e->ts.u.cl->length->ts.type == BT_INTEGER)
3687 {
3688 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3689 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3690 return range_check (result, "LEN");
3691 }
3692 else
3693 return NULL;
3694 }
3695
3696
3697 gfc_expr *
3698 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3699 {
3700 gfc_expr *result;
3701 int count, len, i;
3702 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3703
3704 if (k == -1)
3705 return &gfc_bad_expr;
3706
3707 if (e->expr_type != EXPR_CONSTANT)
3708 return NULL;
3709
3710 len = e->value.character.length;
3711 for (count = 0, i = 1; i <= len; i++)
3712 if (e->value.character.string[len - i] == ' ')
3713 count++;
3714 else
3715 break;
3716
3717 result = gfc_get_int_expr (k, &e->where, len - count);
3718 return range_check (result, "LEN_TRIM");
3719 }
3720
3721 gfc_expr *
3722 gfc_simplify_lgamma (gfc_expr *x)
3723 {
3724 gfc_expr *result;
3725 int sg;
3726
3727 if (x->expr_type != EXPR_CONSTANT)
3728 return NULL;
3729
3730 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3731 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3732
3733 return range_check (result, "LGAMMA");
3734 }
3735
3736
3737 gfc_expr *
3738 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3739 {
3740 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3741 return NULL;
3742
3743 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3744 gfc_compare_string (a, b) >= 0);
3745 }
3746
3747
3748 gfc_expr *
3749 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3750 {
3751 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3752 return NULL;
3753
3754 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3755 gfc_compare_string (a, b) > 0);
3756 }
3757
3758
3759 gfc_expr *
3760 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3761 {
3762 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3763 return NULL;
3764
3765 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3766 gfc_compare_string (a, b) <= 0);
3767 }
3768
3769
3770 gfc_expr *
3771 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3772 {
3773 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3774 return NULL;
3775
3776 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3777 gfc_compare_string (a, b) < 0);
3778 }
3779
3780
3781 gfc_expr *
3782 gfc_simplify_log (gfc_expr *x)
3783 {
3784 gfc_expr *result;
3785
3786 if (x->expr_type != EXPR_CONSTANT)
3787 return NULL;
3788
3789 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3790
3791 switch (x->ts.type)
3792 {
3793 case BT_REAL:
3794 if (mpfr_sgn (x->value.real) <= 0)
3795 {
3796 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3797 "to zero", &x->where);
3798 gfc_free_expr (result);
3799 return &gfc_bad_expr;
3800 }
3801
3802 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3803 break;
3804
3805 case BT_COMPLEX:
3806 if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3807 && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3808 {
3809 gfc_error ("Complex argument of LOG at %L cannot be zero",
3810 &x->where);
3811 gfc_free_expr (result);
3812 return &gfc_bad_expr;
3813 }
3814
3815 gfc_set_model_kind (x->ts.kind);
3816 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3817 break;
3818
3819 default:
3820 gfc_internal_error ("gfc_simplify_log: bad type");
3821 }
3822
3823 return range_check (result, "LOG");
3824 }
3825
3826
3827 gfc_expr *
3828 gfc_simplify_log10 (gfc_expr *x)
3829 {
3830 gfc_expr *result;
3831
3832 if (x->expr_type != EXPR_CONSTANT)
3833 return NULL;
3834
3835 if (mpfr_sgn (x->value.real) <= 0)
3836 {
3837 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3838 "to zero", &x->where);
3839 return &gfc_bad_expr;
3840 }
3841
3842 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3843 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3844
3845 return range_check (result, "LOG10");
3846 }
3847
3848
3849 gfc_expr *
3850 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3851 {
3852 int kind;
3853
3854 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3855 if (kind < 0)
3856 return &gfc_bad_expr;
3857
3858 if (e->expr_type != EXPR_CONSTANT)
3859 return NULL;
3860
3861 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3862 }
3863
3864
3865 gfc_expr*
3866 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3867 {
3868 gfc_expr *result;
3869 int row, result_rows, col, result_columns;
3870 int stride_a, offset_a, stride_b, offset_b;
3871
3872 if (!is_constant_array_expr (matrix_a)
3873 || !is_constant_array_expr (matrix_b))
3874 return NULL;
3875
3876 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3877 result = gfc_get_array_expr (matrix_a->ts.type,
3878 matrix_a->ts.kind,
3879 &matrix_a->where);
3880
3881 if (matrix_a->rank == 1 && matrix_b->rank == 2)
3882 {
3883 result_rows = 1;
3884 result_columns = mpz_get_si (matrix_b->shape[0]);
3885 stride_a = 1;
3886 stride_b = mpz_get_si (matrix_b->shape[0]);
3887
3888 result->rank = 1;
3889 result->shape = gfc_get_shape (result->rank);
3890 mpz_init_set_si (result->shape[0], result_columns);
3891 }
3892 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3893 {
3894 result_rows = mpz_get_si (matrix_b->shape[0]);
3895 result_columns = 1;
3896 stride_a = mpz_get_si (matrix_a->shape[0]);
3897 stride_b = 1;
3898
3899 result->rank = 1;
3900 result->shape = gfc_get_shape (result->rank);
3901 mpz_init_set_si (result->shape[0], result_rows);
3902 }
3903 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3904 {
3905 result_rows = mpz_get_si (matrix_a->shape[0]);
3906 result_columns = mpz_get_si (matrix_b->shape[1]);
3907 stride_a = mpz_get_si (matrix_a->shape[1]);
3908 stride_b = mpz_get_si (matrix_b->shape[0]);
3909
3910 result->rank = 2;
3911 result->shape = gfc_get_shape (result->rank);
3912 mpz_init_set_si (result->shape[0], result_rows);
3913 mpz_init_set_si (result->shape[1], result_columns);
3914 }
3915 else
3916 gcc_unreachable();
3917
3918 offset_a = offset_b = 0;
3919 for (col = 0; col < result_columns; ++col)
3920 {
3921 offset_a = 0;
3922
3923 for (row = 0; row < result_rows; ++row)
3924 {
3925 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3926 matrix_b, 1, offset_b);
3927 gfc_constructor_append_expr (&result->value.constructor,
3928 e, NULL);
3929
3930 offset_a += 1;
3931 }
3932
3933 offset_b += stride_b;
3934 }
3935
3936 return result;
3937 }
3938
3939
3940 gfc_expr *
3941 gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
3942 {
3943 gfc_expr *result;
3944 int kind, arg, k;
3945 const char *s;
3946
3947 if (i->expr_type != EXPR_CONSTANT)
3948 return NULL;
3949
3950 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
3951 if (kind == -1)
3952 return &gfc_bad_expr;
3953 k = gfc_validate_kind (BT_INTEGER, kind, false);
3954
3955 s = gfc_extract_int (i, &arg);
3956 gcc_assert (!s);
3957
3958 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3959
3960 /* MASKR(n) = 2^n - 1 */
3961 mpz_set_ui (result->value.integer, 1);
3962 mpz_mul_2exp (result->value.integer, result->value.integer, arg);
3963 mpz_sub_ui (result->value.integer, result->value.integer, 1);
3964
3965 convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3966
3967 return result;
3968 }
3969
3970
3971 gfc_expr *
3972 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
3973 {
3974 gfc_expr *result;
3975 int kind, arg, k;
3976 const char *s;
3977 mpz_t z;
3978
3979 if (i->expr_type != EXPR_CONSTANT)
3980 return NULL;
3981
3982 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
3983 if (kind == -1)
3984 return &gfc_bad_expr;
3985 k = gfc_validate_kind (BT_INTEGER, kind, false);
3986
3987 s = gfc_extract_int (i, &arg);
3988 gcc_assert (!s);
3989
3990 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3991
3992 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
3993 mpz_init_set_ui (z, 1);
3994 mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
3995 mpz_set_ui (result->value.integer, 1);
3996 mpz_mul_2exp (result->value.integer, result->value.integer,
3997 gfc_integer_kinds[k].bit_size - arg);
3998 mpz_sub (result->value.integer, z, result->value.integer);
3999 mpz_clear (z);
4000
4001 convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4002
4003 return result;
4004 }
4005
4006
4007 gfc_expr *
4008 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4009 {
4010 if (tsource->expr_type != EXPR_CONSTANT
4011 || fsource->expr_type != EXPR_CONSTANT
4012 || mask->expr_type != EXPR_CONSTANT)
4013 return NULL;
4014
4015 return gfc_copy_expr (mask->value.logical ? tsource : fsource);
4016 }
4017
4018
4019 gfc_expr *
4020 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4021 {
4022 mpz_t arg1, arg2, mask;
4023 gfc_expr *result;
4024
4025 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
4026 || mask_expr->expr_type != EXPR_CONSTANT)
4027 return NULL;
4028
4029 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4030
4031 /* Convert all argument to unsigned. */
4032 mpz_init_set (arg1, i->value.integer);
4033 mpz_init_set (arg2, j->value.integer);
4034 mpz_init_set (mask, mask_expr->value.integer);
4035
4036 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4037 mpz_and (arg1, arg1, mask);
4038 mpz_com (mask, mask);
4039 mpz_and (arg2, arg2, mask);
4040 mpz_ior (result->value.integer, arg1, arg2);
4041
4042 mpz_clear (arg1);
4043 mpz_clear (arg2);
4044 mpz_clear (mask);
4045
4046 return result;
4047 }
4048
4049
4050 /* Selects between current value and extremum for simplify_min_max
4051 and simplify_minval_maxval. */
4052 static void
4053 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
4054 {
4055 switch (arg->ts.type)
4056 {
4057 case BT_INTEGER:
4058 if (mpz_cmp (arg->value.integer,
4059 extremum->value.integer) * sign > 0)
4060 mpz_set (extremum->value.integer, arg->value.integer);
4061 break;
4062
4063 case BT_REAL:
4064 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4065 if (sign > 0)
4066 mpfr_max (extremum->value.real, extremum->value.real,
4067 arg->value.real, GFC_RND_MODE);
4068 else
4069 mpfr_min (extremum->value.real, extremum->value.real,
4070 arg->value.real, GFC_RND_MODE);
4071 break;
4072
4073 case BT_CHARACTER:
4074 #define LENGTH(x) ((x)->value.character.length)
4075 #define STRING(x) ((x)->value.character.string)
4076 if (LENGTH(extremum) < LENGTH(arg))
4077 {
4078 gfc_char_t *tmp = STRING(extremum);
4079
4080 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4081 memcpy (STRING(extremum), tmp,
4082 LENGTH(extremum) * sizeof (gfc_char_t));
4083 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4084 LENGTH(arg) - LENGTH(extremum));
4085 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
4086 LENGTH(extremum) = LENGTH(arg);
4087 gfc_free (tmp);
4088 }
4089
4090 if (gfc_compare_string (arg, extremum) * sign > 0)
4091 {
4092 gfc_free (STRING(extremum));
4093 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4094 memcpy (STRING(extremum), STRING(arg),
4095 LENGTH(arg) * sizeof (gfc_char_t));
4096 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4097 LENGTH(extremum) - LENGTH(arg));
4098 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
4099 }
4100 #undef LENGTH
4101 #undef STRING
4102 break;
4103
4104 default:
4105 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4106 }
4107 }
4108
4109
4110 /* This function is special since MAX() can take any number of
4111 arguments. The simplified expression is a rewritten version of the
4112 argument list containing at most one constant element. Other
4113 constant elements are deleted. Because the argument list has
4114 already been checked, this function always succeeds. sign is 1 for
4115 MAX(), -1 for MIN(). */
4116
4117 static gfc_expr *
4118 simplify_min_max (gfc_expr *expr, int sign)
4119 {
4120 gfc_actual_arglist *arg, *last, *extremum;
4121 gfc_intrinsic_sym * specific;
4122
4123 last = NULL;
4124 extremum = NULL;
4125 specific = expr->value.function.isym;
4126
4127 arg = expr->value.function.actual;
4128
4129 for (; arg; last = arg, arg = arg->next)
4130 {
4131 if (arg->expr->expr_type != EXPR_CONSTANT)
4132 continue;
4133
4134 if (extremum == NULL)
4135 {
4136 extremum = arg;
4137 continue;
4138 }
4139
4140 min_max_choose (arg->expr, extremum->expr, sign);
4141
4142 /* Delete the extra constant argument. */
4143 if (last == NULL)
4144 expr->value.function.actual = arg->next;
4145 else
4146 last->next = arg->next;
4147
4148 arg->next = NULL;
4149 gfc_free_actual_arglist (arg);
4150 arg = last;
4151 }
4152
4153 /* If there is one value left, replace the function call with the
4154 expression. */
4155 if (expr->value.function.actual->next != NULL)
4156 return NULL;
4157
4158 /* Convert to the correct type and kind. */
4159 if (expr->ts.type != BT_UNKNOWN)
4160 return gfc_convert_constant (expr->value.function.actual->expr,
4161 expr->ts.type, expr->ts.kind);
4162
4163 if (specific->ts.type != BT_UNKNOWN)
4164 return gfc_convert_constant (expr->value.function.actual->expr,
4165 specific->ts.type, specific->ts.kind);
4166
4167 return gfc_copy_expr (expr->value.function.actual->expr);
4168 }
4169
4170
4171 gfc_expr *
4172 gfc_simplify_min (gfc_expr *e)
4173 {
4174 return simplify_min_max (e, -1);
4175 }
4176
4177
4178 gfc_expr *
4179 gfc_simplify_max (gfc_expr *e)
4180 {
4181 return simplify_min_max (e, 1);
4182 }
4183
4184
4185 /* This is a simplified version of simplify_min_max to provide
4186 simplification of minval and maxval for a vector. */
4187
4188 static gfc_expr *
4189 simplify_minval_maxval (gfc_expr *expr, int sign)
4190 {
4191 gfc_constructor *c, *extremum;
4192 gfc_intrinsic_sym * specific;
4193
4194 extremum = NULL;
4195 specific = expr->value.function.isym;
4196
4197 for (c = gfc_constructor_first (expr->value.constructor);
4198 c; c = gfc_constructor_next (c))
4199 {
4200 if (c->expr->expr_type != EXPR_CONSTANT)
4201 return NULL;
4202
4203 if (extremum == NULL)
4204 {
4205 extremum = c;
4206 continue;
4207 }
4208
4209 min_max_choose (c->expr, extremum->expr, sign);
4210 }
4211
4212 if (extremum == NULL)
4213 return NULL;
4214
4215 /* Convert to the correct type and kind. */
4216 if (expr->ts.type != BT_UNKNOWN)
4217 return gfc_convert_constant (extremum->expr,
4218 expr->ts.type, expr->ts.kind);
4219
4220 if (specific->ts.type != BT_UNKNOWN)
4221 return gfc_convert_constant (extremum->expr,
4222 specific->ts.type, specific->ts.kind);
4223
4224 return gfc_copy_expr (extremum->expr);
4225 }
4226
4227
4228 gfc_expr *
4229 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4230 {
4231 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4232 return NULL;
4233
4234 return simplify_minval_maxval (array, -1);
4235 }
4236
4237
4238 gfc_expr *
4239 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4240 {
4241 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4242 return NULL;
4243
4244 return simplify_minval_maxval (array, 1);
4245 }
4246
4247
4248 gfc_expr *
4249 gfc_simplify_maxexponent (gfc_expr *x)
4250 {
4251 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4252 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4253 gfc_real_kinds[i].max_exponent);
4254 }
4255
4256
4257 gfc_expr *
4258 gfc_simplify_minexponent (gfc_expr *x)
4259 {
4260 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4261 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4262 gfc_real_kinds[i].min_exponent);
4263 }
4264
4265
4266 gfc_expr *
4267 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
4268 {
4269 gfc_expr *result;
4270 mpfr_t tmp;
4271 int kind;
4272
4273 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4274 return NULL;
4275
4276 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4277 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4278
4279 switch (a->ts.type)
4280 {
4281 case BT_INTEGER:
4282 if (mpz_cmp_ui (p->value.integer, 0) == 0)
4283 {
4284 /* Result is processor-dependent. */
4285 gfc_error ("Second argument MOD at %L is zero", &a->where);
4286 gfc_free_expr (result);
4287 return &gfc_bad_expr;
4288 }
4289 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
4290 break;
4291
4292 case BT_REAL:
4293 if (mpfr_cmp_ui (p->value.real, 0) == 0)
4294 {
4295 /* Result is processor-dependent. */
4296 gfc_error ("Second argument of MOD at %L is zero", &p->where);
4297 gfc_free_expr (result);
4298 return &gfc_bad_expr;
4299 }
4300
4301 gfc_set_model_kind (kind);
4302 mpfr_init (tmp);
4303 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
4304 mpfr_trunc (tmp, tmp);
4305 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
4306 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
4307 mpfr_clear (tmp);
4308 break;
4309
4310 default:
4311 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4312 }
4313
4314 return range_check (result, "MOD");
4315 }
4316
4317
4318 gfc_expr *
4319 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
4320 {
4321 gfc_expr *result;
4322 mpfr_t tmp;
4323 int kind;
4324
4325 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4326 return NULL;
4327
4328 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4329 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4330
4331 switch (a->ts.type)
4332 {
4333 case BT_INTEGER:
4334 if (mpz_cmp_ui (p->value.integer, 0) == 0)
4335 {
4336 /* Result is processor-dependent. This processor just opts
4337 to not handle it at all. */
4338 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
4339 gfc_free_expr (result);
4340 return &gfc_bad_expr;
4341 }
4342 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
4343
4344 break;
4345
4346 case BT_REAL:
4347 if (mpfr_cmp_ui (p->value.real, 0) == 0)
4348 {
4349 /* Result is processor-dependent. */
4350 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
4351 gfc_free_expr (result);
4352 return &gfc_bad_expr;
4353 }
4354
4355 gfc_set_model_kind (kind);
4356 mpfr_init (tmp);
4357 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
4358 mpfr_floor (tmp, tmp);
4359 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
4360 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
4361 mpfr_clear (tmp);
4362 break;
4363
4364 default:
4365 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4366 }
4367
4368 return range_check (result, "MODULO");
4369 }
4370
4371
4372 /* Exists for the sole purpose of consistency with other intrinsics. */
4373 gfc_expr *
4374 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
4375 gfc_expr *fp ATTRIBUTE_UNUSED,
4376 gfc_expr *l ATTRIBUTE_UNUSED,
4377 gfc_expr *to ATTRIBUTE_UNUSED,
4378 gfc_expr *tp ATTRIBUTE_UNUSED)
4379 {
4380 return NULL;
4381 }
4382
4383
4384 gfc_expr *
4385 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
4386 {
4387 gfc_expr *result;
4388 mp_exp_t emin, emax;
4389 int kind;
4390
4391 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4392 return NULL;
4393
4394 if (mpfr_sgn (s->value.real) == 0)
4395 {
4396 gfc_error ("Second argument of NEAREST at %L shall not be zero",
4397 &s->where);
4398 return &gfc_bad_expr;
4399 }
4400
4401 result = gfc_copy_expr (x);
4402
4403 /* Save current values of emin and emax. */
4404 emin = mpfr_get_emin ();
4405 emax = mpfr_get_emax ();
4406
4407 /* Set emin and emax for the current model number. */
4408 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
4409 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
4410 mpfr_get_prec(result->value.real) + 1);
4411 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
4412 mpfr_check_range (result->value.real, 0, GMP_RNDU);
4413
4414 if (mpfr_sgn (s->value.real) > 0)
4415 {
4416 mpfr_nextabove (result->value.real);
4417 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
4418 }
4419 else
4420 {
4421 mpfr_nextbelow (result->value.real);
4422 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
4423 }
4424
4425 mpfr_set_emin (emin);
4426 mpfr_set_emax (emax);
4427
4428 /* Only NaN can occur. Do not use range check as it gives an
4429 error for denormal numbers. */
4430 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
4431 {
4432 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
4433 gfc_free_expr (result);
4434 return &gfc_bad_expr;
4435 }
4436
4437 return result;
4438 }
4439
4440
4441 static gfc_expr *
4442 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
4443 {
4444 gfc_expr *itrunc, *result;
4445 int kind;
4446
4447 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
4448 if (kind == -1)
4449 return &gfc_bad_expr;
4450
4451 if (e->expr_type != EXPR_CONSTANT)
4452 return NULL;
4453
4454 itrunc = gfc_copy_expr (e);
4455 mpfr_round (itrunc->value.real, e->value.real);
4456
4457 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
4458 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
4459
4460 gfc_free_expr (itrunc);
4461
4462 return range_check (result, name);
4463 }
4464
4465
4466 gfc_expr *
4467 gfc_simplify_new_line (gfc_expr *e)
4468 {
4469 gfc_expr *result;
4470
4471 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
4472 result->value.character.string[0] = '\n';
4473
4474 return result;
4475 }
4476
4477
4478 gfc_expr *
4479 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
4480 {
4481 return simplify_nint ("NINT", e, k);
4482 }
4483
4484
4485 gfc_expr *
4486 gfc_simplify_idnint (gfc_expr *e)
4487 {
4488 return simplify_nint ("IDNINT", e, NULL);
4489 }
4490
4491
4492 static gfc_expr *
4493 add_squared (gfc_expr *result, gfc_expr *e)
4494 {
4495 mpfr_t tmp;
4496
4497 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4498 gcc_assert (result->ts.type == BT_REAL
4499 && result->expr_type == EXPR_CONSTANT);
4500
4501 gfc_set_model_kind (result->ts.kind);
4502 mpfr_init (tmp);
4503 mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
4504 mpfr_add (result->value.real, result->value.real, tmp,
4505 GFC_RND_MODE);
4506 mpfr_clear (tmp);
4507
4508 return result;
4509 }
4510
4511
4512 static gfc_expr *
4513 do_sqrt (gfc_expr *result, gfc_expr *e)
4514 {
4515 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4516 gcc_assert (result->ts.type == BT_REAL
4517 && result->expr_type == EXPR_CONSTANT);
4518
4519 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
4520 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4521 return result;
4522 }
4523
4524
4525 gfc_expr *
4526 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
4527 {
4528 gfc_expr *result;
4529
4530 if (!is_constant_array_expr (e)
4531 || (dim != NULL && !gfc_is_constant_expr (dim)))
4532 return NULL;
4533
4534 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
4535 init_result_expr (result, 0, NULL);
4536
4537 if (!dim || e->rank == 1)
4538 {
4539 result = simplify_transformation_to_scalar (result, e, NULL,
4540 add_squared);
4541 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4542 }
4543 else
4544 result = simplify_transformation_to_array (result, e, dim, NULL,
4545 add_squared, &do_sqrt);
4546
4547 return result;
4548 }
4549
4550
4551 gfc_expr *
4552 gfc_simplify_not (gfc_expr *e)
4553 {
4554 gfc_expr *result;
4555
4556 if (e->expr_type != EXPR_CONSTANT)
4557 return NULL;
4558
4559 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4560 mpz_com (result->value.integer, e->value.integer);
4561
4562 return range_check (result, "NOT");
4563 }
4564
4565
4566 gfc_expr *
4567 gfc_simplify_null (gfc_expr *mold)
4568 {
4569 gfc_expr *result;
4570
4571 if (mold)
4572 {
4573 result = gfc_copy_expr (mold);
4574 result->expr_type = EXPR_NULL;
4575 }
4576 else
4577 result = gfc_get_null_expr (NULL);
4578
4579 return result;
4580 }
4581
4582
4583 gfc_expr *
4584 gfc_simplify_num_images (void)
4585 {
4586 gfc_expr *result;
4587
4588 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4589 {
4590 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4591 return &gfc_bad_expr;
4592 }
4593
4594 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
4595 return NULL;
4596
4597 /* FIXME: gfc_current_locus is wrong. */
4598 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4599 &gfc_current_locus);
4600 mpz_set_si (result->value.integer, 1);
4601 return result;
4602 }
4603
4604
4605 gfc_expr *
4606 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
4607 {
4608 gfc_expr *result;
4609 int kind;
4610
4611 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4612 return NULL;
4613
4614 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4615
4616 switch (x->ts.type)
4617 {
4618 case BT_INTEGER:
4619 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4620 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4621 return range_check (result, "OR");
4622
4623 case BT_LOGICAL:
4624 return gfc_get_logical_expr (kind, &x->where,
4625 x->value.logical || y->value.logical);
4626 default:
4627 gcc_unreachable();
4628 }
4629 }
4630
4631
4632 gfc_expr *
4633 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4634 {
4635 gfc_expr *result;
4636 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4637
4638 if (!is_constant_array_expr(array)
4639 || !is_constant_array_expr(vector)
4640 || (!gfc_is_constant_expr (mask)
4641 && !is_constant_array_expr(mask)))
4642 return NULL;
4643
4644 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
4645 if (array->ts.type == BT_DERIVED)
4646 result->ts.u.derived = array->ts.u.derived;
4647
4648 array_ctor = gfc_constructor_first (array->value.constructor);
4649 vector_ctor = vector
4650 ? gfc_constructor_first (vector->value.constructor)
4651 : NULL;
4652
4653 if (mask->expr_type == EXPR_CONSTANT
4654 && mask->value.logical)
4655 {
4656 /* Copy all elements of ARRAY to RESULT. */
4657 while (array_ctor)
4658 {
4659 gfc_constructor_append_expr (&result->value.constructor,
4660 gfc_copy_expr (array_ctor->expr),
4661 NULL);
4662
4663 array_ctor = gfc_constructor_next (array_ctor);
4664 vector_ctor = gfc_constructor_next (vector_ctor);
4665 }
4666 }
4667 else if (mask->expr_type == EXPR_ARRAY)
4668 {
4669 /* Copy only those elements of ARRAY to RESULT whose
4670 MASK equals .TRUE.. */
4671 mask_ctor = gfc_constructor_first (mask->value.constructor);
4672 while (mask_ctor)
4673 {
4674 if (mask_ctor->expr->value.logical)
4675 {
4676 gfc_constructor_append_expr (&result->value.constructor,
4677 gfc_copy_expr (array_ctor->expr),
4678 NULL);
4679 vector_ctor = gfc_constructor_next (vector_ctor);
4680 }
4681
4682 array_ctor = gfc_constructor_next (array_ctor);
4683 mask_ctor = gfc_constructor_next (mask_ctor);
4684 }
4685 }
4686
4687 /* Append any left-over elements from VECTOR to RESULT. */
4688 while (vector_ctor)
4689 {
4690 gfc_constructor_append_expr (&result->value.constructor,
4691 gfc_copy_expr (vector_ctor->expr),
4692 NULL);
4693 vector_ctor = gfc_constructor_next (vector_ctor);
4694 }
4695
4696 result->shape = gfc_get_shape (1);
4697 gfc_array_size (result, &result->shape[0]);
4698
4699 if (array->ts.type == BT_CHARACTER)
4700 result->ts.u.cl = array->ts.u.cl;
4701
4702 return result;
4703 }
4704
4705
4706 static gfc_expr *
4707 do_xor (gfc_expr *result, gfc_expr *e)
4708 {
4709 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
4710 gcc_assert (result->ts.type == BT_LOGICAL
4711 && result->expr_type == EXPR_CONSTANT);
4712
4713 result->value.logical = result->value.logical != e->value.logical;
4714 return result;
4715 }
4716
4717
4718
4719 gfc_expr *
4720 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
4721 {
4722 return simplify_transformation (e, dim, NULL, 0, do_xor);
4723 }
4724
4725
4726 gfc_expr *
4727 gfc_simplify_popcnt (gfc_expr *e)
4728 {
4729 int res, k;
4730 mpz_t x;
4731
4732 if (e->expr_type != EXPR_CONSTANT)
4733 return NULL;
4734
4735 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4736
4737 /* Convert argument to unsigned, then count the '1' bits. */
4738 mpz_init_set (x, e->value.integer);
4739 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
4740 res = mpz_popcount (x);
4741 mpz_clear (x);
4742
4743 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
4744 }
4745
4746
4747 gfc_expr *
4748 gfc_simplify_poppar (gfc_expr *e)
4749 {
4750 gfc_expr *popcnt;
4751 const char *s;
4752 int i;
4753
4754 if (e->expr_type != EXPR_CONSTANT)
4755 return NULL;
4756
4757 popcnt = gfc_simplify_popcnt (e);
4758 gcc_assert (popcnt);
4759
4760 s = gfc_extract_int (popcnt, &i);
4761 gcc_assert (!s);
4762
4763 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
4764 }
4765
4766
4767 gfc_expr *
4768 gfc_simplify_precision (gfc_expr *e)
4769 {
4770 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4771 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
4772 gfc_real_kinds[i].precision);
4773 }
4774
4775
4776 gfc_expr *
4777 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4778 {
4779 return simplify_transformation (array, dim, mask, 1, gfc_multiply);
4780 }
4781
4782
4783 gfc_expr *
4784 gfc_simplify_radix (gfc_expr *e)
4785 {
4786 int i;
4787 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4788
4789 switch (e->ts.type)
4790 {
4791 case BT_INTEGER:
4792 i = gfc_integer_kinds[i].radix;
4793 break;
4794
4795 case BT_REAL:
4796 i = gfc_real_kinds[i].radix;
4797 break;
4798
4799 default:
4800 gcc_unreachable ();
4801 }
4802
4803 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4804 }
4805
4806
4807 gfc_expr *
4808 gfc_simplify_range (gfc_expr *e)
4809 {
4810 int i;
4811 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4812
4813 switch (e->ts.type)
4814 {
4815 case BT_INTEGER:
4816 i = gfc_integer_kinds[i].range;
4817 break;
4818
4819 case BT_REAL:
4820 case BT_COMPLEX:
4821 i = gfc_real_kinds[i].range;
4822 break;
4823
4824 default:
4825 gcc_unreachable ();
4826 }
4827
4828 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4829 }
4830
4831
4832 gfc_expr *
4833 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4834 {
4835 gfc_expr *result = NULL;
4836 int kind;
4837
4838 if (e->ts.type == BT_COMPLEX)
4839 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4840 else
4841 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4842
4843 if (kind == -1)
4844 return &gfc_bad_expr;
4845
4846 if (e->expr_type != EXPR_CONSTANT)
4847 return NULL;
4848
4849 if (convert_boz (e, kind) == &gfc_bad_expr)
4850 return &gfc_bad_expr;
4851
4852 result = gfc_convert_constant (e, BT_REAL, kind);
4853 if (result == &gfc_bad_expr)
4854 return &gfc_bad_expr;
4855
4856 return range_check (result, "REAL");
4857 }
4858
4859
4860 gfc_expr *
4861 gfc_simplify_realpart (gfc_expr *e)
4862 {
4863 gfc_expr *result;
4864
4865 if (e->expr_type != EXPR_CONSTANT)
4866 return NULL;
4867
4868 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4869 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4870
4871 return range_check (result, "REALPART");
4872 }
4873
4874 gfc_expr *
4875 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4876 {
4877 gfc_expr *result;
4878 int i, j, len, ncop, nlen;
4879 mpz_t ncopies;
4880 bool have_length = false;
4881
4882 /* If NCOPIES isn't a constant, there's nothing we can do. */
4883 if (n->expr_type != EXPR_CONSTANT)
4884 return NULL;
4885
4886 /* If NCOPIES is negative, it's an error. */
4887 if (mpz_sgn (n->value.integer) < 0)
4888 {
4889 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4890 &n->where);
4891 return &gfc_bad_expr;
4892 }
4893
4894 /* If we don't know the character length, we can do no more. */
4895 if (e->ts.u.cl && e->ts.u.cl->length
4896 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4897 {
4898 len = mpz_get_si (e->ts.u.cl->length->value.integer);
4899 have_length = true;
4900 }
4901 else if (e->expr_type == EXPR_CONSTANT
4902 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4903 {
4904 len = e->value.character.length;
4905 }
4906 else
4907 return NULL;
4908
4909 /* If the source length is 0, any value of NCOPIES is valid
4910 and everything behaves as if NCOPIES == 0. */
4911 mpz_init (ncopies);
4912 if (len == 0)
4913 mpz_set_ui (ncopies, 0);
4914 else
4915 mpz_set (ncopies, n->value.integer);
4916
4917 /* Check that NCOPIES isn't too large. */
4918 if (len)
4919 {
4920 mpz_t max, mlen;
4921 int i;
4922
4923 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4924 mpz_init (max);
4925 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4926
4927 if (have_length)
4928 {
4929 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4930 e->ts.u.cl->length->value.integer);
4931 }
4932 else
4933 {
4934 mpz_init_set_si (mlen, len);
4935 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4936 mpz_clear (mlen);
4937 }
4938
4939 /* The check itself. */
4940 if (mpz_cmp (ncopies, max) > 0)
4941 {
4942 mpz_clear (max);
4943 mpz_clear (ncopies);
4944 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4945 &n->where);
4946 return &gfc_bad_expr;
4947 }
4948
4949 mpz_clear (max);
4950 }
4951 mpz_clear (ncopies);
4952
4953 /* For further simplification, we need the character string to be
4954 constant. */
4955 if (e->expr_type != EXPR_CONSTANT)
4956 return NULL;
4957
4958 if (len ||
4959 (e->ts.u.cl->length &&
4960 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4961 {
4962 const char *res = gfc_extract_int (n, &ncop);
4963 gcc_assert (res == NULL);
4964 }
4965 else
4966 ncop = 0;
4967
4968 len = e->value.character.length;
4969 nlen = ncop * len;
4970
4971 result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4972
4973 if (ncop == 0)
4974 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4975
4976 len = e->value.character.length;
4977 nlen = ncop * len;
4978
4979 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4980 for (i = 0; i < ncop; i++)
4981 for (j = 0; j < len; j++)
4982 result->value.character.string[j+i*len]= e->value.character.string[j];
4983
4984 result->value.character.string[nlen] = '\0'; /* For debugger */
4985 return result;
4986 }
4987
4988
4989 /* This one is a bear, but mainly has to do with shuffling elements. */
4990
4991 gfc_expr *
4992 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4993 gfc_expr *pad, gfc_expr *order_exp)
4994 {
4995 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4996 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4997 mpz_t index, size;
4998 unsigned long j;
4999 size_t nsource;
5000 gfc_expr *e, *result;
5001
5002 /* Check that argument expression types are OK. */
5003 if (!is_constant_array_expr (source)
5004 || !is_constant_array_expr (shape_exp)
5005 || !is_constant_array_expr (pad)
5006 || !is_constant_array_expr (order_exp))
5007 return NULL;
5008
5009 /* Proceed with simplification, unpacking the array. */
5010
5011 mpz_init (index);
5012 rank = 0;
5013
5014 for (;;)
5015 {
5016 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
5017 if (e == NULL)
5018 break;
5019
5020 gfc_extract_int (e, &shape[rank]);
5021
5022 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
5023 gcc_assert (shape[rank] >= 0);
5024
5025 rank++;
5026 }
5027
5028 gcc_assert (rank > 0);
5029
5030 /* Now unpack the order array if present. */
5031 if (order_exp == NULL)
5032 {
5033 for (i = 0; i < rank; i++)
5034 order[i] = i;
5035 }
5036 else
5037 {
5038 for (i = 0; i < rank; i++)
5039 x[i] = 0;
5040
5041 for (i = 0; i < rank; i++)
5042 {
5043 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
5044 gcc_assert (e);
5045
5046 gfc_extract_int (e, &order[i]);
5047
5048 gcc_assert (order[i] >= 1 && order[i] <= rank);
5049 order[i]--;
5050 gcc_assert (x[order[i]] == 0);
5051 x[order[i]] = 1;
5052 }
5053 }
5054
5055 /* Count the elements in the source and padding arrays. */
5056
5057 npad = 0;
5058 if (pad != NULL)
5059 {
5060 gfc_array_size (pad, &size);
5061 npad = mpz_get_ui (size);
5062 mpz_clear (size);
5063 }
5064
5065 gfc_array_size (source, &size);
5066 nsource = mpz_get_ui (size);
5067 mpz_clear (size);
5068
5069 /* If it weren't for that pesky permutation we could just loop
5070 through the source and round out any shortage with pad elements.
5071 But no, someone just had to have the compiler do something the
5072 user should be doing. */
5073
5074 for (i = 0; i < rank; i++)
5075 x[i] = 0;
5076
5077 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5078 &source->where);
5079 if (source->ts.type == BT_DERIVED)
5080 result->ts.u.derived = source->ts.u.derived;
5081 result->rank = rank;
5082 result->shape = gfc_get_shape (rank);
5083 for (i = 0; i < rank; i++)
5084 mpz_init_set_ui (result->shape[i], shape[i]);
5085
5086 while (nsource > 0 || npad > 0)
5087 {
5088 /* Figure out which element to extract. */
5089 mpz_set_ui (index, 0);
5090
5091 for (i = rank - 1; i >= 0; i--)
5092 {
5093 mpz_add_ui (index, index, x[order[i]]);
5094 if (i != 0)
5095 mpz_mul_ui (index, index, shape[order[i - 1]]);
5096 }
5097
5098 if (mpz_cmp_ui (index, INT_MAX) > 0)
5099 gfc_internal_error ("Reshaped array too large at %C");
5100
5101 j = mpz_get_ui (index);
5102
5103 if (j < nsource)
5104 e = gfc_constructor_lookup_expr (source->value.constructor, j);
5105 else
5106 {
5107 gcc_assert (npad > 0);
5108
5109 j = j - nsource;
5110 j = j % npad;
5111 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
5112 }
5113 gcc_assert (e);
5114
5115 gfc_constructor_append_expr (&result->value.constructor,
5116 gfc_copy_expr (e), &e->where);
5117
5118 /* Calculate the next element. */
5119 i = 0;
5120
5121 inc:
5122 if (++x[i] < shape[i])
5123 continue;
5124 x[i++] = 0;
5125 if (i < rank)
5126 goto inc;
5127
5128 break;
5129 }
5130
5131 mpz_clear (index);
5132
5133 return result;
5134 }
5135
5136
5137 gfc_expr *
5138 gfc_simplify_rrspacing (gfc_expr *x)
5139 {
5140 gfc_expr *result;
5141 int i;
5142 long int e, p;
5143
5144 if (x->expr_type != EXPR_CONSTANT)
5145 return NULL;
5146
5147 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5148
5149 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5150 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5151
5152 /* Special case x = -0 and 0. */
5153 if (mpfr_sgn (result->value.real) == 0)
5154 {
5155 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5156 return result;
5157 }
5158
5159 /* | x * 2**(-e) | * 2**p. */
5160 e = - (long int) mpfr_get_exp (x->value.real);
5161 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
5162
5163 p = (long int) gfc_real_kinds[i].digits;
5164 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
5165
5166 return range_check (result, "RRSPACING");
5167 }
5168
5169
5170 gfc_expr *
5171 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
5172 {
5173 int k, neg_flag, power, exp_range;
5174 mpfr_t scale, radix;
5175 gfc_expr *result;
5176
5177 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5178 return NULL;
5179
5180 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5181
5182 if (mpfr_sgn (x->value.real) == 0)
5183 {
5184 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5185 return result;
5186 }
5187
5188 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5189
5190 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
5191
5192 /* This check filters out values of i that would overflow an int. */
5193 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
5194 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
5195 {
5196 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
5197 gfc_free_expr (result);
5198 return &gfc_bad_expr;
5199 }
5200
5201 /* Compute scale = radix ** power. */
5202 power = mpz_get_si (i->value.integer);
5203
5204 if (power >= 0)
5205 neg_flag = 0;
5206 else
5207 {
5208 neg_flag = 1;
5209 power = -power;
5210 }
5211
5212 gfc_set_model_kind (x->ts.kind);
5213 mpfr_init (scale);
5214 mpfr_init (radix);
5215 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
5216 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
5217
5218 if (neg_flag)
5219 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
5220 else
5221 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
5222
5223 mpfr_clears (scale, radix, NULL);
5224
5225 return range_check (result, "SCALE");
5226 }
5227
5228
5229 /* Variants of strspn and strcspn that operate on wide characters. */
5230
5231 static size_t
5232 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
5233 {
5234 size_t i = 0;
5235 const gfc_char_t *c;
5236
5237 while (s1[i])
5238 {
5239 for (c = s2; *c; c++)
5240 {
5241 if (s1[i] == *c)
5242 break;
5243 }
5244 if (*c == '\0')
5245 break;
5246 i++;
5247 }
5248
5249 return i;
5250 }
5251
5252 static size_t
5253 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
5254 {
5255 size_t i = 0;
5256 const gfc_char_t *c;
5257
5258 while (s1[i])
5259 {
5260 for (c = s2; *c; c++)
5261 {
5262 if (s1[i] == *c)
5263 break;
5264 }
5265 if (*c)
5266 break;
5267 i++;
5268 }
5269
5270 return i;
5271 }
5272
5273
5274 gfc_expr *
5275 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
5276 {
5277 gfc_expr *result;
5278 int back;
5279 size_t i;
5280 size_t indx, len, lenc;
5281 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
5282
5283 if (k == -1)
5284 return &gfc_bad_expr;
5285
5286 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
5287 return NULL;
5288
5289 if (b != NULL && b->value.logical != 0)
5290 back = 1;
5291 else
5292 back = 0;
5293
5294 len = e->value.character.length;
5295 lenc = c->value.character.length;
5296
5297 if (len == 0 || lenc == 0)
5298 {
5299 indx = 0;
5300 }
5301 else
5302 {
5303 if (back == 0)
5304 {
5305 indx = wide_strcspn (e->value.character.string,
5306 c->value.character.string) + 1;
5307 if (indx > len)
5308 indx = 0;
5309 }
5310 else
5311 {
5312 i = 0;
5313 for (indx = len; indx > 0; indx--)
5314 {
5315 for (i = 0; i < lenc; i++)
5316 {
5317 if (c->value.character.string[i]
5318 == e->value.character.string[indx - 1])
5319 break;
5320 }
5321 if (i < lenc)
5322 break;
5323 }
5324 }
5325 }
5326
5327 result = gfc_get_int_expr (k, &e->where, indx);
5328 return range_check (result, "SCAN");
5329 }
5330
5331
5332 gfc_expr *
5333 gfc_simplify_selected_char_kind (gfc_expr *e)
5334 {
5335 int kind;
5336
5337 if (e->expr_type != EXPR_CONSTANT)
5338 return NULL;
5339
5340 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
5341 || gfc_compare_with_Cstring (e, "default", false) == 0)
5342 kind = 1;
5343 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
5344 kind = 4;
5345 else
5346 kind = -1;
5347
5348 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5349 }
5350
5351
5352 gfc_expr *
5353 gfc_simplify_selected_int_kind (gfc_expr *e)
5354 {
5355 int i, kind, range;
5356
5357 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
5358 return NULL;
5359
5360 kind = INT_MAX;
5361
5362 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
5363 if (gfc_integer_kinds[i].range >= range
5364 && gfc_integer_kinds[i].kind < kind)
5365 kind = gfc_integer_kinds[i].kind;
5366
5367 if (kind == INT_MAX)
5368 kind = -1;
5369
5370 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5371 }
5372
5373
5374 gfc_expr *
5375 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
5376 {
5377 int range, precision, radix, i, kind, found_precision, found_range,
5378 found_radix;
5379 locus *loc = &gfc_current_locus;
5380
5381 if (p == NULL)
5382 precision = 0;
5383 else
5384 {
5385 if (p->expr_type != EXPR_CONSTANT
5386 || gfc_extract_int (p, &precision) != NULL)
5387 return NULL;
5388 loc = &p->where;
5389 }
5390
5391 if (q == NULL)
5392 range = 0;
5393 else
5394 {
5395 if (q->expr_type != EXPR_CONSTANT
5396 || gfc_extract_int (q, &range) != NULL)
5397 return NULL;
5398
5399 if (!loc)
5400 loc = &q->where;
5401 }
5402
5403 if (rdx == NULL)
5404 radix = 0;
5405 else
5406 {
5407 if (rdx->expr_type != EXPR_CONSTANT
5408 || gfc_extract_int (rdx, &radix) != NULL)
5409 return NULL;
5410
5411 if (!loc)
5412 loc = &rdx->where;
5413 }
5414
5415 kind = INT_MAX;
5416 found_precision = 0;
5417 found_range = 0;
5418 found_radix = 0;
5419
5420 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
5421 {
5422 if (gfc_real_kinds[i].precision >= precision)
5423 found_precision = 1;
5424
5425 if (gfc_real_kinds[i].range >= range)
5426 found_range = 1;
5427
5428 if (gfc_real_kinds[i].radix >= radix)
5429 found_radix = 1;
5430
5431 if (gfc_real_kinds[i].precision >= precision
5432 && gfc_real_kinds[i].range >= range
5433 && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
5434 kind = gfc_real_kinds[i].kind;
5435 }
5436
5437 if (kind == INT_MAX)
5438 {
5439 if (found_radix && found_range && !found_precision)
5440 kind = -1;
5441 else if (found_radix && found_precision && !found_range)
5442 kind = -2;
5443 else if (found_radix && !found_precision && !found_range)
5444 kind = -3;
5445 else if (found_radix)
5446 kind = -4;
5447 else
5448 kind = -5;
5449 }
5450
5451 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
5452 }
5453
5454
5455 gfc_expr *
5456 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
5457 {
5458 gfc_expr *result;
5459 mpfr_t exp, absv, log2, pow2, frac;
5460 unsigned long exp2;
5461
5462 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5463 return NULL;
5464
5465 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5466
5467 if (mpfr_sgn (x->value.real) == 0)
5468 {
5469 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5470 return result;
5471 }
5472
5473 gfc_set_model_kind (x->ts.kind);
5474 mpfr_init (absv);
5475 mpfr_init (log2);
5476 mpfr_init (exp);
5477 mpfr_init (pow2);
5478 mpfr_init (frac);
5479
5480 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
5481 mpfr_log2 (log2, absv, GFC_RND_MODE);
5482
5483 mpfr_trunc (log2, log2);
5484 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
5485
5486 /* Old exponent value, and fraction. */
5487 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
5488
5489 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
5490
5491 /* New exponent. */
5492 exp2 = (unsigned long) mpz_get_d (i->value.integer);
5493 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
5494
5495 mpfr_clears (absv, log2, pow2, frac, NULL);
5496
5497 return range_check (result, "SET_EXPONENT");
5498 }
5499
5500
5501 gfc_expr *
5502 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
5503 {
5504 mpz_t shape[GFC_MAX_DIMENSIONS];
5505 gfc_expr *result, *e, *f;
5506 gfc_array_ref *ar;
5507 int n;
5508 gfc_try t;
5509 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
5510
5511 result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
5512
5513 if (source->rank == 0)
5514 return result;
5515
5516 if (source->expr_type == EXPR_VARIABLE)
5517 {
5518 ar = gfc_find_array_ref (source);
5519 t = gfc_array_ref_shape (ar, shape);
5520 }
5521 else if (source->shape)
5522 {
5523 t = SUCCESS;
5524 for (n = 0; n < source->rank; n++)
5525 {
5526 mpz_init (shape[n]);
5527 mpz_set (shape[n], source->shape[n]);
5528 }
5529 }
5530 else
5531 t = FAILURE;
5532
5533 for (n = 0; n < source->rank; n++)
5534 {
5535 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
5536
5537 if (t == SUCCESS)
5538 {
5539 mpz_set (e->value.integer, shape[n]);
5540 mpz_clear (shape[n]);
5541 }
5542 else
5543 {
5544 mpz_set_ui (e->value.integer, n + 1);
5545
5546 f = gfc_simplify_size (source, e, NULL);
5547 gfc_free_expr (e);
5548 if (f == NULL)
5549 {
5550 gfc_free_expr (result);
5551 return NULL;
5552 }
5553 else
5554 e = f;
5555 }
5556
5557 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5558 }
5559
5560 return result;
5561 }
5562
5563
5564 gfc_expr *
5565 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5566 {
5567 mpz_t size;
5568 gfc_expr *return_value;
5569 int d;
5570 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
5571
5572 if (k == -1)
5573 return &gfc_bad_expr;
5574
5575 /* For unary operations, the size of the result is given by the size
5576 of the operand. For binary ones, it's the size of the first operand
5577 unless it is scalar, then it is the size of the second. */
5578 if (array->expr_type == EXPR_OP && !array->value.op.uop)
5579 {
5580 gfc_expr* replacement;
5581 gfc_expr* simplified;
5582
5583 switch (array->value.op.op)
5584 {
5585 /* Unary operations. */
5586 case INTRINSIC_NOT:
5587 case INTRINSIC_UPLUS:
5588 case INTRINSIC_UMINUS:
5589 replacement = array->value.op.op1;
5590 break;
5591
5592 /* Binary operations. If any one of the operands is scalar, take
5593 the other one's size. If both of them are arrays, it does not
5594 matter -- try to find one with known shape, if possible. */
5595 default:
5596 if (array->value.op.op1->rank == 0)
5597 replacement = array->value.op.op2;
5598 else if (array->value.op.op2->rank == 0)
5599 replacement = array->value.op.op1;
5600 else
5601 {
5602 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
5603 if (simplified)
5604 return simplified;
5605
5606 replacement = array->value.op.op2;
5607 }
5608 break;
5609 }
5610
5611 /* Try to reduce it directly if possible. */
5612 simplified = gfc_simplify_size (replacement, dim, kind);
5613
5614 /* Otherwise, we build a new SIZE call. This is hopefully at least
5615 simpler than the original one. */
5616 if (!simplified)
5617 simplified = gfc_build_intrinsic_call ("size", array->where, 3,
5618 gfc_copy_expr (replacement),
5619 gfc_copy_expr (dim),
5620 gfc_copy_expr (kind));
5621
5622 return simplified;
5623 }
5624
5625 if (dim == NULL)
5626 {
5627 if (gfc_array_size (array, &size) == FAILURE)
5628 return NULL;
5629 }
5630 else
5631 {
5632 if (dim->expr_type != EXPR_CONSTANT)
5633 return NULL;
5634
5635 d = mpz_get_ui (dim->value.integer) - 1;
5636 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
5637 return NULL;
5638 }
5639
5640 return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
5641 mpz_clear (size);
5642 return return_value;
5643 }
5644
5645
5646 gfc_expr *
5647 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
5648 {
5649 gfc_expr *result;
5650
5651 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5652 return NULL;
5653
5654 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5655
5656 switch (x->ts.type)
5657 {
5658 case BT_INTEGER:
5659 mpz_abs (result->value.integer, x->value.integer);
5660 if (mpz_sgn (y->value.integer) < 0)
5661 mpz_neg (result->value.integer, result->value.integer);
5662 break;
5663
5664 case BT_REAL:
5665 if (gfc_option.flag_sign_zero)
5666 mpfr_copysign (result->value.real, x->value.real, y->value.real,
5667 GFC_RND_MODE);
5668 else
5669 mpfr_setsign (result->value.real, x->value.real,
5670 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
5671 break;
5672
5673 default:
5674 gfc_internal_error ("Bad type in gfc_simplify_sign");
5675 }
5676
5677 return result;
5678 }
5679
5680
5681 gfc_expr *
5682 gfc_simplify_sin (gfc_expr *x)
5683 {
5684 gfc_expr *result;
5685
5686 if (x->expr_type != EXPR_CONSTANT)
5687 return NULL;
5688
5689 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5690
5691 switch (x->ts.type)
5692 {
5693 case BT_REAL:
5694 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
5695 break;
5696
5697 case BT_COMPLEX:
5698 gfc_set_model (x->value.real);
5699 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5700 break;
5701
5702 default:
5703 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5704 }
5705
5706 return range_check (result, "SIN");
5707 }
5708
5709
5710 gfc_expr *
5711 gfc_simplify_sinh (gfc_expr *x)
5712 {
5713 gfc_expr *result;
5714
5715 if (x->expr_type != EXPR_CONSTANT)
5716 return NULL;
5717
5718 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5719
5720 switch (x->ts.type)
5721 {
5722 case BT_REAL:
5723 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
5724 break;
5725
5726 case BT_COMPLEX:
5727 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5728 break;
5729
5730 default:
5731 gcc_unreachable ();
5732 }
5733
5734 return range_check (result, "SINH");
5735 }
5736
5737
5738 /* The argument is always a double precision real that is converted to
5739 single precision. TODO: Rounding! */
5740
5741 gfc_expr *
5742 gfc_simplify_sngl (gfc_expr *a)
5743 {
5744 gfc_expr *result;
5745
5746 if (a->expr_type != EXPR_CONSTANT)
5747 return NULL;
5748
5749 result = gfc_real2real (a, gfc_default_real_kind);
5750 return range_check (result, "SNGL");
5751 }
5752
5753
5754 gfc_expr *
5755 gfc_simplify_spacing (gfc_expr *x)
5756 {
5757 gfc_expr *result;
5758 int i;
5759 long int en, ep;
5760
5761 if (x->expr_type != EXPR_CONSTANT)
5762 return NULL;
5763
5764 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5765
5766 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5767
5768 /* Special case x = 0 and -0. */
5769 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5770 if (mpfr_sgn (result->value.real) == 0)
5771 {
5772 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5773 return result;
5774 }
5775
5776 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5777 are the radix, exponent of x, and precision. This excludes the
5778 possibility of subnormal numbers. Fortran 2003 states the result is
5779 b**max(e - p, emin - 1). */
5780
5781 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5782 en = (long int) gfc_real_kinds[i].min_exponent - 1;
5783 en = en > ep ? en : ep;
5784
5785 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5786 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5787
5788 return range_check (result, "SPACING");
5789 }
5790
5791
5792 gfc_expr *
5793 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5794 {
5795 gfc_expr *result = 0L;
5796 int i, j, dim, ncopies;
5797 mpz_t size;
5798
5799 if ((!gfc_is_constant_expr (source)
5800 && !is_constant_array_expr (source))
5801 || !gfc_is_constant_expr (dim_expr)
5802 || !gfc_is_constant_expr (ncopies_expr))
5803 return NULL;
5804
5805 gcc_assert (dim_expr->ts.type == BT_INTEGER);
5806 gfc_extract_int (dim_expr, &dim);
5807 dim -= 1; /* zero-base DIM */
5808
5809 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5810 gfc_extract_int (ncopies_expr, &ncopies);
5811 ncopies = MAX (ncopies, 0);
5812
5813 /* Do not allow the array size to exceed the limit for an array
5814 constructor. */
5815 if (source->expr_type == EXPR_ARRAY)
5816 {
5817 if (gfc_array_size (source, &size) == FAILURE)
5818 gfc_internal_error ("Failure getting length of a constant array.");
5819 }
5820 else
5821 mpz_init_set_ui (size, 1);
5822
5823 if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5824 return NULL;
5825
5826 if (source->expr_type == EXPR_CONSTANT)
5827 {
5828 gcc_assert (dim == 0);
5829
5830 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5831 &source->where);
5832 if (source->ts.type == BT_DERIVED)
5833 result->ts.u.derived = source->ts.u.derived;
5834 result->rank = 1;
5835 result->shape = gfc_get_shape (result->rank);
5836 mpz_init_set_si (result->shape[0], ncopies);
5837
5838 for (i = 0; i < ncopies; ++i)
5839 gfc_constructor_append_expr (&result->value.constructor,
5840 gfc_copy_expr (source), NULL);
5841 }
5842 else if (source->expr_type == EXPR_ARRAY)
5843 {
5844 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5845 gfc_constructor *source_ctor;
5846
5847 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5848 gcc_assert (dim >= 0 && dim <= source->rank);
5849
5850 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5851 &source->where);
5852 if (source->ts.type == BT_DERIVED)
5853 result->ts.u.derived = source->ts.u.derived;
5854 result->rank = source->rank + 1;
5855 result->shape = gfc_get_shape (result->rank);
5856
5857 for (i = 0, j = 0; i < result->rank; ++i)
5858 {
5859 if (i != dim)
5860 mpz_init_set (result->shape[i], source->shape[j++]);
5861 else
5862 mpz_init_set_si (result->shape[i], ncopies);
5863
5864 extent[i] = mpz_get_si (result->shape[i]);
5865 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5866 }
5867
5868 offset = 0;
5869 for (source_ctor = gfc_constructor_first (source->value.constructor);
5870 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5871 {
5872 for (i = 0; i < ncopies; ++i)
5873 gfc_constructor_insert_expr (&result->value.constructor,
5874 gfc_copy_expr (source_ctor->expr),
5875 NULL, offset + i * rstride[dim]);
5876
5877 offset += (dim == 0 ? ncopies : 1);
5878 }
5879 }
5880 else
5881 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5882 Replace NULL with gcc_unreachable() after implementing
5883 gfc_simplify_cshift(). */
5884 return NULL;
5885
5886 if (source->ts.type == BT_CHARACTER)
5887 result->ts.u.cl = source->ts.u.cl;
5888
5889 return result;
5890 }
5891
5892
5893 gfc_expr *
5894 gfc_simplify_sqrt (gfc_expr *e)
5895 {
5896 gfc_expr *result = NULL;
5897
5898 if (e->expr_type != EXPR_CONSTANT)
5899 return NULL;
5900
5901 switch (e->ts.type)
5902 {
5903 case BT_REAL:
5904 if (mpfr_cmp_si (e->value.real, 0) < 0)
5905 {
5906 gfc_error ("Argument of SQRT at %L has a negative value",
5907 &e->where);
5908 return &gfc_bad_expr;
5909 }
5910 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5911 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5912 break;
5913
5914 case BT_COMPLEX:
5915 gfc_set_model (e->value.real);
5916
5917 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5918 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5919 break;
5920
5921 default:
5922 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5923 }
5924
5925 return range_check (result, "SQRT");
5926 }
5927
5928
5929 gfc_expr *
5930 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5931 {
5932 return simplify_transformation (array, dim, mask, 0, gfc_add);
5933 }
5934
5935
5936 gfc_expr *
5937 gfc_simplify_tan (gfc_expr *x)
5938 {
5939 gfc_expr *result;
5940
5941 if (x->expr_type != EXPR_CONSTANT)
5942 return NULL;
5943
5944 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5945
5946 switch (x->ts.type)
5947 {
5948 case BT_REAL:
5949 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5950 break;
5951
5952 case BT_COMPLEX:
5953 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5954 break;
5955
5956 default:
5957 gcc_unreachable ();
5958 }
5959
5960 return range_check (result, "TAN");
5961 }
5962
5963
5964 gfc_expr *
5965 gfc_simplify_tanh (gfc_expr *x)
5966 {
5967 gfc_expr *result;
5968
5969 if (x->expr_type != EXPR_CONSTANT)
5970 return NULL;
5971
5972 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5973
5974 switch (x->ts.type)
5975 {
5976 case BT_REAL:
5977 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5978 break;
5979
5980 case BT_COMPLEX:
5981 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5982 break;
5983
5984 default:
5985 gcc_unreachable ();
5986 }
5987
5988 return range_check (result, "TANH");
5989 }
5990
5991
5992 gfc_expr *
5993 gfc_simplify_tiny (gfc_expr *e)
5994 {
5995 gfc_expr *result;
5996 int i;
5997
5998 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5999
6000 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6001 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
6002
6003 return result;
6004 }
6005
6006
6007 gfc_expr *
6008 gfc_simplify_trailz (gfc_expr *e)
6009 {
6010 unsigned long tz, bs;
6011 int i;
6012
6013 if (e->expr_type != EXPR_CONSTANT)
6014 return NULL;
6015
6016 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6017 bs = gfc_integer_kinds[i].bit_size;
6018 tz = mpz_scan1 (e->value.integer, 0);
6019
6020 return gfc_get_int_expr (gfc_default_integer_kind,
6021 &e->where, MIN (tz, bs));
6022 }
6023
6024
6025 gfc_expr *
6026 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
6027 {
6028 gfc_expr *result;
6029 gfc_expr *mold_element;
6030 size_t source_size;
6031 size_t result_size;
6032 size_t result_elt_size;
6033 size_t buffer_size;
6034 mpz_t tmp;
6035 unsigned char *buffer;
6036
6037 if (!gfc_is_constant_expr (source)
6038 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
6039 || !gfc_is_constant_expr (size))
6040 return NULL;
6041
6042 if (source->expr_type == EXPR_FUNCTION)
6043 return NULL;
6044
6045 /* Calculate the size of the source. */
6046 if (source->expr_type == EXPR_ARRAY
6047 && gfc_array_size (source, &tmp) == FAILURE)
6048 gfc_internal_error ("Failure getting length of a constant array.");
6049
6050 source_size = gfc_target_expr_size (source);
6051
6052 /* Create an empty new expression with the appropriate characteristics. */
6053 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6054 &source->where);
6055 result->ts = mold->ts;
6056
6057 mold_element = mold->expr_type == EXPR_ARRAY
6058 ? gfc_constructor_first (mold->value.constructor)->expr
6059 : mold;
6060
6061 /* Set result character length, if needed. Note that this needs to be
6062 set even for array expressions, in order to pass this information into
6063 gfc_target_interpret_expr. */
6064 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
6065 result->value.character.length = mold_element->value.character.length;
6066
6067 /* Set the number of elements in the result, and determine its size. */
6068 result_elt_size = gfc_target_expr_size (mold_element);
6069 if (result_elt_size == 0)
6070 {
6071 gfc_free_expr (result);
6072 return NULL;
6073 }
6074
6075 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
6076 {
6077 int result_length;
6078
6079 result->expr_type = EXPR_ARRAY;
6080 result->rank = 1;
6081
6082 if (size)
6083 result_length = (size_t)mpz_get_ui (size->value.integer);
6084 else
6085 {
6086 result_length = source_size / result_elt_size;
6087 if (result_length * result_elt_size < source_size)
6088 result_length += 1;
6089 }
6090
6091 result->shape = gfc_get_shape (1);
6092 mpz_init_set_ui (result->shape[0], result_length);
6093
6094 result_size = result_length * result_elt_size;
6095 }
6096 else
6097 {
6098 result->rank = 0;
6099 result_size = result_elt_size;
6100 }
6101
6102 if (gfc_option.warn_surprising && source_size < result_size)
6103 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
6104 "source size %ld < result size %ld", &source->where,
6105 (long) source_size, (long) result_size);
6106
6107 /* Allocate the buffer to store the binary version of the source. */
6108 buffer_size = MAX (source_size, result_size);
6109 buffer = (unsigned char*)alloca (buffer_size);
6110 memset (buffer, 0, buffer_size);
6111
6112 /* Now write source to the buffer. */
6113 gfc_target_encode_expr (source, buffer, buffer_size);
6114
6115 /* And read the buffer back into the new expression. */
6116 gfc_target_interpret_expr (buffer, buffer_size, result);
6117
6118 return result;
6119 }
6120
6121
6122 gfc_expr *
6123 gfc_simplify_transpose (gfc_expr *matrix)
6124 {
6125 int row, matrix_rows, col, matrix_cols;
6126 gfc_expr *result;
6127
6128 if (!is_constant_array_expr (matrix))
6129 return NULL;
6130
6131 gcc_assert (matrix->rank == 2);
6132
6133 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6134 &matrix->where);
6135 result->rank = 2;
6136 result->shape = gfc_get_shape (result->rank);
6137 mpz_set (result->shape[0], matrix->shape[1]);
6138 mpz_set (result->shape[1], matrix->shape[0]);
6139
6140 if (matrix->ts.type == BT_CHARACTER)
6141 result->ts.u.cl = matrix->ts.u.cl;
6142 else if (matrix->ts.type == BT_DERIVED)
6143 result->ts.u.derived = matrix->ts.u.derived;
6144
6145 matrix_rows = mpz_get_si (matrix->shape[0]);
6146 matrix_cols = mpz_get_si (matrix->shape[1]);
6147 for (row = 0; row < matrix_rows; ++row)
6148 for (col = 0; col < matrix_cols; ++col)
6149 {
6150 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6151 col * matrix_rows + row);
6152 gfc_constructor_insert_expr (&result->value.constructor,
6153 gfc_copy_expr (e), &matrix->where,
6154 row * matrix_cols + col);
6155 }
6156
6157 return result;
6158 }
6159
6160
6161 gfc_expr *
6162 gfc_simplify_trim (gfc_expr *e)
6163 {
6164 gfc_expr *result;
6165 int count, i, len, lentrim;
6166
6167 if (e->expr_type != EXPR_CONSTANT)
6168 return NULL;
6169
6170 len = e->value.character.length;
6171 for (count = 0, i = 1; i <= len; ++i)
6172 {
6173 if (e->value.character.string[len - i] == ' ')
6174 count++;
6175 else
6176 break;
6177 }
6178
6179 lentrim = len - count;
6180
6181 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6182 for (i = 0; i < lentrim; i++)
6183 result->value.character.string[i] = e->value.character.string[i];
6184
6185 return result;
6186 }
6187
6188
6189 gfc_expr *
6190 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6191 {
6192 gfc_expr *result;
6193 gfc_ref *ref;
6194 gfc_array_spec *as;
6195 gfc_constructor *sub_cons;
6196 bool first_image;
6197 int d;
6198
6199 if (!is_constant_array_expr (sub))
6200 goto not_implemented; /* return NULL;*/
6201
6202 /* Follow any component references. */
6203 as = coarray->symtree->n.sym->as;
6204 for (ref = coarray->ref; ref; ref = ref->next)
6205 if (ref->type == REF_COMPONENT)
6206 as = ref->u.ar.as;
6207
6208 if (as->type == AS_DEFERRED)
6209 goto not_implemented; /* return NULL;*/
6210
6211 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6212 the cosubscript addresses the first image. */
6213
6214 sub_cons = gfc_constructor_first (sub->value.constructor);
6215 first_image = true;
6216
6217 for (d = 1; d <= as->corank; d++)
6218 {
6219 gfc_expr *ca_bound;
6220 int cmp;
6221
6222 if (sub_cons == NULL)
6223 {
6224 gfc_error ("Too few elements in expression for SUB= argument at %L",
6225 &sub->where);
6226 return &gfc_bad_expr;
6227 }
6228
6229 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6230 NULL, true);
6231 if (ca_bound == NULL)
6232 goto not_implemented; /* return NULL */
6233
6234 if (ca_bound == &gfc_bad_expr)
6235 return ca_bound;
6236
6237 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6238
6239 if (cmp == 0)
6240 {
6241 gfc_free_expr (ca_bound);
6242 sub_cons = gfc_constructor_next (sub_cons);
6243 continue;
6244 }
6245
6246 first_image = false;
6247
6248 if (cmp > 0)
6249 {
6250 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6251 "SUB has %ld and COARRAY lower bound is %ld)",
6252 &coarray->where, d,
6253 mpz_get_si (sub_cons->expr->value.integer),
6254 mpz_get_si (ca_bound->value.integer));
6255 gfc_free_expr (ca_bound);
6256 return &gfc_bad_expr;
6257 }
6258
6259 gfc_free_expr (ca_bound);
6260
6261 /* Check whether upperbound is valid for the multi-images case. */
6262 if (d < as->corank)
6263 {
6264 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6265 NULL, true);
6266 if (ca_bound == &gfc_bad_expr)
6267 return ca_bound;
6268
6269 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6270 && mpz_cmp (ca_bound->value.integer,
6271 sub_cons->expr->value.integer) < 0)
6272 {
6273 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6274 "SUB has %ld and COARRAY upper bound is %ld)",
6275 &coarray->where, d,
6276 mpz_get_si (sub_cons->expr->value.integer),
6277 mpz_get_si (ca_bound->value.integer));
6278 gfc_free_expr (ca_bound);
6279 return &gfc_bad_expr;
6280 }
6281
6282 if (ca_bound)
6283 gfc_free_expr (ca_bound);
6284 }
6285
6286 sub_cons = gfc_constructor_next (sub_cons);
6287 }
6288
6289 if (sub_cons != NULL)
6290 {
6291 gfc_error ("Too many elements in expression for SUB= argument at %L",
6292 &sub->where);
6293 return &gfc_bad_expr;
6294 }
6295
6296 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6297 &gfc_current_locus);
6298 if (first_image)
6299 mpz_set_si (result->value.integer, 1);
6300 else
6301 mpz_set_si (result->value.integer, 0);
6302
6303 return result;
6304
6305 not_implemented:
6306 gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
6307 "cobounds at %L", &coarray->where);
6308 return &gfc_bad_expr;
6309 }
6310
6311
6312 gfc_expr *
6313 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
6314 {
6315 gfc_ref *ref;
6316 gfc_array_spec *as;
6317 int d;
6318
6319 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
6320 return NULL;
6321
6322 if (coarray == NULL)
6323 {
6324 gfc_expr *result;
6325 /* FIXME: gfc_current_locus is wrong. */
6326 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6327 &gfc_current_locus);
6328 mpz_set_si (result->value.integer, 1);
6329 return result;
6330 }
6331
6332 gcc_assert (coarray->expr_type == EXPR_VARIABLE);
6333
6334 /* Follow any component references. */
6335 as = coarray->symtree->n.sym->as;
6336 for (ref = coarray->ref; ref; ref = ref->next)
6337 if (ref->type == REF_COMPONENT)
6338 as = ref->u.ar.as;
6339
6340 if (as->type == AS_DEFERRED)
6341 goto not_implemented; /* return NULL;*/
6342
6343 if (dim == NULL)
6344 {
6345 /* Multi-dimensional bounds. */
6346 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
6347 gfc_expr *e;
6348
6349 /* Simplify the bounds for each dimension. */
6350 for (d = 0; d < as->corank; d++)
6351 {
6352 bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
6353 as, NULL, true);
6354 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
6355 {
6356 int j;
6357
6358 for (j = 0; j < d; j++)
6359 gfc_free_expr (bounds[j]);
6360 if (bounds[d] == NULL)
6361 goto not_implemented;
6362 return bounds[d];
6363 }
6364 }
6365
6366 /* Allocate the result expression. */
6367 e = gfc_get_expr ();
6368 e->where = coarray->where;
6369 e->expr_type = EXPR_ARRAY;
6370 e->ts.type = BT_INTEGER;
6371 e->ts.kind = gfc_default_integer_kind;
6372
6373 e->rank = 1;
6374 e->shape = gfc_get_shape (1);
6375 mpz_init_set_ui (e->shape[0], as->corank);
6376
6377 /* Create the constructor for this array. */
6378 for (d = 0; d < as->corank; d++)
6379 gfc_constructor_append_expr (&e->value.constructor,
6380 bounds[d], &e->where);
6381
6382 return e;
6383 }
6384 else
6385 {
6386 gfc_expr *e;
6387 /* A DIM argument is specified. */
6388 if (dim->expr_type != EXPR_CONSTANT)
6389 goto not_implemented; /*return NULL;*/
6390
6391 d = mpz_get_si (dim->value.integer);
6392
6393 if (d < 1 || d > as->corank)
6394 {
6395 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
6396 return &gfc_bad_expr;
6397 }
6398
6399 /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
6400 e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
6401 if (e != NULL)
6402 return e;
6403 else
6404 goto not_implemented;
6405 }
6406
6407 not_implemented:
6408 gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
6409 "cobounds at %L", &coarray->where);
6410 return &gfc_bad_expr;
6411 }
6412
6413
6414 gfc_expr *
6415 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6416 {
6417 return simplify_bound (array, dim, kind, 1);
6418 }
6419
6420 gfc_expr *
6421 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6422 {
6423 gfc_expr *e;
6424 /* return simplify_cobound (array, dim, kind, 1);*/
6425
6426 e = simplify_cobound (array, dim, kind, 1);
6427 if (e != NULL)
6428 return e;
6429
6430 gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
6431 "cobounds at %L", &array->where);
6432 return &gfc_bad_expr;
6433 }
6434
6435
6436 gfc_expr *
6437 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6438 {
6439 gfc_expr *result, *e;
6440 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6441
6442 if (!is_constant_array_expr (vector)
6443 || !is_constant_array_expr (mask)
6444 || (!gfc_is_constant_expr (field)
6445 && !is_constant_array_expr(field)))
6446 return NULL;
6447
6448 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6449 &vector->where);
6450 if (vector->ts.type == BT_DERIVED)
6451 result->ts.u.derived = vector->ts.u.derived;
6452 result->rank = mask->rank;
6453 result->shape = gfc_copy_shape (mask->shape, mask->rank);
6454
6455 if (vector->ts.type == BT_CHARACTER)
6456 result->ts.u.cl = vector->ts.u.cl;
6457
6458 vector_ctor = gfc_constructor_first (vector->value.constructor);
6459 mask_ctor = gfc_constructor_first (mask->value.constructor);
6460 field_ctor
6461 = field->expr_type == EXPR_ARRAY
6462 ? gfc_constructor_first (field->value.constructor)
6463 : NULL;
6464
6465 while (mask_ctor)
6466 {
6467 if (mask_ctor->expr->value.logical)
6468 {
6469 gcc_assert (vector_ctor);
6470 e = gfc_copy_expr (vector_ctor->expr);
6471 vector_ctor = gfc_constructor_next (vector_ctor);
6472 }
6473 else if (field->expr_type == EXPR_ARRAY)
6474 e = gfc_copy_expr (field_ctor->expr);
6475 else
6476 e = gfc_copy_expr (field);
6477
6478 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6479
6480 mask_ctor = gfc_constructor_next (mask_ctor);
6481 field_ctor = gfc_constructor_next (field_ctor);
6482 }
6483
6484 return result;
6485 }
6486
6487
6488 gfc_expr *
6489 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6490 {
6491 gfc_expr *result;
6492 int back;
6493 size_t index, len, lenset;
6494 size_t i;
6495 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6496
6497 if (k == -1)
6498 return &gfc_bad_expr;
6499
6500 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
6501 return NULL;
6502
6503 if (b != NULL && b->value.logical != 0)
6504 back = 1;
6505 else
6506 back = 0;
6507
6508 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6509
6510 len = s->value.character.length;
6511 lenset = set->value.character.length;
6512
6513 if (len == 0)
6514 {
6515 mpz_set_ui (result->value.integer, 0);
6516 return result;
6517 }
6518
6519 if (back == 0)
6520 {
6521 if (lenset == 0)
6522 {
6523 mpz_set_ui (result->value.integer, 1);
6524 return result;
6525 }
6526
6527 index = wide_strspn (s->value.character.string,
6528 set->value.character.string) + 1;
6529 if (index > len)
6530 index = 0;
6531
6532 }
6533 else
6534 {
6535 if (lenset == 0)
6536 {
6537 mpz_set_ui (result->value.integer, len);
6538 return result;
6539 }
6540 for (index = len; index > 0; index --)
6541 {
6542 for (i = 0; i < lenset; i++)
6543 {
6544 if (s->value.character.string[index - 1]
6545 == set->value.character.string[i])
6546 break;
6547 }
6548 if (i == lenset)
6549 break;
6550 }
6551 }
6552
6553 mpz_set_ui (result->value.integer, index);
6554 return result;
6555 }
6556
6557
6558 gfc_expr *
6559 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6560 {
6561 gfc_expr *result;
6562 int kind;
6563
6564 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6565 return NULL;
6566
6567 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6568
6569 switch (x->ts.type)
6570 {
6571 case BT_INTEGER:
6572 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6573 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6574 return range_check (result, "XOR");
6575
6576 case BT_LOGICAL:
6577 return gfc_get_logical_expr (kind, &x->where,
6578 (x->value.logical && !y->value.logical)
6579 || (!x->value.logical && y->value.logical));
6580
6581 default:
6582 gcc_unreachable ();
6583 }
6584 }
6585
6586
6587 /****************** Constant simplification *****************/
6588
6589 /* Master function to convert one constant to another. While this is
6590 used as a simplification function, it requires the destination type
6591 and kind information which is supplied by a special case in
6592 do_simplify(). */
6593
6594 gfc_expr *
6595 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6596 {
6597 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6598 gfc_constructor *c;
6599
6600 switch (e->ts.type)
6601 {
6602 case BT_INTEGER:
6603 switch (type)
6604 {
6605 case BT_INTEGER:
6606 f = gfc_int2int;
6607 break;
6608 case BT_REAL:
6609 f = gfc_int2real;
6610 break;
6611 case BT_COMPLEX:
6612 f = gfc_int2complex;
6613 break;
6614 case BT_LOGICAL:
6615 f = gfc_int2log;
6616 break;
6617 default:
6618 goto oops;
6619 }
6620 break;
6621
6622 case BT_REAL:
6623 switch (type)
6624 {
6625 case BT_INTEGER:
6626 f = gfc_real2int;
6627 break;
6628 case BT_REAL:
6629 f = gfc_real2real;
6630 break;
6631 case BT_COMPLEX:
6632 f = gfc_real2complex;
6633 break;
6634 default:
6635 goto oops;
6636 }
6637 break;
6638
6639 case BT_COMPLEX:
6640 switch (type)
6641 {
6642 case BT_INTEGER:
6643 f = gfc_complex2int;
6644 break;
6645 case BT_REAL:
6646 f = gfc_complex2real;
6647 break;
6648 case BT_COMPLEX:
6649 f = gfc_complex2complex;
6650 break;
6651
6652 default:
6653 goto oops;
6654 }
6655 break;
6656
6657 case BT_LOGICAL:
6658 switch (type)
6659 {
6660 case BT_INTEGER:
6661 f = gfc_log2int;
6662 break;
6663 case BT_LOGICAL:
6664 f = gfc_log2log;
6665 break;
6666 default:
6667 goto oops;
6668 }
6669 break;
6670
6671 case BT_HOLLERITH:
6672 switch (type)
6673 {
6674 case BT_INTEGER:
6675 f = gfc_hollerith2int;
6676 break;
6677
6678 case BT_REAL:
6679 f = gfc_hollerith2real;
6680 break;
6681
6682 case BT_COMPLEX:
6683 f = gfc_hollerith2complex;
6684 break;
6685
6686 case BT_CHARACTER:
6687 f = gfc_hollerith2character;
6688 break;
6689
6690 case BT_LOGICAL:
6691 f = gfc_hollerith2logical;
6692 break;
6693
6694 default:
6695 goto oops;
6696 }
6697 break;
6698
6699 default:
6700 oops:
6701 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6702 }
6703
6704 result = NULL;
6705
6706 switch (e->expr_type)
6707 {
6708 case EXPR_CONSTANT:
6709 result = f (e, kind);
6710 if (result == NULL)
6711 return &gfc_bad_expr;
6712 break;
6713
6714 case EXPR_ARRAY:
6715 if (!gfc_is_constant_expr (e))
6716 break;
6717
6718 result = gfc_get_array_expr (type, kind, &e->where);
6719 result->shape = gfc_copy_shape (e->shape, e->rank);
6720 result->rank = e->rank;
6721
6722 for (c = gfc_constructor_first (e->value.constructor);
6723 c; c = gfc_constructor_next (c))
6724 {
6725 gfc_expr *tmp;
6726 if (c->iterator == NULL)
6727 tmp = f (c->expr, kind);
6728 else
6729 {
6730 g = gfc_convert_constant (c->expr, type, kind);
6731 if (g == &gfc_bad_expr)
6732 {
6733 gfc_free_expr (result);
6734 return g;
6735 }
6736 tmp = g;
6737 }
6738
6739 if (tmp == NULL)
6740 {
6741 gfc_free_expr (result);
6742 return NULL;
6743 }
6744
6745 gfc_constructor_append_expr (&result->value.constructor,
6746 tmp, &c->where);
6747 }
6748
6749 break;
6750
6751 default:
6752 break;
6753 }
6754
6755 return result;
6756 }
6757
6758
6759 /* Function for converting character constants. */
6760 gfc_expr *
6761 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6762 {
6763 gfc_expr *result;
6764 int i;
6765
6766 if (!gfc_is_constant_expr (e))
6767 return NULL;
6768
6769 if (e->expr_type == EXPR_CONSTANT)
6770 {
6771 /* Simple case of a scalar. */
6772 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6773 if (result == NULL)
6774 return &gfc_bad_expr;
6775
6776 result->value.character.length = e->value.character.length;
6777 result->value.character.string
6778 = gfc_get_wide_string (e->value.character.length + 1);
6779 memcpy (result->value.character.string, e->value.character.string,
6780 (e->value.character.length + 1) * sizeof (gfc_char_t));
6781
6782 /* Check we only have values representable in the destination kind. */
6783 for (i = 0; i < result->value.character.length; i++)
6784 if (!gfc_check_character_range (result->value.character.string[i],
6785 kind))
6786 {
6787 gfc_error ("Character '%s' in string at %L cannot be converted "
6788 "into character kind %d",
6789 gfc_print_wide_char (result->value.character.string[i]),
6790 &e->where, kind);
6791 return &gfc_bad_expr;
6792 }
6793
6794 return result;
6795 }
6796 else if (e->expr_type == EXPR_ARRAY)
6797 {
6798 /* For an array constructor, we convert each constructor element. */
6799 gfc_constructor *c;
6800
6801 result = gfc_get_array_expr (type, kind, &e->where);
6802 result->shape = gfc_copy_shape (e->shape, e->rank);
6803 result->rank = e->rank;
6804 result->ts.u.cl = e->ts.u.cl;
6805
6806 for (c = gfc_constructor_first (e->value.constructor);
6807 c; c = gfc_constructor_next (c))
6808 {
6809 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6810 if (tmp == &gfc_bad_expr)
6811 {
6812 gfc_free_expr (result);
6813 return &gfc_bad_expr;
6814 }
6815
6816 if (tmp == NULL)
6817 {
6818 gfc_free_expr (result);
6819 return NULL;
6820 }
6821
6822 gfc_constructor_append_expr (&result->value.constructor,
6823 tmp, &c->where);
6824 }
6825
6826 return result;
6827 }
6828 else
6829 return NULL;
6830 }
6831
6832
6833 gfc_expr *
6834 gfc_simplify_compiler_options (void)
6835 {
6836 char *str;
6837 gfc_expr *result;
6838
6839 str = gfc_get_option_string ();
6840 result = gfc_get_character_expr (gfc_default_character_kind,
6841 &gfc_current_locus, str, strlen (str));
6842 gfc_free (str);
6843 return result;
6844 }
6845
6846
6847 gfc_expr *
6848 gfc_simplify_compiler_version (void)
6849 {
6850 char *buffer;
6851 size_t len;
6852
6853 len = strlen ("GCC version ") + strlen (version_string);
6854 buffer = XALLOCAVEC (char, len + 1);
6855 snprintf (buffer, len + 1, "GCC version %s", version_string);
6856 return gfc_get_character_expr (gfc_default_character_kind,
6857 &gfc_current_locus, buffer, len);
6858 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org