?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Remove outermost loop parameter.
[official-gcc/graphite-test-results.git] / gcc / fortran / simplify.c
blob743c46329868db4bb7a6c0818fa5591dc9e640c4
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 if (ref->next == NULL)
2940 {
2941 gcc_assert (ref->u.ar.as->corank > 0
2942 && ref->u.ar.as->rank == 0);
2943 as = ref->u.ar.as;
2944 goto done;
2945 }
2946 as = NULL;
2947 continue;
2948
2949 case AR_FULL:
2950 /* We're done because 'as' has already been set in the
2951 previous iteration. */
2952 if (!ref->next)
2953 goto done;
2954
2955 /* Fall through. */
2956
2957 case AR_UNKNOWN:
2958 return NULL;
2959
2960 case AR_SECTION:
2961 as = ref->u.ar.as;
2962 goto done;
2963 }
2964
2965 gcc_unreachable ();
2966
2967 case REF_COMPONENT:
2968 as = ref->u.c.component->as;
2969 continue;
2970
2971 case REF_SUBSTRING:
2972 continue;
2973 }
2974 }
2975
2976 gcc_unreachable ();
2977
2978 done:
2979
2980 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2981 return NULL;
2982
2983 if (dim == NULL)
2984 {
2985 /* Multi-dimensional cobounds. */
2986 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2987 gfc_expr *e;
2988 int k;
2989
2990 /* Simplify the cobounds for each dimension. */
2991 for (d = 0; d < as->corank; d++)
2992 {
2993 bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
2994 upper, as, ref, true);
2995 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2996 {
2997 int j;
2998
2999 for (j = 0; j < d; j++)
3000 gfc_free_expr (bounds[j]);
3001 return bounds[d];
3002 }
3003 }
3004
3005 /* Allocate the result expression. */
3006 e = gfc_get_expr ();
3007 e->where = array->where;
3008 e->expr_type = EXPR_ARRAY;
3009 e->ts.type = BT_INTEGER;
3010 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3011 gfc_default_integer_kind);
3012 if (k == -1)
3013 {
3014 gfc_free_expr (e);
3015 return &gfc_bad_expr;
3016 }
3017 e->ts.kind = k;
3018
3019 /* The result is a rank 1 array; its size is the rank of the first
3020 argument to {L,U}COBOUND. */
3021 e->rank = 1;
3022 e->shape = gfc_get_shape (1);
3023 mpz_init_set_ui (e->shape[0], as->corank);
3024
3025 /* Create the constructor for this array. */
3026 for (d = 0; d < as->corank; d++)
3027 gfc_constructor_append_expr (&e->value.constructor,
3028 bounds[d], &e->where);
3029 return e;
3030 }
3031 else
3032 {
3033 /* A DIM argument is specified. */
3034 if (dim->expr_type != EXPR_CONSTANT)
3035 return NULL;
3036
3037 d = mpz_get_si (dim->value.integer);
3038
3039 if (d < 1 || d > as->corank)
3040 {
3041 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3042 return &gfc_bad_expr;
3043 }
3044
3045 return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
3046 }
3047 }
3048
3049
3050 gfc_expr *
3051 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3052 {
3053 return simplify_bound (array, dim, kind, 0);
3054 }
3055
3056
3057 gfc_expr *
3058 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3059 {
3060 gfc_expr *e;
3061 /* return simplify_cobound (array, dim, kind, 0);*/
3062
3063 e = simplify_cobound (array, dim, kind, 0);
3064 if (e != NULL)
3065 return e;
3066
3067 gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
3068 "cobounds at %L", &array->where);
3069 return &gfc_bad_expr;
3070 }
3071
3072 gfc_expr *
3073 gfc_simplify_leadz (gfc_expr *e)
3074 {
3075 unsigned long lz, bs;
3076 int i;
3077
3078 if (e->expr_type != EXPR_CONSTANT)
3079 return NULL;
3080
3081 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3082 bs = gfc_integer_kinds[i].bit_size;
3083 if (mpz_cmp_si (e->value.integer, 0) == 0)
3084 lz = bs;
3085 else if (mpz_cmp_si (e->value.integer, 0) < 0)
3086 lz = 0;
3087 else
3088 lz = bs - mpz_sizeinbase (e->value.integer, 2);
3089
3090 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3091 }
3092
3093
3094 gfc_expr *
3095 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3096 {
3097 gfc_expr *result;
3098 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3099
3100 if (k == -1)
3101 return &gfc_bad_expr;
3102
3103 if (e->expr_type == EXPR_CONSTANT)
3104 {
3105 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3106 mpz_set_si (result->value.integer, e->value.character.length);
3107 return range_check (result, "LEN");
3108 }
3109 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3110 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3111 && e->ts.u.cl->length->ts.type == BT_INTEGER)
3112 {
3113 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3114 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3115 return range_check (result, "LEN");
3116 }
3117 else
3118 return NULL;
3119 }
3120
3121
3122 gfc_expr *
3123 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3124 {
3125 gfc_expr *result;
3126 int count, len, i;
3127 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3128
3129 if (k == -1)
3130 return &gfc_bad_expr;
3131
3132 if (e->expr_type != EXPR_CONSTANT)
3133 return NULL;
3134
3135 len = e->value.character.length;
3136 for (count = 0, i = 1; i <= len; i++)
3137 if (e->value.character.string[len - i] == ' ')
3138 count++;
3139 else
3140 break;
3141
3142 result = gfc_get_int_expr (k, &e->where, len - count);
3143 return range_check (result, "LEN_TRIM");
3144 }
3145
3146 gfc_expr *
3147 gfc_simplify_lgamma (gfc_expr *x)
3148 {
3149 gfc_expr *result;
3150 int sg;
3151
3152 if (x->expr_type != EXPR_CONSTANT)
3153 return NULL;
3154
3155 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3156 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3157
3158 return range_check (result, "LGAMMA");
3159 }
3160
3161
3162 gfc_expr *
3163 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3164 {
3165 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3166 return NULL;
3167
3168 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3169 gfc_compare_string (a, b) >= 0);
3170 }
3171
3172
3173 gfc_expr *
3174 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3175 {
3176 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3177 return NULL;
3178
3179 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3180 gfc_compare_string (a, b) > 0);
3181 }
3182
3183
3184 gfc_expr *
3185 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3186 {
3187 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3188 return NULL;
3189
3190 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3191 gfc_compare_string (a, b) <= 0);
3192 }
3193
3194
3195 gfc_expr *
3196 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3197 {
3198 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3199 return NULL;
3200
3201 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3202 gfc_compare_string (a, b) < 0);
3203 }
3204
3205
3206 gfc_expr *
3207 gfc_simplify_log (gfc_expr *x)
3208 {
3209 gfc_expr *result;
3210
3211 if (x->expr_type != EXPR_CONSTANT)
3212 return NULL;
3213
3214 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3215
3216 switch (x->ts.type)
3217 {
3218 case BT_REAL:
3219 if (mpfr_sgn (x->value.real) <= 0)
3220 {
3221 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3222 "to zero", &x->where);
3223 gfc_free_expr (result);
3224 return &gfc_bad_expr;
3225 }
3226
3227 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3228 break;
3229
3230 case BT_COMPLEX:
3231 if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3232 && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3233 {
3234 gfc_error ("Complex argument of LOG at %L cannot be zero",
3235 &x->where);
3236 gfc_free_expr (result);
3237 return &gfc_bad_expr;
3238 }
3239
3240 gfc_set_model_kind (x->ts.kind);
3241 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3242 break;
3243
3244 default:
3245 gfc_internal_error ("gfc_simplify_log: bad type");
3246 }
3247
3248 return range_check (result, "LOG");
3249 }
3250
3251
3252 gfc_expr *
3253 gfc_simplify_log10 (gfc_expr *x)
3254 {
3255 gfc_expr *result;
3256
3257 if (x->expr_type != EXPR_CONSTANT)
3258 return NULL;
3259
3260 if (mpfr_sgn (x->value.real) <= 0)
3261 {
3262 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3263 "to zero", &x->where);
3264 return &gfc_bad_expr;
3265 }
3266
3267 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3268 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3269
3270 return range_check (result, "LOG10");
3271 }
3272
3273
3274 gfc_expr *
3275 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3276 {
3277 int kind;
3278
3279 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3280 if (kind < 0)
3281 return &gfc_bad_expr;
3282
3283 if (e->expr_type != EXPR_CONSTANT)
3284 return NULL;
3285
3286 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3287 }
3288
3289
3290 gfc_expr*
3291 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3292 {
3293 gfc_expr *result;
3294 int row, result_rows, col, result_columns;
3295 int stride_a, offset_a, stride_b, offset_b;
3296
3297 if (!is_constant_array_expr (matrix_a)
3298 || !is_constant_array_expr (matrix_b))
3299 return NULL;
3300
3301 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3302 result = gfc_get_array_expr (matrix_a->ts.type,
3303 matrix_a->ts.kind,
3304 &matrix_a->where);
3305
3306 if (matrix_a->rank == 1 && matrix_b->rank == 2)
3307 {
3308 result_rows = 1;
3309 result_columns = mpz_get_si (matrix_b->shape[0]);
3310 stride_a = 1;
3311 stride_b = mpz_get_si (matrix_b->shape[0]);
3312
3313 result->rank = 1;
3314 result->shape = gfc_get_shape (result->rank);
3315 mpz_init_set_si (result->shape[0], result_columns);
3316 }
3317 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3318 {
3319 result_rows = mpz_get_si (matrix_b->shape[0]);
3320 result_columns = 1;
3321 stride_a = mpz_get_si (matrix_a->shape[0]);
3322 stride_b = 1;
3323
3324 result->rank = 1;
3325 result->shape = gfc_get_shape (result->rank);
3326 mpz_init_set_si (result->shape[0], result_rows);
3327 }
3328 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3329 {
3330 result_rows = mpz_get_si (matrix_a->shape[0]);
3331 result_columns = mpz_get_si (matrix_b->shape[1]);
3332 stride_a = mpz_get_si (matrix_a->shape[1]);
3333 stride_b = mpz_get_si (matrix_b->shape[0]);
3334
3335 result->rank = 2;
3336 result->shape = gfc_get_shape (result->rank);
3337 mpz_init_set_si (result->shape[0], result_rows);
3338 mpz_init_set_si (result->shape[1], result_columns);
3339 }
3340 else
3341 gcc_unreachable();
3342
3343 offset_a = offset_b = 0;
3344 for (col = 0; col < result_columns; ++col)
3345 {
3346 offset_a = 0;
3347
3348 for (row = 0; row < result_rows; ++row)
3349 {
3350 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3351 matrix_b, 1, offset_b);
3352 gfc_constructor_append_expr (&result->value.constructor,
3353 e, NULL);
3354
3355 offset_a += 1;
3356 }
3357
3358 offset_b += stride_b;
3359 }
3360
3361 return result;
3362 }
3363
3364
3365 gfc_expr *
3366 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3367 {
3368 if (tsource->expr_type != EXPR_CONSTANT
3369 || fsource->expr_type != EXPR_CONSTANT
3370 || mask->expr_type != EXPR_CONSTANT)
3371 return NULL;
3372
3373 return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3374 }
3375
3376
3377 /* Selects bewteen current value and extremum for simplify_min_max
3378 and simplify_minval_maxval. */
3379 static void
3380 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
3381 {
3382 switch (arg->ts.type)
3383 {
3384 case BT_INTEGER:
3385 if (mpz_cmp (arg->value.integer,
3386 extremum->value.integer) * sign > 0)
3387 mpz_set (extremum->value.integer, arg->value.integer);
3388 break;
3389
3390 case BT_REAL:
3391 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
3392 if (sign > 0)
3393 mpfr_max (extremum->value.real, extremum->value.real,
3394 arg->value.real, GFC_RND_MODE);
3395 else
3396 mpfr_min (extremum->value.real, extremum->value.real,
3397 arg->value.real, GFC_RND_MODE);
3398 break;
3399
3400 case BT_CHARACTER:
3401 #define LENGTH(x) ((x)->value.character.length)
3402 #define STRING(x) ((x)->value.character.string)
3403 if (LENGTH(extremum) < LENGTH(arg))
3404 {
3405 gfc_char_t *tmp = STRING(extremum);
3406
3407 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
3408 memcpy (STRING(extremum), tmp,
3409 LENGTH(extremum) * sizeof (gfc_char_t));
3410 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
3411 LENGTH(arg) - LENGTH(extremum));
3412 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
3413 LENGTH(extremum) = LENGTH(arg);
3414 gfc_free (tmp);
3415 }
3416
3417 if (gfc_compare_string (arg, extremum) * sign > 0)
3418 {
3419 gfc_free (STRING(extremum));
3420 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
3421 memcpy (STRING(extremum), STRING(arg),
3422 LENGTH(arg) * sizeof (gfc_char_t));
3423 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
3424 LENGTH(extremum) - LENGTH(arg));
3425 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
3426 }
3427 #undef LENGTH
3428 #undef STRING
3429 break;
3430
3431 default:
3432 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
3433 }
3434 }
3435
3436
3437 /* This function is special since MAX() can take any number of
3438 arguments. The simplified expression is a rewritten version of the
3439 argument list containing at most one constant element. Other
3440 constant elements are deleted. Because the argument list has
3441 already been checked, this function always succeeds. sign is 1 for
3442 MAX(), -1 for MIN(). */
3443
3444 static gfc_expr *
3445 simplify_min_max (gfc_expr *expr, int sign)
3446 {
3447 gfc_actual_arglist *arg, *last, *extremum;
3448 gfc_intrinsic_sym * specific;
3449
3450 last = NULL;
3451 extremum = NULL;
3452 specific = expr->value.function.isym;
3453
3454 arg = expr->value.function.actual;
3455
3456 for (; arg; last = arg, arg = arg->next)
3457 {
3458 if (arg->expr->expr_type != EXPR_CONSTANT)
3459 continue;
3460
3461 if (extremum == NULL)
3462 {
3463 extremum = arg;
3464 continue;
3465 }
3466
3467 min_max_choose (arg->expr, extremum->expr, sign);
3468
3469 /* Delete the extra constant argument. */
3470 if (last == NULL)
3471 expr->value.function.actual = arg->next;
3472 else
3473 last->next = arg->next;
3474
3475 arg->next = NULL;
3476 gfc_free_actual_arglist (arg);
3477 arg = last;
3478 }
3479
3480 /* If there is one value left, replace the function call with the
3481 expression. */
3482 if (expr->value.function.actual->next != NULL)
3483 return NULL;
3484
3485 /* Convert to the correct type and kind. */
3486 if (expr->ts.type != BT_UNKNOWN)
3487 return gfc_convert_constant (expr->value.function.actual->expr,
3488 expr->ts.type, expr->ts.kind);
3489
3490 if (specific->ts.type != BT_UNKNOWN)
3491 return gfc_convert_constant (expr->value.function.actual->expr,
3492 specific->ts.type, specific->ts.kind);
3493
3494 return gfc_copy_expr (expr->value.function.actual->expr);
3495 }
3496
3497
3498 gfc_expr *
3499 gfc_simplify_min (gfc_expr *e)
3500 {
3501 return simplify_min_max (e, -1);
3502 }
3503
3504
3505 gfc_expr *
3506 gfc_simplify_max (gfc_expr *e)
3507 {
3508 return simplify_min_max (e, 1);
3509 }
3510
3511
3512 /* This is a simplified version of simplify_min_max to provide
3513 simplification of minval and maxval for a vector. */
3514
3515 static gfc_expr *
3516 simplify_minval_maxval (gfc_expr *expr, int sign)
3517 {
3518 gfc_constructor *c, *extremum;
3519 gfc_intrinsic_sym * specific;
3520
3521 extremum = NULL;
3522 specific = expr->value.function.isym;
3523
3524 for (c = gfc_constructor_first (expr->value.constructor);
3525 c; c = gfc_constructor_next (c))
3526 {
3527 if (c->expr->expr_type != EXPR_CONSTANT)
3528 return NULL;
3529
3530 if (extremum == NULL)
3531 {
3532 extremum = c;
3533 continue;
3534 }
3535
3536 min_max_choose (c->expr, extremum->expr, sign);
3537 }
3538
3539 if (extremum == NULL)
3540 return NULL;
3541
3542 /* Convert to the correct type and kind. */
3543 if (expr->ts.type != BT_UNKNOWN)
3544 return gfc_convert_constant (extremum->expr,
3545 expr->ts.type, expr->ts.kind);
3546
3547 if (specific->ts.type != BT_UNKNOWN)
3548 return gfc_convert_constant (extremum->expr,
3549 specific->ts.type, specific->ts.kind);
3550
3551 return gfc_copy_expr (extremum->expr);
3552 }
3553
3554
3555 gfc_expr *
3556 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3557 {
3558 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3559 return NULL;
3560
3561 return simplify_minval_maxval (array, -1);
3562 }
3563
3564
3565 gfc_expr *
3566 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3567 {
3568 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3569 return NULL;
3570
3571 return simplify_minval_maxval (array, 1);
3572 }
3573
3574
3575 gfc_expr *
3576 gfc_simplify_maxexponent (gfc_expr *x)
3577 {
3578 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3579 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3580 gfc_real_kinds[i].max_exponent);
3581 }
3582
3583
3584 gfc_expr *
3585 gfc_simplify_minexponent (gfc_expr *x)
3586 {
3587 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3588 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3589 gfc_real_kinds[i].min_exponent);
3590 }
3591
3592
3593 gfc_expr *
3594 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3595 {
3596 gfc_expr *result;
3597 mpfr_t tmp;
3598 int kind;
3599
3600 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3601 return NULL;
3602
3603 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3604 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3605
3606 switch (a->ts.type)
3607 {
3608 case BT_INTEGER:
3609 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3610 {
3611 /* Result is processor-dependent. */
3612 gfc_error ("Second argument MOD at %L is zero", &a->where);
3613 gfc_free_expr (result);
3614 return &gfc_bad_expr;
3615 }
3616 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3617 break;
3618
3619 case BT_REAL:
3620 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3621 {
3622 /* Result is processor-dependent. */
3623 gfc_error ("Second argument of MOD at %L is zero", &p->where);
3624 gfc_free_expr (result);
3625 return &gfc_bad_expr;
3626 }
3627
3628 gfc_set_model_kind (kind);
3629 mpfr_init (tmp);
3630 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3631 mpfr_trunc (tmp, tmp);
3632 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3633 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3634 mpfr_clear (tmp);
3635 break;
3636
3637 default:
3638 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3639 }
3640
3641 return range_check (result, "MOD");
3642 }
3643
3644
3645 gfc_expr *
3646 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3647 {
3648 gfc_expr *result;
3649 mpfr_t tmp;
3650 int kind;
3651
3652 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3653 return NULL;
3654
3655 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3656 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3657
3658 switch (a->ts.type)
3659 {
3660 case BT_INTEGER:
3661 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3662 {
3663 /* Result is processor-dependent. This processor just opts
3664 to not handle it at all. */
3665 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3666 gfc_free_expr (result);
3667 return &gfc_bad_expr;
3668 }
3669 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3670
3671 break;
3672
3673 case BT_REAL:
3674 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3675 {
3676 /* Result is processor-dependent. */
3677 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3678 gfc_free_expr (result);
3679 return &gfc_bad_expr;
3680 }
3681
3682 gfc_set_model_kind (kind);
3683 mpfr_init (tmp);
3684 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3685 mpfr_floor (tmp, tmp);
3686 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3687 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3688 mpfr_clear (tmp);
3689 break;
3690
3691 default:
3692 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3693 }
3694
3695 return range_check (result, "MODULO");
3696 }
3697
3698
3699 /* Exists for the sole purpose of consistency with other intrinsics. */
3700 gfc_expr *
3701 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
3702 gfc_expr *fp ATTRIBUTE_UNUSED,
3703 gfc_expr *l ATTRIBUTE_UNUSED,
3704 gfc_expr *to ATTRIBUTE_UNUSED,
3705 gfc_expr *tp ATTRIBUTE_UNUSED)
3706 {
3707 return NULL;
3708 }
3709
3710
3711 gfc_expr *
3712 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3713 {
3714 gfc_expr *result;
3715 mp_exp_t emin, emax;
3716 int kind;
3717
3718 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3719 return NULL;
3720
3721 if (mpfr_sgn (s->value.real) == 0)
3722 {
3723 gfc_error ("Second argument of NEAREST at %L shall not be zero",
3724 &s->where);
3725 return &gfc_bad_expr;
3726 }
3727
3728 result = gfc_copy_expr (x);
3729
3730 /* Save current values of emin and emax. */
3731 emin = mpfr_get_emin ();
3732 emax = mpfr_get_emax ();
3733
3734 /* Set emin and emax for the current model number. */
3735 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3736 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3737 mpfr_get_prec(result->value.real) + 1);
3738 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3739 mpfr_check_range (result->value.real, 0, GMP_RNDU);
3740
3741 if (mpfr_sgn (s->value.real) > 0)
3742 {
3743 mpfr_nextabove (result->value.real);
3744 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3745 }
3746 else
3747 {
3748 mpfr_nextbelow (result->value.real);
3749 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3750 }
3751
3752 mpfr_set_emin (emin);
3753 mpfr_set_emax (emax);
3754
3755 /* Only NaN can occur. Do not use range check as it gives an
3756 error for denormal numbers. */
3757 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3758 {
3759 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3760 gfc_free_expr (result);
3761 return &gfc_bad_expr;
3762 }
3763
3764 return result;
3765 }
3766
3767
3768 static gfc_expr *
3769 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3770 {
3771 gfc_expr *itrunc, *result;
3772 int kind;
3773
3774 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3775 if (kind == -1)
3776 return &gfc_bad_expr;
3777
3778 if (e->expr_type != EXPR_CONSTANT)
3779 return NULL;
3780
3781 itrunc = gfc_copy_expr (e);
3782 mpfr_round (itrunc->value.real, e->value.real);
3783
3784 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3785 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3786
3787 gfc_free_expr (itrunc);
3788
3789 return range_check (result, name);
3790 }
3791
3792
3793 gfc_expr *
3794 gfc_simplify_new_line (gfc_expr *e)
3795 {
3796 gfc_expr *result;
3797
3798 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
3799 result->value.character.string[0] = '\n';
3800
3801 return result;
3802 }
3803
3804
3805 gfc_expr *
3806 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3807 {
3808 return simplify_nint ("NINT", e, k);
3809 }
3810
3811
3812 gfc_expr *
3813 gfc_simplify_idnint (gfc_expr *e)
3814 {
3815 return simplify_nint ("IDNINT", e, NULL);
3816 }
3817
3818
3819 gfc_expr *
3820 gfc_simplify_not (gfc_expr *e)
3821 {
3822 gfc_expr *result;
3823
3824 if (e->expr_type != EXPR_CONSTANT)
3825 return NULL;
3826
3827 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3828 mpz_com (result->value.integer, e->value.integer);
3829
3830 return range_check (result, "NOT");
3831 }
3832
3833
3834 gfc_expr *
3835 gfc_simplify_null (gfc_expr *mold)
3836 {
3837 gfc_expr *result;
3838
3839 if (mold)
3840 {
3841 result = gfc_copy_expr (mold);
3842 result->expr_type = EXPR_NULL;
3843 }
3844 else
3845 result = gfc_get_null_expr (NULL);
3846
3847 return result;
3848 }
3849
3850
3851 gfc_expr *
3852 gfc_simplify_num_images (void)
3853 {
3854 gfc_expr *result;
3855
3856 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3857 {
3858 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3859 return &gfc_bad_expr;
3860 }
3861
3862 /* FIXME: gfc_current_locus is wrong. */
3863 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3864 &gfc_current_locus);
3865 mpz_set_si (result->value.integer, 1);
3866 return result;
3867 }
3868
3869
3870 gfc_expr *
3871 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3872 {
3873 gfc_expr *result;
3874 int kind;
3875
3876 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3877 return NULL;
3878
3879 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3880
3881 switch (x->ts.type)
3882 {
3883 case BT_INTEGER:
3884 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
3885 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3886 return range_check (result, "OR");
3887
3888 case BT_LOGICAL:
3889 return gfc_get_logical_expr (kind, &x->where,
3890 x->value.logical || y->value.logical);
3891 default:
3892 gcc_unreachable();
3893 }
3894 }
3895
3896
3897 gfc_expr *
3898 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3899 {
3900 gfc_expr *result;
3901 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
3902
3903 if (!is_constant_array_expr(array)
3904 || !is_constant_array_expr(vector)
3905 || (!gfc_is_constant_expr (mask)
3906 && !is_constant_array_expr(mask)))
3907 return NULL;
3908
3909 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
3910
3911 array_ctor = gfc_constructor_first (array->value.constructor);
3912 vector_ctor = vector
3913 ? gfc_constructor_first (vector->value.constructor)
3914 : NULL;
3915
3916 if (mask->expr_type == EXPR_CONSTANT
3917 && mask->value.logical)
3918 {
3919 /* Copy all elements of ARRAY to RESULT. */
3920 while (array_ctor)
3921 {
3922 gfc_constructor_append_expr (&result->value.constructor,
3923 gfc_copy_expr (array_ctor->expr),
3924 NULL);
3925
3926 array_ctor = gfc_constructor_next (array_ctor);
3927 vector_ctor = gfc_constructor_next (vector_ctor);
3928 }
3929 }
3930 else if (mask->expr_type == EXPR_ARRAY)
3931 {
3932 /* Copy only those elements of ARRAY to RESULT whose
3933 MASK equals .TRUE.. */
3934 mask_ctor = gfc_constructor_first (mask->value.constructor);
3935 while (mask_ctor)
3936 {
3937 if (mask_ctor->expr->value.logical)
3938 {
3939 gfc_constructor_append_expr (&result->value.constructor,
3940 gfc_copy_expr (array_ctor->expr),
3941 NULL);
3942 vector_ctor = gfc_constructor_next (vector_ctor);
3943 }
3944
3945 array_ctor = gfc_constructor_next (array_ctor);
3946 mask_ctor = gfc_constructor_next (mask_ctor);
3947 }
3948 }
3949
3950 /* Append any left-over elements from VECTOR to RESULT. */
3951 while (vector_ctor)
3952 {
3953 gfc_constructor_append_expr (&result->value.constructor,
3954 gfc_copy_expr (vector_ctor->expr),
3955 NULL);
3956 vector_ctor = gfc_constructor_next (vector_ctor);
3957 }
3958
3959 result->shape = gfc_get_shape (1);
3960 gfc_array_size (result, &result->shape[0]);
3961
3962 if (array->ts.type == BT_CHARACTER)
3963 result->ts.u.cl = array->ts.u.cl;
3964
3965 return result;
3966 }
3967
3968
3969 gfc_expr *
3970 gfc_simplify_precision (gfc_expr *e)
3971 {
3972 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3973 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3974 gfc_real_kinds[i].precision);
3975 }
3976
3977
3978 gfc_expr *
3979 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3980 {
3981 gfc_expr *result;
3982
3983 if (!is_constant_array_expr (array)
3984 || !gfc_is_constant_expr (dim))
3985 return NULL;
3986
3987 if (mask
3988 && !is_constant_array_expr (mask)
3989 && mask->expr_type != EXPR_CONSTANT)
3990 return NULL;
3991
3992 result = transformational_result (array, dim, array->ts.type,
3993 array->ts.kind, &array->where);
3994 init_result_expr (result, 1, NULL);
3995
3996 return !dim || array->rank == 1 ?
3997 simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
3998 simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
3999 }
4000
4001
4002 gfc_expr *
4003 gfc_simplify_radix (gfc_expr *e)
4004 {
4005 int i;
4006 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4007
4008 switch (e->ts.type)
4009 {
4010 case BT_INTEGER:
4011 i = gfc_integer_kinds[i].radix;
4012 break;
4013
4014 case BT_REAL:
4015 i = gfc_real_kinds[i].radix;
4016 break;
4017
4018 default:
4019 gcc_unreachable ();
4020 }
4021
4022 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4023 }
4024
4025
4026 gfc_expr *
4027 gfc_simplify_range (gfc_expr *e)
4028 {
4029 int i;
4030 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4031
4032 switch (e->ts.type)
4033 {
4034 case BT_INTEGER:
4035 i = gfc_integer_kinds[i].range;
4036 break;
4037
4038 case BT_REAL:
4039 case BT_COMPLEX:
4040 i = gfc_real_kinds[i].range;
4041 break;
4042
4043 default:
4044 gcc_unreachable ();
4045 }
4046
4047 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4048 }
4049
4050
4051 gfc_expr *
4052 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4053 {
4054 gfc_expr *result = NULL;
4055 int kind;
4056
4057 if (e->ts.type == BT_COMPLEX)
4058 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4059 else
4060 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4061
4062 if (kind == -1)
4063 return &gfc_bad_expr;
4064
4065 if (e->expr_type != EXPR_CONSTANT)
4066 return NULL;
4067
4068 if (convert_boz (e, kind) == &gfc_bad_expr)
4069 return &gfc_bad_expr;
4070
4071 result = gfc_convert_constant (e, BT_REAL, kind);
4072 if (result == &gfc_bad_expr)
4073 return &gfc_bad_expr;
4074
4075 return range_check (result, "REAL");
4076 }
4077
4078
4079 gfc_expr *
4080 gfc_simplify_realpart (gfc_expr *e)
4081 {
4082 gfc_expr *result;
4083
4084 if (e->expr_type != EXPR_CONSTANT)
4085 return NULL;
4086
4087 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4088 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4089
4090 return range_check (result, "REALPART");
4091 }
4092
4093 gfc_expr *
4094 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4095 {
4096 gfc_expr *result;
4097 int i, j, len, ncop, nlen;
4098 mpz_t ncopies;
4099 bool have_length = false;
4100
4101 /* If NCOPIES isn't a constant, there's nothing we can do. */
4102 if (n->expr_type != EXPR_CONSTANT)
4103 return NULL;
4104
4105 /* If NCOPIES is negative, it's an error. */
4106 if (mpz_sgn (n->value.integer) < 0)
4107 {
4108 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4109 &n->where);
4110 return &gfc_bad_expr;
4111 }
4112
4113 /* If we don't know the character length, we can do no more. */
4114 if (e->ts.u.cl && e->ts.u.cl->length
4115 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4116 {
4117 len = mpz_get_si (e->ts.u.cl->length->value.integer);
4118 have_length = true;
4119 }
4120 else if (e->expr_type == EXPR_CONSTANT
4121 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4122 {
4123 len = e->value.character.length;
4124 }
4125 else
4126 return NULL;
4127
4128 /* If the source length is 0, any value of NCOPIES is valid
4129 and everything behaves as if NCOPIES == 0. */
4130 mpz_init (ncopies);
4131 if (len == 0)
4132 mpz_set_ui (ncopies, 0);
4133 else
4134 mpz_set (ncopies, n->value.integer);
4135
4136 /* Check that NCOPIES isn't too large. */
4137 if (len)
4138 {
4139 mpz_t max, mlen;
4140 int i;
4141
4142 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4143 mpz_init (max);
4144 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4145
4146 if (have_length)
4147 {
4148 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4149 e->ts.u.cl->length->value.integer);
4150 }
4151 else
4152 {
4153 mpz_init_set_si (mlen, len);
4154 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4155 mpz_clear (mlen);
4156 }
4157
4158 /* The check itself. */
4159 if (mpz_cmp (ncopies, max) > 0)
4160 {
4161 mpz_clear (max);
4162 mpz_clear (ncopies);
4163 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4164 &n->where);
4165 return &gfc_bad_expr;
4166 }
4167
4168 mpz_clear (max);
4169 }
4170 mpz_clear (ncopies);
4171
4172 /* For further simplification, we need the character string to be
4173 constant. */
4174 if (e->expr_type != EXPR_CONSTANT)
4175 return NULL;
4176
4177 if (len ||
4178 (e->ts.u.cl->length &&
4179 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4180 {
4181 const char *res = gfc_extract_int (n, &ncop);
4182 gcc_assert (res == NULL);
4183 }
4184 else
4185 ncop = 0;
4186
4187 len = e->value.character.length;
4188 nlen = ncop * len;
4189
4190 result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4191
4192 if (ncop == 0)
4193 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4194
4195 len = e->value.character.length;
4196 nlen = ncop * len;
4197
4198 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4199 for (i = 0; i < ncop; i++)
4200 for (j = 0; j < len; j++)
4201 result->value.character.string[j+i*len]= e->value.character.string[j];
4202
4203 result->value.character.string[nlen] = '\0'; /* For debugger */
4204 return result;
4205 }
4206
4207
4208 /* This one is a bear, but mainly has to do with shuffling elements. */
4209
4210 gfc_expr *
4211 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4212 gfc_expr *pad, gfc_expr *order_exp)
4213 {
4214 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4215 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4216 mpz_t index, size;
4217 unsigned long j;
4218 size_t nsource;
4219 gfc_expr *e, *result;
4220
4221 /* Check that argument expression types are OK. */
4222 if (!is_constant_array_expr (source)
4223 || !is_constant_array_expr (shape_exp)
4224 || !is_constant_array_expr (pad)
4225 || !is_constant_array_expr (order_exp))
4226 return NULL;
4227
4228 /* Proceed with simplification, unpacking the array. */
4229
4230 mpz_init (index);
4231 rank = 0;
4232
4233 for (;;)
4234 {
4235 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4236 if (e == NULL)
4237 break;
4238
4239 gfc_extract_int (e, &shape[rank]);
4240
4241 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4242 gcc_assert (shape[rank] >= 0);
4243
4244 rank++;
4245 }
4246
4247 gcc_assert (rank > 0);
4248
4249 /* Now unpack the order array if present. */
4250 if (order_exp == NULL)
4251 {
4252 for (i = 0; i < rank; i++)
4253 order[i] = i;
4254 }
4255 else
4256 {
4257 for (i = 0; i < rank; i++)
4258 x[i] = 0;
4259
4260 for (i = 0; i < rank; i++)
4261 {
4262 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
4263 gcc_assert (e);
4264
4265 gfc_extract_int (e, &order[i]);
4266
4267 gcc_assert (order[i] >= 1 && order[i] <= rank);
4268 order[i]--;
4269 gcc_assert (x[order[i]] == 0);
4270 x[order[i]] = 1;
4271 }
4272 }
4273
4274 /* Count the elements in the source and padding arrays. */
4275
4276 npad = 0;
4277 if (pad != NULL)
4278 {
4279 gfc_array_size (pad, &size);
4280 npad = mpz_get_ui (size);
4281 mpz_clear (size);
4282 }
4283
4284 gfc_array_size (source, &size);
4285 nsource = mpz_get_ui (size);
4286 mpz_clear (size);
4287
4288 /* If it weren't for that pesky permutation we could just loop
4289 through the source and round out any shortage with pad elements.
4290 But no, someone just had to have the compiler do something the
4291 user should be doing. */
4292
4293 for (i = 0; i < rank; i++)
4294 x[i] = 0;
4295
4296 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4297 &source->where);
4298 result->rank = rank;
4299 result->shape = gfc_get_shape (rank);
4300 for (i = 0; i < rank; i++)
4301 mpz_init_set_ui (result->shape[i], shape[i]);
4302
4303 while (nsource > 0 || npad > 0)
4304 {
4305 /* Figure out which element to extract. */
4306 mpz_set_ui (index, 0);
4307
4308 for (i = rank - 1; i >= 0; i--)
4309 {
4310 mpz_add_ui (index, index, x[order[i]]);
4311 if (i != 0)
4312 mpz_mul_ui (index, index, shape[order[i - 1]]);
4313 }
4314
4315 if (mpz_cmp_ui (index, INT_MAX) > 0)
4316 gfc_internal_error ("Reshaped array too large at %C");
4317
4318 j = mpz_get_ui (index);
4319
4320 if (j < nsource)
4321 e = gfc_constructor_lookup_expr (source->value.constructor, j);
4322 else
4323 {
4324 gcc_assert (npad > 0);
4325
4326 j = j - nsource;
4327 j = j % npad;
4328 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
4329 }
4330 gcc_assert (e);
4331
4332 gfc_constructor_append_expr (&result->value.constructor,
4333 gfc_copy_expr (e), &e->where);
4334
4335 /* Calculate the next element. */
4336 i = 0;
4337
4338 inc:
4339 if (++x[i] < shape[i])
4340 continue;
4341 x[i++] = 0;
4342 if (i < rank)
4343 goto inc;
4344
4345 break;
4346 }
4347
4348 mpz_clear (index);
4349
4350 return result;
4351 }
4352
4353
4354 gfc_expr *
4355 gfc_simplify_rrspacing (gfc_expr *x)
4356 {
4357 gfc_expr *result;
4358 int i;
4359 long int e, p;
4360
4361 if (x->expr_type != EXPR_CONSTANT)
4362 return NULL;
4363
4364 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4365
4366 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4367 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4368
4369 /* Special case x = -0 and 0. */
4370 if (mpfr_sgn (result->value.real) == 0)
4371 {
4372 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4373 return result;
4374 }
4375
4376 /* | x * 2**(-e) | * 2**p. */
4377 e = - (long int) mpfr_get_exp (x->value.real);
4378 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
4379
4380 p = (long int) gfc_real_kinds[i].digits;
4381 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
4382
4383 return range_check (result, "RRSPACING");
4384 }
4385
4386
4387 gfc_expr *
4388 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
4389 {
4390 int k, neg_flag, power, exp_range;
4391 mpfr_t scale, radix;
4392 gfc_expr *result;
4393
4394 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4395 return NULL;
4396
4397 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4398
4399 if (mpfr_sgn (x->value.real) == 0)
4400 {
4401 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4402 return result;
4403 }
4404
4405 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4406
4407 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
4408
4409 /* This check filters out values of i that would overflow an int. */
4410 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
4411 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
4412 {
4413 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
4414 gfc_free_expr (result);
4415 return &gfc_bad_expr;
4416 }
4417
4418 /* Compute scale = radix ** power. */
4419 power = mpz_get_si (i->value.integer);
4420
4421 if (power >= 0)
4422 neg_flag = 0;
4423 else
4424 {
4425 neg_flag = 1;
4426 power = -power;
4427 }
4428
4429 gfc_set_model_kind (x->ts.kind);
4430 mpfr_init (scale);
4431 mpfr_init (radix);
4432 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
4433 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
4434
4435 if (neg_flag)
4436 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
4437 else
4438 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
4439
4440 mpfr_clears (scale, radix, NULL);
4441
4442 return range_check (result, "SCALE");
4443 }
4444
4445
4446 /* Variants of strspn and strcspn that operate on wide characters. */
4447
4448 static size_t
4449 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
4450 {
4451 size_t i = 0;
4452 const gfc_char_t *c;
4453
4454 while (s1[i])
4455 {
4456 for (c = s2; *c; c++)
4457 {
4458 if (s1[i] == *c)
4459 break;
4460 }
4461 if (*c == '\0')
4462 break;
4463 i++;
4464 }
4465
4466 return i;
4467 }
4468
4469 static size_t
4470 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
4471 {
4472 size_t i = 0;
4473 const gfc_char_t *c;
4474
4475 while (s1[i])
4476 {
4477 for (c = s2; *c; c++)
4478 {
4479 if (s1[i] == *c)
4480 break;
4481 }
4482 if (*c)
4483 break;
4484 i++;
4485 }
4486
4487 return i;
4488 }
4489
4490
4491 gfc_expr *
4492 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
4493 {
4494 gfc_expr *result;
4495 int back;
4496 size_t i;
4497 size_t indx, len, lenc;
4498 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
4499
4500 if (k == -1)
4501 return &gfc_bad_expr;
4502
4503 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
4504 return NULL;
4505
4506 if (b != NULL && b->value.logical != 0)
4507 back = 1;
4508 else
4509 back = 0;
4510
4511 len = e->value.character.length;
4512 lenc = c->value.character.length;
4513
4514 if (len == 0 || lenc == 0)
4515 {
4516 indx = 0;
4517 }
4518 else
4519 {
4520 if (back == 0)
4521 {
4522 indx = wide_strcspn (e->value.character.string,
4523 c->value.character.string) + 1;
4524 if (indx > len)
4525 indx = 0;
4526 }
4527 else
4528 {
4529 i = 0;
4530 for (indx = len; indx > 0; indx--)
4531 {
4532 for (i = 0; i < lenc; i++)
4533 {
4534 if (c->value.character.string[i]
4535 == e->value.character.string[indx - 1])
4536 break;
4537 }
4538 if (i < lenc)
4539 break;
4540 }
4541 }
4542 }
4543
4544 result = gfc_get_int_expr (k, &e->where, indx);
4545 return range_check (result, "SCAN");
4546 }
4547
4548
4549 gfc_expr *
4550 gfc_simplify_selected_char_kind (gfc_expr *e)
4551 {
4552 int kind;
4553
4554 if (e->expr_type != EXPR_CONSTANT)
4555 return NULL;
4556
4557 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4558 || gfc_compare_with_Cstring (e, "default", false) == 0)
4559 kind = 1;
4560 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4561 kind = 4;
4562 else
4563 kind = -1;
4564
4565 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4566 }
4567
4568
4569 gfc_expr *
4570 gfc_simplify_selected_int_kind (gfc_expr *e)
4571 {
4572 int i, kind, range;
4573
4574 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4575 return NULL;
4576
4577 kind = INT_MAX;
4578
4579 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4580 if (gfc_integer_kinds[i].range >= range
4581 && gfc_integer_kinds[i].kind < kind)
4582 kind = gfc_integer_kinds[i].kind;
4583
4584 if (kind == INT_MAX)
4585 kind = -1;
4586
4587 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4588 }
4589
4590
4591 gfc_expr *
4592 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
4593 {
4594 int range, precision, i, kind, found_precision, found_range;
4595
4596 if (p == NULL)
4597 precision = 0;
4598 else
4599 {
4600 if (p->expr_type != EXPR_CONSTANT
4601 || gfc_extract_int (p, &precision) != NULL)
4602 return NULL;
4603 }
4604
4605 if (q == NULL)
4606 range = 0;
4607 else
4608 {
4609 if (q->expr_type != EXPR_CONSTANT
4610 || gfc_extract_int (q, &range) != NULL)
4611 return NULL;
4612 }
4613
4614 kind = INT_MAX;
4615 found_precision = 0;
4616 found_range = 0;
4617
4618 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4619 {
4620 if (gfc_real_kinds[i].precision >= precision)
4621 found_precision = 1;
4622
4623 if (gfc_real_kinds[i].range >= range)
4624 found_range = 1;
4625
4626 if (gfc_real_kinds[i].precision >= precision
4627 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
4628 kind = gfc_real_kinds[i].kind;
4629 }
4630
4631 if (kind == INT_MAX)
4632 {
4633 kind = 0;
4634
4635 if (!found_precision)
4636 kind = -1;
4637 if (!found_range)
4638 kind -= 2;
4639 }
4640
4641 return gfc_get_int_expr (gfc_default_integer_kind,
4642 p ? &p->where : &q->where, kind);
4643 }
4644
4645
4646 gfc_expr *
4647 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4648 {
4649 gfc_expr *result;
4650 mpfr_t exp, absv, log2, pow2, frac;
4651 unsigned long exp2;
4652
4653 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4654 return NULL;
4655
4656 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4657
4658 if (mpfr_sgn (x->value.real) == 0)
4659 {
4660 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4661 return result;
4662 }
4663
4664 gfc_set_model_kind (x->ts.kind);
4665 mpfr_init (absv);
4666 mpfr_init (log2);
4667 mpfr_init (exp);
4668 mpfr_init (pow2);
4669 mpfr_init (frac);
4670
4671 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4672 mpfr_log2 (log2, absv, GFC_RND_MODE);
4673
4674 mpfr_trunc (log2, log2);
4675 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4676
4677 /* Old exponent value, and fraction. */
4678 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4679
4680 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4681
4682 /* New exponent. */
4683 exp2 = (unsigned long) mpz_get_d (i->value.integer);
4684 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4685
4686 mpfr_clears (absv, log2, pow2, frac, NULL);
4687
4688 return range_check (result, "SET_EXPONENT");
4689 }
4690
4691
4692 gfc_expr *
4693 gfc_simplify_shape (gfc_expr *source)
4694 {
4695 mpz_t shape[GFC_MAX_DIMENSIONS];
4696 gfc_expr *result, *e, *f;
4697 gfc_array_ref *ar;
4698 int n;
4699 gfc_try t;
4700
4701 if (source->rank == 0)
4702 return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4703 &source->where);
4704
4705 if (source->expr_type != EXPR_VARIABLE)
4706 return NULL;
4707
4708 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4709 &source->where);
4710
4711 ar = gfc_find_array_ref (source);
4712
4713 t = gfc_array_ref_shape (ar, shape);
4714
4715 for (n = 0; n < source->rank; n++)
4716 {
4717 e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4718 &source->where);
4719
4720 if (t == SUCCESS)
4721 {
4722 mpz_set (e->value.integer, shape[n]);
4723 mpz_clear (shape[n]);
4724 }
4725 else
4726 {
4727 mpz_set_ui (e->value.integer, n + 1);
4728
4729 f = gfc_simplify_size (source, e, NULL);
4730 gfc_free_expr (e);
4731 if (f == NULL)
4732 {
4733 gfc_free_expr (result);
4734 return NULL;
4735 }
4736 else
4737 {
4738 e = f;
4739 }
4740 }
4741
4742 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
4743 }
4744
4745 return result;
4746 }
4747
4748
4749 gfc_expr *
4750 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4751 {
4752 mpz_t size;
4753 int d;
4754 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4755
4756 if (k == -1)
4757 return &gfc_bad_expr;
4758
4759 if (dim == NULL)
4760 {
4761 if (gfc_array_size (array, &size) == FAILURE)
4762 return NULL;
4763 }
4764 else
4765 {
4766 if (dim->expr_type != EXPR_CONSTANT)
4767 return NULL;
4768
4769 d = mpz_get_ui (dim->value.integer) - 1;
4770 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4771 return NULL;
4772 }
4773
4774 return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
4775 }
4776
4777
4778 gfc_expr *
4779 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4780 {
4781 gfc_expr *result;
4782
4783 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4784 return NULL;
4785
4786 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4787
4788 switch (x->ts.type)
4789 {
4790 case BT_INTEGER:
4791 mpz_abs (result->value.integer, x->value.integer);
4792 if (mpz_sgn (y->value.integer) < 0)
4793 mpz_neg (result->value.integer, result->value.integer);
4794 break;
4795
4796 case BT_REAL:
4797 if (gfc_option.flag_sign_zero)
4798 mpfr_copysign (result->value.real, x->value.real, y->value.real,
4799 GFC_RND_MODE);
4800 else
4801 mpfr_setsign (result->value.real, x->value.real,
4802 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
4803 break;
4804
4805 default:
4806 gfc_internal_error ("Bad type in gfc_simplify_sign");
4807 }
4808
4809 return result;
4810 }
4811
4812
4813 gfc_expr *
4814 gfc_simplify_sin (gfc_expr *x)
4815 {
4816 gfc_expr *result;
4817
4818 if (x->expr_type != EXPR_CONSTANT)
4819 return NULL;
4820
4821 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4822
4823 switch (x->ts.type)
4824 {
4825 case BT_REAL:
4826 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4827 break;
4828
4829 case BT_COMPLEX:
4830 gfc_set_model (x->value.real);
4831 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4832 break;
4833
4834 default:
4835 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4836 }
4837
4838 return range_check (result, "SIN");
4839 }
4840
4841
4842 gfc_expr *
4843 gfc_simplify_sinh (gfc_expr *x)
4844 {
4845 gfc_expr *result;
4846
4847 if (x->expr_type != EXPR_CONSTANT)
4848 return NULL;
4849
4850 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4851
4852 switch (x->ts.type)
4853 {
4854 case BT_REAL:
4855 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4856 break;
4857
4858 case BT_COMPLEX:
4859 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4860 break;
4861
4862 default:
4863 gcc_unreachable ();
4864 }
4865
4866 return range_check (result, "SINH");
4867 }
4868
4869
4870 /* The argument is always a double precision real that is converted to
4871 single precision. TODO: Rounding! */
4872
4873 gfc_expr *
4874 gfc_simplify_sngl (gfc_expr *a)
4875 {
4876 gfc_expr *result;
4877
4878 if (a->expr_type != EXPR_CONSTANT)
4879 return NULL;
4880
4881 result = gfc_real2real (a, gfc_default_real_kind);
4882 return range_check (result, "SNGL");
4883 }
4884
4885
4886 gfc_expr *
4887 gfc_simplify_spacing (gfc_expr *x)
4888 {
4889 gfc_expr *result;
4890 int i;
4891 long int en, ep;
4892
4893 if (x->expr_type != EXPR_CONSTANT)
4894 return NULL;
4895
4896 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4897
4898 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4899
4900 /* Special case x = 0 and -0. */
4901 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4902 if (mpfr_sgn (result->value.real) == 0)
4903 {
4904 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4905 return result;
4906 }
4907
4908 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4909 are the radix, exponent of x, and precision. This excludes the
4910 possibility of subnormal numbers. Fortran 2003 states the result is
4911 b**max(e - p, emin - 1). */
4912
4913 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4914 en = (long int) gfc_real_kinds[i].min_exponent - 1;
4915 en = en > ep ? en : ep;
4916
4917 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4918 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4919
4920 return range_check (result, "SPACING");
4921 }
4922
4923
4924 gfc_expr *
4925 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
4926 {
4927 gfc_expr *result = 0L;
4928 int i, j, dim, ncopies;
4929 mpz_t size;
4930
4931 if ((!gfc_is_constant_expr (source)
4932 && !is_constant_array_expr (source))
4933 || !gfc_is_constant_expr (dim_expr)
4934 || !gfc_is_constant_expr (ncopies_expr))
4935 return NULL;
4936
4937 gcc_assert (dim_expr->ts.type == BT_INTEGER);
4938 gfc_extract_int (dim_expr, &dim);
4939 dim -= 1; /* zero-base DIM */
4940
4941 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
4942 gfc_extract_int (ncopies_expr, &ncopies);
4943 ncopies = MAX (ncopies, 0);
4944
4945 /* Do not allow the array size to exceed the limit for an array
4946 constructor. */
4947 if (source->expr_type == EXPR_ARRAY)
4948 {
4949 if (gfc_array_size (source, &size) == FAILURE)
4950 gfc_internal_error ("Failure getting length of a constant array.");
4951 }
4952 else
4953 mpz_init_set_ui (size, 1);
4954
4955 if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
4956 return NULL;
4957
4958 if (source->expr_type == EXPR_CONSTANT)
4959 {
4960 gcc_assert (dim == 0);
4961
4962 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4963 &source->where);
4964 result->rank = 1;
4965 result->shape = gfc_get_shape (result->rank);
4966 mpz_init_set_si (result->shape[0], ncopies);
4967
4968 for (i = 0; i < ncopies; ++i)
4969 gfc_constructor_append_expr (&result->value.constructor,
4970 gfc_copy_expr (source), NULL);
4971 }
4972 else if (source->expr_type == EXPR_ARRAY)
4973 {
4974 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
4975 gfc_constructor *source_ctor;
4976
4977 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
4978 gcc_assert (dim >= 0 && dim <= source->rank);
4979
4980 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4981 &source->where);
4982 result->rank = source->rank + 1;
4983 result->shape = gfc_get_shape (result->rank);
4984
4985 for (i = 0, j = 0; i < result->rank; ++i)
4986 {
4987 if (i != dim)
4988 mpz_init_set (result->shape[i], source->shape[j++]);
4989 else
4990 mpz_init_set_si (result->shape[i], ncopies);
4991
4992 extent[i] = mpz_get_si (result->shape[i]);
4993 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
4994 }
4995
4996 offset = 0;
4997 for (source_ctor = gfc_constructor_first (source->value.constructor);
4998 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
4999 {
5000 for (i = 0; i < ncopies; ++i)
5001 gfc_constructor_insert_expr (&result->value.constructor,
5002 gfc_copy_expr (source_ctor->expr),
5003 NULL, offset + i * rstride[dim]);
5004
5005 offset += (dim == 0 ? ncopies : 1);
5006 }
5007 }
5008 else
5009 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5010 Replace NULL with gcc_unreachable() after implementing
5011 gfc_simplify_cshift(). */
5012 return NULL;
5013
5014 if (source->ts.type == BT_CHARACTER)
5015 result->ts.u.cl = source->ts.u.cl;
5016
5017 return result;
5018 }
5019
5020
5021 gfc_expr *
5022 gfc_simplify_sqrt (gfc_expr *e)
5023 {
5024 gfc_expr *result = NULL;
5025
5026 if (e->expr_type != EXPR_CONSTANT)
5027 return NULL;
5028
5029 switch (e->ts.type)
5030 {
5031 case BT_REAL:
5032 if (mpfr_cmp_si (e->value.real, 0) < 0)
5033 {
5034 gfc_error ("Argument of SQRT at %L has a negative value",
5035 &e->where);
5036 return &gfc_bad_expr;
5037 }
5038 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5039 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5040 break;
5041
5042 case BT_COMPLEX:
5043 gfc_set_model (e->value.real);
5044
5045 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5046 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5047 break;
5048
5049 default:
5050 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5051 }
5052
5053 return range_check (result, "SQRT");
5054 }
5055
5056
5057 gfc_expr *
5058 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5059 {
5060 gfc_expr *result;
5061
5062 if (!is_constant_array_expr (array)
5063 || !gfc_is_constant_expr (dim))
5064 return NULL;
5065
5066 if (mask
5067 && !is_constant_array_expr (mask)
5068 && mask->expr_type != EXPR_CONSTANT)
5069 return NULL;
5070
5071 result = transformational_result (array, dim, array->ts.type,
5072 array->ts.kind, &array->where);
5073 init_result_expr (result, 0, NULL);
5074
5075 return !dim || array->rank == 1 ?
5076 simplify_transformation_to_scalar (result, array, mask, gfc_add) :
5077 simplify_transformation_to_array (result, array, dim, mask, gfc_add);
5078 }
5079
5080
5081 gfc_expr *
5082 gfc_simplify_tan (gfc_expr *x)
5083 {
5084 gfc_expr *result;
5085
5086 if (x->expr_type != EXPR_CONSTANT)
5087 return NULL;
5088
5089 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5090
5091 switch (x->ts.type)
5092 {
5093 case BT_REAL:
5094 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5095 break;
5096
5097 case BT_COMPLEX:
5098 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5099 break;
5100
5101 default:
5102 gcc_unreachable ();
5103 }
5104
5105 return range_check (result, "TAN");
5106 }
5107
5108
5109 gfc_expr *
5110 gfc_simplify_tanh (gfc_expr *x)
5111 {
5112 gfc_expr *result;
5113
5114 if (x->expr_type != EXPR_CONSTANT)
5115 return NULL;
5116
5117 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5118
5119 switch (x->ts.type)
5120 {
5121 case BT_REAL:
5122 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5123 break;
5124
5125 case BT_COMPLEX:
5126 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5127 break;
5128
5129 default:
5130 gcc_unreachable ();
5131 }
5132
5133 return range_check (result, "TANH");
5134 }
5135
5136
5137 gfc_expr *
5138 gfc_simplify_tiny (gfc_expr *e)
5139 {
5140 gfc_expr *result;
5141 int i;
5142
5143 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5144
5145 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5146 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5147
5148 return result;
5149 }
5150
5151
5152 gfc_expr *
5153 gfc_simplify_trailz (gfc_expr *e)
5154 {
5155 unsigned long tz, bs;
5156 int i;
5157
5158 if (e->expr_type != EXPR_CONSTANT)
5159 return NULL;
5160
5161 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5162 bs = gfc_integer_kinds[i].bit_size;
5163 tz = mpz_scan1 (e->value.integer, 0);
5164
5165 return gfc_get_int_expr (gfc_default_integer_kind,
5166 &e->where, MIN (tz, bs));
5167 }
5168
5169
5170 gfc_expr *
5171 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5172 {
5173 gfc_expr *result;
5174 gfc_expr *mold_element;
5175 size_t source_size;
5176 size_t result_size;
5177 size_t result_elt_size;
5178 size_t buffer_size;
5179 mpz_t tmp;
5180 unsigned char *buffer;
5181
5182 if (!gfc_is_constant_expr (source)
5183 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5184 || !gfc_is_constant_expr (size))
5185 return NULL;
5186
5187 if (source->expr_type == EXPR_FUNCTION)
5188 return NULL;
5189
5190 /* Calculate the size of the source. */
5191 if (source->expr_type == EXPR_ARRAY
5192 && gfc_array_size (source, &tmp) == FAILURE)
5193 gfc_internal_error ("Failure getting length of a constant array.");
5194
5195 source_size = gfc_target_expr_size (source);
5196
5197 /* Create an empty new expression with the appropriate characteristics. */
5198 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
5199 &source->where);
5200 result->ts = mold->ts;
5201
5202 mold_element = mold->expr_type == EXPR_ARRAY
5203 ? gfc_constructor_first (mold->value.constructor)->expr
5204 : mold;
5205
5206 /* Set result character length, if needed. Note that this needs to be
5207 set even for array expressions, in order to pass this information into
5208 gfc_target_interpret_expr. */
5209 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5210 result->value.character.length = mold_element->value.character.length;
5211
5212 /* Set the number of elements in the result, and determine its size. */
5213 result_elt_size = gfc_target_expr_size (mold_element);
5214 if (result_elt_size == 0)
5215 {
5216 gfc_free_expr (result);
5217 return NULL;
5218 }
5219
5220 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5221 {
5222 int result_length;
5223
5224 result->expr_type = EXPR_ARRAY;
5225 result->rank = 1;
5226
5227 if (size)
5228 result_length = (size_t)mpz_get_ui (size->value.integer);
5229 else
5230 {
5231 result_length = source_size / result_elt_size;
5232 if (result_length * result_elt_size < source_size)
5233 result_length += 1;
5234 }
5235
5236 result->shape = gfc_get_shape (1);
5237 mpz_init_set_ui (result->shape[0], result_length);
5238
5239 result_size = result_length * result_elt_size;
5240 }
5241 else
5242 {
5243 result->rank = 0;
5244 result_size = result_elt_size;
5245 }
5246
5247 if (gfc_option.warn_surprising && source_size < result_size)
5248 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5249 "source size %ld < result size %ld", &source->where,
5250 (long) source_size, (long) result_size);
5251
5252 /* Allocate the buffer to store the binary version of the source. */
5253 buffer_size = MAX (source_size, result_size);
5254 buffer = (unsigned char*)alloca (buffer_size);
5255 memset (buffer, 0, buffer_size);
5256
5257 /* Now write source to the buffer. */
5258 gfc_target_encode_expr (source, buffer, buffer_size);
5259
5260 /* And read the buffer back into the new expression. */
5261 gfc_target_interpret_expr (buffer, buffer_size, result);
5262
5263 return result;
5264 }
5265
5266
5267 gfc_expr *
5268 gfc_simplify_transpose (gfc_expr *matrix)
5269 {
5270 int row, matrix_rows, col, matrix_cols;
5271 gfc_expr *result;
5272
5273 if (!is_constant_array_expr (matrix))
5274 return NULL;
5275
5276 gcc_assert (matrix->rank == 2);
5277
5278 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
5279 &matrix->where);
5280 result->rank = 2;
5281 result->shape = gfc_get_shape (result->rank);
5282 mpz_set (result->shape[0], matrix->shape[1]);
5283 mpz_set (result->shape[1], matrix->shape[0]);
5284
5285 if (matrix->ts.type == BT_CHARACTER)
5286 result->ts.u.cl = matrix->ts.u.cl;
5287
5288 matrix_rows = mpz_get_si (matrix->shape[0]);
5289 matrix_cols = mpz_get_si (matrix->shape[1]);
5290 for (row = 0; row < matrix_rows; ++row)
5291 for (col = 0; col < matrix_cols; ++col)
5292 {
5293 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
5294 col * matrix_rows + row);
5295 gfc_constructor_insert_expr (&result->value.constructor,
5296 gfc_copy_expr (e), &matrix->where,
5297 row * matrix_cols + col);
5298 }
5299
5300 return result;
5301 }
5302
5303
5304 gfc_expr *
5305 gfc_simplify_trim (gfc_expr *e)
5306 {
5307 gfc_expr *result;
5308 int count, i, len, lentrim;
5309
5310 if (e->expr_type != EXPR_CONSTANT)
5311 return NULL;
5312
5313 len = e->value.character.length;
5314 for (count = 0, i = 1; i <= len; ++i)
5315 {
5316 if (e->value.character.string[len - i] == ' ')
5317 count++;
5318 else
5319 break;
5320 }
5321
5322 lentrim = len - count;
5323
5324 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
5325 for (i = 0; i < lentrim; i++)
5326 result->value.character.string[i] = e->value.character.string[i];
5327
5328 return result;
5329 }
5330
5331
5332 gfc_expr *
5333 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
5334 {
5335 gfc_expr *result;
5336 gfc_ref *ref;
5337 gfc_array_spec *as;
5338 gfc_constructor *sub_cons;
5339 bool first_image;
5340 int d;
5341
5342 if (!is_constant_array_expr (sub))
5343 goto not_implemented; /* return NULL;*/
5344
5345 /* Follow any component references. */
5346 as = coarray->symtree->n.sym->as;
5347 for (ref = coarray->ref; ref; ref = ref->next)
5348 if (ref->type == REF_COMPONENT)
5349 as = ref->u.ar.as;
5350
5351 if (as->type == AS_DEFERRED)
5352 goto not_implemented; /* return NULL;*/
5353
5354 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
5355 the cosubscript addresses the first image. */
5356
5357 sub_cons = gfc_constructor_first (sub->value.constructor);
5358 first_image = true;
5359
5360 for (d = 1; d <= as->corank; d++)
5361 {
5362 gfc_expr *ca_bound;
5363 int cmp;
5364
5365 if (sub_cons == NULL)
5366 {
5367 gfc_error ("Too few elements in expression for SUB= argument at %L",
5368 &sub->where);
5369 return &gfc_bad_expr;
5370 }
5371
5372 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
5373 NULL, true);
5374 if (ca_bound == NULL)
5375 goto not_implemented; /* return NULL */
5376
5377 if (ca_bound == &gfc_bad_expr)
5378 return ca_bound;
5379
5380 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
5381
5382 if (cmp == 0)
5383 {
5384 gfc_free_expr (ca_bound);
5385 sub_cons = gfc_constructor_next (sub_cons);
5386 continue;
5387 }
5388
5389 first_image = false;
5390
5391 if (cmp > 0)
5392 {
5393 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5394 "SUB has %ld and COARRAY lower bound is %ld)",
5395 &coarray->where, d,
5396 mpz_get_si (sub_cons->expr->value.integer),
5397 mpz_get_si (ca_bound->value.integer));
5398 gfc_free_expr (ca_bound);
5399 return &gfc_bad_expr;
5400 }
5401
5402 gfc_free_expr (ca_bound);
5403
5404 /* Check whether upperbound is valid for the multi-images case. */
5405 if (d < as->corank)
5406 {
5407 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
5408 NULL, true);
5409 if (ca_bound == &gfc_bad_expr)
5410 return ca_bound;
5411
5412 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
5413 && mpz_cmp (ca_bound->value.integer,
5414 sub_cons->expr->value.integer) < 0)
5415 {
5416 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5417 "SUB has %ld and COARRAY upper bound is %ld)",
5418 &coarray->where, d,
5419 mpz_get_si (sub_cons->expr->value.integer),
5420 mpz_get_si (ca_bound->value.integer));
5421 gfc_free_expr (ca_bound);
5422 return &gfc_bad_expr;
5423 }
5424
5425 if (ca_bound)
5426 gfc_free_expr (ca_bound);
5427 }
5428
5429 sub_cons = gfc_constructor_next (sub_cons);
5430 }
5431
5432 if (sub_cons != NULL)
5433 {
5434 gfc_error ("Too many elements in expression for SUB= argument at %L",
5435 &sub->where);
5436 return &gfc_bad_expr;
5437 }
5438
5439 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5440 &gfc_current_locus);
5441 if (first_image)
5442 mpz_set_si (result->value.integer, 1);
5443 else
5444 mpz_set_si (result->value.integer, 0);
5445
5446 return result;
5447
5448 not_implemented:
5449 gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
5450 "cobounds at %L", &coarray->where);
5451 return &gfc_bad_expr;
5452 }
5453
5454
5455 gfc_expr *
5456 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
5457 {
5458 gfc_ref *ref;
5459 gfc_array_spec *as;
5460 int d;
5461
5462 if (coarray == NULL)
5463 {
5464 gfc_expr *result;
5465 /* FIXME: gfc_current_locus is wrong. */
5466 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5467 &gfc_current_locus);
5468 mpz_set_si (result->value.integer, 1);
5469 return result;
5470 }
5471
5472 gcc_assert (coarray->expr_type == EXPR_VARIABLE);
5473
5474 /* Follow any component references. */
5475 as = coarray->symtree->n.sym->as;
5476 for (ref = coarray->ref; ref; ref = ref->next)
5477 if (ref->type == REF_COMPONENT)
5478 as = ref->u.ar.as;
5479
5480 if (as->type == AS_DEFERRED)
5481 goto not_implemented; /* return NULL;*/
5482
5483 if (dim == NULL)
5484 {
5485 /* Multi-dimensional bounds. */
5486 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
5487 gfc_expr *e;
5488
5489 /* Simplify the bounds for each dimension. */
5490 for (d = 0; d < as->corank; d++)
5491 {
5492 bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
5493 as, NULL, true);
5494 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
5495 {
5496 int j;
5497
5498 for (j = 0; j < d; j++)
5499 gfc_free_expr (bounds[j]);
5500 if (bounds[d] == NULL)
5501 goto not_implemented;
5502 return bounds[d];
5503 }
5504 }
5505
5506 /* Allocate the result expression. */
5507 e = gfc_get_expr ();
5508 e->where = coarray->where;
5509 e->expr_type = EXPR_ARRAY;
5510 e->ts.type = BT_INTEGER;
5511 e->ts.kind = gfc_default_integer_kind;
5512
5513 e->rank = 1;
5514 e->shape = gfc_get_shape (1);
5515 mpz_init_set_ui (e->shape[0], as->corank);
5516
5517 /* Create the constructor for this array. */
5518 for (d = 0; d < as->corank; d++)
5519 gfc_constructor_append_expr (&e->value.constructor,
5520 bounds[d], &e->where);
5521
5522 return e;
5523 }
5524 else
5525 {
5526 gfc_expr *e;
5527 /* A DIM argument is specified. */
5528 if (dim->expr_type != EXPR_CONSTANT)
5529 goto not_implemented; /*return NULL;*/
5530
5531 d = mpz_get_si (dim->value.integer);
5532
5533 if (d < 1 || d > as->corank)
5534 {
5535 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
5536 return &gfc_bad_expr;
5537 }
5538
5539 /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
5540 e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
5541 if (e != NULL)
5542 return e;
5543 else
5544 goto not_implemented;
5545 }
5546
5547 not_implemented:
5548 gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
5549 "cobounds at %L", &coarray->where);
5550 return &gfc_bad_expr;
5551 }
5552
5553
5554 gfc_expr *
5555 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5556 {
5557 return simplify_bound (array, dim, kind, 1);
5558 }
5559
5560 gfc_expr *
5561 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5562 {
5563 gfc_expr *e;
5564 /* return simplify_cobound (array, dim, kind, 1);*/
5565
5566 e = simplify_cobound (array, dim, kind, 1);
5567 if (e != NULL)
5568 return e;
5569
5570 gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
5571 "cobounds at %L", &array->where);
5572 return &gfc_bad_expr;
5573 }
5574
5575
5576 gfc_expr *
5577 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5578 {
5579 gfc_expr *result, *e;
5580 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
5581
5582 if (!is_constant_array_expr (vector)
5583 || !is_constant_array_expr (mask)
5584 || (!gfc_is_constant_expr (field)
5585 && !is_constant_array_expr(field)))
5586 return NULL;
5587
5588 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
5589 &vector->where);
5590 result->rank = mask->rank;
5591 result->shape = gfc_copy_shape (mask->shape, mask->rank);
5592
5593 if (vector->ts.type == BT_CHARACTER)
5594 result->ts.u.cl = vector->ts.u.cl;
5595
5596 vector_ctor = gfc_constructor_first (vector->value.constructor);
5597 mask_ctor = gfc_constructor_first (mask->value.constructor);
5598 field_ctor
5599 = field->expr_type == EXPR_ARRAY
5600 ? gfc_constructor_first (field->value.constructor)
5601 : NULL;
5602
5603 while (mask_ctor)
5604 {
5605 if (mask_ctor->expr->value.logical)
5606 {
5607 gcc_assert (vector_ctor);
5608 e = gfc_copy_expr (vector_ctor->expr);
5609 vector_ctor = gfc_constructor_next (vector_ctor);
5610 }
5611 else if (field->expr_type == EXPR_ARRAY)
5612 e = gfc_copy_expr (field_ctor->expr);
5613 else
5614 e = gfc_copy_expr (field);
5615
5616 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5617
5618 mask_ctor = gfc_constructor_next (mask_ctor);
5619 field_ctor = gfc_constructor_next (field_ctor);
5620 }
5621
5622 return result;
5623 }
5624
5625
5626 gfc_expr *
5627 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
5628 {
5629 gfc_expr *result;
5630 int back;
5631 size_t index, len, lenset;
5632 size_t i;
5633 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
5634
5635 if (k == -1)
5636 return &gfc_bad_expr;
5637
5638 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
5639 return NULL;
5640
5641 if (b != NULL && b->value.logical != 0)
5642 back = 1;
5643 else
5644 back = 0;
5645
5646 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
5647
5648 len = s->value.character.length;
5649 lenset = set->value.character.length;
5650
5651 if (len == 0)
5652 {
5653 mpz_set_ui (result->value.integer, 0);
5654 return result;
5655 }
5656
5657 if (back == 0)
5658 {
5659 if (lenset == 0)
5660 {
5661 mpz_set_ui (result->value.integer, 1);
5662 return result;
5663 }
5664
5665 index = wide_strspn (s->value.character.string,
5666 set->value.character.string) + 1;
5667 if (index > len)
5668 index = 0;
5669
5670 }
5671 else
5672 {
5673 if (lenset == 0)
5674 {
5675 mpz_set_ui (result->value.integer, len);
5676 return result;
5677 }
5678 for (index = len; index > 0; index --)
5679 {
5680 for (i = 0; i < lenset; i++)
5681 {
5682 if (s->value.character.string[index - 1]
5683 == set->value.character.string[i])
5684 break;
5685 }
5686 if (i == lenset)
5687 break;
5688 }
5689 }
5690
5691 mpz_set_ui (result->value.integer, index);
5692 return result;
5693 }
5694
5695
5696 gfc_expr *
5697 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5698 {
5699 gfc_expr *result;
5700 int kind;
5701
5702 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5703 return NULL;
5704
5705 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
5706
5707 switch (x->ts.type)
5708 {
5709 case BT_INTEGER:
5710 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
5711 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
5712 return range_check (result, "XOR");
5713
5714 case BT_LOGICAL:
5715 return gfc_get_logical_expr (kind, &x->where,
5716 (x->value.logical && !y->value.logical)
5717 || (!x->value.logical && y->value.logical));
5718
5719 default:
5720 gcc_unreachable ();
5721 }
5722 }
5723
5724
5725 /****************** Constant simplification *****************/
5726
5727 /* Master function to convert one constant to another. While this is
5728 used as a simplification function, it requires the destination type
5729 and kind information which is supplied by a special case in
5730 do_simplify(). */
5731
5732 gfc_expr *
5733 gfc_convert_constant (gfc_expr *e, bt type, int kind)
5734 {
5735 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
5736 gfc_constructor *c;
5737
5738 switch (e->ts.type)
5739 {
5740 case BT_INTEGER:
5741 switch (type)
5742 {
5743 case BT_INTEGER:
5744 f = gfc_int2int;
5745 break;
5746 case BT_REAL:
5747 f = gfc_int2real;
5748 break;
5749 case BT_COMPLEX:
5750 f = gfc_int2complex;
5751 break;
5752 case BT_LOGICAL:
5753 f = gfc_int2log;
5754 break;
5755 default:
5756 goto oops;
5757 }
5758 break;
5759
5760 case BT_REAL:
5761 switch (type)
5762 {
5763 case BT_INTEGER:
5764 f = gfc_real2int;
5765 break;
5766 case BT_REAL:
5767 f = gfc_real2real;
5768 break;
5769 case BT_COMPLEX:
5770 f = gfc_real2complex;
5771 break;
5772 default:
5773 goto oops;
5774 }
5775 break;
5776
5777 case BT_COMPLEX:
5778 switch (type)
5779 {
5780 case BT_INTEGER:
5781 f = gfc_complex2int;
5782 break;
5783 case BT_REAL:
5784 f = gfc_complex2real;
5785 break;
5786 case BT_COMPLEX:
5787 f = gfc_complex2complex;
5788 break;
5789
5790 default:
5791 goto oops;
5792 }
5793 break;
5794
5795 case BT_LOGICAL:
5796 switch (type)
5797 {
5798 case BT_INTEGER:
5799 f = gfc_log2int;
5800 break;
5801 case BT_LOGICAL:
5802 f = gfc_log2log;
5803 break;
5804 default:
5805 goto oops;
5806 }
5807 break;
5808
5809 case BT_HOLLERITH:
5810 switch (type)
5811 {
5812 case BT_INTEGER:
5813 f = gfc_hollerith2int;
5814 break;
5815
5816 case BT_REAL:
5817 f = gfc_hollerith2real;
5818 break;
5819
5820 case BT_COMPLEX:
5821 f = gfc_hollerith2complex;
5822 break;
5823
5824 case BT_CHARACTER:
5825 f = gfc_hollerith2character;
5826 break;
5827
5828 case BT_LOGICAL:
5829 f = gfc_hollerith2logical;
5830 break;
5831
5832 default:
5833 goto oops;
5834 }
5835 break;
5836
5837 default:
5838 oops:
5839 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
5840 }
5841
5842 result = NULL;
5843
5844 switch (e->expr_type)
5845 {
5846 case EXPR_CONSTANT:
5847 result = f (e, kind);
5848 if (result == NULL)
5849 return &gfc_bad_expr;
5850 break;
5851
5852 case EXPR_ARRAY:
5853 if (!gfc_is_constant_expr (e))
5854 break;
5855
5856 result = gfc_get_array_expr (type, kind, &e->where);
5857 result->shape = gfc_copy_shape (e->shape, e->rank);
5858 result->rank = e->rank;
5859
5860 for (c = gfc_constructor_first (e->value.constructor);
5861 c; c = gfc_constructor_next (c))
5862 {
5863 gfc_expr *tmp;
5864 if (c->iterator == NULL)
5865 tmp = f (c->expr, kind);
5866 else
5867 {
5868 g = gfc_convert_constant (c->expr, type, kind);
5869 if (g == &gfc_bad_expr)
5870 {
5871 gfc_free_expr (result);
5872 return g;
5873 }
5874 tmp = g;
5875 }
5876
5877 if (tmp == NULL)
5878 {
5879 gfc_free_expr (result);
5880 return NULL;
5881 }
5882
5883 gfc_constructor_append_expr (&result->value.constructor,
5884 tmp, &c->where);
5885 }
5886
5887 break;
5888
5889 default:
5890 break;
5891 }
5892
5893 return result;
5894 }
5895
5896
5897 /* Function for converting character constants. */
5898 gfc_expr *
5899 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
5900 {
5901 gfc_expr *result;
5902 int i;
5903
5904 if (!gfc_is_constant_expr (e))
5905 return NULL;
5906
5907 if (e->expr_type == EXPR_CONSTANT)
5908 {
5909 /* Simple case of a scalar. */
5910 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
5911 if (result == NULL)
5912 return &gfc_bad_expr;
5913
5914 result->value.character.length = e->value.character.length;
5915 result->value.character.string
5916 = gfc_get_wide_string (e->value.character.length + 1);
5917 memcpy (result->value.character.string, e->value.character.string,
5918 (e->value.character.length + 1) * sizeof (gfc_char_t));
5919
5920 /* Check we only have values representable in the destination kind. */
5921 for (i = 0; i < result->value.character.length; i++)
5922 if (!gfc_check_character_range (result->value.character.string[i],
5923 kind))
5924 {
5925 gfc_error ("Character '%s' in string at %L cannot be converted "
5926 "into character kind %d",
5927 gfc_print_wide_char (result->value.character.string[i]),
5928 &e->where, kind);
5929 return &gfc_bad_expr;
5930 }
5931
5932 return result;
5933 }
5934 else if (e->expr_type == EXPR_ARRAY)
5935 {
5936 /* For an array constructor, we convert each constructor element. */
5937 gfc_constructor *c;
5938
5939 result = gfc_get_array_expr (type, kind, &e->where);
5940 result->shape = gfc_copy_shape (e->shape, e->rank);
5941 result->rank = e->rank;
5942 result->ts.u.cl = e->ts.u.cl;
5943
5944 for (c = gfc_constructor_first (e->value.constructor);
5945 c; c = gfc_constructor_next (c))
5946 {
5947 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
5948 if (tmp == &gfc_bad_expr)
5949 {
5950 gfc_free_expr (result);
5951 return &gfc_bad_expr;
5952 }
5953
5954 if (tmp == NULL)
5955 {
5956 gfc_free_expr (result);
5957 return NULL;
5958 }
5959
5960 gfc_constructor_append_expr (&result->value.constructor,
5961 tmp, &c->where);
5962 }
5963
5964 return result;
5965 }
5966 else
5967 return NULL;
5968 }
GCC graphite test results