OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [arith.c] - Blame information for rev 329

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 285 jeremybenn
/* Compiler arithmetic
2
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3
   Free Software Foundation, Inc.
4
   Contributed by Andy Vaught
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
/* Since target arithmetic must be done on the host, there has to
23
   be some way of evaluating arithmetic expressions as the host
24
   would evaluate them.  We use the GNU MP library and the MPFR
25
   library to do arithmetic, and this file provides the interface.  */
26
 
27
#include "config.h"
28
#include "system.h"
29
#include "flags.h"
30
#include "gfortran.h"
31
#include "arith.h"
32
#include "target-memory.h"
33
 
34
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
35
   It's easily implemented with a few calls though.  */
36
 
37
void
38
gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
39
{
40
  mp_exp_t e;
41
 
42
  if (mpfr_inf_p (x) || mpfr_nan_p (x))
43
    {
44
      gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
45
                 "to INTEGER", where);
46
      mpz_set_ui (z, 0);
47
      return;
48
    }
49
 
50
  e = mpfr_get_z_exp (z, x);
51
 
52
  if (e > 0)
53
    mpz_mul_2exp (z, z, e);
54
  else
55
    mpz_tdiv_q_2exp (z, z, -e);
56
}
57
 
58
 
59
/* Set the model number precision by the requested KIND.  */
60
 
61
void
62
gfc_set_model_kind (int kind)
63
{
64
  int index = gfc_validate_kind (BT_REAL, kind, false);
65
  int base2prec;
66
 
67
  base2prec = gfc_real_kinds[index].digits;
68
  if (gfc_real_kinds[index].radix != 2)
69
    base2prec *= gfc_real_kinds[index].radix / 2;
70
  mpfr_set_default_prec (base2prec);
71
}
72
 
73
 
74
/* Set the model number precision from mpfr_t x.  */
75
 
76
void
77
gfc_set_model (mpfr_t x)
78
{
79
  mpfr_set_default_prec (mpfr_get_prec (x));
80
}
81
 
82
 
83
/* Given an arithmetic error code, return a pointer to a string that
84
   explains the error.  */
85
 
86
static const char *
87
gfc_arith_error (arith code)
88
{
89
  const char *p;
90
 
91
  switch (code)
92
    {
93
    case ARITH_OK:
94
      p = _("Arithmetic OK at %L");
95
      break;
96
    case ARITH_OVERFLOW:
97
      p = _("Arithmetic overflow at %L");
98
      break;
99
    case ARITH_UNDERFLOW:
100
      p = _("Arithmetic underflow at %L");
101
      break;
102
    case ARITH_NAN:
103
      p = _("Arithmetic NaN at %L");
104
      break;
105
    case ARITH_DIV0:
106
      p = _("Division by zero at %L");
107
      break;
108
    case ARITH_INCOMMENSURATE:
109
      p = _("Array operands are incommensurate at %L");
110
      break;
111
    case ARITH_ASYMMETRIC:
112
      p =
113
        _("Integer outside symmetric range implied by Standard Fortran at %L");
114
      break;
115
    default:
116
      gfc_internal_error ("gfc_arith_error(): Bad error code");
117
    }
118
 
119
  return p;
120
}
121
 
122
 
123
/* Get things ready to do math.  */
124
 
125
void
126
gfc_arith_init_1 (void)
127
{
128
  gfc_integer_info *int_info;
129
  gfc_real_info *real_info;
130
  mpfr_t a, b;
131
  int i;
132
 
133
  mpfr_set_default_prec (128);
134
  mpfr_init (a);
135
 
136
  /* Convert the minimum and maximum values for each kind into their
137
     GNU MP representation.  */
138
  for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
139
    {
140
      /* Huge  */
141
      mpz_init (int_info->huge);
142
      mpz_set_ui (int_info->huge, int_info->radix);
143
      mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
144
      mpz_sub_ui (int_info->huge, int_info->huge, 1);
145
 
146
      /* These are the numbers that are actually representable by the
147
         target.  For bases other than two, this needs to be changed.  */
148
      if (int_info->radix != 2)
149
        gfc_internal_error ("Fix min_int calculation");
150
 
151
      /* See PRs 13490 and 17912, related to integer ranges.
152
         The pedantic_min_int exists for range checking when a program
153
         is compiled with -pedantic, and reflects the belief that
154
         Standard Fortran requires integers to be symmetrical, i.e.
155
         every negative integer must have a representable positive
156
         absolute value, and vice versa.  */
157
 
158
      mpz_init (int_info->pedantic_min_int);
159
      mpz_neg (int_info->pedantic_min_int, int_info->huge);
160
 
161
      mpz_init (int_info->min_int);
162
      mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
163
 
164
      /* Range  */
165
      mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
166
      mpfr_log10 (a, a, GFC_RND_MODE);
167
      mpfr_trunc (a, a);
168
      int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
169
    }
170
 
171
  mpfr_clear (a);
172
 
173
  for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
174
    {
175
      gfc_set_model_kind (real_info->kind);
176
 
177
      mpfr_init (a);
178
      mpfr_init (b);
179
 
180
      /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b  */
181
      /* 1 - b**(-p)  */
182
      mpfr_init (real_info->huge);
183
      mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
184
      mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
185
      mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
186
      mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
187
 
188
      /* b**(emax-1)  */
189
      mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
190
      mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
191
 
192
      /* (1 - b**(-p)) * b**(emax-1)  */
193
      mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
194
 
195
      /* (1 - b**(-p)) * b**(emax-1) * b  */
196
      mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
197
                   GFC_RND_MODE);
198
 
199
      /* tiny(x) = b**(emin-1)  */
200
      mpfr_init (real_info->tiny);
201
      mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
202
      mpfr_pow_si (real_info->tiny, real_info->tiny,
203
                   real_info->min_exponent - 1, GFC_RND_MODE);
204
 
205
      /* subnormal (x) = b**(emin - digit)  */
206
      mpfr_init (real_info->subnormal);
207
      mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
208
      mpfr_pow_si (real_info->subnormal, real_info->subnormal,
209
                   real_info->min_exponent - real_info->digits, GFC_RND_MODE);
210
 
211
      /* epsilon(x) = b**(1-p)  */
212
      mpfr_init (real_info->epsilon);
213
      mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
214
      mpfr_pow_si (real_info->epsilon, real_info->epsilon,
215
                   1 - real_info->digits, GFC_RND_MODE);
216
 
217
      /* range(x) = int(min(log10(huge(x)), -log10(tiny))  */
218
      mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
219
      mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
220
      mpfr_neg (b, b, GFC_RND_MODE);
221
 
222
      /* a = min(a, b)  */
223
      mpfr_min (a, a, b, GFC_RND_MODE);
224
      mpfr_trunc (a, a);
225
      real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
226
 
227
      /* precision(x) = int((p - 1) * log10(b)) + k  */
228
      mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
229
      mpfr_log10 (a, a, GFC_RND_MODE);
230
      mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
231
      mpfr_trunc (a, a);
232
      real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
233
 
234
      /* If the radix is an integral power of 10, add one to the precision.  */
235
      for (i = 10; i <= real_info->radix; i *= 10)
236
        if (i == real_info->radix)
237
          real_info->precision++;
238
 
239
      mpfr_clears (a, b, NULL);
240
    }
241
}
242
 
243
 
244
/* Clean up, get rid of numeric constants.  */
245
 
246
void
247
gfc_arith_done_1 (void)
248
{
249
  gfc_integer_info *ip;
250
  gfc_real_info *rp;
251
 
252
  for (ip = gfc_integer_kinds; ip->kind; ip++)
253
    {
254
      mpz_clear (ip->min_int);
255
      mpz_clear (ip->pedantic_min_int);
256
      mpz_clear (ip->huge);
257
    }
258
 
259
  for (rp = gfc_real_kinds; rp->kind; rp++)
260
    mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
261
}
262
 
263
 
264
/* Given a wide character value and a character kind, determine whether
265
   the character is representable for that kind.  */
266
bool
267
gfc_check_character_range (gfc_char_t c, int kind)
268
{
269
  /* As wide characters are stored as 32-bit values, they're all
270
     representable in UCS=4.  */
271
  if (kind == 4)
272
    return true;
273
 
274
  if (kind == 1)
275
    return c <= 255 ? true : false;
276
 
277
  gcc_unreachable ();
278
}
279
 
280
 
281
/* Given an integer and a kind, make sure that the integer lies within
282
   the range of the kind.  Returns ARITH_OK, ARITH_ASYMMETRIC or
283
   ARITH_OVERFLOW.  */
284
 
