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