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