285
arith
286
gfc_check_integer_range (mpz_t p, int kind)
287
{
288
  arith result;
289
  int i;
290
 
291
  i = gfc_validate_kind (BT_INTEGER, kind, false);
292
  result = ARITH_OK;
293
 
294
  if (pedantic)
295
    {
296
      if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
297
        result = ARITH_ASYMMETRIC;
298
    }
299
 
300
 
301
  if (gfc_option.flag_range_check == 0)
302
    return result;
303
 
304
  if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
305
      || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
306
    result = ARITH_OVERFLOW;
307
 
308
  return result;
309
}
310
 
311
 
312
/* Given a real and a kind, make sure that the real lies within the
313
   range of the kind.  Returns ARITH_OK, ARITH_OVERFLOW or
314
   ARITH_UNDERFLOW.  */
315
 
316
static arith
317
gfc_check_real_range (mpfr_t p, int kind)
318
{
319
  arith retval;
320
  mpfr_t q;
321
  int i;
322
 
323
  i = gfc_validate_kind (BT_REAL, kind, false);
324
 
325
  gfc_set_model (p);
326
  mpfr_init (q);
327
  mpfr_abs (q, p, GFC_RND_MODE);
328
 
329
  retval = ARITH_OK;
330
 
331
  if (mpfr_inf_p (p))
332
    {
333
      if (gfc_option.flag_range_check != 0)
334
        retval = ARITH_OVERFLOW;
335
    }
336
  else if (mpfr_nan_p (p))
337
    {
338
      if (gfc_option.flag_range_check != 0)
339
        retval = ARITH_NAN;
340
    }
341
  else if (mpfr_sgn (q) == 0)
342
    {
343
      mpfr_clear (q);
344
      return retval;
345
    }
346
  else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
347
    {
348
      if (gfc_option.flag_range_check == 0)
349
        mpfr_set_inf (p, mpfr_sgn (p));
350
      else
351
        retval = ARITH_OVERFLOW;
352
    }
353
  else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
354
    {
355
      if (gfc_option.flag_range_check == 0)
356
        {
357
          if (mpfr_sgn (p) < 0)
358
            {
359
              mpfr_set_ui (p, 0, GFC_RND_MODE);
360
              mpfr_set_si (q, -1, GFC_RND_MODE);
361
              mpfr_copysign (p, p, q, GFC_RND_MODE);
362
            }
363
          else
364
            mpfr_set_ui (p, 0, GFC_RND_MODE);
365
        }
366
      else
367
        retval = ARITH_UNDERFLOW;
368
    }
369
  else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
370
    {
371
      mp_exp_t emin, emax;
372
      int en;
373
 
374
      /* Save current values of emin and emax.  */
375
      emin = mpfr_get_emin ();
376
      emax = mpfr_get_emax ();
377
 
378
      /* Set emin and emax for the current model number.  */
379
      en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
380
      mpfr_set_emin ((mp_exp_t) en);
381
      mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
382
      mpfr_check_range (q, 0, GFC_RND_MODE);
383
      mpfr_subnormalize (q, 0, GFC_RND_MODE);
384
 
385
      /* Reset emin and emax.  */
386
      mpfr_set_emin (emin);
387
      mpfr_set_emax (emax);
388
 
389
      /* Copy sign if needed.  */
390
      if (mpfr_sgn (p) < 0)
391
        mpfr_neg (p, q, GMP_RNDN);
392
      else
393
        mpfr_set (p, q, GMP_RNDN);
394
    }
395
 
396
  mpfr_clear (q);
397
 
398
  return retval;
399
}
400
 
401
 
402
/* Function to return a constant expression node of a given type and kind.  */
403
 
404
gfc_expr *
405
gfc_constant_result (bt type, int kind, locus *where)
406
{
407
  gfc_expr *result;
408
 
409
  if (!where)
410
    gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
411
 
412
  result = gfc_get_expr ();
413
 
414
  result->expr_type = EXPR_CONSTANT;
415
  result->ts.type = type;
416
  result->ts.kind = kind;
417
  result->where = *where;
418
 
419
  switch (type)
420
    {
421
    case BT_INTEGER:
422
      mpz_init (result->value.integer);
423
      break;
424
 
425
    case BT_REAL:
426
      gfc_set_model_kind (kind);
427
      mpfr_init (result->value.real);
428
      break;
429
 
430
    case BT_COMPLEX:
431
      gfc_set_model_kind (kind);
432
      mpc_init2 (result->value.complex, mpfr_get_default_prec());
433
      break;
434
 
435
    default:
436
      break;
437
    }
438
 
439
  return result;
440
}
441
 
442
 
443
/* Low-level arithmetic functions.  All of these subroutines assume
444
   that all operands are of the same type and return an operand of the
445
   same type.  The other thing about these subroutines is that they
446
   can fail in various ways -- overflow, underflow, division by zero,
447
   zero raised to the zero, etc.  */
448
 
449
static arith
450
gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
451
{
452
  gfc_expr *result;
453
 
454
  result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
455
  result->value.logical = !op1->value.logical;
456
  *resultp = result;
457
 
458
  return ARITH_OK;
459
}
460
 
461
 
462
static arith
463
gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
464
{
465
  gfc_expr *result;
466
 
467
  result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
468
                                &op1->where);
469
  result->value.logical = op1->value.logical && op2->value.logical;
470
  *resultp = result;
471
 
472
  return ARITH_OK;
473
}
474
 
475
 
476
static arith
477
gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
478
{
479
  gfc_expr *result;
480
 
481
  result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
482
                                &op1->where);
483
  result->value.logical = op1->value.logical || op2->value.logical;
484
  *resultp = result;
485
 
486
  return ARITH_OK;
487
}
488
 
489
 
490
static arith
491
gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
492
{
493
  gfc_expr *result;
494
 
495
  result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
496
                                &op1->where);
497
  result->value.logical = op1->value.logical == op2->value.logical;
498
  *resultp = result;
499
 
500
  return ARITH_OK;
501
}
502
 
503
 
504
static arith
505
gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
506
{
507
  gfc_expr *result;
508
 
509
  result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
510
                                &op1->where);
511
  result->value.logical = op1->value.logical != op2->value.logical;
512
  *resultp = result;
513
 
514
  return ARITH_OK;
515
}
516
 
517
 
518
/* Make sure a constant numeric expression is within the range for
519
   its type and kind.  Note that there's also a gfc_check_range(),
520
   but that one deals with the intrinsic RANGE function.  */
521
 
522
arith
523
gfc_range_check (gfc_expr *e)
524
{
525
  arith rc;
526
  arith rc2;
527
 
528
  switch (e->ts.type)
529
    {
530
    case BT_INTEGER:
531
      rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
532
      break;
533
 
534
    case BT_REAL:
535
      rc = gfc_check_real_range (e->value.real, e->ts.kind);
536
      if (rc == ARITH_UNDERFLOW)
537
        mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
538
      if (rc == ARITH_OVERFLOW)
539
        mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
540
      if (rc == ARITH_NAN)
541
        mpfr_set_nan (e->value.real);
542
      break;
543
 
544
    case BT_COMPLEX:
545
      rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
546
      if (rc == ARITH_UNDERFLOW)
547
        mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
548
      if (rc == ARITH_OVERFLOW)
549
        mpfr_set_inf (mpc_realref (e->value.complex),
550
                      mpfr_sgn (mpc_realref (e->value.complex)));
551
      if (rc == ARITH_NAN)
552
        mpfr_set_nan (mpc_realref (e->value.complex));
553
 
554
      rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
555
      if (rc == ARITH_UNDERFLOW)
556
        mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
557
      if (rc == ARITH_OVERFLOW)
558
        mpfr_set_inf (mpc_imagref (e->value.complex),
559
                      mpfr_sgn (mpc_imagref (e->value.complex)));
560
      if (rc == ARITH_NAN)
561
        mpfr_set_nan (mpc_imagref (e->value.complex));
562
 
563
      if (rc == ARITH_OK)
564
        rc = rc2;
565
      break;
566
 
567
    default:
568
      gfc_internal_error ("gfc_range_check(): Bad type");
569
    }
570
 
571
  return rc;
572
}
573
 
574
 
575
/* Several of the following routines use the same set of statements to
576
   check the validity of the result.  Encapsulate the checking here.  */
577
 
578
static arith
579
check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
580
{
581
  arith val = rc;
582
 
583
  if (val == ARITH_UNDERFLOW)
584
    {
585
      if (gfc_option.warn_underflow)
586
        gfc_warning (gfc_arith_error (val), &x->where);
587
      val = ARITH_OK;
588
    }
589
 
590
  if (val == ARITH_ASYMMETRIC)
591
    {
592
      gfc_warning (gfc_arith_error (val), &x->where);
593
      val = ARITH_OK;
594
    }
595
 
596
  if (val != ARITH_OK)
597
    gfc_free_expr (r);
598
  else
599
    *rp = r;
600
 
601
  return val;
602
}
603
 
604
 
