?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* arm.c (FL_WBUF): Define.
[official-gcc.git] / gcc / fortran / simplify.c
blobadd391f195e9c3b18e16769ee40542e9ec4ec494
1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
3 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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA. */
22
23 #include "config.h"
24 #include "system.h"
25 #include "flags.h"
26 #include "gfortran.h"
27 #include "arith.h"
28 #include "intrinsic.h"
29
30 gfc_expr gfc_bad_expr;
31
32
33 /* Note that 'simplification' is not just transforming expressions.
34 For functions that are not simplified at compile time, range
35 checking is done if possible.
36
37 The return convention is that each simplification function returns:
38
39 A new expression node corresponding to the simplified arguments.
40 The original arguments are destroyed by the caller, and must not
41 be a part of the new expression.
42
43 NULL pointer indicating that no simplification was possible and
44 the original expression should remain intact. If the
45 simplification function sets the type and/or the function name
46 via the pointer gfc_simple_expression, then this type is
47 retained.
48
49 An expression pointer to gfc_bad_expr (a static placeholder)
50 indicating that some error has prevented simplification. For
51 example, sqrt(-1.0). The error is generated within the function
52 and should be propagated upwards
53
54 By the time a simplification function gets control, it has been
55 decided that the function call is really supposed to be the
56 intrinsic. No type checking is strictly necessary, since only
57 valid types will be passed on. On the other hand, a simplification
58 subroutine may have to look at the type of an argument as part of
59 its processing.
60
61 Array arguments are never passed to these subroutines.
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 /* Static table for converting non-ascii character sets to ascii.
68 The xascii_table[] is the inverse table. */
69
70 static int ascii_table[256] = {
71 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
72 '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
73 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
74 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
75 ' ', '!', '\'', '#', '$', '%', '&', '\'',
76 '(', ')', '*', '+', ',', '-', '.', '/',
77 '0', '1', '2', '3', '4', '5', '6', '7',
78 '8', '9', ':', ';', '<', '=', '>', '?',
79 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
80 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
81 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
82 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
83 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
84 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
85 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
86 'x', 'y', 'z', '{', '|', '}', '~', '\?'
87 };
88
89 static int xascii_table[256];
90
91
92 /* Range checks an expression node. If all goes well, returns the
93 node, otherwise returns &gfc_bad_expr and frees the node. */
94
95 static gfc_expr *
96 range_check (gfc_expr * result, const char *name)
97 {
98 if (gfc_range_check (result) == ARITH_OK)
99 return result;
100
101 gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
102 gfc_free_expr (result);
103 return &gfc_bad_expr;
104 }
105
106
107 /* A helper function that gets an optional and possibly missing
108 kind parameter. Returns the kind, -1 if something went wrong. */
109
110 static int
111 get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
112 {
113 int kind;
114
115 if (k == NULL)
116 return default_kind;
117
118 if (k->expr_type != EXPR_CONSTANT)
119 {
120 gfc_error ("KIND parameter of %s at %L must be an initialization "
121 "expression", name, &k->where);
122
123 return -1;
124 }
125
126 if (gfc_extract_int (k, &kind) != NULL
127 || gfc_validate_kind (type, kind, true) < 0)
128 {
129
130 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
131 return -1;
132 }
133
134 return kind;
135 }
136
137
138 /* Checks if X, which is assumed to represent a two's complement
139 integer of binary width BITSIZE, has the signbit set. If so, makes
140 X the corresponding negative number. */
141
142 static void
143 twos_complement (mpz_t x, int bitsize)
144 {
145 mpz_t mask;
146
147 if (mpz_tstbit (x, bitsize - 1) == 1)
148 {
149 mpz_init_set_ui(mask, 1);
150 mpz_mul_2exp(mask, mask, bitsize);
151 mpz_sub_ui(mask, mask, 1);
152
153 /* We negate the number by hand, zeroing the high bits, that is
154 make it the corresponding positive number, and then have it
155 negated by GMP, giving the correct representation of the
156 negative number. */
157 mpz_com (x, x);
158 mpz_add_ui (x, x, 1);
159 mpz_and (x, x, mask);
160
161 mpz_neg (x, x);
162
163 mpz_clear (mask);
164 }
165 }
166
167
168 /********************** Simplification functions *****************************/
169
170 gfc_expr *
171 gfc_simplify_abs (gfc_expr * e)
172 {
173 gfc_expr *result;
174
175 if (e->expr_type != EXPR_CONSTANT)
176 return NULL;
177
178 switch (e->ts.type)
179 {
180 case BT_INTEGER:
181 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
182
183 mpz_abs (result->value.integer, e->value.integer);
184
185 result = range_check (result, "IABS");
186 break;
187
188 case BT_REAL:
189 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
190
191 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
192
193 result = range_check (result, "ABS");
194 break;
195
196 case BT_COMPLEX:
197 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
198
199 gfc_set_model_kind (e->ts.kind);
200
201 mpfr_hypot (result->value.real, e->value.complex.r,
202 e->value.complex.i, GFC_RND_MODE);
203 result = range_check (result, "CABS");
204 break;
205
206 default:
207 gfc_internal_error ("gfc_simplify_abs(): Bad type");
208 }
209
210 return result;
211 }
212
213
214 gfc_expr *
215 gfc_simplify_achar (gfc_expr * e)
216 {
217 gfc_expr *result;
218 int index;
219
220 if (e->expr_type != EXPR_CONSTANT)
221 return NULL;
222
223 /* We cannot assume that the native character set is ASCII in this
224 function. */
225 if (gfc_extract_int (e, &index) != NULL || index < 0 || index > 127)
226 {
227 gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L "
228 "must be between 0 and 127", &e->where);
229 return &gfc_bad_expr;
230 }
231
232 result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
233 &e->where);
234
235 result->value.character.string = gfc_getmem (2);
236
237 result->value.character.length = 1;
238 result->value.character.string[0] = ascii_table[index];
239 result->value.character.string[1] = '\0'; /* For debugger */
240 return result;
241 }
242
243
244 gfc_expr *
245 gfc_simplify_acos (gfc_expr * x)
246 {
247 gfc_expr *result;
248
249 if (x->expr_type != EXPR_CONSTANT)
250 return NULL;
251
252 if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
253 {
254 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
255 &x->where);
256 return &gfc_bad_expr;
257 }
258
259 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
260
261 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
262
263 return range_check (result, "ACOS");
264 }
265
266
267 gfc_expr *
268 gfc_simplify_adjustl (gfc_expr * e)
269 {
270 gfc_expr *result;
271 int count, i, len;
272 char ch;
273
274 if (e->expr_type != EXPR_CONSTANT)
275 return NULL;
276
277 len = e->value.character.length;
278
279 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
280
281 result->value.character.length = len;
282 result->value.character.string = gfc_getmem (len + 1);
283
284 for (count = 0, i = 0; i < len; ++i)
285 {
286 ch = e->value.character.string[i];
287 if (ch != ' ')
288 break;
289 ++count;
290 }
291
292 for (i = 0; i < len - count; ++i)
293 {
294 result->value.character.string[i] =
295 e->value.character.string[count + i];
296 }
297
298 for (i = len - count; i < len; ++i)
299 {
300 result->value.character.string[i] = ' ';
301 }
302
303 result->value.character.string[len] = '\0'; /* For debugger */
304
305 return result;
306 }
307
308
309 gfc_expr *
310 gfc_simplify_adjustr (gfc_expr * e)
311 {
312 gfc_expr *result;
313 int count, i, len;
314 char ch;
315
316 if (e->expr_type != EXPR_CONSTANT)
317 return NULL;
318
319 len = e->value.character.length;
320
321 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
322
323 result->value.character.length = len;
324 result->value.character.string = gfc_getmem (len + 1);
325
326 for (count = 0, i = len - 1; i >= 0; --i)
327 {
328 ch = e->value.character.string[i];
329 if (ch != ' ')
330 break;
331 ++count;
332 }
333
334 for (i = 0; i < count; ++i)
335 {
336 result->value.character.string[i] = ' ';
337 }
338
339 for (i = count; i < len; ++i)
340 {
341 result->value.character.string[i] =
342 e->value.character.string[i - count];
343 }
344
345 result->value.character.string[len] = '\0'; /* For debugger */
346
347 return result;
348 }
349
350
351 gfc_expr *
352 gfc_simplify_aimag (gfc_expr * e)
353 {
354 gfc_expr *result;
355
356 if (e->expr_type != EXPR_CONSTANT)
357 return NULL;
358
359 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
360 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
361
362 return range_check (result, "AIMAG");
363 }
364
365
366 gfc_expr *
367 gfc_simplify_aint (gfc_expr * e, gfc_expr * k)
368 {
369 gfc_expr *rtrunc, *result;
370 int kind;
371
372 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
373 if (kind == -1)
374 return &gfc_bad_expr;
375
376 if (e->expr_type != EXPR_CONSTANT)
377 return NULL;
378
379 rtrunc = gfc_copy_expr (e);
380
381 mpfr_trunc (rtrunc->value.real, e->value.real);
382
383 result = gfc_real2real (rtrunc, kind);
384 gfc_free_expr (rtrunc);
385
386 return range_check (result, "AINT");
387 }
388
389
390 gfc_expr *
391 gfc_simplify_dint (gfc_expr * e)
392 {
393 gfc_expr *rtrunc, *result;
394
395 if (e->expr_type != EXPR_CONSTANT)
396 return NULL;
397
398 rtrunc = gfc_copy_expr (e);
399
400 mpfr_trunc (rtrunc->value.real, e->value.real);
401
402 result = gfc_real2real (rtrunc, gfc_default_double_kind);
403 gfc_free_expr (rtrunc);
404
405 return range_check (result, "DINT");
406 }
407
408
409 gfc_expr *
410 gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
411 {
412 gfc_expr *rtrunc, *result;
413 int kind, cmp;
414 mpfr_t half;
415
416 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
417 if (kind == -1)
418 return &gfc_bad_expr;
419
420 if (e->expr_type != EXPR_CONSTANT)
421 return NULL;
422
423 result = gfc_constant_result (e->ts.type, kind, &e->where);
424
425 rtrunc = gfc_copy_expr (e);
426
427 cmp = mpfr_cmp_ui (e->value.real, 0);
428
429 gfc_set_model_kind (kind);
430 mpfr_init (half);
431 mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
432
433 if (cmp > 0)
434 {
435 mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
436 mpfr_trunc (result->value.real, rtrunc->value.real);
437 }
438 else if (cmp < 0)
439 {
440 mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
441 mpfr_trunc (result->value.real, rtrunc->value.real);
442 }
443 else
444 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
445
446 gfc_free_expr (rtrunc);
447 mpfr_clear (half);
448
449 return range_check (result, "ANINT");
450 }
451
452
453 gfc_expr *
454 gfc_simplify_dnint (gfc_expr * e)
455 {
456 gfc_expr *rtrunc, *result;
457 int cmp;
458 mpfr_t half;
459
460 if (e->expr_type != EXPR_CONSTANT)
461 return NULL;
462
463 result =
464 gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
465
466 rtrunc = gfc_copy_expr (e);
467
468 cmp = mpfr_cmp_ui (e->value.real, 0);
469
470 gfc_set_model_kind (gfc_default_double_kind);
471 mpfr_init (half);
472 mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
473
474 if (cmp > 0)
475 {
476 mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
477 mpfr_trunc (result->value.real, rtrunc->value.real);
478 }
479 else if (cmp < 0)
480 {
481 mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
482 mpfr_trunc (result->value.real, rtrunc->value.real);
483 }
484 else
485 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
486
487 gfc_free_expr (rtrunc);
488 mpfr_clear (half);
489
490 return range_check (result, "DNINT");
491 }
492
493
494 gfc_expr *
495 gfc_simplify_asin (gfc_expr * x)
496 {
497 gfc_expr *result;
498
499 if (x->expr_type != EXPR_CONSTANT)
500 return NULL;
501
502 if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
503 {
504 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
505 &x->where);
506 return &gfc_bad_expr;
507 }
508
509 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
510
511 mpfr_asin(result->value.real, x->value.real, GFC_RND_MODE);
512
513 return range_check (result, "ASIN");
514 }
515
516
517 gfc_expr *
518 gfc_simplify_atan (gfc_expr * x)
519 {
520 gfc_expr *result;
521
522 if (x->expr_type != EXPR_CONSTANT)
523 return NULL;
524
525 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
526
527 mpfr_atan(result->value.real, x->value.real, GFC_RND_MODE);
528
529 return range_check (result, "ATAN");
530
531 }
532
533
534 gfc_expr *
535 gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
536 {
537 gfc_expr *result;
538
539 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
540 return NULL;
541
542 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
543
544 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
545 {
546 gfc_error
547 ("If first argument of ATAN2 %L is zero, then the second argument "
548 "must not be zero", &x->where);
549 gfc_free_expr (result);
550 return &gfc_bad_expr;
551 }
552
553 arctangent2 (y->value.real, x->value.real, result->value.real);
554
555 return range_check (result, "ATAN2");
556
557 }
558
559
560 gfc_expr *
561 gfc_simplify_bit_size (gfc_expr * e)
562 {
563 gfc_expr *result;
564 int i;
565
566 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
567 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
568 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
569
570 return result;
571 }
572
573
574 gfc_expr *
575 gfc_simplify_btest (gfc_expr * e, gfc_expr * bit)
576 {
577 int b;
578
579 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
580 return NULL;
581
582 if (gfc_extract_int (bit, &b) != NULL || b < 0)
583 return gfc_logical_expr (0, &e->where);
584
585 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
586 }
587
588
589 gfc_expr *
590 gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
591 {
592 gfc_expr *ceil, *result;
593 int kind;
594
595 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
596 if (kind == -1)
597 return &gfc_bad_expr;
598
599 if (e->expr_type != EXPR_CONSTANT)
600 return NULL;
601
602 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
603
604 ceil = gfc_copy_expr (e);
605
606 mpfr_ceil (ceil->value.real, e->value.real);
607 gfc_mpfr_to_mpz(result->value.integer, ceil->value.real);
608
609 gfc_free_expr (ceil);
610
611 return range_check (result, "CEILING");
612 }
613
614
615 gfc_expr *
616 gfc_simplify_char (gfc_expr * e, gfc_expr * k)
617 {
618 gfc_expr *result;
619 int c, kind;
620
621 kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
622 if (kind == -1)
623 return &gfc_bad_expr;
624
625 if (e->expr_type != EXPR_CONSTANT)
626 return NULL;
627
628 if (gfc_extract_int (e, &c) != NULL || c < 0 || c > 255)
629 {
630 gfc_error ("Bad character in CHAR function at %L", &e->where);
631 return &gfc_bad_expr;
632 }
633
634 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
635
636 result->value.character.length = 1;
637 result->value.character.string = gfc_getmem (2);
638
639 result->value.character.string[0] = c;
640 result->value.character.string[1] = '\0'; /* For debugger */
641
642 return result;
643 }
644
645
646 /* Common subroutine for simplifying CMPLX and DCMPLX. */
647
648 static gfc_expr *
649 simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind)
650 {
651 gfc_expr *result;
652
653 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
654
655 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
656
657 switch (x->ts.type)
658 {
659 case BT_INTEGER:
660 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
661 break;
662
663 case BT_REAL:
664 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
665 break;
666
667 case BT_COMPLEX:
668 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
669 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
670 break;
671
672 default:
673 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
674 }
675
676 if (y != NULL)
677 {
678 switch (y->ts.type)
679 {
680 case BT_INTEGER:
681 mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
682 break;
683
684 case BT_REAL:
685 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
686 break;
687
688 default:
689 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
690 }
691 }
692
693 return range_check (result, name);
694 }
695
696
697 gfc_expr *
698 gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
699 {
700 int kind;
701
702 if (x->expr_type != EXPR_CONSTANT
703 || (y != NULL && y->expr_type != EXPR_CONSTANT))
704 return NULL;
705
706 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
707 if (kind == -1)
708 return &gfc_bad_expr;
709
710 return simplify_cmplx ("CMPLX", x, y, kind);
711 }
712
713
714 gfc_expr *
715 gfc_simplify_conjg (gfc_expr * e)
716 {
717 gfc_expr *result;
718
719 if (e->expr_type != EXPR_CONSTANT)
720 return NULL;
721
722 result = gfc_copy_expr (e);
723 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
724
725 return range_check (result, "CONJG");
726 }
727
728
729 gfc_expr *
730 gfc_simplify_cos (gfc_expr * x)
731 {
732 gfc_expr *result;
733 mpfr_t xp, xq;
734
735 if (x->expr_type != EXPR_CONSTANT)
736 return NULL;
737
738 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
739
740 switch (x->ts.type)
741 {
742 case BT_REAL:
743 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
744 break;
745 case BT_COMPLEX:
746 gfc_set_model_kind (x->ts.kind);
747 mpfr_init (xp);
748 mpfr_init (xq);
749
750 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
751 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
752 mpfr_mul(result->value.complex.r, xp, xq, GFC_RND_MODE);
753
754 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
755 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
756 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
757 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
758
759 mpfr_clear (xp);
760 mpfr_clear (xq);
761 break;
762 default:
763 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
764 }
765
766 return range_check (result, "COS");
767
768 }
769
770
771 gfc_expr *
772 gfc_simplify_cosh (gfc_expr * x)
773 {
774 gfc_expr *result;
775
776 if (x->expr_type != EXPR_CONSTANT)
777 return NULL;
778
779 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
780
781 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
782
783 return range_check (result, "COSH");
784 }
785
786
787 gfc_expr *
788 gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y)
789 {
790
791 if (x->expr_type != EXPR_CONSTANT
792 || (y != NULL && y->expr_type != EXPR_CONSTANT))
793 return NULL;
794
795 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
796 }
797
798
799 gfc_expr *
800 gfc_simplify_dble (gfc_expr * e)
801 {
802 gfc_expr *result;
803
804 if (e->expr_type != EXPR_CONSTANT)
805 return NULL;
806
807 switch (e->ts.type)
808 {
809 case BT_INTEGER:
810 result = gfc_int2real (e, gfc_default_double_kind);
811 break;
812
813 case BT_REAL:
814 result = gfc_real2real (e, gfc_default_double_kind);
815 break;
816
817 case BT_COMPLEX:
818 result = gfc_complex2real (e, gfc_default_double_kind);
819 break;
820
821 default:
822 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
823 }
824
825 return range_check (result, "DBLE");
826 }
827
828
829 gfc_expr *
830 gfc_simplify_digits (gfc_expr * x)
831 {
832 int i, digits;
833
834 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
835 switch (x->ts.type)
836 {
837 case BT_INTEGER:
838 digits = gfc_integer_kinds[i].digits;
839 break;
840
841 case BT_REAL:
842 case BT_COMPLEX:
843 digits = gfc_real_kinds[i].digits;
844 break;
845
846 default:
847 gcc_unreachable ();
848 }
849
850 return gfc_int_expr (digits);
851 }
852
853
854 gfc_expr *
855 gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
856 {
857 gfc_expr *result;
858
859 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
860 return NULL;
861
862 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
863
864 switch (x->ts.type)
865 {
866 case BT_INTEGER:
867 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
868 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
869 else
870 mpz_set_ui (result->value.integer, 0);
871
872 break;
873
874 case BT_REAL:
875 if (mpfr_cmp (x->value.real, y->value.real) > 0)
876 mpfr_sub (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
877 else
878 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
879
880 break;
881
882 default:
883 gfc_internal_error ("gfc_simplify_dim(): Bad type");
884 }
885
886 return range_check (result, "DIM");
887 }
888
889
890 gfc_expr *
891 gfc_simplify_dprod (gfc_expr * x, gfc_expr * y)
892 {
893 gfc_expr *a1, *a2, *result;
894
895 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
896 return NULL;
897
898 result =
899 gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
900
901 a1 = gfc_real2real (x, gfc_default_double_kind);
902 a2 = gfc_real2real (y, gfc_default_double_kind);
903
904 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
905
906 gfc_free_expr (a1);
907 gfc_free_expr (a2);
908
909 return range_check (result, "DPROD");
910 }
911
912
913 gfc_expr *
914 gfc_simplify_epsilon (gfc_expr * e)
915 {
916 gfc_expr *result;
917 int i;
918
919 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
920
921 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
922
923 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
924
925 return range_check (result, "EPSILON");
926 }
927
928
929 gfc_expr *
930 gfc_simplify_exp (gfc_expr * x)
931 {
932 gfc_expr *result;
933 mpfr_t xp, xq;
934
935 if (x->expr_type != EXPR_CONSTANT)
936 return NULL;
937
938 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
939
940 switch (x->ts.type)
941 {
942 case BT_REAL:
943 mpfr_exp(result->value.real, x->value.real, GFC_RND_MODE);
944 break;
945
946 case BT_COMPLEX:
947 gfc_set_model_kind (x->ts.kind);
948 mpfr_init (xp);
949 mpfr_init (xq);
950 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
951 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
952 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
953 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
954 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
955 mpfr_clear (xp);
956 mpfr_clear (xq);
957 break;
958
959 default:
960 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
961 }
962
963 return range_check (result, "EXP");
964 }
965
966 /* FIXME: MPFR should be able to do this better */
967 gfc_expr *
968 gfc_simplify_exponent (gfc_expr * x)
969 {
970 int i;
971 mpfr_t tmp;
972 gfc_expr *result;
973
974 if (x->expr_type != EXPR_CONSTANT)
975 return NULL;
976
977 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
978 &x->where);
979
980 gfc_set_model (x->value.real);
981
982 if (mpfr_sgn (x->value.real) == 0)
983 {
984 mpz_set_ui (result->value.integer, 0);
985 return result;
986 }
987
988 mpfr_init (tmp);
989
990 mpfr_abs (tmp, x->value.real, GFC_RND_MODE);
991 mpfr_log2 (tmp, tmp, GFC_RND_MODE);
992
993 gfc_mpfr_to_mpz (result->value.integer, tmp);
994
995 /* The model number for tiny(x) is b**(emin - 1) where b is the base and emin
996 is the smallest exponent value. So, we need to add 1 if x is tiny(x). */
997 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
998 if (mpfr_cmp (x->value.real, gfc_real_kinds[i].tiny) == 0)
999 mpz_add_ui (result->value.integer,result->value.integer, 1);
1000
1001 mpfr_clear (tmp);
1002
1003 return range_check (result, "EXPONENT");
1004 }
1005
1006
1007 gfc_expr *
1008 gfc_simplify_float (gfc_expr * a)
1009 {
1010 gfc_expr *result;
1011
1012 if (a->expr_type != EXPR_CONSTANT)
1013 return NULL;
1014
1015 result = gfc_int2real (a, gfc_default_real_kind);
1016 return range_check (result, "FLOAT");
1017 }
1018
1019
1020 gfc_expr *
1021 gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
1022 {
1023 gfc_expr *result;
1024 mpfr_t floor;
1025 int kind;
1026
1027 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1028 if (kind == -1)
1029 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1030
1031 if (e->expr_type != EXPR_CONSTANT)
1032 return NULL;
1033
1034 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1035
1036 gfc_set_model_kind (kind);
1037 mpfr_init (floor);
1038 mpfr_floor (floor, e->value.real);
1039
1040 gfc_mpfr_to_mpz (result->value.integer, floor);
1041
1042 mpfr_clear (floor);
1043
1044 return range_check (result, "FLOOR");
1045 }
1046
1047
1048 gfc_expr *
1049 gfc_simplify_fraction (gfc_expr * x)
1050 {
1051 gfc_expr *result;
1052 mpfr_t absv, exp, pow2;
1053
1054 if (x->expr_type != EXPR_CONSTANT)
1055 return NULL;
1056
1057 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1058
1059 gfc_set_model_kind (x->ts.kind);
1060
1061 if (mpfr_sgn (x->value.real) == 0)
1062 {
1063 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1064 return result;
1065 }
1066
1067 mpfr_init (exp);
1068 mpfr_init (absv);
1069 mpfr_init (pow2);
1070
1071 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1072 mpfr_log2 (exp, absv, GFC_RND_MODE);
1073
1074 mpfr_trunc (exp, exp);
1075 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1076
1077 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1078
1079 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1080
1081 mpfr_clear (exp);
1082 mpfr_clear (absv);
1083 mpfr_clear (pow2);
1084
1085 return range_check (result, "FRACTION");
1086 }
1087
1088
1089 gfc_expr *
1090 gfc_simplify_huge (gfc_expr * e)
1091 {
1092 gfc_expr *result;
1093 int i;
1094
1095 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1096
1097 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1098
1099 switch (e->ts.type)
1100 {
1101 case BT_INTEGER:
1102 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1103 break;
1104
1105 case BT_REAL:
1106 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1107 break;
1108
1109 default:
1110 gcc_unreachable ();
1111 }
1112
1113 return result;
1114 }
1115
1116
1117 gfc_expr *
1118 gfc_simplify_iachar (gfc_expr * e)
1119 {
1120 gfc_expr *result;
1121 int index;
1122
1123 if (e->expr_type != EXPR_CONSTANT)
1124 return NULL;
1125
1126 if (e->value.character.length != 1)
1127 {
1128 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1129 return &gfc_bad_expr;
1130 }
1131
1132 index = xascii_table[(int) e->value.character.string[0] & 0xFF];
1133
1134 result = gfc_int_expr (index);
1135 result->where = e->where;
1136
1137 return range_check (result, "IACHAR");
1138 }
1139
1140
1141 gfc_expr *
1142 gfc_simplify_iand (gfc_expr * x, gfc_expr * y)
1143 {
1144 gfc_expr *result;
1145
1146 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1147 return NULL;
1148
1149 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1150
1151 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1152
1153 return range_check (result, "IAND");
1154 }
1155
1156
1157 gfc_expr *
1158 gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
1159 {
1160 gfc_expr *result;
1161 int k, pos;
1162
1163 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1164 return NULL;
1165
1166 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1167 {
1168 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1169 return &gfc_bad_expr;
1170 }
1171
1172 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1173
1174 if (pos > gfc_integer_kinds[k].bit_size)
1175 {
1176 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1177 &y->where);
1178 return &gfc_bad_expr;
1179 }
1180
1181 result = gfc_copy_expr (x);
1182
1183 mpz_clrbit (result->value.integer, pos);
1184 return range_check (result, "IBCLR");
1185 }
1186
1187
1188 gfc_expr *
1189 gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1190 {
1191 gfc_expr *result;
1192 int pos, len;
1193 int i, k, bitsize;
1194 int *bits;
1195
1196 if (x->expr_type != EXPR_CONSTANT
1197 || y->expr_type != EXPR_CONSTANT
1198 || z->expr_type != EXPR_CONSTANT)
1199 return NULL;
1200
1201 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1202 {
1203 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1204 return &gfc_bad_expr;
1205 }
1206
1207 if (gfc_extract_int (z, &len) != NULL || len < 0)
1208 {
1209 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1210 return &gfc_bad_expr;
1211 }
1212
1213 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1214
1215 bitsize = gfc_integer_kinds[k].bit_size;
1216
1217 if (pos + len > bitsize)
1218 {
1219 gfc_error
1220 ("Sum of second and third arguments of IBITS exceeds bit size "
1221 "at %L", &y->where);
1222 return &gfc_bad_expr;
1223 }
1224
1225 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1226
1227 bits = gfc_getmem (bitsize * sizeof (int));
1228
1229 for (i = 0; i < bitsize; i++)
1230 bits[i] = 0;
1231
1232 for (i = 0; i < len; i++)
1233 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1234
1235 for (i = 0; i < bitsize; i++)
1236 {
1237 if (bits[i] == 0)
1238 {
1239 mpz_clrbit (result->value.integer, i);
1240 }
1241 else if (bits[i] == 1)
1242 {
1243 mpz_setbit (result->value.integer, i);
1244 }
1245 else
1246 {
1247 gfc_internal_error ("IBITS: Bad bit");
1248 }
1249 }
1250
1251 gfc_free (bits);
1252
1253 return range_check (result, "IBITS");
1254 }
1255
1256
1257 gfc_expr *
1258 gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
1259 {
1260 gfc_expr *result;
1261 int k, pos;
1262
1263 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1264 return NULL;
1265
1266 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1267 {
1268 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1269 return &gfc_bad_expr;
1270 }
1271
1272 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1273
1274 if (pos > gfc_integer_kinds[k].bit_size)
1275 {
1276 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1277 &y->where);
1278 return &gfc_bad_expr;
1279 }
1280
1281 result = gfc_copy_expr (x);
1282
1283 mpz_setbit (result->value.integer, pos);
1284 return range_check (result, "IBSET");
1285 }
1286
1287
1288 gfc_expr *
1289 gfc_simplify_ichar (gfc_expr * e)
1290 {
1291 gfc_expr *result;
1292 int index;
1293
1294 if (e->expr_type != EXPR_CONSTANT)
1295 return NULL;
1296
1297 if (e->value.character.length != 1)
1298 {
1299 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1300 return &gfc_bad_expr;
1301 }
1302
1303 index = (int) e->value.character.string[0];
1304
1305 if (index < CHAR_MIN || index > CHAR_MAX)
1306 {
1307 gfc_error ("Argument of ICHAR at %L out of range of this processor",
1308 &e->where);
1309 return &gfc_bad_expr;
1310 }
1311
1312 result = gfc_int_expr (index);
1313 result->where = e->where;
1314 return range_check (result, "ICHAR");
1315 }
1316
1317
1318 gfc_expr *
1319 gfc_simplify_ieor (gfc_expr * x, gfc_expr * y)
1320 {
1321 gfc_expr *result;
1322
1323 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1324 return NULL;
1325
1326 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1327
1328 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1329
1330 return range_check (result, "IEOR");
1331 }
1332
1333
1334 gfc_expr *
1335 gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
1336 {
1337 gfc_expr *result;
1338 int back, len, lensub;
1339 int i, j, k, count, index = 0, start;
1340
1341 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1342 return NULL;
1343
1344 if (b != NULL && b->value.logical != 0)
1345 back = 1;
1346 else
1347 back = 0;
1348
1349 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1350 &x->where);
1351
1352 len = x->value.character.length;
1353 lensub = y->value.character.length;
1354
1355 if (len < lensub)
1356 {
1357 mpz_set_si (result->value.integer, 0);
1358 return result;
1359 }
1360
1361 if (back == 0)
1362 {
1363
1364 if (lensub == 0)
1365 {
1366 mpz_set_si (result->value.integer, 1);
1367 return result;
1368 }
1369 else if (lensub == 1)
1370 {
1371 for (i = 0; i < len; i++)
1372 {
1373 for (j = 0; j < lensub; j++)
1374 {
1375 if (y->value.character.string[j] ==
1376 x->value.character.string[i])
1377 {
1378 index = i + 1;
1379 goto done;
1380 }
1381 }
1382 }
1383 }
1384 else
1385 {
1386 for (i = 0; i < len; i++)
1387 {
1388 for (j = 0; j < lensub; j++)
1389 {
1390 if (y->value.character.string[j] ==
1391 x->value.character.string[i])
1392 {
1393 start = i;
1394 count = 0;
1395
1396 for (k = 0; k < lensub; k++)
1397 {
1398 if (y->value.character.string[k] ==
1399 x->value.character.string[k + start])
1400 count++;
1401 }
1402
1403 if (count == lensub)
1404 {
1405 index = start + 1;
1406 goto done;
1407 }
1408 }
1409 }
1410 }
1411 }
1412
1413 }
1414 else
1415 {
1416
1417 if (lensub == 0)
1418 {
1419 mpz_set_si (result->value.integer, len + 1);
1420 return result;
1421 }
1422 else if (lensub == 1)
1423 {
1424 for (i = 0; i < len; i++)
1425 {
1426 for (j = 0; j < lensub; j++)
1427 {
1428 if (y->value.character.string[j] ==
1429 x->value.character.string[len - i])
1430 {
1431 index = len - i + 1;
1432 goto done;
1433 }
1434 }
1435 }
1436 }
1437 else
1438 {
1439 for (i = 0; i < len; i++)
1440 {
1441 for (j = 0; j < lensub; j++)
1442 {
1443 if (y->value.character.string[j] ==
1444 x->value.character.string[len - i])
1445 {
1446 start = len - i;
1447 if (start <= len - lensub)
1448 {
1449 count = 0;
1450 for (k = 0; k < lensub; k++)
1451 if (y->value.character.string[k] ==
1452 x->value.character.string[k + start])
1453 count++;
1454
1455 if (count == lensub)
1456 {
1457 index = start + 1;
1458 goto done;
1459 }
1460 }
1461 else
1462 {
1463 continue;
1464 }
1465 }
1466 }
1467 }
1468 }
1469 }
1470
1471 done:
1472 mpz_set_si (result->value.integer, index);
1473 return range_check (result, "INDEX");
1474 }
1475
1476
1477 gfc_expr *
1478 gfc_simplify_int (gfc_expr * e, gfc_expr * k)
1479 {
1480 gfc_expr *rpart, *rtrunc, *result;
1481 int kind;
1482
1483 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1484 if (kind == -1)
1485 return &gfc_bad_expr;
1486
1487 if (e->expr_type != EXPR_CONSTANT)
1488 return NULL;
1489
1490 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1491
1492 switch (e->ts.type)
1493 {
1494 case BT_INTEGER:
1495 mpz_set (result->value.integer, e->value.integer);
1496 break;
1497
1498 case BT_REAL:
1499 rtrunc = gfc_copy_expr (e);
1500 mpfr_trunc (rtrunc->value.real, e->value.real);
1501 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1502 gfc_free_expr (rtrunc);
1503 break;
1504
1505 case BT_COMPLEX:
1506 rpart = gfc_complex2real (e, kind);
1507 rtrunc = gfc_copy_expr (rpart);
1508 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1509 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1510 gfc_free_expr (rpart);
1511 gfc_free_expr (rtrunc);
1512 break;
1513
1514 default:
1515 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1516 gfc_free_expr (result);
1517 return &gfc_bad_expr;
1518 }
1519
1520 return range_check (result, "INT");
1521 }
1522
1523
1524 gfc_expr *
1525 gfc_simplify_ifix (gfc_expr * e)
1526 {
1527 gfc_expr *rtrunc, *result;
1528
1529 if (e->expr_type != EXPR_CONSTANT)
1530 return NULL;
1531
1532 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1533 &e->where);
1534
1535 rtrunc = gfc_copy_expr (e);
1536
1537 mpfr_trunc (rtrunc->value.real, e->value.real);
1538 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1539
1540 gfc_free_expr (rtrunc);
1541 return range_check (result, "IFIX");
1542 }
1543
1544
1545 gfc_expr *
1546 gfc_simplify_idint (gfc_expr * e)
1547 {
1548 gfc_expr *rtrunc, *result;
1549
1550 if (e->expr_type != EXPR_CONSTANT)
1551 return NULL;
1552
1553 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1554 &e->where);
1555
1556 rtrunc = gfc_copy_expr (e);
1557
1558 mpfr_trunc (rtrunc->value.real, e->value.real);
1559 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1560
1561 gfc_free_expr (rtrunc);
1562 return range_check (result, "IDINT");
1563 }
1564
1565
1566 gfc_expr *
1567 gfc_simplify_ior (gfc_expr * x, gfc_expr * y)
1568 {
1569 gfc_expr *result;
1570
1571 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1572 return NULL;
1573
1574 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1575
1576 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1577 return range_check (result, "IOR");
1578 }
1579
1580
1581 gfc_expr *
1582 gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
1583 {
1584 gfc_expr *result;
1585 int shift, ashift, isize, k, *bits, i;
1586
1587 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1588 return NULL;
1589
1590 if (gfc_extract_int (s, &shift) != NULL)
1591 {
1592 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1593 return &gfc_bad_expr;
1594 }
1595
1596 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1597
1598 isize = gfc_integer_kinds[k].bit_size;
1599
1600 if (shift >= 0)
1601 ashift = shift;
1602 else
1603 ashift = -shift;
1604
1605 if (ashift > isize)
1606 {
1607 gfc_error
1608 ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1609 &s->where);
1610 return &gfc_bad_expr;
1611 }
1612
1613 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1614
1615 if (shift == 0)
1616 {
1617 mpz_set (result->value.integer, e->value.integer);
1618 return range_check (result, "ISHFT");
1619 }
1620
1621 bits = gfc_getmem (isize * sizeof (int));
1622
1623 for (i = 0; i < isize; i++)
1624 bits[i] = mpz_tstbit (e->value.integer, i);
1625
1626 if (shift > 0)
1627 {
1628 for (i = 0; i < shift; i++)
1629 mpz_clrbit (result->value.integer, i);
1630
1631 for (i = 0; i < isize - shift; i++)
1632 {
1633 if (bits[i] == 0)
1634 mpz_clrbit (result->value.integer, i + shift);
1635 else
1636 mpz_setbit (result->value.integer, i + shift);
1637 }
1638 }
1639 else
1640 {
1641 for (i = isize - 1; i >= isize - ashift; i--)
1642 mpz_clrbit (result->value.integer, i);
1643
1644 for (i = isize - 1; i >= ashift; i--)
1645 {
1646 if (bits[i] == 0)
1647 mpz_clrbit (result->value.integer, i - ashift);
1648 else
1649 mpz_setbit (result->value.integer, i - ashift);
1650 }
1651 }
1652
1653 twos_complement (result->value.integer, isize);
1654
1655 gfc_free (bits);
1656 return result;
1657 }
1658
1659
1660 gfc_expr *
1661 gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
1662 {
1663 gfc_expr *result;
1664 int shift, ashift, isize, delta, k;
1665 int i, *bits;
1666
1667 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1668 return NULL;
1669
1670 if (gfc_extract_int (s, &shift) != NULL)
1671 {
1672 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1673 return &gfc_bad_expr;
1674 }
1675
1676 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1677
1678 if (sz != NULL)
1679 {
1680 if (gfc_extract_int (sz, &isize) != NULL || isize < 0)
1681 {
1682 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1683 return &gfc_bad_expr;
1684 }
1685 }
1686 else
1687 isize = gfc_integer_kinds[k].bit_size;
1688
1689 if (shift >= 0)
1690 ashift = shift;
1691 else
1692 ashift = -shift;
1693
1694 if (ashift > isize)
1695 {
1696 gfc_error
1697 ("Magnitude of second argument of ISHFTC exceeds third argument "
1698 "at %L", &s->where);
1699 return &gfc_bad_expr;
1700 }
1701
1702 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1703
1704 if (shift == 0)
1705 {
1706 mpz_set (result->value.integer, e->value.integer);
1707 return result;
1708 }
1709
1710 bits = gfc_getmem (isize * sizeof (int));
1711
1712 for (i = 0; i < isize; i++)
1713 bits[i] = mpz_tstbit (e->value.integer, i);
1714
1715 delta = isize - ashift;
1716
1717 if (shift > 0)
1718 {
1719 for (i = 0; i < delta; i++)
1720 {
1721 if (bits[i] == 0)
1722 mpz_clrbit (result->value.integer, i + shift);
1723 else
1724 mpz_setbit (result->value.integer, i + shift);
1725 }
1726
1727 for (i = delta; i < isize; i++)
1728 {
1729 if (bits[i] == 0)
1730 mpz_clrbit (result->value.integer, i - delta);
1731 else
1732 mpz_setbit (result->value.integer, i - delta);
1733 }
1734 }
1735 else
1736 {
1737 for (i = 0; i < ashift; i++)
1738 {
1739 if (bits[i] == 0)
1740 mpz_clrbit (result->value.integer, i + delta);
1741 else
1742 mpz_setbit (result->value.integer, i + delta);
1743 }
1744
1745 for (i = ashift; i < isize; i++)
1746 {
1747 if (bits[i] == 0)
1748 mpz_clrbit (result->value.integer, i + shift);
1749 else
1750 mpz_setbit (result->value.integer, i + shift);
1751 }
1752 }
1753
1754 twos_complement (result->value.integer, isize);
1755
1756 gfc_free (bits);
1757 return result;
1758 }
1759
1760
1761 gfc_expr *
1762 gfc_simplify_kind (gfc_expr * e)
1763 {
1764
1765 if (e->ts.type == BT_DERIVED)
1766 {
1767 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
1768 return &gfc_bad_expr;
1769 }
1770
1771 return gfc_int_expr (e->ts.kind);
1772 }
1773
1774
1775 static gfc_expr *
1776 simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
1777 {
1778 gfc_ref *ref;
1779 gfc_array_spec *as;
1780 gfc_expr *e;
1781 int d;
1782
1783 if (array->expr_type != EXPR_VARIABLE)
1784 return NULL;
1785
1786 if (dim == NULL)
1787 /* TODO: Simplify constant multi-dimensional bounds. */
1788 return NULL;
1789
1790 if (dim->expr_type != EXPR_CONSTANT)
1791 return NULL;
1792
1793 /* Follow any component references. */
1794 as = array->symtree->n.sym->as;
1795 for (ref = array->ref; ref; ref = ref->next)
1796 {
1797 switch (ref->type)
1798 {
1799 case REF_ARRAY:
1800 switch (ref->u.ar.type)
1801 {
1802 case AR_ELEMENT:
1803 as = NULL;
1804 continue;
1805
1806 case AR_FULL:
1807 /* We're done because 'as' has already been set in the
1808 previous iteration. */
1809 goto done;
1810
1811 case AR_SECTION:
1812 case AR_UNKNOWN:
1813 return NULL;
1814 }
1815
1816 gcc_unreachable ();
1817
1818 case REF_COMPONENT:
1819 as = ref->u.c.component->as;
1820 continue;
1821
1822 case REF_SUBSTRING:
1823 continue;
1824 }
1825 }
1826
1827 gcc_unreachable ();
1828
1829 done:
1830 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
1831 return NULL;
1832
1833 d = mpz_get_si (dim->value.integer);
1834
1835 if (d < 1 || d > as->rank
1836 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
1837 {
1838 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
1839 return &gfc_bad_expr;
1840 }
1841
1842 e = upper ? as->upper[d-1] : as->lower[d-1];
1843
1844 if (e->expr_type != EXPR_CONSTANT)
1845 return NULL;
1846
1847 return gfc_copy_expr (e);
1848 }
1849
1850
1851 gfc_expr *
1852 gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
1853 {
1854 return simplify_bound (array, dim, 0);
1855 }
1856
1857
1858 gfc_expr *
1859 gfc_simplify_len (gfc_expr * e)
1860 {
1861 gfc_expr *result;
1862
1863 if (e->expr_type != EXPR_CONSTANT)
1864 return NULL;
1865
1866 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1867 &e->where);
1868
1869 mpz_set_si (result->value.integer, e->value.character.length);
1870 return range_check (result, "LEN");
1871 }
1872
1873
1874 gfc_expr *
1875 gfc_simplify_len_trim (gfc_expr * e)
1876 {
1877 gfc_expr *result;
1878 int count, len, lentrim, i;
1879
1880 if (e->expr_type != EXPR_CONSTANT)
1881 return NULL;
1882
1883 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1884 &e->where);
1885
1886 len = e->value.character.length;
1887
1888 for (count = 0, i = 1; i <= len; i++)
1889 if (e->value.character.string[len - i] == ' ')
1890 count++;
1891 else
1892 break;
1893
1894 lentrim = len - count;
1895
1896 mpz_set_si (result->value.integer, lentrim);
1897 return range_check (result, "LEN_TRIM");
1898 }
1899
1900
1901 gfc_expr *
1902 gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
1903 {
1904
1905 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1906 return NULL;
1907
1908 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) >= 0,
1909 &a->where);
1910 }
1911
1912
1913 gfc_expr *
1914 gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
1915 {
1916
1917 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1918 return NULL;
1919
1920 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) > 0,
1921 &a->where);
1922 }
1923
1924
1925 gfc_expr *
1926 gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
1927 {
1928
1929 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1930 return NULL;
1931
1932 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) <= 0,
1933 &a->where);
1934 }
1935
1936
1937 gfc_expr *
1938 gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
1939 {
1940
1941 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1942 return NULL;
1943
1944 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) < 0,
1945 &a->where);
1946 }
1947
1948
1949 gfc_expr *
1950 gfc_simplify_log (gfc_expr * x)
1951 {
1952 gfc_expr *result;
1953 mpfr_t xr, xi;
1954
1955 if (x->expr_type != EXPR_CONSTANT)
1956 return NULL;
1957
1958 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1959
1960 gfc_set_model_kind (x->ts.kind);
1961
1962 switch (x->ts.type)
1963 {
1964 case BT_REAL:
1965 if (mpfr_sgn (x->value.real) <= 0)
1966 {
1967 gfc_error
1968 ("Argument of LOG at %L cannot be less than or equal to zero",
1969 &x->where);
1970 gfc_free_expr (result);
1971 return &gfc_bad_expr;
1972 }
1973
1974 mpfr_log(result->value.real, x->value.real, GFC_RND_MODE);
1975 break;
1976
1977 case BT_COMPLEX:
1978 if ((mpfr_sgn (x->value.complex.r) == 0)
1979 && (mpfr_sgn (x->value.complex.i) == 0))
1980 {
1981 gfc_error ("Complex argument of LOG at %L cannot be zero",
1982 &x->where);
1983 gfc_free_expr (result);
1984 return &gfc_bad_expr;
1985 }
1986
1987 mpfr_init (xr);
1988 mpfr_init (xi);
1989
1990 arctangent2 (x->value.complex.i, x->value.complex.r,
1991 result->value.complex.i);
1992
1993 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
1994 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
1995 mpfr_add (xr, xr, xi, GFC_RND_MODE);
1996 mpfr_sqrt (xr, xr, GFC_RND_MODE);
1997 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
1998
1999 mpfr_clear (xr);
2000 mpfr_clear (xi);
2001
2002 break;
2003
2004 default:
2005 gfc_internal_error ("gfc_simplify_log: bad type");
2006 }
2007
2008 return range_check (result, "LOG");
2009 }
2010
2011
2012 gfc_expr *
2013 gfc_simplify_log10 (gfc_expr * x)
2014 {
2015 gfc_expr *result;
2016
2017 if (x->expr_type != EXPR_CONSTANT)
2018 return NULL;
2019
2020 gfc_set_model_kind (x->ts.kind);
2021
2022 if (mpfr_sgn (x->value.real) <= 0)
2023 {
2024 gfc_error
2025 ("Argument of LOG10 at %L cannot be less than or equal to zero",
2026 &x->where);
2027 return &gfc_bad_expr;
2028 }
2029
2030 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2031
2032 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2033
2034 return range_check (result, "LOG10");
2035 }
2036
2037
2038 gfc_expr *
2039 gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
2040 {
2041 gfc_expr *result;
2042 int kind;
2043
2044 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2045 if (kind < 0)
2046 return &gfc_bad_expr;
2047
2048 if (e->expr_type != EXPR_CONSTANT)
2049 return NULL;
2050
2051 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2052
2053 result->value.logical = e->value.logical;
2054
2055 return result;
2056 }
2057
2058
2059 /* This function is special since MAX() can take any number of
2060 arguments. The simplified expression is a rewritten version of the
2061 argument list containing at most one constant element. Other
2062 constant elements are deleted. Because the argument list has
2063 already been checked, this function always succeeds. sign is 1 for
2064 MAX(), -1 for MIN(). */
2065
2066 static gfc_expr *
2067 simplify_min_max (gfc_expr * expr, int sign)
2068 {
2069 gfc_actual_arglist *arg, *last, *extremum;
2070 gfc_intrinsic_sym * specific;
2071
2072 last = NULL;
2073 extremum = NULL;
2074 specific = expr->value.function.isym;
2075
2076 arg = expr->value.function.actual;
2077
2078 for (; arg; last = arg, arg = arg->next)
2079 {
2080 if (arg->expr->expr_type != EXPR_CONSTANT)
2081 continue;
2082
2083 if (extremum == NULL)
2084 {
2085 extremum = arg;
2086 continue;
2087 }
2088
2089 switch (arg->expr->ts.type)
2090 {
2091 case BT_INTEGER:
2092 if (mpz_cmp (arg->expr->value.integer,
2093 extremum->expr->value.integer) * sign > 0)
2094 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2095
2096 break;
2097
2098 case BT_REAL:
2099 if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) *
2100 sign > 0)
2101 mpfr_set (extremum->expr->value.real, arg->expr->value.real,
2102 GFC_RND_MODE);
2103
2104 break;
2105
2106 default:
2107 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2108 }
2109
2110 /* Delete the extra constant argument. */
2111 if (last == NULL)
2112 expr->value.function.actual = arg->next;
2113 else
2114 last->next = arg->next;
2115
2116 arg->next = NULL;
2117 gfc_free_actual_arglist (arg);
2118 arg = last;
2119 }
2120
2121 /* If there is one value left, replace the function call with the
2122 expression. */
2123 if (expr->value.function.actual->next != NULL)
2124 return NULL;
2125
2126 /* Convert to the correct type and kind. */
2127 if (expr->ts.type != BT_UNKNOWN)
2128 return gfc_convert_constant (expr->value.function.actual->expr,
2129 expr->ts.type, expr->ts.kind);
2130
2131 if (specific->ts.type != BT_UNKNOWN)
2132 return gfc_convert_constant (expr->value.function.actual->expr,
2133 specific->ts.type, specific->ts.kind);
2134
2135 return gfc_copy_expr (expr->value.function.actual->expr);
2136 }
2137
2138
2139 gfc_expr *
2140 gfc_simplify_min (gfc_expr * e)
2141 {
2142 return simplify_min_max (e, -1);
2143 }
2144
2145
2146 gfc_expr *
2147 gfc_simplify_max (gfc_expr * e)
2148 {
2149 return simplify_min_max (e, 1);
2150 }
2151
2152
2153 gfc_expr *
2154 gfc_simplify_maxexponent (gfc_expr * x)
2155 {
2156 gfc_expr *result;
2157 int i;
2158
2159 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2160
2161 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2162 result->where = x->where;
2163
2164 return result;
2165 }
2166
2167
2168 gfc_expr *
2169 gfc_simplify_minexponent (gfc_expr * x)
2170 {
2171 gfc_expr *result;
2172 int i;
2173
2174 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2175
2176 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2177 result->where = x->where;
2178
2179 return result;
2180 }
2181
2182
2183 gfc_expr *
2184 gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
2185 {
2186 gfc_expr *result;
2187 mpfr_t quot, iquot, term;
2188
2189 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2190 return NULL;
2191
2192 result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
2193
2194 switch (a->ts.type)
2195 {
2196 case BT_INTEGER:
2197 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2198 {
2199 /* Result is processor-dependent. */
2200 gfc_error ("Second argument MOD at %L is zero", &a->where);
2201 gfc_free_expr (result);
2202 return &gfc_bad_expr;
2203 }
2204 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2205 break;
2206
2207 case BT_REAL:
2208 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2209 {
2210 /* Result is processor-dependent. */
2211 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2212 gfc_free_expr (result);
2213 return &gfc_bad_expr;
2214 }
2215
2216 gfc_set_model_kind (a->ts.kind);
2217 mpfr_init (quot);
2218 mpfr_init (iquot);
2219 mpfr_init (term);
2220
2221 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2222 mpfr_trunc (iquot, quot);
2223 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2224 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2225
2226 mpfr_clear (quot);
2227 mpfr_clear (iquot);
2228 mpfr_clear (term);
2229 break;
2230
2231 default:
2232 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2233 }
2234
2235 return range_check (result, "MOD");
2236 }
2237
2238
2239 gfc_expr *
2240 gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
2241 {
2242 gfc_expr *result;
2243 mpfr_t quot, iquot, term;
2244
2245 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2246 return NULL;
2247
2248 result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
2249
2250 switch (a->ts.type)
2251 {
2252 case BT_INTEGER:
2253 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2254 {
2255 /* Result is processor-dependent. This processor just opts
2256 to not handle it at all. */
2257 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2258 gfc_free_expr (result);
2259 return &gfc_bad_expr;
2260 }
2261 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2262
2263 break;
2264
2265 case BT_REAL:
2266 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2267 {
2268 /* Result is processor-dependent. */
2269 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2270 gfc_free_expr (result);
2271 return &gfc_bad_expr;
2272 }
2273
2274 gfc_set_model_kind (a->ts.kind);
2275 mpfr_init (quot);
2276 mpfr_init (iquot);
2277 mpfr_init (term);
2278
2279 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2280 mpfr_floor (iquot, quot);
2281 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2282
2283 mpfr_clear (quot);
2284 mpfr_clear (iquot);
2285 mpfr_clear (term);
2286
2287 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2288 break;
2289
2290 default:
2291 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2292 }
2293
2294 return range_check (result, "MODULO");
2295 }
2296
2297
2298 /* Exists for the sole purpose of consistency with other intrinsics. */
2299 gfc_expr *
2300 gfc_simplify_mvbits (gfc_expr * f ATTRIBUTE_UNUSED,
2301 gfc_expr * fp ATTRIBUTE_UNUSED,
2302 gfc_expr * l ATTRIBUTE_UNUSED,
2303 gfc_expr * to ATTRIBUTE_UNUSED,
2304 gfc_expr * tp ATTRIBUTE_UNUSED)
2305 {
2306 return NULL;
2307 }
2308
2309
2310 gfc_expr *
2311 gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
2312 {
2313 gfc_expr *result;
2314 float rval;
2315 double val, eps;
2316 int p, i, k, match_float;
2317
2318 /* FIXME: This implementation is dopey and probably not quite right,
2319 but it's a start. */
2320
2321 if (x->expr_type != EXPR_CONSTANT)
2322 return NULL;
2323
2324 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2325
2326 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2327
2328 val = mpfr_get_d (x->value.real, GFC_RND_MODE);
2329 p = gfc_real_kinds[k].digits;
2330
2331 eps = 1.;
2332 for (i = 1; i < p; ++i)
2333 {
2334 eps = eps / 2.;
2335 }
2336
2337 /* TODO we should make sure that 'float' matches kind 4 */
2338 match_float = gfc_real_kinds[k].kind == 4;
2339 if (mpfr_cmp_ui (s->value.real, 0) > 0)
2340 {
2341 if (match_float)
2342 {
2343 rval = (float) val;
2344 rval = rval + eps;
2345 mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
2346 }
2347 else
2348 {
2349 val = val + eps;
2350 mpfr_set_d (result->value.real, val, GFC_RND_MODE);
2351 }
2352 }
2353 else if (mpfr_cmp_ui (s->value.real, 0) < 0)
2354 {
2355 if (match_float)
2356 {
2357 rval = (float) val;
2358 rval = rval - eps;
2359 mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
2360 }
2361 else
2362 {
2363 val = val - eps;
2364 mpfr_set_d (result->value.real, val, GFC_RND_MODE);
2365 }
2366 }
2367 else
2368 {
2369 gfc_error ("Invalid second argument of NEAREST at %L", &s->where);
2370 gfc_free (result);
2371 return &gfc_bad_expr;
2372 }
2373
2374 return range_check (result, "NEAREST");
2375 }
2376
2377
2378 static gfc_expr *
2379 simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
2380 {
2381 gfc_expr *rtrunc, *itrunc, *result;
2382 int kind, cmp;
2383 mpfr_t half;
2384
2385 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2386 if (kind == -1)
2387 return &gfc_bad_expr;
2388
2389 if (e->expr_type != EXPR_CONSTANT)
2390 return NULL;
2391
2392 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2393
2394 rtrunc = gfc_copy_expr (e);
2395 itrunc = gfc_copy_expr (e);
2396
2397 cmp = mpfr_cmp_ui (e->value.real, 0);
2398
2399 gfc_set_model (e->value.real);
2400 mpfr_init (half);
2401 mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
2402
2403 if (cmp > 0)
2404 {
2405 mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
2406 mpfr_trunc (itrunc->value.real, rtrunc->value.real);
2407 }
2408 else if (cmp < 0)
2409 {
2410 mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
2411 mpfr_trunc (itrunc->value.real, rtrunc->value.real);
2412 }
2413 else
2414 mpfr_set_ui (itrunc->value.real, 0, GFC_RND_MODE);
2415
2416 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2417
2418 gfc_free_expr (itrunc);
2419 gfc_free_expr (rtrunc);
2420 mpfr_clear (half);
2421
2422 return range_check (result, name);
2423 }
2424
2425
2426 gfc_expr *
2427 gfc_simplify_nint (gfc_expr * e, gfc_expr * k)
2428 {
2429 return simplify_nint ("NINT", e, k);
2430 }
2431
2432
2433 gfc_expr *
2434 gfc_simplify_idnint (gfc_expr * e)
2435 {
2436 return simplify_nint ("IDNINT", e, NULL);
2437 }
2438
2439
2440 gfc_expr *
2441 gfc_simplify_not (gfc_expr * e)
2442 {
2443 gfc_expr *result;
2444 int i;
2445
2446 if (e->expr_type != EXPR_CONSTANT)
2447 return NULL;
2448
2449 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2450
2451 mpz_com (result->value.integer, e->value.integer);
2452
2453 /* Because of how GMP handles numbers, the result must be ANDed with
2454 the max_int mask. For radices <> 2, this will require change. */
2455
2456 i = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2457
2458 mpz_and (result->value.integer, result->value.integer,
2459 gfc_integer_kinds[i].max_int);
2460
2461 return range_check (result, "NOT");
2462 }
2463
2464
2465 gfc_expr *
2466 gfc_simplify_null (gfc_expr * mold)
2467 {
2468 gfc_expr *result;
2469
2470 result = gfc_get_expr ();
2471 result->expr_type = EXPR_NULL;
2472
2473 if (mold == NULL)
2474 result->ts.type = BT_UNKNOWN;
2475 else
2476 {
2477 result->ts = mold->ts;
2478 result->where = mold->where;
2479 }
2480
2481 return result;
2482 }
2483
2484
2485 gfc_expr *
2486 gfc_simplify_precision (gfc_expr * e)
2487 {
2488 gfc_expr *result;
2489 int i;
2490
2491 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2492
2493 result = gfc_int_expr (gfc_real_kinds[i].precision);
2494 result->where = e->where;
2495
2496 return result;
2497 }
2498
2499
2500 gfc_expr *
2501 gfc_simplify_radix (gfc_expr * e)
2502 {
2503 gfc_expr *result;
2504 int i;
2505
2506 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2507 switch (e->ts.type)
2508 {
2509 case BT_INTEGER:
2510 i = gfc_integer_kinds[i].radix;
2511 break;
2512
2513 case BT_REAL:
2514 i = gfc_real_kinds[i].radix;
2515 break;
2516
2517 default:
2518 gcc_unreachable ();
2519 }
2520
2521 result = gfc_int_expr (i);
2522 result->where = e->where;
2523
2524 return result;
2525 }
2526
2527
2528 gfc_expr *
2529 gfc_simplify_range (gfc_expr * e)
2530 {
2531 gfc_expr *result;
2532 int i;
2533 long j;
2534
2535 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2536
2537 switch (e->ts.type)
2538 {
2539 case BT_INTEGER:
2540 j = gfc_integer_kinds[i].range;
2541 break;
2542
2543 case BT_REAL:
2544 case BT_COMPLEX:
2545 j = gfc_real_kinds[i].range;
2546 break;
2547
2548 default:
2549 gcc_unreachable ();
2550 }
2551
2552 result = gfc_int_expr (j);
2553 result->where = e->where;
2554
2555 return result;
2556 }
2557
2558
2559 gfc_expr *
2560 gfc_simplify_real (gfc_expr * e, gfc_expr * k)
2561 {
2562 gfc_expr *result;
2563 int kind;
2564
2565 if (e->ts.type == BT_COMPLEX)
2566 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2567 else
2568 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2569
2570 if (kind == -1)
2571 return &gfc_bad_expr;
2572
2573 if (e->expr_type != EXPR_CONSTANT)
2574 return NULL;
2575
2576 switch (e->ts.type)
2577 {
2578 case BT_INTEGER:
2579 result = gfc_int2real (e, kind);
2580 break;
2581
2582 case BT_REAL:
2583 result = gfc_real2real (e, kind);
2584 break;
2585
2586 case BT_COMPLEX:
2587 result = gfc_complex2real (e, kind);
2588 break;
2589
2590 default:
2591 gfc_internal_error ("bad type in REAL");
2592 /* Not reached */
2593 }
2594
2595 return range_check (result, "REAL");
2596 }
2597
2598 gfc_expr *
2599 gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
2600 {
2601 gfc_expr *result;
2602 int i, j, len, ncopies, nlen;
2603
2604 if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT)
2605 return NULL;
2606
2607 if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0))
2608 {
2609 gfc_error ("Invalid second argument of REPEAT at %L", &n->where);
2610 return &gfc_bad_expr;
2611 }
2612
2613 len = e->value.character.length;
2614 nlen = ncopies * len;
2615
2616 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2617
2618 if (ncopies == 0)
2619 {
2620 result->value.character.string = gfc_getmem (1);
2621 result->value.character.length = 0;
2622 result->value.character.string[0] = '\0';
2623 return result;
2624 }
2625
2626 result->value.character.length = nlen;
2627 result->value.character.string = gfc_getmem (nlen + 1);
2628
2629 for (i = 0; i < ncopies; i++)
2630 for (j = 0; j < len; j++)
2631 result->value.character.string[j + i * len] =
2632 e->value.character.string[j];
2633
2634 result->value.character.string[nlen] = '\0'; /* For debugger */
2635 return result;
2636 }
2637
2638
2639 /* This one is a bear, but mainly has to do with shuffling elements. */
2640
2641 gfc_expr *
2642 gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
2643 gfc_expr * pad, gfc_expr * order_exp)
2644 {
2645
2646 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
2647 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
2648 gfc_constructor *head, *tail;
2649 mpz_t index, size;
2650 unsigned long j;
2651 size_t nsource;
2652 gfc_expr *e;
2653
2654 /* Unpack the shape array. */
2655 if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
2656 return NULL;
2657
2658 if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
2659 return NULL;
2660
2661 if (pad != NULL
2662 && (pad->expr_type != EXPR_ARRAY
2663 || !gfc_is_constant_expr (pad)))
2664 return NULL;
2665
2666 if (order_exp != NULL
2667 && (order_exp->expr_type != EXPR_ARRAY
2668 || !gfc_is_constant_expr (order_exp)))
2669 return NULL;
2670
2671 mpz_init (index);
2672 rank = 0;
2673 head = tail = NULL;
2674
2675 for (;;)
2676 {
2677 e = gfc_get_array_element (shape_exp, rank);
2678 if (e == NULL)
2679 break;
2680
2681 if (gfc_extract_int (e, &shape[rank]) != NULL)
2682 {
2683 gfc_error ("Integer too large in shape specification at %L",
2684 &e->where);
2685 gfc_free_expr (e);
2686 goto bad_reshape;
2687 }
2688
2689 gfc_free_expr (e);
2690
2691 if (rank >= GFC_MAX_DIMENSIONS)
2692 {
2693 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2694 "at %L", &e->where);
2695
2696 goto bad_reshape;
2697 }
2698
2699 if (shape[rank] < 0)
2700 {
2701 gfc_error ("Shape specification at %L cannot be negative",
2702 &e->where);
2703 goto bad_reshape;
2704 }
2705
2706 rank++;
2707 }
2708
2709 if (rank == 0)
2710 {
2711 gfc_error ("Shape specification at %L cannot be the null array",
2712 &shape_exp->where);
2713 goto bad_reshape;
2714 }
2715
2716 /* Now unpack the order array if present. */
2717 if (order_exp == NULL)
2718 {
2719 for (i = 0; i < rank; i++)
2720 order[i] = i;
2721
2722 }
2723 else
2724 {
2725
2726 for (i = 0; i < rank; i++)
2727 x[i] = 0;
2728
2729 for (i = 0; i < rank; i++)
2730 {
2731 e = gfc_get_array_element (order_exp, i);
2732 if (e == NULL)
2733 {
2734 gfc_error
2735 ("ORDER parameter of RESHAPE at %L is not the same size "
2736 "as SHAPE parameter", &order_exp->where);
2737 goto bad_reshape;
2738 }
2739
2740 if (gfc_extract_int (e, &order[i]) != NULL)
2741 {
2742 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2743 &e->where);
2744 gfc_free_expr (e);
2745 goto bad_reshape;
2746 }
2747
2748 gfc_free_expr (e);
2749
2750 if (order[i] < 1 || order[i] > rank)
2751 {
2752 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2753 &e->where);
2754 goto bad_reshape;
2755 }
2756
2757 order[i]--;
2758
2759 if (x[order[i]])
2760 {
2761 gfc_error ("Invalid permutation in ORDER parameter at %L",
2762 &e->where);
2763 goto bad_reshape;
2764 }
2765
2766 x[order[i]] = 1;
2767 }
2768 }
2769
2770 /* Count the elements in the source and padding arrays. */
2771
2772 npad = 0;
2773 if (pad != NULL)
2774 {
2775 gfc_array_size (pad, &size);
2776 npad = mpz_get_ui (size);
2777 mpz_clear (size);
2778 }
2779
2780 gfc_array_size (source, &size);
2781 nsource = mpz_get_ui (size);
2782 mpz_clear (size);
2783
2784 /* If it weren't for that pesky permutation we could just loop
2785 through the source and round out any shortage with pad elements.
2786 But no, someone just had to have the compiler do something the
2787 user should be doing. */
2788
2789 for (i = 0; i < rank; i++)
2790 x[i] = 0;
2791
2792 for (;;)
2793 {
2794 /* Figure out which element to extract. */
2795 mpz_set_ui (index, 0);
2796
2797 for (i = rank - 1; i >= 0; i--)
2798 {
2799 mpz_add_ui (index, index, x[order[i]]);
2800 if (i != 0)
2801 mpz_mul_ui (index, index, shape[order[i - 1]]);
2802 }
2803
2804 if (mpz_cmp_ui (index, INT_MAX) > 0)
2805 gfc_internal_error ("Reshaped array too large at %L", &e->where);
2806
2807 j = mpz_get_ui (index);
2808
2809 if (j < nsource)
2810 e = gfc_get_array_element (source, j);
2811 else
2812 {
2813 j = j - nsource;
2814
2815 if (npad == 0)
2816 {
2817 gfc_error
2818 ("PAD parameter required for short SOURCE parameter at %L",
2819 &source->where);
2820 goto bad_reshape;
2821 }
2822
2823 j = j % npad;
2824 e = gfc_get_array_element (pad, j);
2825 }
2826
2827 if (head == NULL)
2828 head = tail = gfc_get_constructor ();
2829 else
2830 {
2831 tail->next = gfc_get_constructor ();
2832 tail = tail->next;
2833 }
2834
2835 if (e == NULL)
2836 goto bad_reshape;
2837
2838 tail->where = e->where;
2839 tail->expr = e;
2840
2841 /* Calculate the next element. */
2842 i = 0;
2843
2844 inc:
2845 if (++x[i] < shape[i])
2846 continue;
2847 x[i++] = 0;
2848 if (i < rank)
2849 goto inc;
2850
2851 break;
2852 }
2853
2854 mpz_clear (index);
2855
2856 e = gfc_get_expr ();
2857 e->where = source->where;
2858 e->expr_type = EXPR_ARRAY;
2859 e->value.constructor = head;
2860 e->shape = gfc_get_shape (rank);
2861
2862 for (i = 0; i < rank; i++)
2863 mpz_init_set_ui (e->shape[i], shape[i]);
2864
2865 e->ts = head->expr->ts;
2866 e->rank = rank;
2867
2868 return e;
2869
2870 bad_reshape:
2871 gfc_free_constructor (head);
2872 mpz_clear (index);
2873 return &gfc_bad_expr;
2874 }
2875
2876
2877 gfc_expr *
2878 gfc_simplify_rrspacing (gfc_expr * x)
2879 {
2880 gfc_expr *result;
2881 mpfr_t absv, log2, exp, frac, pow2;
2882 int i, p;
2883
2884 if (x->expr_type != EXPR_CONSTANT)
2885 return NULL;
2886
2887 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2888
2889 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
2890
2891 p = gfc_real_kinds[i].digits;
2892
2893 gfc_set_model_kind (x->ts.kind);
2894
2895 if (mpfr_sgn (x->value.real) == 0)
2896 {
2897 mpfr_ui_div (result->value.real, 1, gfc_real_kinds[i].tiny, GFC_RND_MODE);
2898 return result;
2899 }
2900
2901 mpfr_init (log2);
2902 mpfr_init (absv);
2903 mpfr_init (frac);
2904 mpfr_init (pow2);
2905
2906 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
2907 mpfr_log2 (log2, absv, GFC_RND_MODE);
2908
2909 mpfr_trunc (log2, log2);
2910 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
2911
2912 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
2913 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
2914
2915 mpfr_mul_2exp (result->value.real, frac, (unsigned long)p, GFC_RND_MODE);
2916
2917 mpfr_clear (log2);
2918 mpfr_clear (absv);
2919 mpfr_clear (frac);
2920 mpfr_clear (pow2);
2921
2922 return range_check (result, "RRSPACING");
2923 }
2924
2925
2926 gfc_expr *
2927 gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
2928 {
2929 int k, neg_flag, power, exp_range;
2930 mpfr_t scale, radix;
2931 gfc_expr *result;
2932
2933 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
2934 return NULL;
2935
2936 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
2937
2938 if (mpfr_sgn (x->value.real) == 0)
2939 {
2940 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2941 return result;
2942 }
2943
2944 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2945
2946 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
2947
2948 /* This check filters out values of i that would overflow an int. */
2949 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
2950 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
2951 {
2952 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
2953 return &gfc_bad_expr;
2954 }
2955
2956 /* Compute scale = radix ** power. */
2957 power = mpz_get_si (i->value.integer);
2958
2959 if (power >= 0)
2960 neg_flag = 0;
2961 else
2962 {
2963 neg_flag = 1;
2964 power = -power;
2965 }
2966
2967 gfc_set_model_kind (x->ts.kind);
2968 mpfr_init (scale);
2969 mpfr_init (radix);
2970 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
2971 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
2972
2973 if (neg_flag)
2974 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
2975 else
2976 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
2977
2978 mpfr_clear (scale);
2979 mpfr_clear (radix);
2980
2981 return range_check (result, "SCALE");
2982 }
2983
2984
2985 gfc_expr *
2986 gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
2987 {
2988 gfc_expr *result;
2989 int back;
2990 size_t i;
2991 size_t indx, len, lenc;
2992
2993 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
2994 return NULL;
2995
2996 if (b != NULL && b->value.logical != 0)
2997 back = 1;
2998 else
2999 back = 0;
3000
3001 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3002 &e->where);
3003
3004 len = e->value.character.length;
3005 lenc = c->value.character.length;
3006
3007 if (len == 0 || lenc == 0)
3008 {
3009 indx = 0;
3010 }
3011 else
3012 {
3013 if (back == 0)
3014 {
3015 indx =
3016 strcspn (e->value.character.string, c->value.character.string) + 1;
3017 if (indx > len)
3018 indx = 0;
3019 }
3020 else
3021 {
3022 i = 0;
3023 for (indx = len; indx > 0; indx--)
3024 {
3025 for (i = 0; i < lenc; i++)
3026 {
3027 if (c->value.character.string[i]
3028 == e->value.character.string[indx - 1])
3029 break;
3030 }
3031 if (i < lenc)
3032 break;
3033 }
3034 }
3035 }
3036 mpz_set_ui (result->value.integer, indx);
3037 return range_check (result, "SCAN");
3038 }
3039
3040
3041 gfc_expr *
3042 gfc_simplify_selected_int_kind (gfc_expr * e)
3043 {
3044 int i, kind, range;
3045 gfc_expr *result;
3046
3047 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3048 return NULL;
3049
3050 kind = INT_MAX;
3051
3052 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3053 if (gfc_integer_kinds[i].range >= range
3054 && gfc_integer_kinds[i].kind < kind)
3055 kind = gfc_integer_kinds[i].kind;
3056
3057 if (kind == INT_MAX)
3058 kind = -1;
3059
3060 result = gfc_int_expr (kind);
3061 result->where = e->where;
3062
3063 return result;
3064 }
3065
3066
3067 gfc_expr *
3068 gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
3069 {
3070 int range, precision, i, kind, found_precision, found_range;
3071 gfc_expr *result;
3072
3073 if (p == NULL)
3074 precision = 0;
3075 else
3076 {
3077 if (p->expr_type != EXPR_CONSTANT
3078 || gfc_extract_int (p, &precision) != NULL)
3079 return NULL;
3080 }
3081
3082 if (q == NULL)
3083 range = 0;
3084 else
3085 {
3086 if (q->expr_type != EXPR_CONSTANT
3087 || gfc_extract_int (q, &range) != NULL)
3088 return NULL;
3089 }
3090
3091 kind = INT_MAX;
3092 found_precision = 0;
3093 found_range = 0;
3094
3095 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3096 {
3097 if (gfc_real_kinds[i].precision >= precision)
3098 found_precision = 1;
3099
3100 if (gfc_real_kinds[i].range >= range)
3101 found_range = 1;
3102
3103 if (gfc_real_kinds[i].precision >= precision
3104 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3105 kind = gfc_real_kinds[i].kind;
3106 }
3107
3108 if (kind == INT_MAX)
3109 {
3110 kind = 0;
3111
3112 if (!found_precision)
3113 kind = -1;
3114 if (!found_range)
3115 kind -= 2;
3116 }
3117
3118 result = gfc_int_expr (kind);
3119 result->where = (p != NULL) ? p->where : q->where;
3120
3121 return result;
3122 }
3123
3124
3125 gfc_expr *
3126 gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
3127 {
3128 gfc_expr *result;
3129 mpfr_t exp, absv, log2, pow2, frac;
3130 unsigned long exp2;
3131
3132 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3133 return NULL;
3134
3135 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3136
3137 gfc_set_model_kind (x->ts.kind);
3138
3139 if (mpfr_sgn (x->value.real) == 0)
3140 {
3141 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3142 return result;
3143 }
3144
3145 mpfr_init (absv);
3146 mpfr_init (log2);
3147 mpfr_init (exp);
3148 mpfr_init (pow2);
3149 mpfr_init (frac);
3150
3151 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3152 mpfr_log2 (log2, absv, GFC_RND_MODE);
3153
3154 mpfr_trunc (log2, log2);
3155 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3156
3157 /* Old exponent value, and fraction. */
3158 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3159
3160 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3161
3162 /* New exponent. */
3163 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3164 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3165
3166 mpfr_clear (absv);
3167 mpfr_clear (log2);
3168 mpfr_clear (pow2);
3169 mpfr_clear (frac);
3170
3171 return range_check (result, "SET_EXPONENT");
3172 }
3173
3174
3175 gfc_expr *
3176 gfc_simplify_shape (gfc_expr * source)
3177 {
3178 mpz_t shape[GFC_MAX_DIMENSIONS];
3179 gfc_expr *result, *e, *f;
3180 gfc_array_ref *ar;
3181 int n;
3182 try t;
3183
3184 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3185 return NULL;
3186
3187 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3188 &source->where);
3189
3190 ar = gfc_find_array_ref (source);
3191
3192 t = gfc_array_ref_shape (ar, shape);
3193
3194 for (n = 0; n < source->rank; n++)
3195 {
3196 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3197 &source->where);
3198
3199 if (t == SUCCESS)
3200 {
3201 mpz_set (e->value.integer, shape[n]);
3202 mpz_clear (shape[n]);
3203 }
3204 else
3205 {
3206 mpz_set_ui (e->value.integer, n + 1);
3207
3208 f = gfc_simplify_size (source, e);
3209 gfc_free_expr (e);
3210 if (f == NULL)
3211 {
3212 gfc_free_expr (result);
3213 return NULL;
3214 }
3215 else
3216 {
3217 e = f;
3218 }
3219 }
3220
3221 gfc_append_constructor (result, e);
3222 }
3223
3224 return result;
3225 }
3226
3227
3228 gfc_expr *
3229 gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
3230 {
3231 mpz_t size;
3232 gfc_expr *result;
3233 int d;
3234
3235 if (dim == NULL)
3236 {
3237 if (gfc_array_size (array, &size) == FAILURE)
3238 return NULL;
3239 }
3240 else
3241 {
3242 if (dim->expr_type != EXPR_CONSTANT)
3243 return NULL;
3244
3245 d = mpz_get_ui (dim->value.integer) - 1;
3246 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3247 return NULL;
3248 }
3249
3250 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3251 &array->where);
3252
3253 mpz_set (result->value.integer, size);
3254
3255 return result;
3256 }
3257
3258
3259 gfc_expr *
3260 gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
3261 {
3262 gfc_expr *result;
3263
3264 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3265 return NULL;
3266
3267 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3268
3269 switch (x->ts.type)
3270 {
3271 case BT_INTEGER:
3272 mpz_abs (result->value.integer, x->value.integer);
3273 if (mpz_sgn (y->value.integer) < 0)
3274 mpz_neg (result->value.integer, result->value.integer);
3275
3276 break;
3277
3278 case BT_REAL:
3279 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3280 it. */
3281 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3282 if (mpfr_sgn (y->value.real) < 0)
3283 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3284
3285 break;
3286
3287 default:
3288 gfc_internal_error ("Bad type in gfc_simplify_sign");
3289 }
3290
3291 return result;
3292 }
3293
3294
3295 gfc_expr *
3296 gfc_simplify_sin (gfc_expr * x)
3297 {
3298 gfc_expr *result;
3299 mpfr_t xp, xq;
3300
3301 if (x->expr_type != EXPR_CONSTANT)
3302 return NULL;
3303
3304 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3305
3306 switch (x->ts.type)
3307 {
3308 case BT_REAL:
3309 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3310 break;
3311
3312 case BT_COMPLEX:
3313 gfc_set_model (x->value.real);
3314 mpfr_init (xp);
3315 mpfr_init (xq);
3316
3317 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3318 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3319 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3320
3321 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3322 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3323 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3324
3325 mpfr_clear (xp);
3326 mpfr_clear (xq);
3327 break;
3328
3329 default:
3330 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3331 }
3332
3333 return range_check (result, "SIN");
3334 }
3335
3336
3337 gfc_expr *
3338 gfc_simplify_sinh (gfc_expr * x)
3339 {
3340 gfc_expr *result;
3341
3342 if (x->expr_type != EXPR_CONSTANT)
3343 return NULL;
3344
3345 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3346
3347 mpfr_sinh(result->value.real, x->value.real, GFC_RND_MODE);
3348
3349 return range_check (result, "SINH");
3350 }
3351
3352
3353 /* The argument is always a double precision real that is converted to
3354 single precision. TODO: Rounding! */
3355
3356 gfc_expr *
3357 gfc_simplify_sngl (gfc_expr * a)
3358 {
3359 gfc_expr *result;
3360
3361 if (a->expr_type != EXPR_CONSTANT)
3362 return NULL;
3363
3364 result = gfc_real2real (a, gfc_default_real_kind);
3365 return range_check (result, "SNGL");
3366 }
3367
3368
3369 gfc_expr *
3370 gfc_simplify_spacing (gfc_expr * x)
3371 {
3372 gfc_expr *result;
3373 mpfr_t absv, log2;
3374 long diff;
3375 int i, p;
3376
3377 if (x->expr_type != EXPR_CONSTANT)
3378 return NULL;
3379
3380 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3381
3382 p = gfc_real_kinds[i].digits;
3383
3384 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3385
3386 gfc_set_model_kind (x->ts.kind);
3387
3388 if (mpfr_sgn (x->value.real) == 0)
3389 {
3390 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3391 return result;
3392 }
3393
3394 mpfr_init (log2);
3395 mpfr_init (absv);
3396
3397 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3398 mpfr_log2 (log2, absv, GFC_RND_MODE);
3399 mpfr_trunc (log2, log2);
3400
3401 mpfr_add_ui (log2, log2, 1, GFC_RND_MODE);
3402
3403 /* FIXME: We should be using mpfr_get_si here, but this function is
3404 not available with the version of mpfr distributed with gmp (as of
3405 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3406 tree. */
3407 diff = (long)mpfr_get_d (log2, GFC_RND_MODE) - (long)p;
3408 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3409 mpfr_mul_2si (result->value.real, result->value.real, diff, GFC_RND_MODE);
3410
3411 mpfr_clear (log2);
3412 mpfr_clear (absv);
3413
3414 if (mpfr_cmp (result->value.real, gfc_real_kinds[i].tiny) < 0)
3415 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3416
3417 return range_check (result, "SPACING");
3418 }
3419
3420
3421 gfc_expr *
3422 gfc_simplify_sqrt (gfc_expr * e)
3423 {
3424 gfc_expr *result;
3425 mpfr_t ac, ad, s, t, w;
3426
3427 if (e->expr_type != EXPR_CONSTANT)
3428 return NULL;
3429
3430 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3431
3432 switch (e->ts.type)
3433 {
3434 case BT_REAL:
3435 if (mpfr_cmp_si (e->value.real, 0) < 0)
3436 goto negative_arg;
3437 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3438
3439 break;
3440
3441 case BT_COMPLEX:
3442 /* Formula taken from Numerical Recipes to avoid over- and
3443 underflow. */
3444
3445 gfc_set_model (e->value.real);
3446 mpfr_init (ac);
3447 mpfr_init (ad);
3448 mpfr_init (s);
3449 mpfr_init (t);
3450 mpfr_init (w);
3451
3452 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3453 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3454 {
3455
3456 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3457 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3458 break;
3459 }
3460
3461 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3462 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3463
3464 if (mpfr_cmp (ac, ad) >= 0)
3465 {
3466 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3467 mpfr_mul (t, t, t, GFC_RND_MODE);
3468 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3469 mpfr_sqrt (t, t, GFC_RND_MODE);
3470 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3471 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3472 mpfr_sqrt (t, t, GFC_RND_MODE);
3473 mpfr_sqrt (s, ac, GFC_RND_MODE);
3474 mpfr_mul (w, s, t, GFC_RND_MODE);
3475 }
3476 else
3477 {
3478 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3479 mpfr_mul (t, s, s, GFC_RND_MODE);
3480 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3481 mpfr_sqrt (t, t, GFC_RND_MODE);
3482 mpfr_abs (s, s, GFC_RND_MODE);
3483 mpfr_add (t, t, s, GFC_RND_MODE);
3484 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3485 mpfr_sqrt (t, t, GFC_RND_MODE);
3486 mpfr_sqrt (s, ad, GFC_RND_MODE);
3487 mpfr_mul (w, s, t, GFC_RND_MODE);
3488 }
3489
3490 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3491 {
3492 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3493 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3494 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3495 }
3496 else if (mpfr_cmp_ui (w, 0) != 0
3497 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3498 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3499 {
3500 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3501 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3502 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3503 }
3504 else if (mpfr_cmp_ui (w, 0) != 0
3505 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3506 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3507 {
3508 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3509 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3510 mpfr_neg (w, w, GFC_RND_MODE);
3511 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3512 }
3513 else
3514 gfc_internal_error ("invalid complex argument of SQRT at %L",
3515 &e->where);
3516
3517 mpfr_clear (s);
3518 mpfr_clear (t);
3519 mpfr_clear (ac);
3520 mpfr_clear (ad);
3521 mpfr_clear (w);
3522
3523 break;
3524
3525 default:
3526 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3527 }
3528
3529 return range_check (result, "SQRT");
3530
3531 negative_arg:
3532 gfc_free_expr (result);
3533 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3534 return &gfc_bad_expr;
3535 }
3536
3537
3538 gfc_expr *
3539 gfc_simplify_tan (gfc_expr * x)
3540 {
3541 int i;
3542 gfc_expr *result;
3543
3544 if (x->expr_type != EXPR_CONSTANT)
3545 return NULL;
3546
3547 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3548
3549 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3550
3551 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3552
3553 return range_check (result, "TAN");
3554 }
3555
3556
3557 gfc_expr *
3558 gfc_simplify_tanh (gfc_expr * x)
3559 {
3560 gfc_expr *result;
3561
3562 if (x->expr_type != EXPR_CONSTANT)
3563 return NULL;
3564
3565 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3566
3567 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3568
3569 return range_check (result, "TANH");
3570
3571 }
3572
3573
3574 gfc_expr *
3575 gfc_simplify_tiny (gfc_expr * e)
3576 {
3577 gfc_expr *result;
3578 int i;
3579
3580 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3581
3582 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3583 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3584
3585 return result;
3586 }
3587
3588
3589 gfc_expr *
3590 gfc_simplify_trim (gfc_expr * e)
3591 {
3592 gfc_expr *result;
3593 int count, i, len, lentrim;
3594
3595 if (e->expr_type != EXPR_CONSTANT)
3596 return NULL;
3597
3598 len = e->value.character.length;
3599
3600 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3601
3602 for (count = 0, i = 1; i <= len; ++i)
3603 {
3604 if (e->value.character.string[len - i] == ' ')
3605 count++;
3606 else
3607 break;
3608 }
3609
3610 lentrim = len - count;
3611
3612 result->value.character.length = lentrim;
3613 result->value.character.string = gfc_getmem (lentrim + 1);
3614
3615 for (i = 0; i < lentrim; i++)
3616 result->value.character.string[i] = e->value.character.string[i];
3617
3618 result->value.character.string[lentrim] = '\0'; /* For debugger */
3619
3620 return result;
3621 }
3622
3623
3624 gfc_expr *
3625 gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
3626 {
3627 return simplify_bound (array, dim, 1);
3628 }
3629
3630
3631 gfc_expr *
3632 gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
3633 {
3634 gfc_expr *result;
3635 int back;
3636 size_t index, len, lenset;
3637 size_t i;
3638
3639 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
3640 return NULL;
3641
3642 if (b != NULL && b->value.logical != 0)
3643 back = 1;
3644 else
3645 back = 0;
3646
3647 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3648 &s->where);
3649
3650 len = s->value.character.length;
3651 lenset = set->value.character.length;
3652
3653 if (len == 0)
3654 {
3655 mpz_set_ui (result->value.integer, 0);
3656 return result;
3657 }
3658
3659 if (back == 0)
3660 {
3661 if (lenset == 0)
3662 {
3663 mpz_set_ui (result->value.integer, len);
3664 return result;
3665 }
3666
3667 index =
3668 strspn (s->value.character.string, set->value.character.string) + 1;
3669 if (index > len)
3670 index = 0;
3671
3672 }
3673 else
3674 {
3675 if (lenset == 0)
3676 {
3677 mpz_set_ui (result->value.integer, 1);
3678 return result;
3679 }
3680 for (index = len; index > 0; index --)
3681 {
3682 for (i = 0; i < lenset; i++)
3683 {
3684 if (s->value.character.string[index - 1]
3685 == set->value.character.string[i])
3686 break;
3687 }
3688 if (i == lenset)
3689 break;
3690 }
3691 }
3692
3693 mpz_set_ui (result->value.integer, index);
3694 return result;
3695 }
3696
3697 /****************** Constant simplification *****************/
3698
3699 /* Master function to convert one constant to another. While this is
3700 used as a simplification function, it requires the destination type
3701 and kind information which is supplied by a special case in
3702 do_simplify(). */
3703
3704 gfc_expr *
3705 gfc_convert_constant (gfc_expr * e, bt type, int kind)
3706 {
3707 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
3708 gfc_constructor *head, *c, *tail = NULL;
3709
3710 switch (e->ts.type)
3711 {
3712 case BT_INTEGER:
3713 switch (type)
3714 {
3715 case BT_INTEGER:
3716 f = gfc_int2int;
3717 break;
3718 case BT_REAL:
3719 f = gfc_int2real;
3720 break;
3721 case BT_COMPLEX:
3722 f = gfc_int2complex;
3723 break;
3724 default:
3725 goto oops;
3726 }
3727 break;
3728
3729 case BT_REAL:
3730 switch (type)
3731 {
3732 case BT_INTEGER:
3733 f = gfc_real2int;
3734 break;
3735 case BT_REAL:
3736 f = gfc_real2real;
3737 break;
3738 case BT_COMPLEX:
3739 f = gfc_real2complex;
3740 break;
3741 default:
3742 goto oops;
3743 }
3744 break;
3745
3746 case BT_COMPLEX:
3747 switch (type)
3748 {
3749 case BT_INTEGER:
3750 f = gfc_complex2int;
3751 break;
3752 case BT_REAL:
3753 f = gfc_complex2real;
3754 break;
3755 case BT_COMPLEX:
3756 f = gfc_complex2complex;
3757 break;
3758
3759 default:
3760 goto oops;
3761 }
3762 break;
3763
3764 case BT_LOGICAL:
3765 if (type != BT_LOGICAL)
3766 goto oops;
3767 f = gfc_log2log;
3768 break;
3769
3770 default:
3771 oops:
3772 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3773 }
3774
3775 result = NULL;
3776
3777 switch (e->expr_type)
3778 {
3779 case EXPR_CONSTANT:
3780 result = f (e, kind);
3781 if (result == NULL)
3782 return &gfc_bad_expr;
3783 break;
3784
3785 case EXPR_ARRAY:
3786 if (!gfc_is_constant_expr (e))
3787 break;
3788
3789 head = NULL;
3790
3791 for (c = e->value.constructor; c; c = c->next)
3792 {
3793 if (head == NULL)
3794 head = tail = gfc_get_constructor ();
3795 else
3796 {
3797 tail->next = gfc_get_constructor ();
3798 tail = tail->next;
3799 }
3800
3801 tail->where = c->where;
3802
3803 if (c->iterator == NULL)
3804 tail->expr = f (c->expr, kind);
3805 else
3806 {
3807 g = gfc_convert_constant (c->expr, type, kind);
3808 if (g == &gfc_bad_expr)
3809 return g;
3810 tail->expr = g;
3811 }
3812
3813 if (tail->expr == NULL)
3814 {
3815 gfc_free_constructor (head);
3816 return NULL;
3817 }
3818 }
3819
3820 result = gfc_get_expr ();
3821 result->ts.type = type;
3822 result->ts.kind = kind;
3823 result->expr_type = EXPR_ARRAY;
3824 result->value.constructor = head;
3825 result->shape = gfc_copy_shape (e->shape, e->rank);
3826 result->where = e->where;
3827 result->rank = e->rank;
3828 break;
3829
3830 default:
3831 break;
3832 }
3833
3834 return result;
3835 }
3836
3837
3838 /****************** Helper functions ***********************/
3839
3840 /* Given a collating table, create the inverse table. */
3841
3842 static void
3843 invert_table (const int *table, int *xtable)
3844 {
3845 int i;
3846
3847 for (i = 0; i < 256; i++)
3848 xtable[i] = 0;
3849
3850 for (i = 0; i < 256; i++)
3851 xtable[table[i]] = i;
3852 }
3853
3854
3855 void
3856 gfc_simplify_init_1 (void)
3857 {
3858
3859 invert_table (ascii_table, xascii_table);
3860 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org