605
/* It may seem silly to have a subroutine that actually computes the
606
   unary plus of a constant, but it prevents us from making exceptions
607
   in the code elsewhere.  Used for unary plus and parenthesized
608
   expressions.  */
609
 
610
static arith
611
gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
612
{
613
  *resultp = gfc_copy_expr (op1);
614
  return ARITH_OK;
615
}
616
 
617
 
618
static arith
619
gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
620
{
621
  gfc_expr *result;
622
  arith rc;
623
 
624
  result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
625
 
626
  switch (op1->ts.type)
627
    {
628
    case BT_INTEGER:
629
      mpz_neg (result->value.integer, op1->value.integer);
630
      break;
631
 
632
    case BT_REAL:
633
      mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
634
      break;
635
 
636
    case BT_COMPLEX:
637
      mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
638
      break;
639
 
640
    default:
641
      gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
642
    }
643
 
644
  rc = gfc_range_check (result);
645
 
646
  return check_result (rc, op1, result, resultp);
647
}
648
 
649
 
650
static arith
651
gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
652
{
653
  gfc_expr *result;
654
  arith rc;
655
 
656
  result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
657
 
658
  switch (op1->ts.type)
659
    {
660
    case BT_INTEGER:
661
      mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
662
      break;
663
 
664
    case BT_REAL:
665
      mpfr_add (result->value.real, op1->value.real, op2->value.real,
666
               GFC_RND_MODE);
667
      break;
668
 
669
    case BT_COMPLEX:
670
      mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
671
               GFC_MPC_RND_MODE);
672
      break;
673
 
674
    default:
675
      gfc_internal_error ("gfc_arith_plus(): Bad basic type");
676
    }
677
 
678
  rc = gfc_range_check (result);
679
 
680
  return check_result (rc, op1, result, resultp);
681
}
682
 
683
 
684
static arith
685
gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
686
{
687
  gfc_expr *result;
688
  arith rc;
689
 
690
  result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
691
 
692
  switch (op1->ts.type)
693
    {
694
    case BT_INTEGER:
695
      mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
696
      break;
697
 
698
    case BT_REAL:
699
      mpfr_sub (result->value.real, op1->value.real, op2->value.real,
700
                GFC_RND_MODE);
701
      break;
702
 
703
    case BT_COMPLEX:
704
      mpc_sub (result->value.complex, op1->value.complex,
705
               op2->value.complex, GFC_MPC_RND_MODE);
706
      break;
707
 
708
    default:
709
      gfc_internal_error ("gfc_arith_minus(): Bad basic type");
710
    }
711
 
712
  rc = gfc_range_check (result);
713
 
714
  return check_result (rc, op1, result, resultp);
715
}
716
 
717
 
718
static arith
719
gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
720
{
721
  gfc_expr *result;
722
  arith rc;
723
 
724
  result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
725
 
726
  switch (op1->ts.type)
727
    {
728
    case BT_INTEGER:
729
      mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
730
      break;
731
 
732
    case BT_REAL:
733
      mpfr_mul (result->value.real, op1->value.real, op2->value.real,
734
               GFC_RND_MODE);
735
      break;
736
 
737
    case BT_COMPLEX:
738
      gfc_set_model (mpc_realref (op1->value.complex));
739
      mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
740
               GFC_MPC_RND_MODE);
741
      break;
742
 
743
    default:
744
      gfc_internal_error ("gfc_arith_times(): Bad basic type");
745
    }
746
 
747
  rc = gfc_range_check (result);
748
 
749
  return check_result (rc, op1, result, resultp);
750
}
751
 
752
 
753
static arith
754
gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
755
{
756
  gfc_expr *result;
757
  arith rc;
758
 
759
  rc = ARITH_OK;
760
 
761
  result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
762
 
763
  switch (op1->ts.type)
764
    {
765
    case BT_INTEGER:
766
      if (mpz_sgn (op2->value.integer) == 0)
767
        {
768
          rc = ARITH_DIV0;
769
          break;
770
        }
771
 
772
      mpz_tdiv_q (result->value.integer, op1->value.integer,
773
                  op2->value.integer);
774
      break;
775
 
776
    case BT_REAL:
777
      if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
778
        {
779
          rc = ARITH_DIV0;
780
          break;
781
        }
782
 
783
      mpfr_div (result->value.real, op1->value.real, op2->value.real,
784
               GFC_RND_MODE);
785
      break;
786
 
787
    case BT_COMPLEX:
788
      if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
789
          && gfc_option.flag_range_check == 1)
790
        {
791
          rc = ARITH_DIV0;
792
          break;
793
        }
794
 
795
      gfc_set_model (mpc_realref (op1->value.complex));
796
      if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
797
      {
798
        /* In Fortran, return (NaN + NaN I) for any zero divisor.  See
799
           PR 40318. */
800
        mpfr_set_nan (mpc_realref (result->value.complex));
801
        mpfr_set_nan (mpc_imagref (result->value.complex));
802
      }
803
      else
804
        mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
805
                 GFC_MPC_RND_MODE);
806
      break;
807
 
808
    default:
809
      gfc_internal_error ("gfc_arith_divide(): Bad basic type");
810
    }
811
 
812
  if (rc == ARITH_OK)
813
    rc = gfc_range_check (result);
814
 
815
  return check_result (rc, op1, result, resultp);
816
}
817
 
818
/* Raise a number to a power.  */
819
 
820
static arith
821
arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
822
{
823
  int power_sign;
824
  gfc_expr *result;
825
  arith rc;
826
  extern bool init_flag;
827
 
828
  rc = ARITH_OK;
829
  result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
830
 
831
  switch (op2->ts.type)
832
    {
833
    case BT_INTEGER:
834
      power_sign = mpz_sgn (op2->value.integer);
835
 
836
      if (power_sign == 0)
837
        {
838
          /* Handle something to the zeroth power.  Since we're dealing
839
             with integral exponents, there is no ambiguity in the
840
             limiting procedure used to determine the value of 0**0.  */
841
          switch (op1->ts.type)
842
            {
843
            case BT_INTEGER:
844
              mpz_set_ui (result->value.integer, 1);
845
              break;
846
 
847
            case BT_REAL:
848
              mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
849
              break;
850
 
851
            case BT_COMPLEX:
852
              mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
853
              break;
854
 
855
            default:
856
              gfc_internal_error ("arith_power(): Bad base");
857
            }
858
        }
859
      else
860
        {
861
          switch (op1->ts.type)
862
            {
863
            case BT_INTEGER:
864
              {
865
                int power;
866
 
867
                /* First, we simplify the cases of op1 == 1, 0 or -1.  */
868
                if (mpz_cmp_si (op1->value.integer, 1) == 0)
869
                  {
870
                    /* 1**op2 == 1 */
871
                    mpz_set_si (result->value.integer, 1);
872
                  }
873
                else if (mpz_cmp_si (op1->value.integer, 0) == 0)
874
                  {
875
                    /* 0**op2 == 0, if op2 > 0
876
                       0**op2 overflow, if op2 < 0 ; in that case, we
877
                       set the result to 0 and return ARITH_DIV0.  */
878
                    mpz_set_si (result->value.integer, 0);
879
                    if (mpz_cmp_si (op2->value.integer, 0) < 0)
880
                      rc = ARITH_DIV0;
881
                  }
882
                else if (mpz_cmp_si (op1->value.integer, -1) == 0)
883
                  {
884
                    /* (-1)**op2 == (-1)**(mod(op2,2)) */
885
                    unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
886
                    if (odd)
887
                      mpz_set_si (result->value.integer, -1);
888
                    else
889
                      mpz_set_si (result->value.integer, 1);
890
                  }
891
                /* Then, we take care of op2 < 0.  */
892
                else if (mpz_cmp_si (op2->value.integer, 0) < 0)
893
                  {
894
                    /* if op2 < 0, op1**op2 == 0  because abs(op1) > 1.  */
895
                    mpz_set_si (result->value.integer, 0);
896
                  }
897
                else if (gfc_extract_int (op2, &power) != NULL)
898
                  {
899
                    /* If op2 doesn't fit in an int, the exponentiation will
900
                       overflow, because op2 > 0 and abs(op1) > 1.  */
901
                    mpz_t max;
902
                    int i;
903
                    i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
904
 
905
                    if (gfc_option.flag_range_check)
906
                      rc = ARITH_OVERFLOW;
907
 
908
                    /* Still, we want to give the same value as the
909
                       processor.  */
910
                    mpz_init (max);
911
                    mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
912
                    mpz_mul_ui (max, max, 2);
913
                    mpz_powm (result->value.integer, op1->value.integer,
914
                              op2->value.integer, max);
915
                    mpz_clear (max);
916
                  }
917
                else
918
                  mpz_pow_ui (result->value.integer, op1->value.integer,
919
                              power);
920
              }
921
              break;
922
 
923
            case BT_REAL:
924
              mpfr_pow_z (result->value.real, op1->value.real,
925
                          op2->value.integer, GFC_RND_MODE);
926
              break;
927
 
928
            case BT_COMPLEX:
929
              mpc_pow_z (result->value.complex, op1->value.complex,
930
                         op2->value.integer, GFC_MPC_RND_MODE);
931
              break;
932
 
933
            default:
934
              break;
935
            }
936
        }
937
      break;
938
 
939
    case BT_REAL:
940
 
941
      if (init_flag)
942
        {
943
          if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
944
                              "exponent in an initialization "
945
                              "expression at %L", &op2->where) == FAILURE)
946
            return ARITH_PROHIBIT;
947
        }
948
 
949
      if (mpfr_cmp_si (op1->value.real, 0) < 0)
950
        {
951
          gfc_error ("Raising a negative REAL at %L to "
952
                     "a REAL power is prohibited", &op1->where);
953
          gfc_free (result);
954
          return ARITH_PROHIBIT;
955
        }
956
 
957
        mpfr_pow (result->value.real, op1->value.real, op2->value.real,
958
                  GFC_RND_MODE);
959
      break;
960
 
961
    case BT_COMPLEX:
962
      {
963
        if (init_flag)
964
          {
965
            if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
966
                                "exponent in an initialization "
967
                                "expression at %L", &op2->where) == FAILURE)
968
              return ARITH_PROHIBIT;
969
          }
970
 
971
        mpc_pow (result->value.complex, op1->value.complex,
972
                 op2->value.complex, GFC_MPC_RND_MODE);
973
      }
974
      break;
975
    default:
976
      gfc_internal_error ("arith_power(): unknown type");
977
    }
978
 
979
  if (rc == ARITH_OK)
980
    rc = gfc_range_check (result);
981
 
982
  return check_result (rc, op1, result, resultp);
983
}
984
 
985
 
986
/* Concatenate two string constants.  */
987
 
988
static arith
989
gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
990
{
991
  gfc_expr *result;
992
  int len;
993
 
994
  gcc_assert (op1->ts.kind == op2->ts.kind);
995
  result = gfc_constant_result (BT_CHARACTER, op1->ts.kind,
996
                                &op1->where);
997
 
998
  len = op1->value.character.length + op2->value.character.length;
999
 
1000
  result->value.character.string = gfc_get_wide_string (len + 1);
1001
  result->value.character.length = len;
1002
 
1003
  memcpy (result->value.character.string, op1->value.character.string,
1004
          op1->value.character.length * sizeof (gfc_char_t));
1005
 
1006
  memcpy (&result->value.character.string[op1->value.character.length],
1007
          op2->value.character.string,
1008
          op2->value.character.length * sizeof (gfc_char_t));
1009
 
1010
  result->value.character.string[len] = '\0';
1011
 
1012
  *resultp = result;
1013
 
1014
  return ARITH_OK;
1015
}
1016
 
1017
/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
1018
   This function mimics mpfr_cmp but takes NaN into account.  */
1019
 
1020
static int
1021
compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1022
{
1023
  int rc;
1024
  switch (op)
1025
    {
1026
      case INTRINSIC_EQ:
1027
        rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
1028
        break;
1029
      case INTRINSIC_GT:
1030
        rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
1031
        break;
1032
      case INTRINSIC_GE:
1033
        rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
1034
        break;
1035
      case INTRINSIC_LT:
1036
        rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
1037
        break;
1038
      case INTRINSIC_LE:
1039
        rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
1040
        break;
1041
      default:
1042
        gfc_internal_error ("compare_real(): Bad operator");
1043
    }
1044
 
1045
  return rc;
1046
}
1047
 
1048
/* Comparison operators.  Assumes that the two expression nodes
1049
   contain two constants of the same type. The op argument is
1050
   needed to handle NaN correctly.  */
1051
 
1052
int
1053
gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1054
{
1055
  int rc;
1056
 
1057
  switch (op1->ts.type)
1058
    {
1059
    case BT_INTEGER:
1060
      rc = mpz_cmp (op1->value.integer, op2->value.integer);
1061
      break;
1062
 
1063
    case BT_REAL:
1064
      rc = compare_real (op1, op2, op);
1065
      break;
1066
 
1067
    case BT_CHARACTER:
1068
      rc = gfc_compare_string (op1, op2);
1069
      break;
1070
 
1071
    case BT_LOGICAL:
1072
      rc = ((!op1->value.logical && op2->value.logical)
1073
            || (op1->value.logical && !op2->value.logical));
1074
      break;
1075
 
1076
    default:
1077
      gfc_internal_error ("gfc_compare_expr(): Bad basic type");
1078
    }
1079
 
1080
  return rc;
1081
}
1082
 
1083
 
1084
/* Compare a pair of complex numbers.  Naturally, this is only for
1085
   equality and inequality.  */
1086
 
1087
static int
1088
compare_complex (gfc_expr *op1, gfc_expr *op2)
1089
{
1090
  return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1091
}
1092
 
1093
 
1094
/* Given two constant strings and the inverse collating sequence, compare the
1095
   strings.  We return -1 for a < b, 0 for a == b and 1 for a > b.
1096
   We use the processor's default collating sequence.  */
1097
 
1098
int
1099
gfc_compare_string (gfc_expr *a, gfc_expr *b)
1100
{
1101
  int len, alen, blen, i;
1102
  gfc_char_t ac, bc;
1103
 
1104
  alen = a->value.character.length;
1105
  blen = b->value.character.length;
1106
 
1107
  len = MAX(alen, blen);
1108
 
1109
  for (i = 0; i < len; i++)
1110
    {
1111
      ac = ((i < alen) ? a->value.character.string[i] : ' ');
1112
      bc = ((i < blen) ? b->value.character.string[i] : ' ');
1113
 
1114
      if (ac < bc)
1115
        return -1;
1116
      if (ac > bc)
1117
        return 1;
1118
    }
1119
 
1120
  /* Strings are equal */
1121
  return 0;
1122
}
1123
 
1124
 
1125
int
1126
gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1127
{
1128
  int len, alen, blen, i;
1129
  gfc_char_t ac, bc;
1130
 
1131
  alen = a->value.character.length;
1132
  blen = strlen (b);
1133
 
1134
  len = MAX(alen, blen);
1135
 
1136
  for (i = 0; i < len; i++)
1137
    {
1138
      ac = ((i < alen) ? a->value.character.string[i] : ' ');
1139
      bc = ((i < blen) ? b[i] : ' ');
1140
 
1141
      if (!case_sensitive)
1142
        {
1143
          ac = TOLOWER (ac);
1144
          bc = TOLOWER (bc);
1145
        }
1146
 
1147
      if (ac < bc)
1148
        return -1;
1149
      if (ac > bc)
1150
        return 1;
1151
    }
1152
 
1153
  /* Strings are equal */
1154
  return 0;
1155
}
1156
 
1157
 
1158
/* Specific comparison subroutines.  */
1159
 
1160
static arith
1161
gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1162
{
1163
  gfc_expr *result;
1164
 
1165
  result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1166
                                &op1->where);
1167
  result->value.logical = (op1->ts.type == BT_COMPLEX)
1168
                        ? compare_complex (op1, op2)
1169
                        : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
1170
 
1171
  *resultp = result;
1172
  return ARITH_OK;
1173
}
1174
 
1175
 
1176
static arith
1177
gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1178
{
1179
  gfc_expr *result;
1180
 
1181
  result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1182
                                &op1->where);
1183
  result->value.logical = (op1->ts.type == BT_COMPLEX)
1184
                        ? !compare_complex (op1, op2)
1185
                        : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
1186
 
1187
  *resultp = result;
1188
  return ARITH_OK;
1189
}
1190
 
1191
 
1192
static arith
1193
gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1194
{
1195
  gfc_expr *result;
1196
 
1197
  result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1198
                                &op1->where);
1199
  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
1200
  *resultp = result;
1201
 
1202
  return ARITH_OK;
1203
}
1204
 
1205
 
1206
static arith
1207
gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1208
{
1209
  gfc_expr *result;
1210
 
1211
  result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1212
                                &op1->where);
1213
  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
1214
  *resultp = result;
1215
 
1216
  return ARITH_OK;
1217
}
1218
 
1219
 
1220
static arith
1221
gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1222
{
1223
  gfc_expr *result;
1224
 
1225
  result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1226
                                &op1->where);
1227
  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
1228
  *resultp = result;
1229
 
1230
  return ARITH_OK;
1231
}
1232
 
1233
 
1234
static arith
1235
gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1236
{
1237
  gfc_expr *result;
1238
 
1239
  result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
1240
                                &op1->where);
1241
  result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
1242
  *resultp = result;
1243
 
1244
  return ARITH_OK;
1245
}
1246
 
1247
 
1248
static arith
1249
reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
1250
              gfc_expr **result)
1251
{
1252
  gfc_constructor *c, *head;
1253
  gfc_expr *r;
1254
  arith rc;
1255
 
1256
  if (op->expr_type == EXPR_CONSTANT)
1257
    return eval (op, result);
1258
 
1259
  rc = ARITH_OK;
1260
  head = gfc_copy_constructor (op->value.constructor);
1261
 
1262
  for (c = head; c; c = c->next)
1263
    {
1264
      rc = reduce_unary (eval, c->expr, &r);
1265
 
1266
      if (rc != ARITH_OK)
1267
        break;
1268
 
1269
      gfc_replace_expr (c->expr, r);
1270
    }
1271
 
1272
  if (rc != ARITH_OK)
1273
    gfc_free_constructor (head);
1274
  else
1275
    {
1276
      r = gfc_get_expr ();
1277
      r->expr_type = EXPR_ARRAY;
1278
      r->value.constructor = head;
1279
      r->shape = gfc_copy_shape (op->shape, op->rank);
1280
 
1281
      r->ts = head->expr->ts;
1282
      r->where = op->where;
1283
      r->rank = op->rank;
1284
 
1285
      *result = r;
1286
    }
1287
 
1288
  return rc;
1289
}
1290
 
1291
 
1292
static arith
1293
reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1294
                  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1295
{
1296
  gfc_constructor *c, *head;
1297
  gfc_expr *r;
1298
  arith rc;
1299
 
1300
  head = gfc_copy_constructor (op1->value.constructor);
1301
  rc = ARITH_OK;
1302
 
1303
  for (c = head; c; c = c->next)
1304
    {
1305
      if (c->expr->expr_type == EXPR_CONSTANT)
1306
        rc = eval (c->expr, op2, &r);
1307
      else
1308
        rc = reduce_binary_ac (eval, c->expr, op2, &r);
1309
 
1310
      if (rc != ARITH_OK)
1311
        break;
1312
 
1313
      gfc_replace_expr (c->expr, r);
1314
    }
1315
 
1316
  if (rc != ARITH_OK)
1317
    gfc_free_constructor (head);
1318
  else
1319
    {
1320
      r = gfc_get_expr ();
1321
      r->expr_type = EXPR_ARRAY;
1322
      r->value.constructor = head;
1323
      r->shape = gfc_copy_shape (op1->shape, op1->rank);
1324
 
1325
      r->ts = head->expr->ts;
1326
      r->where = op1->where;
1327
      r->rank = op1->rank;
1328
 
1329
      *result = r;
1330
    }
1331
 
1332
  return rc;
1333
}
1334
 
1335
 
1336
static arith
1337
reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1338
                  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1339
{
1340
  gfc_constructor *c, *head;
1341
  gfc_expr *r;
1342
  arith rc;
1343
 
1344
  head = gfc_copy_constructor (op2->value.constructor);
1345
  rc = ARITH_OK;
1346
 
1347
  for (c = head; c; c = c->next)
1348
    {
1349
      if (c->expr->expr_type == EXPR_CONSTANT)
1350
        rc = eval (op1, c->expr, &r);
1351
      else
1352
        rc = reduce_binary_ca (eval, op1, c->expr, &r);
1353
 
1354
      if (rc != ARITH_OK)
1355
        break;
1356
 
1357
      gfc_replace_expr (c->expr, r);
1358
    }
1359
 
1360
  if (rc != ARITH_OK)
1361
    gfc_free_constructor (head);
1362
  else
1363
    {
1364
      r = gfc_get_expr ();
1365
      r->expr_type = EXPR_ARRAY;
1366
      r->value.constructor = head;
1367
      r->shape = gfc_copy_shape (op2->shape, op2->rank);
1368
 
1369
      r->ts = head->expr->ts;
1370
      r->where = op2->where;
1371
      r->rank = op2->rank;
1372
 
1373
      *result = r;
1374
    }
1375
 
1376
  return rc;
1377
}
1378
 
1379
 
1380
/* We need a forward declaration of reduce_binary.  */
1381
static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1382
                            gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
1383
 
1384
 
1385
static arith
1386
reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1387
                  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1388
{
1389
  gfc_constructor *c, *d, *head;
1390
  gfc_expr *r;
1391
  arith rc;
1392
 
1393
  head = gfc_copy_constructor (op1->value.constructor);
1394
 
1395
  rc = ARITH_OK;
1396
  d = op2->value.constructor;
1397
 
1398
  if (gfc_check_conformance (op1, op2, "elemental binary operation")
1399
      != SUCCESS)
1400
    rc = ARITH_INCOMMENSURATE;
1401
  else
1402
    {
1403
      for (c = head; c; c = c->next, d = d->next)
1404
        {
1405
          if (d == NULL)
1406
            {
1407
              rc = ARITH_INCOMMENSURATE;
1408
              break;
1409
            }
1410
 
1411
          rc = reduce_binary (eval, c->expr, d->expr, &r);
1412
          if (rc != ARITH_OK)
1413
            break;
1414
 
1415
          gfc_replace_expr (c->expr, r);
1416
        }
1417
 
1418
      if (d != NULL)
1419
        rc = ARITH_INCOMMENSURATE;
1420
    }
1421
 
1422
  if (rc != ARITH_OK)
1423
    gfc_free_constructor (head);
1424
  else
1425
    {
1426
      r = gfc_get_expr ();
1427
      r->expr_type = EXPR_ARRAY;
1428
      r->value.constructor = head;
1429
      r->shape = gfc_copy_shape (op1->shape, op1->rank);
1430
 
1431
      r->ts = head->expr->ts;
1432
      r->where = op1->where;
1433
      r->rank = op1->rank;
1434
 
1435
      *result = r;
1436
    }
1437
 
1438
  return rc;
1439
}
1440
 
1441
 
1442
static arith
1443
reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1444
               gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1445
{
1446
  if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
1447
    return eval (op1, op2, result);
1448
 
1449
  if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
1450
    return reduce_binary_ca (eval, op1, op2, result);
1451
 
1452
  if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
1453
    return reduce_binary_ac (eval, op1, op2, result);
1454
 
1455
  return reduce_binary_aa (eval, op1, op2, result);
1456
}
1457
 
1458
 
1459
typedef union
1460
{
1461
  arith (*f2)(gfc_expr *, gfc_expr **);
1462
  arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1463
}
1464
eval_f;
1465
 
1466
/* High level arithmetic subroutines.  These subroutines go into
1467
   eval_intrinsic(), which can do one of several things to its
1468
   operands.  If the operands are incompatible with the intrinsic
1469
   operation, we return a node pointing to the operands and hope that
1470
   an operator interface is found during resolution.
1471
 
1472
   If the operands are compatible and are constants, then we try doing
1473
   the arithmetic.  We also handle the cases where either or both
1474
   operands are array constructors.  */
1475
 
1476
static gfc_expr *
1477
eval_intrinsic (gfc_intrinsic_op op,
1478
                eval_f eval, gfc_expr *op1, gfc_expr *op2)
1479
{
1480
  gfc_expr temp, *result;
1481
  int unary;
1482
  arith rc;
1483
 
1484
  gfc_clear_ts (&temp.ts);
1485
 
1486
  switch (op)
1487
    {
1488
    /* Logical unary  */
1489
    case INTRINSIC_NOT:
1490
      if (op1->ts.type != BT_LOGICAL)
1491
        goto runtime;
1492
 
1493
      temp.ts.type = BT_LOGICAL;
1494
      temp.ts.kind = gfc_default_logical_kind;
1495
      unary = 1;
1496
      break;
1497
 
1498
    /* Logical binary operators  */
1499
    case INTRINSIC_OR:
1500
    case INTRINSIC_AND:
1501
    case INTRINSIC_NEQV:
1502
    case INTRINSIC_EQV:
1503
      if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
1504
        goto runtime;
1505
 
1506
      temp.ts.type = BT_LOGICAL;
1507
      temp.ts.kind = gfc_default_logical_kind;
1508
      unary = 0;
1509
      break;
1510
 
1511
    /* Numeric unary  */
1512
    case INTRINSIC_UPLUS:
1513
    case INTRINSIC_UMINUS:
1514
      if (!gfc_numeric_ts (&op1->ts))
1515
        goto runtime;
1516
 
1517
      temp.ts = op1->ts;
1518
      unary = 1;
1519
      break;
1520
 
1521
    case INTRINSIC_PARENTHESES:
1522
      temp.ts = op1->ts;
1523
      unary = 1;
1524
      break;
1525
 
1526
    /* Additional restrictions for ordering relations.  */
1527
    case INTRINSIC_GE:
1528
    case INTRINSIC_GE_OS:
1529
    case INTRINSIC_LT:
1530
    case INTRINSIC_LT_OS:
1531
    case INTRINSIC_LE:
1532
    case INTRINSIC_LE_OS:
1533
    case INTRINSIC_GT:
1534
    case INTRINSIC_GT_OS:
1535
      if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1536
        {
1537
          temp.ts.type = BT_LOGICAL;
1538
          temp.ts.kind = gfc_default_logical_kind;
1539
          goto runtime;
1540
        }
1541
 
1542
    /* Fall through  */
1543
    case INTRINSIC_EQ:
1544
    case INTRINSIC_EQ_OS:
1545
    case INTRINSIC_NE:
1546
    case INTRINSIC_NE_OS:
1547
      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1548
        {
1549
          unary = 0;
1550
          temp.ts.type = BT_LOGICAL;
1551
          temp.ts.kind = gfc_default_logical_kind;
1552
 
1553
          /* If kind mismatch, exit and we'll error out later.  */
1554
          if (op1->ts.kind != op2->ts.kind)
1555
            goto runtime;
1556
 
1557
          break;
1558
        }
1559
 
1560
    /* Fall through  */
1561
    /* Numeric binary  */
1562
    case INTRINSIC_PLUS:
1563
    case INTRINSIC_MINUS:
1564
    case INTRINSIC_TIMES:
1565
    case INTRINSIC_DIVIDE:
1566
    case INTRINSIC_POWER:
1567
      if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
1568
        goto runtime;
1569
 
1570
      /* Insert any necessary type conversions to make the operands
1571
         compatible.  */
1572
 
1573
      temp.expr_type = EXPR_OP;
1574
      gfc_clear_ts (&temp.ts);
1575
      temp.value.op.op = op;
1576
 
1577
      temp.value.op.op1 = op1;
1578
      temp.value.op.op2 = op2;
1579
 
1580
      gfc_type_convert_binary (&temp, 0);
1581
 
1582
      if (op == INTRINSIC_EQ || op == INTRINSIC_NE
1583
          || op == INTRINSIC_GE || op == INTRINSIC_GT
1584
          || op == INTRINSIC_LE || op == INTRINSIC_LT
1585
          || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
1586
          || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
1587
          || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
1588
        {
1589
          temp.ts.type = BT_LOGICAL;
1590
          temp.ts.kind = gfc_default_logical_kind;
1591
        }
1592
 
1593
      unary = 0;
1594
      break;
1595
 
1596
    /* Character binary  */
1597
    case INTRINSIC_CONCAT:
1598
      if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
1599
          || op1->ts.kind != op2->ts.kind)
1600
        goto runtime;
1601
 
1602
      temp.ts.type = BT_CHARACTER;
1603
      temp.ts.kind = op1->ts.kind;
1604
      unary = 0;
1605
      break;
1606
 
1607
    case INTRINSIC_USER:
1608
      goto runtime;
1609
 
1610
    default:
1611
      gfc_internal_error ("eval_intrinsic(): Bad operator");
1612
    }
1613
 
1614
  if (op1->expr_type != EXPR_CONSTANT
1615
      && (op1->expr_type != EXPR_ARRAY
1616
          || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
1617
    goto runtime;
1618
 
1619
  if (op2 != NULL
1620
      && op2->expr_type != EXPR_CONSTANT
1621
         && (op2->expr_type != EXPR_ARRAY
1622
             || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
1623
    goto runtime;
1624
 
1625
  if (unary)
1626
    rc = reduce_unary (eval.f2, op1, &result);
1627
  else
1628
    rc = reduce_binary (eval.f3, op1, op2, &result);
1629
 
1630
 
1631
  /* Something went wrong.  */
1632
  if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
1633
    return NULL;
1634
 
1635
  if (rc != ARITH_OK)
1636
    {
1637
      gfc_error (gfc_arith_error (rc), &op1->where);
1638
      return NULL;
1639
    }
1640
 
1641
  gfc_free_expr (op1);
1642
  gfc_free_expr (op2);
1643
  return result;
1644
 
1645
runtime:
1646
  /* Create a run-time expression.  */
1647
  result = gfc_get_expr ();
1648
  result->ts = temp.ts;
1649
 
1650
  result->expr_type = EXPR_OP;
1651
  result->value.op.op = op;
1652
 
1653
  result->value.op.op1 = op1;
1654
  result->value.op.op2 = op2;
1655
 
1656
  result->where = op1->where;
1657
 
1658
  return result;
1659
}
1660
 
1661
 
1662
/* Modify type of expression for zero size array.  */
1663
 
1664
static gfc_expr *
1665
eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1666
{
1667
  if (op == NULL)
1668
    gfc_internal_error ("eval_type_intrinsic0(): op NULL");
1669
 
1670
  switch (iop)
1671
    {
1672
    case INTRINSIC_GE:
1673
    case INTRINSIC_GE_OS:
1674
    case INTRINSIC_LT:
1675
    case INTRINSIC_LT_OS:
1676
    case INTRINSIC_LE:
1677
    case INTRINSIC_LE_OS:
1678
    case INTRINSIC_GT:
1679
    case INTRINSIC_GT_OS:
1680
    case INTRINSIC_EQ:
1681
    case INTRINSIC_EQ_OS:
1682
    case INTRINSIC_NE:
1683
    case INTRINSIC_NE_OS:
1684
      op->ts.type = BT_LOGICAL;
1685
      op->ts.kind = gfc_default_logical_kind;
1686
      break;
1687
 
1688
    default:
1689
      break;
1690
    }
1691
 
1692
  return op;
1693
}
1694
 
1695
 
1696
/* Return nonzero if the expression is a zero size array.  */
1697
 
1698
static int
1699
gfc_zero_size_array (gfc_expr *e)
1700
{
1701
  if (e->expr_type != EXPR_ARRAY)
1702
    return 0;
1703
 
1704
  return e->value.constructor == NULL;
1705
}
1706
 
1707
 
1708
/* Reduce a binary expression where at least one of the operands
1709
   involves a zero-length array.  Returns NULL if neither of the
1710
   operands is a zero-length array.  */
1711
 
1712
static gfc_expr *
1713
reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1714
{
1715
  if (gfc_zero_size_array (op1))
1716
    {
1717
      gfc_free_expr (op2);
1718
      return op1;
1719
    }
1720
 
1721
  if (gfc_zero_size_array (op2))
1722
    {
1723
      gfc_free_expr (op1);
1724
      return op2;
1725
    }
1726
 
1727
  return NULL;
1728
}
1729
 
1730
 
1731
static gfc_expr *
1732
eval_intrinsic_f2 (gfc_intrinsic_op op,
1733
                   arith (*eval) (gfc_expr *, gfc_expr **),
1734
                   gfc_expr *op1, gfc_expr *op2)
1735
{
1736
  gfc_expr *result;
1737
  eval_f f;
1738
 
1739
  if (op2 == NULL)
1740
    {
1741
      if (gfc_zero_size_array (op1))
1742
        return eval_type_intrinsic0 (op, op1);
1743
    }
1744
  else
1745
    {
1746
      result = reduce_binary0 (op1, op2);
1747
      if (result != NULL)
1748
        return eval_type_intrinsic0 (op, result);
1749
    }
1750
 
1751
  f.f2 = eval;
1752
  return eval_intrinsic (op, f, op1, op2);
1753
}
1754
 
1755
 
1756
static gfc_expr *
1757
eval_intrinsic_f3 (gfc_intrinsic_op op,
1758
                   arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
1759
                   gfc_expr *op1, gfc_expr *op2)
1760
{
1761
  gfc_expr *result;
1762
  eval_f f;
1763
 
1764
  result = reduce_binary0 (op1, op2);
1765
  if (result != NULL)
1766
    return eval_type_intrinsic0(op, result);
1767
 
1768
  f.f3 = eval;
1769
  return eval_intrinsic (op, f, op1, op2);
1770
}
1771
 
1772
 
1773
gfc_expr *
1774
gfc_parentheses (gfc_expr *op)
1775
{
1776
  if (gfc_is_constant_expr (op))
1777
    return op;
1778
 
1779
  return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
1780
                            op, NULL);
1781
}
1782
 
1783
gfc_expr *
1784
gfc_uplus (gfc_expr *op)
1785
{
1786
  return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
1787
}
1788
 
1789
 
1790
gfc_expr *
1791
gfc_uminus (gfc_expr *op)
1792
{
1793
  return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
1794
}
1795
 
1796
 
1797
gfc_expr *
1798
gfc_add (gfc_expr *op1, gfc_expr *op2)
1799
{
1800
  return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1801
}
1802
 
1803
 
1804
gfc_expr *
1805
gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1806
{
1807
  return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1808
}
1809
 
1810
 
1811
gfc_expr *
1812
gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1813
{
1814
  return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1815
}
1816
 
1817
 
1818
gfc_expr *
1819
gfc_divide (gfc_expr *op1, gfc_expr *op2)
1820
{
1821
  return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1822
}
1823
 
1824
 
1825
gfc_expr *
1826
gfc_power (gfc_expr *op1, gfc_expr *op2)
1827
{
1828
  return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1829
}
1830
 
1831
 
1832
gfc_expr *
1833
gfc_concat (gfc_expr *op1, gfc_expr *op2)
1834
{
1835
  return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1836
}
1837
 
1838
 
1839
gfc_expr *
1840
gfc_and (gfc_expr *op1, gfc_expr *op2)
1841
{
1842
  return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1843
}
1844
 
1845
 
1846
gfc_expr *
1847
gfc_or (gfc_expr *op1, gfc_expr *op2)
1848
{
1849
  return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1850
}
1851
 
1852
 
1853
gfc_expr *
1854
gfc_not (gfc_expr *op1)
1855
{
1856
  return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
1857
}
1858
 
1859
 
1860
gfc_expr *
1861
gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1862
{
1863
  return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1864
}
1865
 
1866
 
1867
gfc_expr *
1868
gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1869
{
1870
  return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1871
}
1872
 
1873
 
1874
gfc_expr *
1875
gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1876
{
1877
  return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1878
}
1879
 
1880
 
1881
gfc_expr *
1882
gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1883
{
1884
  return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1885
}
1886
 
1887
 
1888
gfc_expr *
1889
gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1890
{
1891
  return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1892
}
1893
 
1894
 
1895
gfc_expr *
1896
gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1897
{
1898
  return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
1899
}
1900
 
1901
 
1902
gfc_expr *
1903
gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1904
{
1905
  return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
1906
}
1907
 
1908
 
1909
gfc_expr *
1910
gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1911
{
1912
  return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1913
}
1914
 
1915
 
1916
/* Convert an integer string to an expression node.  */
1917
 
1918
gfc_expr *
1919
gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
1920
{
1921
  gfc_expr *e;
1922
  const char *t;
1923
 
1924
  e = gfc_constant_result (BT_INTEGER, kind, where);
1925
  /* A leading plus is allowed, but not by mpz_set_str.  */
1926
  if (buffer[0] == '+')
1927
    t = buffer + 1;
1928
  else
1929
    t = buffer;
1930
  mpz_set_str (e->value.integer, t, radix);
1931
 
1932
  return e;
1933
}
1934
 
1935
 
1936
/* Convert a real string to an expression node.  */
1937
 
1938
gfc_expr *
1939
gfc_convert_real (const char *buffer, int kind, locus *where)
1940
{
1941
  gfc_expr *e;
1942
 
1943
  e = gfc_constant_result (BT_REAL, kind, where);
1944
  mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
1945
 
1946
  return e;
1947
}
1948
 
1949
 
1950
/* Convert a pair of real, constant expression nodes to a single
1951
   complex expression node.  */
1952
 
1953
gfc_expr *
1954
gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
1955
{
1956
  gfc_expr *e;
1957
 
1958
  e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
1959
  mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
1960
                 GFC_MPC_RND_MODE);
1961
 
1962
  return e;
1963
}
1964
 
1965
 
1966
/******* Simplification of intrinsic functions with constant arguments *****/
1967
 
1968
 
1969
/* Deal with an arithmetic error.  */
1970
 
1971
static void
1972
arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
1973
{
1974
  switch (rc)
1975
    {
1976
    case ARITH_OK:
1977
      gfc_error ("Arithmetic OK converting %s to %s at %L",
1978
                 gfc_typename (from), gfc_typename (to), where);
1979
      break;
1980
    case ARITH_OVERFLOW:
1981
      gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
1982
                 "can be disabled with the option -fno-range-check",
1983
                 gfc_typename (from), gfc_typename (to), where);
1984
      break;
1985
    case ARITH_UNDERFLOW:
1986
      gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
1987
                 "can be disabled with the option -fno-range-check",
1988
                 gfc_typename (from), gfc_typename (to), where);
1989
      break;
1990
    case ARITH_NAN:
1991
      gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
1992
                 "can be disabled with the option -fno-range-check",
1993
                 gfc_typename (from), gfc_typename (to), where);
1994
      break;
1995
    case ARITH_DIV0:
1996
      gfc_error ("Division by zero converting %s to %s at %L",
1997
                 gfc_typename (from), gfc_typename (to), where);
1998
      break;
1999
    case ARITH_INCOMMENSURATE:
2000
      gfc_error ("Array operands are incommensurate converting %s to %s at %L",
2001
                 gfc_typename (from), gfc_typename (to), where);
2002
      break;
2003
    case ARITH_ASYMMETRIC:
2004
      gfc_error ("Integer outside symmetric range implied by Standard Fortran"
2005
                 " converting %s to %s at %L",
2006
                 gfc_typename (from), gfc_typename (to), where);
2007
      break;
2008
    default:
2009
      gfc_internal_error ("gfc_arith_error(): Bad error code");
2010
    }
2011
 
2012
  /* TODO: Do something about the error, i.e., throw exception, return
2013
     NaN, etc.  */
2014
}
2015
 
2016
 
2017
/* Convert integers to integers.  */
2018
 
2019
gfc_expr *
2020
gfc_int2int (gfc_expr *src, int kind)
2021
{
2022
  gfc_expr *result;
2023
  arith rc;
2024
 
2025
  result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2026
 
2027
  mpz_set (result->value.integer, src->value.integer);
2028
 
2029
  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2030
    {
2031
      if (rc == ARITH_ASYMMETRIC)
2032
        {
2033
          gfc_warning (gfc_arith_error (rc), &src->where);
2034
        }
2035
      else
2036
        {
2037
          arith_error (rc, &src->ts, &result->ts, &src->where);
2038
          gfc_free_expr (result);
2039
          return NULL;
2040
        }
2041
    }
2042
 
2043
  return result;
2044
}
2045
 
2046
 
2047
/* Convert integers to reals.  */
2048
 
2049
gfc_expr *
2050
gfc_int2real (gfc_expr *src, int kind)
2051
{
2052
  gfc_expr *result;
2053
  arith rc;
2054
 
2055
  result = gfc_constant_result (BT_REAL, kind, &src->where);
2056
 
2057
  mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
2058
 
2059
  if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
2060
    {
2061
      arith_error (rc, &src->ts, &result->ts, &src->where);
2062
      gfc_free_expr (result);
2063
      return NULL;
2064
    }
2065
 
2066
  return result;
2067
}
2068
 
2069
 
2070
/* Convert default integer to default complex.  */
2071
 
2072
gfc_expr *
2073
gfc_int2complex (gfc_expr *src, int kind)
2074
{
2075
  gfc_expr *result;
2076
  arith rc;
2077
 
2078
  result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2079
 
2080
  mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
2081
 
2082
  if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
2083
      != ARITH_OK)
2084
    {
2085
      arith_error (rc, &src->ts, &result->ts, &src->where);
2086
      gfc_free_expr (result);
2087
      return NULL;
2088
    }
2089
 
2090
  return result;
2091
}
2092
 
2093
 
2094
/* Convert default real to default integer.  */
2095
 
2096
gfc_expr *
2097
gfc_real2int (gfc_expr *src, int kind)
2098
{
2099
  gfc_expr *result;
2100
  arith rc;
2101
 
2102
  result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2103
 
2104
  gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
2105
 
2106
  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2107
    {
2108
      arith_error (rc, &src->ts, &result->ts, &src->where);
2109
      gfc_free_expr (result);
2110
      return NULL;
2111
    }
2112
 
2113
  return result;
2114
}
2115
 
2116
 
2117
/* Convert real to real.  */
2118
 
2119
gfc_expr *
2120
gfc_real2real (gfc_expr *src, int kind)
2121
{
2122
  gfc_expr *result;
2123
  arith rc;
2124
 
2125
  result = gfc_constant_result (BT_REAL, kind, &src->where);
2126
 
2127
  mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
2128
 
2129
  rc = gfc_check_real_range (result->value.real, kind);
2130
 
2131
  if (rc == ARITH_UNDERFLOW)
2132
    {
2133
      if (gfc_option.warn_underflow)
2134
        gfc_warning (gfc_arith_error (rc), &src->where);
2135
      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2136
    }
2137
  else if (rc != ARITH_OK)
2138
    {
2139
      arith_error (rc, &src->ts, &result->ts, &src->where);
2140
      gfc_free_expr (result);
2141
      return NULL;
2142
    }
2143
 
2144
  return result;
2145
}
2146
 
2147
 
2148
/* Convert real to complex.  */
2149
 
2150
gfc_expr *
2151
gfc_real2complex (gfc_expr *src, int kind)
2152
{
2153
  gfc_expr *result;
2154
  arith rc;
2155
 
2156
  result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2157
 
2158
  mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
2159
 
2160
  rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2161
 
2162
  if (rc == ARITH_UNDERFLOW)
2163
    {
2164
      if (gfc_option.warn_underflow)
2165
        gfc_warning (gfc_arith_error (rc), &src->where);
2166
      mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2167
    }
2168
  else if (rc != ARITH_OK)
2169
    {
2170
      arith_error (rc, &src->ts, &result->ts, &src->where);
2171
      gfc_free_expr (result);
2172
      return NULL;
2173
    }
2174
 
2175
  return result;
2176
}
2177
 
2178
 
2179
/* Convert complex to integer.  */
2180
 
2181
gfc_expr *
2182
gfc_complex2int (gfc_expr *src, int kind)
2183
{
2184
  gfc_expr *result;
2185
  arith rc;
2186
 
2187
  result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2188
 
2189
  gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
2190
                   &src->where);
2191
 
2192
  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
2193
    {
2194
      arith_error (rc, &src->ts, &result->ts, &src->where);
2195
      gfc_free_expr (result);
2196
      return NULL;
2197
    }
2198
 
2199
  return result;
2200
}
2201
 
2202
 
2203
/* Convert complex to real.  */
2204
 
2205
gfc_expr *
2206
gfc_complex2real (gfc_expr *src, int kind)
2207
{
2208
  gfc_expr *result;
2209
  arith rc;
2210
 
2211
  result = gfc_constant_result (BT_REAL, kind, &src->where);
2212
 
2213
  mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
2214
 
2215
  rc = gfc_check_real_range (result->value.real, kind);
2216
 
2217
  if (rc == ARITH_UNDERFLOW)
2218
    {
2219
      if (gfc_option.warn_underflow)
2220
        gfc_warning (gfc_arith_error (rc), &src->where);
2221
      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2222
    }
2223
  if (rc != ARITH_OK)
2224
    {
2225
      arith_error (rc, &src->ts, &result->ts, &src->where);
2226
      gfc_free_expr (result);
2227
      return NULL;
2228
    }
2229
 
2230
  return result;
2231
}
2232
 
2233
 
2234
/* Convert complex to complex.  */
2235
 
2236
gfc_expr *
2237
gfc_complex2complex (gfc_expr *src, int kind)
2238
{
2239
  gfc_expr *result;
2240
  arith rc;
2241
 
2242
  result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
2243
 
2244
  mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
2245
 
2246
  rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
2247
 
2248
  if (rc == ARITH_UNDERFLOW)
2249
    {
2250
      if (gfc_option.warn_underflow)
2251
        gfc_warning (gfc_arith_error (rc), &src->where);
2252
      mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
2253
    }
2254
  else if (rc != ARITH_OK)
2255
    {
2256
      arith_error (rc, &src->ts, &result->ts, &src->where);
2257
      gfc_free_expr (result);
2258
      return NULL;
2259
    }
2260
 
2261
  rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
2262
 
2263
  if (rc == ARITH_UNDERFLOW)
2264
    {
2265
      if (gfc_option.warn_underflow)
2266
        gfc_warning (gfc_arith_error (rc), &src->where);
2267
      mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
2268
    }
2269
  else if (rc != ARITH_OK)
2270
    {
2271
      arith_error (rc, &src->ts, &result->ts, &src->where);
2272
      gfc_free_expr (result);
2273
      return NULL;
2274
    }
2275
 
2276
  return result;
2277
}
2278
 
2279
 
2280
/* Logical kind conversion.  */
2281
 
2282
gfc_expr *
2283
gfc_log2log (gfc_expr *src, int kind)
2284
{
2285
  gfc_expr *result;
2286
 
2287
  result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2288
  result->value.logical = src->value.logical;
2289
 
2290
  return result;
2291
}
2292
 
2293
 
2294
/* Convert logical to integer.  */
2295
 
2296
gfc_expr *
2297
gfc_log2int (gfc_expr *src, int kind)
2298
{
2299
  gfc_expr *result;
2300
 
2301
  result = gfc_constant_result (BT_INTEGER, kind, &src->where);
2302
  mpz_set_si (result->value.integer, src->value.logical);
2303
 
2304
  return result;
2305
}
2306
 
2307
 
2308
/* Convert integer to logical.  */
2309
 
2310
gfc_expr *
2311
gfc_int2log (gfc_expr *src, int kind)
2312
{
2313
  gfc_expr *result;
2314
 
2315
  result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
2316
  result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2317
 
2318
  return result;
2319
}
2320
 
2321
 
2322
/* Helper function to set the representation in a Hollerith conversion.
2323
   This assumes that the ts.type and ts.kind of the result have already
2324
   been set.  */
2325
 
2326
static void
2327
hollerith2representation (gfc_expr *result, gfc_expr *src)
2328
{
2329
  int src_len, result_len;
2330
 
2331
  src_len = src->representation.length;
2332
  result_len = gfc_target_expr_size (result);
2333
 
2334
  if (src_len > result_len)
2335
    {
2336
      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
2337
                   &src->where, gfc_typename(&result->ts));
2338
    }
2339
 
2340
  result->representation.string = XCNEWVEC (char, result_len + 1);
2341
  memcpy (result->representation.string, src->representation.string,
2342
          MIN (result_len, src_len));
2343
 
2344
  if (src_len < result_len)
2345
    memset (&result->representation.string[src_len], ' ', result_len - src_len);
2346
 
2347
  result->representation.string[result_len] = '\0'; /* For debugger  */
2348
  result->representation.length = result_len;
2349
}
2350
 
2351
 
2352
/* Convert Hollerith to integer. The constant will be padded or truncated.  */
2353
 
2354
gfc_expr *
2355
gfc_hollerith2int (gfc_expr *src, int kind)
2356
{
2357
  gfc_expr *result;
2358
 
2359
  result = gfc_get_expr ();
2360
  result->expr_type = EXPR_CONSTANT;
2361
  result->ts.type = BT_INTEGER;
2362
  result->ts.kind = kind;
2363
  result->where = src->where;
2364
 
2365
  hollerith2representation (result, src);
2366
  gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
2367
                         result->representation.length, result->value.integer);
2368
 
2369
  return result;
2370
}
2371
 
2372
 
2373
/* Convert Hollerith to real. The constant will be padded or truncated.  */
2374
 
2375
gfc_expr *
2376
gfc_hollerith2real (gfc_expr *src, int kind)
2377
{
2378
  gfc_expr *result;
2379
 
2380
  result = gfc_get_expr ();
2381
  result->expr_type = EXPR_CONSTANT;
2382
  result->ts.type = BT_REAL;
2383
  result->ts.kind = kind;
2384
  result->where = src->where;
2385
 
2386
  hollerith2representation (result, src);
2387
  gfc_interpret_float (kind, (unsigned char *) result->representation.string,
2388
                       result->representation.length, result->value.real);
2389
 
2390
  return result;
2391
}
2392
 
2393
 
2394
/* Convert Hollerith to complex. The constant will be padded or truncated.  */
2395
 
2396
gfc_expr *
2397
gfc_hollerith2complex (gfc_expr *src, int kind)
2398
{
2399
  gfc_expr *result;
2400
 
2401
  result = gfc_get_expr ();
2402
  result->expr_type = EXPR_CONSTANT;
2403
  result->ts.type = BT_COMPLEX;
2404
  result->ts.kind = kind;
2405
  result->where = src->where;
2406
 
2407
  hollerith2representation (result, src);
2408
  gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
2409
                         result->representation.length, result->value.complex);
2410
 
2411
  return result;
2412
}
2413
 
2414
 
2415
/* Convert Hollerith to character. */
2416
 
2417
gfc_expr *
2418
gfc_hollerith2character (gfc_expr *src, int kind)
2419
{
2420
  gfc_expr *result;
2421
 
2422
  result = gfc_copy_expr (src);
2423
  result->ts.type = BT_CHARACTER;
2424
  result->ts.kind = kind;
2425
 
2426
  result->value.character.length = result->representation.length;
2427
  result->value.character.string
2428
    = gfc_char_to_widechar (result->representation.string);
2429
 
2430
  return result;
2431
}
2432
 
2433
 
2434
/* Convert Hollerith to logical. The constant will be padded or truncated.  */
2435
 
2436
gfc_expr *
2437
gfc_hollerith2logical (gfc_expr *src, int kind)
2438
{
2439
  gfc_expr *result;
2440
 
2441
  result = gfc_get_expr ();
2442
  result->expr_type = EXPR_CONSTANT;
2443
  result->ts.type = BT_LOGICAL;
2444
  result->ts.kind = kind;
2445
  result->where = src->where;
2446
 
2447
  hollerith2representation (result, src);
2448
  gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
2449
                         result->representation.length, &result->value.logical);
2450
 
2451
  return result;
2452
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.