/* Compiler arithmetic
|
/* Compiler arithmetic
|
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
|
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Andy Vaught
|
Contributed by Andy Vaught
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
GCC is free software; you can redistribute it and/or modify it under
|
the terms of the GNU General Public License as published by the Free
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
/* Since target arithmetic must be done on the host, there has to
|
/* Since target arithmetic must be done on the host, there has to
|
be some way of evaluating arithmetic expressions as the host
|
be some way of evaluating arithmetic expressions as the host
|
would evaluate them. We use the GNU MP library and the MPFR
|
would evaluate them. We use the GNU MP library and the MPFR
|
library to do arithmetic, and this file provides the interface. */
|
library to do arithmetic, and this file provides the interface. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "flags.h"
|
#include "flags.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "arith.h"
|
#include "arith.h"
|
#include "target-memory.h"
|
#include "target-memory.h"
|
|
|
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
|
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
|
It's easily implemented with a few calls though. */
|
It's easily implemented with a few calls though. */
|
|
|
void
|
void
|
gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
|
gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
|
{
|
{
|
mp_exp_t e;
|
mp_exp_t e;
|
|
|
if (mpfr_inf_p (x) || mpfr_nan_p (x))
|
if (mpfr_inf_p (x) || mpfr_nan_p (x))
|
{
|
{
|
gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
|
gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
|
"to INTEGER", where);
|
"to INTEGER", where);
|
mpz_set_ui (z, 0);
|
mpz_set_ui (z, 0);
|
return;
|
return;
|
}
|
}
|
|
|
e = mpfr_get_z_exp (z, x);
|
e = mpfr_get_z_exp (z, x);
|
|
|
if (e > 0)
|
if (e > 0)
|
mpz_mul_2exp (z, z, e);
|
mpz_mul_2exp (z, z, e);
|
else
|
else
|
mpz_tdiv_q_2exp (z, z, -e);
|
mpz_tdiv_q_2exp (z, z, -e);
|
}
|
}
|
|
|
|
|
/* Set the model number precision by the requested KIND. */
|
/* Set the model number precision by the requested KIND. */
|
|
|
void
|
void
|
gfc_set_model_kind (int kind)
|
gfc_set_model_kind (int kind)
|
{
|
{
|
int index = gfc_validate_kind (BT_REAL, kind, false);
|
int index = gfc_validate_kind (BT_REAL, kind, false);
|
int base2prec;
|
int base2prec;
|
|
|
base2prec = gfc_real_kinds[index].digits;
|
base2prec = gfc_real_kinds[index].digits;
|
if (gfc_real_kinds[index].radix != 2)
|
if (gfc_real_kinds[index].radix != 2)
|
base2prec *= gfc_real_kinds[index].radix / 2;
|
base2prec *= gfc_real_kinds[index].radix / 2;
|
mpfr_set_default_prec (base2prec);
|
mpfr_set_default_prec (base2prec);
|
}
|
}
|
|
|
|
|
/* Set the model number precision from mpfr_t x. */
|
/* Set the model number precision from mpfr_t x. */
|
|
|
void
|
void
|
gfc_set_model (mpfr_t x)
|
gfc_set_model (mpfr_t x)
|
{
|
{
|
mpfr_set_default_prec (mpfr_get_prec (x));
|
mpfr_set_default_prec (mpfr_get_prec (x));
|
}
|
}
|
|
|
|
|
/* Given an arithmetic error code, return a pointer to a string that
|
/* Given an arithmetic error code, return a pointer to a string that
|
explains the error. */
|
explains the error. */
|
|
|
static const char *
|
static const char *
|
gfc_arith_error (arith code)
|
gfc_arith_error (arith code)
|
{
|
{
|
const char *p;
|
const char *p;
|
|
|
switch (code)
|
switch (code)
|
{
|
{
|
case ARITH_OK:
|
case ARITH_OK:
|
p = _("Arithmetic OK at %L");
|
p = _("Arithmetic OK at %L");
|
break;
|
break;
|
case ARITH_OVERFLOW:
|
case ARITH_OVERFLOW:
|
p = _("Arithmetic overflow at %L");
|
p = _("Arithmetic overflow at %L");
|
break;
|
break;
|
case ARITH_UNDERFLOW:
|
case ARITH_UNDERFLOW:
|
p = _("Arithmetic underflow at %L");
|
p = _("Arithmetic underflow at %L");
|
break;
|
break;
|
case ARITH_NAN:
|
case ARITH_NAN:
|
p = _("Arithmetic NaN at %L");
|
p = _("Arithmetic NaN at %L");
|
break;
|
break;
|
case ARITH_DIV0:
|
case ARITH_DIV0:
|
p = _("Division by zero at %L");
|
p = _("Division by zero at %L");
|
break;
|
break;
|
case ARITH_INCOMMENSURATE:
|
case ARITH_INCOMMENSURATE:
|
p = _("Array operands are incommensurate at %L");
|
p = _("Array operands are incommensurate at %L");
|
break;
|
break;
|
case ARITH_ASYMMETRIC:
|
case ARITH_ASYMMETRIC:
|
p =
|
p =
|
_("Integer outside symmetric range implied by Standard Fortran at %L");
|
_("Integer outside symmetric range implied by Standard Fortran at %L");
|
break;
|
break;
|
default:
|
default:
|
gfc_internal_error ("gfc_arith_error(): Bad error code");
|
gfc_internal_error ("gfc_arith_error(): Bad error code");
|
}
|
}
|
|
|
return p;
|
return p;
|
}
|
}
|
|
|
|
|
/* Get things ready to do math. */
|
/* Get things ready to do math. */
|
|
|
void
|
void
|
gfc_arith_init_1 (void)
|
gfc_arith_init_1 (void)
|
{
|
{
|
gfc_integer_info *int_info;
|
gfc_integer_info *int_info;
|
gfc_real_info *real_info;
|
gfc_real_info *real_info;
|
mpfr_t a, b;
|
mpfr_t a, b;
|
int i;
|
int i;
|
|
|
mpfr_set_default_prec (128);
|
mpfr_set_default_prec (128);
|
mpfr_init (a);
|
mpfr_init (a);
|
|
|
/* Convert the minimum and maximum values for each kind into their
|
/* Convert the minimum and maximum values for each kind into their
|
GNU MP representation. */
|
GNU MP representation. */
|
for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
|
for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
|
{
|
{
|
/* Huge */
|
/* Huge */
|
mpz_init (int_info->huge);
|
mpz_init (int_info->huge);
|
mpz_set_ui (int_info->huge, int_info->radix);
|
mpz_set_ui (int_info->huge, int_info->radix);
|
mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
|
mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
|
mpz_sub_ui (int_info->huge, int_info->huge, 1);
|
mpz_sub_ui (int_info->huge, int_info->huge, 1);
|
|
|
/* These are the numbers that are actually representable by the
|
/* These are the numbers that are actually representable by the
|
target. For bases other than two, this needs to be changed. */
|
target. For bases other than two, this needs to be changed. */
|
if (int_info->radix != 2)
|
if (int_info->radix != 2)
|
gfc_internal_error ("Fix min_int calculation");
|
gfc_internal_error ("Fix min_int calculation");
|
|
|
/* See PRs 13490 and 17912, related to integer ranges.
|
/* See PRs 13490 and 17912, related to integer ranges.
|
The pedantic_min_int exists for range checking when a program
|
The pedantic_min_int exists for range checking when a program
|
is compiled with -pedantic, and reflects the belief that
|
is compiled with -pedantic, and reflects the belief that
|
Standard Fortran requires integers to be symmetrical, i.e.
|
Standard Fortran requires integers to be symmetrical, i.e.
|
every negative integer must have a representable positive
|
every negative integer must have a representable positive
|
absolute value, and vice versa. */
|
absolute value, and vice versa. */
|
|
|
mpz_init (int_info->pedantic_min_int);
|
mpz_init (int_info->pedantic_min_int);
|
mpz_neg (int_info->pedantic_min_int, int_info->huge);
|
mpz_neg (int_info->pedantic_min_int, int_info->huge);
|
|
|
mpz_init (int_info->min_int);
|
mpz_init (int_info->min_int);
|
mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
|
mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
|
|
|
/* Range */
|
/* Range */
|
mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
|
mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
|
mpfr_log10 (a, a, GFC_RND_MODE);
|
mpfr_log10 (a, a, GFC_RND_MODE);
|
mpfr_trunc (a, a);
|
mpfr_trunc (a, a);
|
int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
|
int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
|
}
|
}
|
|
|
mpfr_clear (a);
|
mpfr_clear (a);
|
|
|
for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
|
for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
|
{
|
{
|
gfc_set_model_kind (real_info->kind);
|
gfc_set_model_kind (real_info->kind);
|
|
|
mpfr_init (a);
|
mpfr_init (a);
|
mpfr_init (b);
|
mpfr_init (b);
|
|
|
/* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
|
/* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */
|
/* 1 - b**(-p) */
|
/* 1 - b**(-p) */
|
mpfr_init (real_info->huge);
|
mpfr_init (real_info->huge);
|
mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
|
mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
|
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
|
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
|
mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
|
mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
|
mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
|
mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
|
|
|
/* b**(emax-1) */
|
/* b**(emax-1) */
|
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
|
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
|
mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
|
mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
|
|
|
/* (1 - b**(-p)) * b**(emax-1) */
|
/* (1 - b**(-p)) * b**(emax-1) */
|
mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
|
mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
|
|
|
/* (1 - b**(-p)) * b**(emax-1) * b */
|
/* (1 - b**(-p)) * b**(emax-1) * b */
|
mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
|
mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
|
|
/* tiny(x) = b**(emin-1) */
|
/* tiny(x) = b**(emin-1) */
|
mpfr_init (real_info->tiny);
|
mpfr_init (real_info->tiny);
|
mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
|
mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
|
mpfr_pow_si (real_info->tiny, real_info->tiny,
|
mpfr_pow_si (real_info->tiny, real_info->tiny,
|
real_info->min_exponent - 1, GFC_RND_MODE);
|
real_info->min_exponent - 1, GFC_RND_MODE);
|
|
|
/* subnormal (x) = b**(emin - digit) */
|
/* subnormal (x) = b**(emin - digit) */
|
mpfr_init (real_info->subnormal);
|
mpfr_init (real_info->subnormal);
|
mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
|
mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
|
mpfr_pow_si (real_info->subnormal, real_info->subnormal,
|
mpfr_pow_si (real_info->subnormal, real_info->subnormal,
|
real_info->min_exponent - real_info->digits, GFC_RND_MODE);
|
real_info->min_exponent - real_info->digits, GFC_RND_MODE);
|
|
|
/* epsilon(x) = b**(1-p) */
|
/* epsilon(x) = b**(1-p) */
|
mpfr_init (real_info->epsilon);
|
mpfr_init (real_info->epsilon);
|
mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
|
mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
|
mpfr_pow_si (real_info->epsilon, real_info->epsilon,
|
mpfr_pow_si (real_info->epsilon, real_info->epsilon,
|
1 - real_info->digits, GFC_RND_MODE);
|
1 - real_info->digits, GFC_RND_MODE);
|
|
|
/* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
|
/* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
|
mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
|
mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
|
mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
|
mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
|
mpfr_neg (b, b, GFC_RND_MODE);
|
mpfr_neg (b, b, GFC_RND_MODE);
|
|
|
/* a = min(a, b) */
|
/* a = min(a, b) */
|
mpfr_min (a, a, b, GFC_RND_MODE);
|
mpfr_min (a, a, b, GFC_RND_MODE);
|
mpfr_trunc (a, a);
|
mpfr_trunc (a, a);
|
real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
|
real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
|
|
|
/* precision(x) = int((p - 1) * log10(b)) + k */
|
/* precision(x) = int((p - 1) * log10(b)) + k */
|
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
|
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
|
mpfr_log10 (a, a, GFC_RND_MODE);
|
mpfr_log10 (a, a, GFC_RND_MODE);
|
mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
|
mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
|
mpfr_trunc (a, a);
|
mpfr_trunc (a, a);
|
real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
|
real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
|
|
|
/* If the radix is an integral power of 10, add one to the precision. */
|
/* If the radix is an integral power of 10, add one to the precision. */
|
for (i = 10; i <= real_info->radix; i *= 10)
|
for (i = 10; i <= real_info->radix; i *= 10)
|
if (i == real_info->radix)
|
if (i == real_info->radix)
|
real_info->precision++;
|
real_info->precision++;
|
|
|
mpfr_clears (a, b, NULL);
|
mpfr_clears (a, b, NULL);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Clean up, get rid of numeric constants. */
|
/* Clean up, get rid of numeric constants. */
|
|
|
void
|
void
|
gfc_arith_done_1 (void)
|
gfc_arith_done_1 (void)
|
{
|
{
|
gfc_integer_info *ip;
|
gfc_integer_info *ip;
|
gfc_real_info *rp;
|
gfc_real_info *rp;
|
|
|
for (ip = gfc_integer_kinds; ip->kind; ip++)
|
for (ip = gfc_integer_kinds; ip->kind; ip++)
|
{
|
{
|
mpz_clear (ip->min_int);
|
mpz_clear (ip->min_int);
|
mpz_clear (ip->pedantic_min_int);
|
mpz_clear (ip->pedantic_min_int);
|
mpz_clear (ip->huge);
|
mpz_clear (ip->huge);
|
}
|
}
|
|
|
for (rp = gfc_real_kinds; rp->kind; rp++)
|
for (rp = gfc_real_kinds; rp->kind; rp++)
|
mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
|
mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
|
}
|
}
|
|
|
|
|
/* Given a wide character value and a character kind, determine whether
|
/* Given a wide character value and a character kind, determine whether
|
the character is representable for that kind. */
|
the character is representable for that kind. */
|
bool
|
bool
|
gfc_check_character_range (gfc_char_t c, int kind)
|
gfc_check_character_range (gfc_char_t c, int kind)
|
{
|
{
|
/* As wide characters are stored as 32-bit values, they're all
|
/* As wide characters are stored as 32-bit values, they're all
|
representable in UCS=4. */
|
representable in UCS=4. */
|
if (kind == 4)
|
if (kind == 4)
|
return true;
|
return true;
|
|
|
if (kind == 1)
|
if (kind == 1)
|
return c <= 255 ? true : false;
|
return c <= 255 ? true : false;
|
|
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
|
|
/* Given an integer and a kind, make sure that the integer lies within
|
/* Given an integer and a kind, make sure that the integer lies within
|
the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
|
the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
|
ARITH_OVERFLOW. */
|
ARITH_OVERFLOW. */
|
|
|
arith
|
arith
|
gfc_check_integer_range (mpz_t p, int kind)
|
gfc_check_integer_range (mpz_t p, int kind)
|
{
|
{
|
arith result;
|
arith result;
|
int i;
|
int i;
|
|
|
i = gfc_validate_kind (BT_INTEGER, kind, false);
|
i = gfc_validate_kind (BT_INTEGER, kind, false);
|
result = ARITH_OK;
|
result = ARITH_OK;
|
|
|
if (pedantic)
|
if (pedantic)
|
{
|
{
|
if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
|
if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
|
result = ARITH_ASYMMETRIC;
|
result = ARITH_ASYMMETRIC;
|
}
|
}
|
|
|
|
|
if (gfc_option.flag_range_check == 0)
|
if (gfc_option.flag_range_check == 0)
|
return result;
|
return result;
|
|
|
if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
|
if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
|
|| mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
|
|| mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
|
result = ARITH_OVERFLOW;
|
result = ARITH_OVERFLOW;
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Given a real and a kind, make sure that the real lies within the
|
/* Given a real and a kind, make sure that the real lies within the
|
range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
|
range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
|
ARITH_UNDERFLOW. */
|
ARITH_UNDERFLOW. */
|
|
|
static arith
|
static arith
|
gfc_check_real_range (mpfr_t p, int kind)
|
gfc_check_real_range (mpfr_t p, int kind)
|
{
|
{
|
arith retval;
|
arith retval;
|
mpfr_t q;
|
mpfr_t q;
|
int i;
|
int i;
|
|
|
i = gfc_validate_kind (BT_REAL, kind, false);
|
i = gfc_validate_kind (BT_REAL, kind, false);
|
|
|
gfc_set_model (p);
|
gfc_set_model (p);
|
mpfr_init (q);
|
mpfr_init (q);
|
mpfr_abs (q, p, GFC_RND_MODE);
|
mpfr_abs (q, p, GFC_RND_MODE);
|
|
|
retval = ARITH_OK;
|
retval = ARITH_OK;
|
|
|
if (mpfr_inf_p (p))
|
if (mpfr_inf_p (p))
|
{
|
{
|
if (gfc_option.flag_range_check != 0)
|
if (gfc_option.flag_range_check != 0)
|
retval = ARITH_OVERFLOW;
|
retval = ARITH_OVERFLOW;
|
}
|
}
|
else if (mpfr_nan_p (p))
|
else if (mpfr_nan_p (p))
|
{
|
{
|
if (gfc_option.flag_range_check != 0)
|
if (gfc_option.flag_range_check != 0)
|
retval = ARITH_NAN;
|
retval = ARITH_NAN;
|
}
|
}
|
else if (mpfr_sgn (q) == 0)
|
else if (mpfr_sgn (q) == 0)
|
{
|
{
|
mpfr_clear (q);
|
mpfr_clear (q);
|
return retval;
|
return retval;
|
}
|
}
|
else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
|
else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
|
{
|
{
|
if (gfc_option.flag_range_check == 0)
|
if (gfc_option.flag_range_check == 0)
|
mpfr_set_inf (p, mpfr_sgn (p));
|
mpfr_set_inf (p, mpfr_sgn (p));
|
else
|
else
|
retval = ARITH_OVERFLOW;
|
retval = ARITH_OVERFLOW;
|
}
|
}
|
else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
|
else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
|
{
|
{
|
if (gfc_option.flag_range_check == 0)
|
if (gfc_option.flag_range_check == 0)
|
{
|
{
|
if (mpfr_sgn (p) < 0)
|
if (mpfr_sgn (p) < 0)
|
{
|
{
|
mpfr_set_ui (p, 0, GFC_RND_MODE);
|
mpfr_set_ui (p, 0, GFC_RND_MODE);
|
mpfr_set_si (q, -1, GFC_RND_MODE);
|
mpfr_set_si (q, -1, GFC_RND_MODE);
|
mpfr_copysign (p, p, q, GFC_RND_MODE);
|
mpfr_copysign (p, p, q, GFC_RND_MODE);
|
}
|
}
|
else
|
else
|
mpfr_set_ui (p, 0, GFC_RND_MODE);
|
mpfr_set_ui (p, 0, GFC_RND_MODE);
|
}
|
}
|
else
|
else
|
retval = ARITH_UNDERFLOW;
|
retval = ARITH_UNDERFLOW;
|
}
|
}
|
else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
|
else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
|
{
|
{
|
mp_exp_t emin, emax;
|
mp_exp_t emin, emax;
|
int en;
|
int en;
|
|
|
/* Save current values of emin and emax. */
|
/* Save current values of emin and emax. */
|
emin = mpfr_get_emin ();
|
emin = mpfr_get_emin ();
|
emax = mpfr_get_emax ();
|
emax = mpfr_get_emax ();
|
|
|
/* Set emin and emax for the current model number. */
|
/* Set emin and emax for the current model number. */
|
en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
|
en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
|
mpfr_set_emin ((mp_exp_t) en);
|
mpfr_set_emin ((mp_exp_t) en);
|
mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
|
mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
|
mpfr_check_range (q, 0, GFC_RND_MODE);
|
mpfr_check_range (q, 0, GFC_RND_MODE);
|
mpfr_subnormalize (q, 0, GFC_RND_MODE);
|
mpfr_subnormalize (q, 0, GFC_RND_MODE);
|
|
|
/* Reset emin and emax. */
|
/* Reset emin and emax. */
|
mpfr_set_emin (emin);
|
mpfr_set_emin (emin);
|
mpfr_set_emax (emax);
|
mpfr_set_emax (emax);
|
|
|
/* Copy sign if needed. */
|
/* Copy sign if needed. */
|
if (mpfr_sgn (p) < 0)
|
if (mpfr_sgn (p) < 0)
|
mpfr_neg (p, q, GMP_RNDN);
|
mpfr_neg (p, q, GMP_RNDN);
|
else
|
else
|
mpfr_set (p, q, GMP_RNDN);
|
mpfr_set (p, q, GMP_RNDN);
|
}
|
}
|
|
|
mpfr_clear (q);
|
mpfr_clear (q);
|
|
|
return retval;
|
return retval;
|
}
|
}
|
|
|
|
|
/* Function to return a constant expression node of a given type and kind. */
|
/* Function to return a constant expression node of a given type and kind. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_constant_result (bt type, int kind, locus *where)
|
gfc_constant_result (bt type, int kind, locus *where)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
if (!where)
|
if (!where)
|
gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
|
gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
|
|
|
result = gfc_get_expr ();
|
result = gfc_get_expr ();
|
|
|
result->expr_type = EXPR_CONSTANT;
|
result->expr_type = EXPR_CONSTANT;
|
result->ts.type = type;
|
result->ts.type = type;
|
result->ts.kind = kind;
|
result->ts.kind = kind;
|
result->where = *where;
|
result->where = *where;
|
|
|
switch (type)
|
switch (type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
mpz_init (result->value.integer);
|
mpz_init (result->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
gfc_set_model_kind (kind);
|
gfc_set_model_kind (kind);
|
mpfr_init (result->value.real);
|
mpfr_init (result->value.real);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
gfc_set_model_kind (kind);
|
gfc_set_model_kind (kind);
|
mpc_init2 (result->value.complex, mpfr_get_default_prec());
|
mpc_init2 (result->value.complex, mpfr_get_default_prec());
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Low-level arithmetic functions. All of these subroutines assume
|
/* Low-level arithmetic functions. All of these subroutines assume
|
that all operands are of the same type and return an operand of the
|
that all operands are of the same type and return an operand of the
|
same type. The other thing about these subroutines is that they
|
same type. The other thing about these subroutines is that they
|
can fail in various ways -- overflow, underflow, division by zero,
|
can fail in various ways -- overflow, underflow, division by zero,
|
zero raised to the zero, etc. */
|
zero raised to the zero, etc. */
|
|
|
static arith
|
static arith
|
gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
|
gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
|
result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
|
result->value.logical = !op1->value.logical;
|
result->value.logical = !op1->value.logical;
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
&op1->where);
|
&op1->where);
|
result->value.logical = op1->value.logical && op2->value.logical;
|
result->value.logical = op1->value.logical && op2->value.logical;
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
&op1->where);
|
&op1->where);
|
result->value.logical = op1->value.logical || op2->value.logical;
|
result->value.logical = op1->value.logical || op2->value.logical;
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
&op1->where);
|
&op1->where);
|
result->value.logical = op1->value.logical == op2->value.logical;
|
result->value.logical = op1->value.logical == op2->value.logical;
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
|
&op1->where);
|
&op1->where);
|
result->value.logical = op1->value.logical != op2->value.logical;
|
result->value.logical = op1->value.logical != op2->value.logical;
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
/* Make sure a constant numeric expression is within the range for
|
/* Make sure a constant numeric expression is within the range for
|
its type and kind. Note that there's also a gfc_check_range(),
|
its type and kind. Note that there's also a gfc_check_range(),
|
but that one deals with the intrinsic RANGE function. */
|
but that one deals with the intrinsic RANGE function. */
|
|
|
arith
|
arith
|
gfc_range_check (gfc_expr *e)
|
gfc_range_check (gfc_expr *e)
|
{
|
{
|
arith rc;
|
arith rc;
|
arith rc2;
|
arith rc2;
|
|
|
switch (e->ts.type)
|
switch (e->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
|
rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
rc = gfc_check_real_range (e->value.real, e->ts.kind);
|
rc = gfc_check_real_range (e->value.real, e->ts.kind);
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
|
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
|
if (rc == ARITH_OVERFLOW)
|
if (rc == ARITH_OVERFLOW)
|
mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
|
mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
|
if (rc == ARITH_NAN)
|
if (rc == ARITH_NAN)
|
mpfr_set_nan (e->value.real);
|
mpfr_set_nan (e->value.real);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
|
rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
|
mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
|
if (rc == ARITH_OVERFLOW)
|
if (rc == ARITH_OVERFLOW)
|
mpfr_set_inf (mpc_realref (e->value.complex),
|
mpfr_set_inf (mpc_realref (e->value.complex),
|
mpfr_sgn (mpc_realref (e->value.complex)));
|
mpfr_sgn (mpc_realref (e->value.complex)));
|
if (rc == ARITH_NAN)
|
if (rc == ARITH_NAN)
|
mpfr_set_nan (mpc_realref (e->value.complex));
|
mpfr_set_nan (mpc_realref (e->value.complex));
|
|
|
rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
|
rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
|
mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
|
if (rc == ARITH_OVERFLOW)
|
if (rc == ARITH_OVERFLOW)
|
mpfr_set_inf (mpc_imagref (e->value.complex),
|
mpfr_set_inf (mpc_imagref (e->value.complex),
|
mpfr_sgn (mpc_imagref (e->value.complex)));
|
mpfr_sgn (mpc_imagref (e->value.complex)));
|
if (rc == ARITH_NAN)
|
if (rc == ARITH_NAN)
|
mpfr_set_nan (mpc_imagref (e->value.complex));
|
mpfr_set_nan (mpc_imagref (e->value.complex));
|
|
|
if (rc == ARITH_OK)
|
if (rc == ARITH_OK)
|
rc = rc2;
|
rc = rc2;
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_range_check(): Bad type");
|
gfc_internal_error ("gfc_range_check(): Bad type");
|
}
|
}
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
|
|
/* Several of the following routines use the same set of statements to
|
/* Several of the following routines use the same set of statements to
|
check the validity of the result. Encapsulate the checking here. */
|
check the validity of the result. Encapsulate the checking here. */
|
|
|
static arith
|
static arith
|
check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
|
check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
|
{
|
{
|
arith val = rc;
|
arith val = rc;
|
|
|
if (val == ARITH_UNDERFLOW)
|
if (val == ARITH_UNDERFLOW)
|
{
|
{
|
if (gfc_option.warn_underflow)
|
if (gfc_option.warn_underflow)
|
gfc_warning (gfc_arith_error (val), &x->where);
|
gfc_warning (gfc_arith_error (val), &x->where);
|
val = ARITH_OK;
|
val = ARITH_OK;
|
}
|
}
|
|
|
if (val == ARITH_ASYMMETRIC)
|
if (val == ARITH_ASYMMETRIC)
|
{
|
{
|
gfc_warning (gfc_arith_error (val), &x->where);
|
gfc_warning (gfc_arith_error (val), &x->where);
|
val = ARITH_OK;
|
val = ARITH_OK;
|
}
|
}
|
|
|
if (val != ARITH_OK)
|
if (val != ARITH_OK)
|
gfc_free_expr (r);
|
gfc_free_expr (r);
|
else
|
else
|
*rp = r;
|
*rp = r;
|
|
|
return val;
|
return val;
|
}
|
}
|
|
|
|
|
/* It may seem silly to have a subroutine that actually computes the
|
/* It may seem silly to have a subroutine that actually computes the
|
unary plus of a constant, but it prevents us from making exceptions
|
unary plus of a constant, but it prevents us from making exceptions
|
in the code elsewhere. Used for unary plus and parenthesized
|
in the code elsewhere. Used for unary plus and parenthesized
|
expressions. */
|
expressions. */
|
|
|
static arith
|
static arith
|
gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
|
gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
|
{
|
{
|
*resultp = gfc_copy_expr (op1);
|
*resultp = gfc_copy_expr (op1);
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
|
gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
|
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
mpz_neg (result->value.integer, op1->value.integer);
|
mpz_neg (result->value.integer, op1->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
|
mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
|
mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
|
gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
|
}
|
}
|
|
|
rc = gfc_range_check (result);
|
rc = gfc_range_check (result);
|
|
|
return check_result (rc, op1, result, resultp);
|
return check_result (rc, op1, result, resultp);
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
|
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
|
mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_add (result->value.real, op1->value.real, op2->value.real,
|
mpfr_add (result->value.real, op1->value.real, op2->value.real,
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
|
mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
|
GFC_MPC_RND_MODE);
|
GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_arith_plus(): Bad basic type");
|
gfc_internal_error ("gfc_arith_plus(): Bad basic type");
|
}
|
}
|
|
|
rc = gfc_range_check (result);
|
rc = gfc_range_check (result);
|
|
|
return check_result (rc, op1, result, resultp);
|
return check_result (rc, op1, result, resultp);
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
|
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
|
mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_sub (result->value.real, op1->value.real, op2->value.real,
|
mpfr_sub (result->value.real, op1->value.real, op2->value.real,
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
mpc_sub (result->value.complex, op1->value.complex,
|
mpc_sub (result->value.complex, op1->value.complex,
|
op2->value.complex, GFC_MPC_RND_MODE);
|
op2->value.complex, GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_arith_minus(): Bad basic type");
|
gfc_internal_error ("gfc_arith_minus(): Bad basic type");
|
}
|
}
|
|
|
rc = gfc_range_check (result);
|
rc = gfc_range_check (result);
|
|
|
return check_result (rc, op1, result, resultp);
|
return check_result (rc, op1, result, resultp);
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
|
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
|
mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_mul (result->value.real, op1->value.real, op2->value.real,
|
mpfr_mul (result->value.real, op1->value.real, op2->value.real,
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
gfc_set_model (mpc_realref (op1->value.complex));
|
gfc_set_model (mpc_realref (op1->value.complex));
|
mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
|
mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
|
GFC_MPC_RND_MODE);
|
GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_arith_times(): Bad basic type");
|
gfc_internal_error ("gfc_arith_times(): Bad basic type");
|
}
|
}
|
|
|
rc = gfc_range_check (result);
|
rc = gfc_range_check (result);
|
|
|
return check_result (rc, op1, result, resultp);
|
return check_result (rc, op1, result, resultp);
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
rc = ARITH_OK;
|
rc = ARITH_OK;
|
|
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
|
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
if (mpz_sgn (op2->value.integer) == 0)
|
if (mpz_sgn (op2->value.integer) == 0)
|
{
|
{
|
rc = ARITH_DIV0;
|
rc = ARITH_DIV0;
|
break;
|
break;
|
}
|
}
|
|
|
mpz_tdiv_q (result->value.integer, op1->value.integer,
|
mpz_tdiv_q (result->value.integer, op1->value.integer,
|
op2->value.integer);
|
op2->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
|
if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
|
{
|
{
|
rc = ARITH_DIV0;
|
rc = ARITH_DIV0;
|
break;
|
break;
|
}
|
}
|
|
|
mpfr_div (result->value.real, op1->value.real, op2->value.real,
|
mpfr_div (result->value.real, op1->value.real, op2->value.real,
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
|
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
|
&& gfc_option.flag_range_check == 1)
|
&& gfc_option.flag_range_check == 1)
|
{
|
{
|
rc = ARITH_DIV0;
|
rc = ARITH_DIV0;
|
break;
|
break;
|
}
|
}
|
|
|
gfc_set_model (mpc_realref (op1->value.complex));
|
gfc_set_model (mpc_realref (op1->value.complex));
|
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
|
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
|
{
|
{
|
/* In Fortran, return (NaN + NaN I) for any zero divisor. See
|
/* In Fortran, return (NaN + NaN I) for any zero divisor. See
|
PR 40318. */
|
PR 40318. */
|
mpfr_set_nan (mpc_realref (result->value.complex));
|
mpfr_set_nan (mpc_realref (result->value.complex));
|
mpfr_set_nan (mpc_imagref (result->value.complex));
|
mpfr_set_nan (mpc_imagref (result->value.complex));
|
}
|
}
|
else
|
else
|
mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
|
mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
|
GFC_MPC_RND_MODE);
|
GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_arith_divide(): Bad basic type");
|
gfc_internal_error ("gfc_arith_divide(): Bad basic type");
|
}
|
}
|
|
|
if (rc == ARITH_OK)
|
if (rc == ARITH_OK)
|
rc = gfc_range_check (result);
|
rc = gfc_range_check (result);
|
|
|
return check_result (rc, op1, result, resultp);
|
return check_result (rc, op1, result, resultp);
|
}
|
}
|
|
|
/* Raise a number to a power. */
|
/* Raise a number to a power. */
|
|
|
static arith
|
static arith
|
arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
int power_sign;
|
int power_sign;
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
extern bool init_flag;
|
extern bool init_flag;
|
|
|
rc = ARITH_OK;
|
rc = ARITH_OK;
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
|
|
|
switch (op2->ts.type)
|
switch (op2->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
power_sign = mpz_sgn (op2->value.integer);
|
power_sign = mpz_sgn (op2->value.integer);
|
|
|
if (power_sign == 0)
|
if (power_sign == 0)
|
{
|
{
|
/* Handle something to the zeroth power. Since we're dealing
|
/* Handle something to the zeroth power. Since we're dealing
|
with integral exponents, there is no ambiguity in the
|
with integral exponents, there is no ambiguity in the
|
limiting procedure used to determine the value of 0**0. */
|
limiting procedure used to determine the value of 0**0. */
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
mpz_set_ui (result->value.integer, 1);
|
mpz_set_ui (result->value.integer, 1);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
|
mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
|
mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("arith_power(): Bad base");
|
gfc_internal_error ("arith_power(): Bad base");
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
{
|
{
|
int power;
|
int power;
|
|
|
/* First, we simplify the cases of op1 == 1, 0 or -1. */
|
/* First, we simplify the cases of op1 == 1, 0 or -1. */
|
if (mpz_cmp_si (op1->value.integer, 1) == 0)
|
if (mpz_cmp_si (op1->value.integer, 1) == 0)
|
{
|
{
|
/* 1**op2 == 1 */
|
/* 1**op2 == 1 */
|
mpz_set_si (result->value.integer, 1);
|
mpz_set_si (result->value.integer, 1);
|
}
|
}
|
else if (mpz_cmp_si (op1->value.integer, 0) == 0)
|
else if (mpz_cmp_si (op1->value.integer, 0) == 0)
|
{
|
{
|
/* 0**op2 == 0, if op2 > 0
|
/* 0**op2 == 0, if op2 > 0
|
0**op2 overflow, if op2 < 0 ; in that case, we
|
0**op2 overflow, if op2 < 0 ; in that case, we
|
set the result to 0 and return ARITH_DIV0. */
|
set the result to 0 and return ARITH_DIV0. */
|
mpz_set_si (result->value.integer, 0);
|
mpz_set_si (result->value.integer, 0);
|
if (mpz_cmp_si (op2->value.integer, 0) < 0)
|
if (mpz_cmp_si (op2->value.integer, 0) < 0)
|
rc = ARITH_DIV0;
|
rc = ARITH_DIV0;
|
}
|
}
|
else if (mpz_cmp_si (op1->value.integer, -1) == 0)
|
else if (mpz_cmp_si (op1->value.integer, -1) == 0)
|
{
|
{
|
/* (-1)**op2 == (-1)**(mod(op2,2)) */
|
/* (-1)**op2 == (-1)**(mod(op2,2)) */
|
unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
|
unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
|
if (odd)
|
if (odd)
|
mpz_set_si (result->value.integer, -1);
|
mpz_set_si (result->value.integer, -1);
|
else
|
else
|
mpz_set_si (result->value.integer, 1);
|
mpz_set_si (result->value.integer, 1);
|
}
|
}
|
/* Then, we take care of op2 < 0. */
|
/* Then, we take care of op2 < 0. */
|
else if (mpz_cmp_si (op2->value.integer, 0) < 0)
|
else if (mpz_cmp_si (op2->value.integer, 0) < 0)
|
{
|
{
|
/* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
|
/* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
|
mpz_set_si (result->value.integer, 0);
|
mpz_set_si (result->value.integer, 0);
|
}
|
}
|
else if (gfc_extract_int (op2, &power) != NULL)
|
else if (gfc_extract_int (op2, &power) != NULL)
|
{
|
{
|
/* If op2 doesn't fit in an int, the exponentiation will
|
/* If op2 doesn't fit in an int, the exponentiation will
|
overflow, because op2 > 0 and abs(op1) > 1. */
|
overflow, because op2 > 0 and abs(op1) > 1. */
|
mpz_t max;
|
mpz_t max;
|
int i;
|
int i;
|
i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
|
i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
|
|
|
if (gfc_option.flag_range_check)
|
if (gfc_option.flag_range_check)
|
rc = ARITH_OVERFLOW;
|
rc = ARITH_OVERFLOW;
|
|
|
/* Still, we want to give the same value as the
|
/* Still, we want to give the same value as the
|
processor. */
|
processor. */
|
mpz_init (max);
|
mpz_init (max);
|
mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
|
mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
|
mpz_mul_ui (max, max, 2);
|
mpz_mul_ui (max, max, 2);
|
mpz_powm (result->value.integer, op1->value.integer,
|
mpz_powm (result->value.integer, op1->value.integer,
|
op2->value.integer, max);
|
op2->value.integer, max);
|
mpz_clear (max);
|
mpz_clear (max);
|
}
|
}
|
else
|
else
|
mpz_pow_ui (result->value.integer, op1->value.integer,
|
mpz_pow_ui (result->value.integer, op1->value.integer,
|
power);
|
power);
|
}
|
}
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_pow_z (result->value.real, op1->value.real,
|
mpfr_pow_z (result->value.real, op1->value.real,
|
op2->value.integer, GFC_RND_MODE);
|
op2->value.integer, GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
mpc_pow_z (result->value.complex, op1->value.complex,
|
mpc_pow_z (result->value.complex, op1->value.complex,
|
op2->value.integer, GFC_MPC_RND_MODE);
|
op2->value.integer, GFC_MPC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
}
|
}
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
|
|
if (init_flag)
|
if (init_flag)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
|
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
|
"exponent in an initialization "
|
"exponent in an initialization "
|
"expression at %L", &op2->where) == FAILURE)
|
"expression at %L", &op2->where) == FAILURE)
|
return ARITH_PROHIBIT;
|
return ARITH_PROHIBIT;
|
}
|
}
|
|
|
if (mpfr_cmp_si (op1->value.real, 0) < 0)
|
if (mpfr_cmp_si (op1->value.real, 0) < 0)
|
{
|
{
|
gfc_error ("Raising a negative REAL at %L to "
|
gfc_error ("Raising a negative REAL at %L to "
|
"a REAL power is prohibited", &op1->where);
|
"a REAL power is prohibited", &op1->where);
|
gfc_free (result);
|
gfc_free (result);
|
return ARITH_PROHIBIT;
|
return ARITH_PROHIBIT;
|
}
|
}
|
|
|
mpfr_pow (result->value.real, op1->value.real, op2->value.real,
|
mpfr_pow (result->value.real, op1->value.real, op2->value.real,
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
{
|
{
|
if (init_flag)
|
if (init_flag)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
|
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
|
"exponent in an initialization "
|
"exponent in an initialization "
|
"expression at %L", &op2->where) == FAILURE)
|
"expression at %L", &op2->where) == FAILURE)
|
return ARITH_PROHIBIT;
|
return ARITH_PROHIBIT;
|
}
|
}
|
|
|
mpc_pow (result->value.complex, op1->value.complex,
|
mpc_pow (result->value.complex, op1->value.complex,
|
op2->value.complex, GFC_MPC_RND_MODE);
|
op2->value.complex, GFC_MPC_RND_MODE);
|
}
|
}
|
break;
|
break;
|
default:
|
default:
|
gfc_internal_error ("arith_power(): unknown type");
|
gfc_internal_error ("arith_power(): unknown type");
|
}
|
}
|
|
|
if (rc == ARITH_OK)
|
if (rc == ARITH_OK)
|
rc = gfc_range_check (result);
|
rc = gfc_range_check (result);
|
|
|
return check_result (rc, op1, result, resultp);
|
return check_result (rc, op1, result, resultp);
|
}
|
}
|
|
|
|
|
/* Concatenate two string constants. */
|
/* Concatenate two string constants. */
|
|
|
static arith
|
static arith
|
gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
int len;
|
int len;
|
|
|
gcc_assert (op1->ts.kind == op2->ts.kind);
|
gcc_assert (op1->ts.kind == op2->ts.kind);
|
result = gfc_constant_result (BT_CHARACTER, op1->ts.kind,
|
result = gfc_constant_result (BT_CHARACTER, op1->ts.kind,
|
&op1->where);
|
&op1->where);
|
|
|
len = op1->value.character.length + op2->value.character.length;
|
len = op1->value.character.length + op2->value.character.length;
|
|
|
result->value.character.string = gfc_get_wide_string (len + 1);
|
result->value.character.string = gfc_get_wide_string (len + 1);
|
result->value.character.length = len;
|
result->value.character.length = len;
|
|
|
memcpy (result->value.character.string, op1->value.character.string,
|
memcpy (result->value.character.string, op1->value.character.string,
|
op1->value.character.length * sizeof (gfc_char_t));
|
op1->value.character.length * sizeof (gfc_char_t));
|
|
|
memcpy (&result->value.character.string[op1->value.character.length],
|
memcpy (&result->value.character.string[op1->value.character.length],
|
op2->value.character.string,
|
op2->value.character.string,
|
op2->value.character.length * sizeof (gfc_char_t));
|
op2->value.character.length * sizeof (gfc_char_t));
|
|
|
result->value.character.string[len] = '\0';
|
result->value.character.string[len] = '\0';
|
|
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
|
/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
|
This function mimics mpfr_cmp but takes NaN into account. */
|
This function mimics mpfr_cmp but takes NaN into account. */
|
|
|
static int
|
static int
|
compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
int rc;
|
int rc;
|
switch (op)
|
switch (op)
|
{
|
{
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ:
|
rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
|
rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
|
break;
|
break;
|
case INTRINSIC_GT:
|
case INTRINSIC_GT:
|
rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
|
rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
|
break;
|
break;
|
case INTRINSIC_GE:
|
case INTRINSIC_GE:
|
rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
|
rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
|
break;
|
break;
|
case INTRINSIC_LT:
|
case INTRINSIC_LT:
|
rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
|
rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
|
break;
|
break;
|
case INTRINSIC_LE:
|
case INTRINSIC_LE:
|
rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
|
rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
|
break;
|
break;
|
default:
|
default:
|
gfc_internal_error ("compare_real(): Bad operator");
|
gfc_internal_error ("compare_real(): Bad operator");
|
}
|
}
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
/* Comparison operators. Assumes that the two expression nodes
|
/* Comparison operators. Assumes that the two expression nodes
|
contain two constants of the same type. The op argument is
|
contain two constants of the same type. The op argument is
|
needed to handle NaN correctly. */
|
needed to handle NaN correctly. */
|
|
|
int
|
int
|
gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
int rc;
|
int rc;
|
|
|
switch (op1->ts.type)
|
switch (op1->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
rc = mpz_cmp (op1->value.integer, op2->value.integer);
|
rc = mpz_cmp (op1->value.integer, op2->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
rc = compare_real (op1, op2, op);
|
rc = compare_real (op1, op2, op);
|
break;
|
break;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
rc = gfc_compare_string (op1, op2);
|
rc = gfc_compare_string (op1, op2);
|
break;
|
break;
|
|
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
rc = ((!op1->value.logical && op2->value.logical)
|
rc = ((!op1->value.logical && op2->value.logical)
|
|| (op1->value.logical && !op2->value.logical));
|
|| (op1->value.logical && !op2->value.logical));
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_compare_expr(): Bad basic type");
|
gfc_internal_error ("gfc_compare_expr(): Bad basic type");
|
}
|
}
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
|
|
/* Compare a pair of complex numbers. Naturally, this is only for
|
/* Compare a pair of complex numbers. Naturally, this is only for
|
equality and inequality. */
|
equality and inequality. */
|
|
|
static int
|
static int
|
compare_complex (gfc_expr *op1, gfc_expr *op2)
|
compare_complex (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
|
return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
|
}
|
}
|
|
|
|
|
/* Given two constant strings and the inverse collating sequence, compare the
|
/* Given two constant strings and the inverse collating sequence, compare the
|
strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
|
strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
|
We use the processor's default collating sequence. */
|
We use the processor's default collating sequence. */
|
|
|
int
|
int
|
gfc_compare_string (gfc_expr *a, gfc_expr *b)
|
gfc_compare_string (gfc_expr *a, gfc_expr *b)
|
{
|
{
|
int len, alen, blen, i;
|
int len, alen, blen, i;
|
gfc_char_t ac, bc;
|
gfc_char_t ac, bc;
|
|
|
alen = a->value.character.length;
|
alen = a->value.character.length;
|
blen = b->value.character.length;
|
blen = b->value.character.length;
|
|
|
len = MAX(alen, blen);
|
len = MAX(alen, blen);
|
|
|
for (i = 0; i < len; i++)
|
for (i = 0; i < len; i++)
|
{
|
{
|
ac = ((i < alen) ? a->value.character.string[i] : ' ');
|
ac = ((i < alen) ? a->value.character.string[i] : ' ');
|
bc = ((i < blen) ? b->value.character.string[i] : ' ');
|
bc = ((i < blen) ? b->value.character.string[i] : ' ');
|
|
|
if (ac < bc)
|
if (ac < bc)
|
return -1;
|
return -1;
|
if (ac > bc)
|
if (ac > bc)
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/* Strings are equal */
|
/* Strings are equal */
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
|
gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
|
{
|
{
|
int len, alen, blen, i;
|
int len, alen, blen, i;
|
gfc_char_t ac, bc;
|
gfc_char_t ac, bc;
|
|
|
alen = a->value.character.length;
|
alen = a->value.character.length;
|
blen = strlen (b);
|
blen = strlen (b);
|
|
|
len = MAX(alen, blen);
|
len = MAX(alen, blen);
|
|
|
for (i = 0; i < len; i++)
|
for (i = 0; i < len; i++)
|
{
|
{
|
ac = ((i < alen) ? a->value.character.string[i] : ' ');
|
ac = ((i < alen) ? a->value.character.string[i] : ' ');
|
bc = ((i < blen) ? b[i] : ' ');
|
bc = ((i < blen) ? b[i] : ' ');
|
|
|
if (!case_sensitive)
|
if (!case_sensitive)
|
{
|
{
|
ac = TOLOWER (ac);
|
ac = TOLOWER (ac);
|
bc = TOLOWER (bc);
|
bc = TOLOWER (bc);
|
}
|
}
|
|
|
if (ac < bc)
|
if (ac < bc)
|
return -1;
|
return -1;
|
if (ac > bc)
|
if (ac > bc)
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/* Strings are equal */
|
/* Strings are equal */
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Specific comparison subroutines. */
|
/* Specific comparison subroutines. */
|
|
|
static arith
|
static arith
|
gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
&op1->where);
|
&op1->where);
|
result->value.logical = (op1->ts.type == BT_COMPLEX)
|
result->value.logical = (op1->ts.type == BT_COMPLEX)
|
? compare_complex (op1, op2)
|
? compare_complex (op1, op2)
|
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
|
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
|
|
|
*resultp = result;
|
*resultp = result;
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
&op1->where);
|
&op1->where);
|
result->value.logical = (op1->ts.type == BT_COMPLEX)
|
result->value.logical = (op1->ts.type == BT_COMPLEX)
|
? !compare_complex (op1, op2)
|
? !compare_complex (op1, op2)
|
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
|
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
|
|
|
*resultp = result;
|
*resultp = result;
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
&op1->where);
|
&op1->where);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
&op1->where);
|
&op1->where);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
&op1->where);
|
&op1->where);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
|
&op1->where);
|
&op1->where);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
|
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
|
*resultp = result;
|
*resultp = result;
|
|
|
return ARITH_OK;
|
return ARITH_OK;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
|
reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
|
gfc_expr **result)
|
gfc_expr **result)
|
{
|
{
|
gfc_constructor *c, *head;
|
gfc_constructor *c, *head;
|
gfc_expr *r;
|
gfc_expr *r;
|
arith rc;
|
arith rc;
|
|
|
if (op->expr_type == EXPR_CONSTANT)
|
if (op->expr_type == EXPR_CONSTANT)
|
return eval (op, result);
|
return eval (op, result);
|
|
|
rc = ARITH_OK;
|
rc = ARITH_OK;
|
head = gfc_copy_constructor (op->value.constructor);
|
head = gfc_copy_constructor (op->value.constructor);
|
|
|
for (c = head; c; c = c->next)
|
for (c = head; c; c = c->next)
|
{
|
{
|
rc = reduce_unary (eval, c->expr, &r);
|
rc = reduce_unary (eval, c->expr, &r);
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
break;
|
break;
|
|
|
gfc_replace_expr (c->expr, r);
|
gfc_replace_expr (c->expr, r);
|
}
|
}
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
gfc_free_constructor (head);
|
gfc_free_constructor (head);
|
else
|
else
|
{
|
{
|
r = gfc_get_expr ();
|
r = gfc_get_expr ();
|
r->expr_type = EXPR_ARRAY;
|
r->expr_type = EXPR_ARRAY;
|
r->value.constructor = head;
|
r->value.constructor = head;
|
r->shape = gfc_copy_shape (op->shape, op->rank);
|
r->shape = gfc_copy_shape (op->shape, op->rank);
|
|
|
r->ts = head->expr->ts;
|
r->ts = head->expr->ts;
|
r->where = op->where;
|
r->where = op->where;
|
r->rank = op->rank;
|
r->rank = op->rank;
|
|
|
*result = r;
|
*result = r;
|
}
|
}
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
{
|
{
|
gfc_constructor *c, *head;
|
gfc_constructor *c, *head;
|
gfc_expr *r;
|
gfc_expr *r;
|
arith rc;
|
arith rc;
|
|
|
head = gfc_copy_constructor (op1->value.constructor);
|
head = gfc_copy_constructor (op1->value.constructor);
|
rc = ARITH_OK;
|
rc = ARITH_OK;
|
|
|
for (c = head; c; c = c->next)
|
for (c = head; c; c = c->next)
|
{
|
{
|
if (c->expr->expr_type == EXPR_CONSTANT)
|
if (c->expr->expr_type == EXPR_CONSTANT)
|
rc = eval (c->expr, op2, &r);
|
rc = eval (c->expr, op2, &r);
|
else
|
else
|
rc = reduce_binary_ac (eval, c->expr, op2, &r);
|
rc = reduce_binary_ac (eval, c->expr, op2, &r);
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
break;
|
break;
|
|
|
gfc_replace_expr (c->expr, r);
|
gfc_replace_expr (c->expr, r);
|
}
|
}
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
gfc_free_constructor (head);
|
gfc_free_constructor (head);
|
else
|
else
|
{
|
{
|
r = gfc_get_expr ();
|
r = gfc_get_expr ();
|
r->expr_type = EXPR_ARRAY;
|
r->expr_type = EXPR_ARRAY;
|
r->value.constructor = head;
|
r->value.constructor = head;
|
r->shape = gfc_copy_shape (op1->shape, op1->rank);
|
r->shape = gfc_copy_shape (op1->shape, op1->rank);
|
|
|
r->ts = head->expr->ts;
|
r->ts = head->expr->ts;
|
r->where = op1->where;
|
r->where = op1->where;
|
r->rank = op1->rank;
|
r->rank = op1->rank;
|
|
|
*result = r;
|
*result = r;
|
}
|
}
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
{
|
{
|
gfc_constructor *c, *head;
|
gfc_constructor *c, *head;
|
gfc_expr *r;
|
gfc_expr *r;
|
arith rc;
|
arith rc;
|
|
|
head = gfc_copy_constructor (op2->value.constructor);
|
head = gfc_copy_constructor (op2->value.constructor);
|
rc = ARITH_OK;
|
rc = ARITH_OK;
|
|
|
for (c = head; c; c = c->next)
|
for (c = head; c; c = c->next)
|
{
|
{
|
if (c->expr->expr_type == EXPR_CONSTANT)
|
if (c->expr->expr_type == EXPR_CONSTANT)
|
rc = eval (op1, c->expr, &r);
|
rc = eval (op1, c->expr, &r);
|
else
|
else
|
rc = reduce_binary_ca (eval, op1, c->expr, &r);
|
rc = reduce_binary_ca (eval, op1, c->expr, &r);
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
break;
|
break;
|
|
|
gfc_replace_expr (c->expr, r);
|
gfc_replace_expr (c->expr, r);
|
}
|
}
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
gfc_free_constructor (head);
|
gfc_free_constructor (head);
|
else
|
else
|
{
|
{
|
r = gfc_get_expr ();
|
r = gfc_get_expr ();
|
r->expr_type = EXPR_ARRAY;
|
r->expr_type = EXPR_ARRAY;
|
r->value.constructor = head;
|
r->value.constructor = head;
|
r->shape = gfc_copy_shape (op2->shape, op2->rank);
|
r->shape = gfc_copy_shape (op2->shape, op2->rank);
|
|
|
r->ts = head->expr->ts;
|
r->ts = head->expr->ts;
|
r->where = op2->where;
|
r->where = op2->where;
|
r->rank = op2->rank;
|
r->rank = op2->rank;
|
|
|
*result = r;
|
*result = r;
|
}
|
}
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
|
|
/* We need a forward declaration of reduce_binary. */
|
/* We need a forward declaration of reduce_binary. */
|
static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
|
|
|
|
|
static arith
|
static arith
|
reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
{
|
{
|
gfc_constructor *c, *d, *head;
|
gfc_constructor *c, *d, *head;
|
gfc_expr *r;
|
gfc_expr *r;
|
arith rc;
|
arith rc;
|
|
|
head = gfc_copy_constructor (op1->value.constructor);
|
head = gfc_copy_constructor (op1->value.constructor);
|
|
|
rc = ARITH_OK;
|
rc = ARITH_OK;
|
d = op2->value.constructor;
|
d = op2->value.constructor;
|
|
|
if (gfc_check_conformance (op1, op2, "elemental binary operation")
|
if (gfc_check_conformance (op1, op2, "elemental binary operation")
|
!= SUCCESS)
|
!= SUCCESS)
|
rc = ARITH_INCOMMENSURATE;
|
rc = ARITH_INCOMMENSURATE;
|
else
|
else
|
{
|
{
|
for (c = head; c; c = c->next, d = d->next)
|
for (c = head; c; c = c->next, d = d->next)
|
{
|
{
|
if (d == NULL)
|
if (d == NULL)
|
{
|
{
|
rc = ARITH_INCOMMENSURATE;
|
rc = ARITH_INCOMMENSURATE;
|
break;
|
break;
|
}
|
}
|
|
|
rc = reduce_binary (eval, c->expr, d->expr, &r);
|
rc = reduce_binary (eval, c->expr, d->expr, &r);
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
break;
|
break;
|
|
|
gfc_replace_expr (c->expr, r);
|
gfc_replace_expr (c->expr, r);
|
}
|
}
|
|
|
if (d != NULL)
|
if (d != NULL)
|
rc = ARITH_INCOMMENSURATE;
|
rc = ARITH_INCOMMENSURATE;
|
}
|
}
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
gfc_free_constructor (head);
|
gfc_free_constructor (head);
|
else
|
else
|
{
|
{
|
r = gfc_get_expr ();
|
r = gfc_get_expr ();
|
r->expr_type = EXPR_ARRAY;
|
r->expr_type = EXPR_ARRAY;
|
r->value.constructor = head;
|
r->value.constructor = head;
|
r->shape = gfc_copy_shape (op1->shape, op1->rank);
|
r->shape = gfc_copy_shape (op1->shape, op1->rank);
|
|
|
r->ts = head->expr->ts;
|
r->ts = head->expr->ts;
|
r->where = op1->where;
|
r->where = op1->where;
|
r->rank = op1->rank;
|
r->rank = op1->rank;
|
|
|
*result = r;
|
*result = r;
|
}
|
}
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
|
|
static arith
|
static arith
|
reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
|
{
|
{
|
if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
|
if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
|
return eval (op1, op2, result);
|
return eval (op1, op2, result);
|
|
|
if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
|
if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
|
return reduce_binary_ca (eval, op1, op2, result);
|
return reduce_binary_ca (eval, op1, op2, result);
|
|
|
if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
|
if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
|
return reduce_binary_ac (eval, op1, op2, result);
|
return reduce_binary_ac (eval, op1, op2, result);
|
|
|
return reduce_binary_aa (eval, op1, op2, result);
|
return reduce_binary_aa (eval, op1, op2, result);
|
}
|
}
|
|
|
|
|
typedef union
|
typedef union
|
{
|
{
|
arith (*f2)(gfc_expr *, gfc_expr **);
|
arith (*f2)(gfc_expr *, gfc_expr **);
|
arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
|
arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
|
}
|
}
|
eval_f;
|
eval_f;
|
|
|
/* High level arithmetic subroutines. These subroutines go into
|
/* High level arithmetic subroutines. These subroutines go into
|
eval_intrinsic(), which can do one of several things to its
|
eval_intrinsic(), which can do one of several things to its
|
operands. If the operands are incompatible with the intrinsic
|
operands. If the operands are incompatible with the intrinsic
|
operation, we return a node pointing to the operands and hope that
|
operation, we return a node pointing to the operands and hope that
|
an operator interface is found during resolution.
|
an operator interface is found during resolution.
|
|
|
If the operands are compatible and are constants, then we try doing
|
If the operands are compatible and are constants, then we try doing
|
the arithmetic. We also handle the cases where either or both
|
the arithmetic. We also handle the cases where either or both
|
operands are array constructors. */
|
operands are array constructors. */
|
|
|
static gfc_expr *
|
static gfc_expr *
|
eval_intrinsic (gfc_intrinsic_op op,
|
eval_intrinsic (gfc_intrinsic_op op,
|
eval_f eval, gfc_expr *op1, gfc_expr *op2)
|
eval_f eval, gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
gfc_expr temp, *result;
|
gfc_expr temp, *result;
|
int unary;
|
int unary;
|
arith rc;
|
arith rc;
|
|
|
gfc_clear_ts (&temp.ts);
|
gfc_clear_ts (&temp.ts);
|
|
|
switch (op)
|
switch (op)
|
{
|
{
|
/* Logical unary */
|
/* Logical unary */
|
case INTRINSIC_NOT:
|
case INTRINSIC_NOT:
|
if (op1->ts.type != BT_LOGICAL)
|
if (op1->ts.type != BT_LOGICAL)
|
goto runtime;
|
goto runtime;
|
|
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.kind = gfc_default_logical_kind;
|
temp.ts.kind = gfc_default_logical_kind;
|
unary = 1;
|
unary = 1;
|
break;
|
break;
|
|
|
/* Logical binary operators */
|
/* Logical binary operators */
|
case INTRINSIC_OR:
|
case INTRINSIC_OR:
|
case INTRINSIC_AND:
|
case INTRINSIC_AND:
|
case INTRINSIC_NEQV:
|
case INTRINSIC_NEQV:
|
case INTRINSIC_EQV:
|
case INTRINSIC_EQV:
|
if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
|
if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
|
goto runtime;
|
goto runtime;
|
|
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.kind = gfc_default_logical_kind;
|
temp.ts.kind = gfc_default_logical_kind;
|
unary = 0;
|
unary = 0;
|
break;
|
break;
|
|
|
/* Numeric unary */
|
/* Numeric unary */
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UMINUS:
|
case INTRINSIC_UMINUS:
|
if (!gfc_numeric_ts (&op1->ts))
|
if (!gfc_numeric_ts (&op1->ts))
|
goto runtime;
|
goto runtime;
|
|
|
temp.ts = op1->ts;
|
temp.ts = op1->ts;
|
unary = 1;
|
unary = 1;
|
break;
|
break;
|
|
|
case INTRINSIC_PARENTHESES:
|
case INTRINSIC_PARENTHESES:
|
temp.ts = op1->ts;
|
temp.ts = op1->ts;
|
unary = 1;
|
unary = 1;
|
break;
|
break;
|
|
|
/* Additional restrictions for ordering relations. */
|
/* Additional restrictions for ordering relations. */
|
case INTRINSIC_GE:
|
case INTRINSIC_GE:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE_OS:
|
case INTRINSIC_LE_OS:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_GT_OS:
|
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
|
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
|
{
|
{
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.kind = gfc_default_logical_kind;
|
temp.ts.kind = gfc_default_logical_kind;
|
goto runtime;
|
goto runtime;
|
}
|
}
|
|
|
/* Fall through */
|
/* Fall through */
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE_OS:
|
case INTRINSIC_NE_OS:
|
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
|
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
|
{
|
{
|
unary = 0;
|
unary = 0;
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.kind = gfc_default_logical_kind;
|
temp.ts.kind = gfc_default_logical_kind;
|
|
|
/* If kind mismatch, exit and we'll error out later. */
|
/* If kind mismatch, exit and we'll error out later. */
|
if (op1->ts.kind != op2->ts.kind)
|
if (op1->ts.kind != op2->ts.kind)
|
goto runtime;
|
goto runtime;
|
|
|
break;
|
break;
|
}
|
}
|
|
|
/* Fall through */
|
/* Fall through */
|
/* Numeric binary */
|
/* Numeric binary */
|
case INTRINSIC_PLUS:
|
case INTRINSIC_PLUS:
|
case INTRINSIC_MINUS:
|
case INTRINSIC_MINUS:
|
case INTRINSIC_TIMES:
|
case INTRINSIC_TIMES:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_POWER:
|
case INTRINSIC_POWER:
|
if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
|
if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
|
goto runtime;
|
goto runtime;
|
|
|
/* Insert any necessary type conversions to make the operands
|
/* Insert any necessary type conversions to make the operands
|
compatible. */
|
compatible. */
|
|
|
temp.expr_type = EXPR_OP;
|
temp.expr_type = EXPR_OP;
|
gfc_clear_ts (&temp.ts);
|
gfc_clear_ts (&temp.ts);
|
temp.value.op.op = op;
|
temp.value.op.op = op;
|
|
|
temp.value.op.op1 = op1;
|
temp.value.op.op1 = op1;
|
temp.value.op.op2 = op2;
|
temp.value.op.op2 = op2;
|
|
|
gfc_type_convert_binary (&temp, 0);
|
gfc_type_convert_binary (&temp, 0);
|
|
|
if (op == INTRINSIC_EQ || op == INTRINSIC_NE
|
if (op == INTRINSIC_EQ || op == INTRINSIC_NE
|
|| op == INTRINSIC_GE || op == INTRINSIC_GT
|
|| op == INTRINSIC_GE || op == INTRINSIC_GT
|
|| op == INTRINSIC_LE || op == INTRINSIC_LT
|
|| op == INTRINSIC_LE || op == INTRINSIC_LT
|
|| op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
|
|| op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
|
|| op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
|
|| op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
|
|| op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
|
|| op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
|
{
|
{
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.type = BT_LOGICAL;
|
temp.ts.kind = gfc_default_logical_kind;
|
temp.ts.kind = gfc_default_logical_kind;
|
}
|
}
|
|
|
unary = 0;
|
unary = 0;
|
break;
|
break;
|
|
|
/* Character binary */
|
/* Character binary */
|
case INTRINSIC_CONCAT:
|
case INTRINSIC_CONCAT:
|
if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
|
if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
|
|| op1->ts.kind != op2->ts.kind)
|
|| op1->ts.kind != op2->ts.kind)
|
goto runtime;
|
goto runtime;
|
|
|
temp.ts.type = BT_CHARACTER;
|
temp.ts.type = BT_CHARACTER;
|
temp.ts.kind = op1->ts.kind;
|
temp.ts.kind = op1->ts.kind;
|
unary = 0;
|
unary = 0;
|
break;
|
break;
|
|
|
case INTRINSIC_USER:
|
case INTRINSIC_USER:
|
goto runtime;
|
goto runtime;
|
|
|
default:
|
default:
|
gfc_internal_error ("eval_intrinsic(): Bad operator");
|
gfc_internal_error ("eval_intrinsic(): Bad operator");
|
}
|
}
|
|
|
if (op1->expr_type != EXPR_CONSTANT
|
if (op1->expr_type != EXPR_CONSTANT
|
&& (op1->expr_type != EXPR_ARRAY
|
&& (op1->expr_type != EXPR_ARRAY
|
|| !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
|
|| !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
|
goto runtime;
|
goto runtime;
|
|
|
if (op2 != NULL
|
if (op2 != NULL
|
&& op2->expr_type != EXPR_CONSTANT
|
&& op2->expr_type != EXPR_CONSTANT
|
&& (op2->expr_type != EXPR_ARRAY
|
&& (op2->expr_type != EXPR_ARRAY
|
|| !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
|
|| !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
|
goto runtime;
|
goto runtime;
|
|
|
if (unary)
|
if (unary)
|
rc = reduce_unary (eval.f2, op1, &result);
|
rc = reduce_unary (eval.f2, op1, &result);
|
else
|
else
|
rc = reduce_binary (eval.f3, op1, op2, &result);
|
rc = reduce_binary (eval.f3, op1, op2, &result);
|
|
|
|
|
/* Something went wrong. */
|
/* Something went wrong. */
|
if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
|
if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
|
return NULL;
|
return NULL;
|
|
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
{
|
{
|
gfc_error (gfc_arith_error (rc), &op1->where);
|
gfc_error (gfc_arith_error (rc), &op1->where);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
gfc_free_expr (op1);
|
gfc_free_expr (op1);
|
gfc_free_expr (op2);
|
gfc_free_expr (op2);
|
return result;
|
return result;
|
|
|
runtime:
|
runtime:
|
/* Create a run-time expression. */
|
/* Create a run-time expression. */
|
result = gfc_get_expr ();
|
result = gfc_get_expr ();
|
result->ts = temp.ts;
|
result->ts = temp.ts;
|
|
|
result->expr_type = EXPR_OP;
|
result->expr_type = EXPR_OP;
|
result->value.op.op = op;
|
result->value.op.op = op;
|
|
|
result->value.op.op1 = op1;
|
result->value.op.op1 = op1;
|
result->value.op.op2 = op2;
|
result->value.op.op2 = op2;
|
|
|
result->where = op1->where;
|
result->where = op1->where;
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Modify type of expression for zero size array. */
|
/* Modify type of expression for zero size array. */
|
|
|
static gfc_expr *
|
static gfc_expr *
|
eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
|
eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
|
{
|
{
|
if (op == NULL)
|
if (op == NULL)
|
gfc_internal_error ("eval_type_intrinsic0(): op NULL");
|
gfc_internal_error ("eval_type_intrinsic0(): op NULL");
|
|
|
switch (iop)
|
switch (iop)
|
{
|
{
|
case INTRINSIC_GE:
|
case INTRINSIC_GE:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE_OS:
|
case INTRINSIC_LE_OS:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE_OS:
|
case INTRINSIC_NE_OS:
|
op->ts.type = BT_LOGICAL;
|
op->ts.type = BT_LOGICAL;
|
op->ts.kind = gfc_default_logical_kind;
|
op->ts.kind = gfc_default_logical_kind;
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
|
|
return op;
|
return op;
|
}
|
}
|
|
|
|
|
/* Return nonzero if the expression is a zero size array. */
|
/* Return nonzero if the expression is a zero size array. */
|
|
|
static int
|
static int
|
gfc_zero_size_array (gfc_expr *e)
|
gfc_zero_size_array (gfc_expr *e)
|
{
|
{
|
if (e->expr_type != EXPR_ARRAY)
|
if (e->expr_type != EXPR_ARRAY)
|
return 0;
|
return 0;
|
|
|
return e->value.constructor == NULL;
|
return e->value.constructor == NULL;
|
}
|
}
|
|
|
|
|
/* Reduce a binary expression where at least one of the operands
|
/* Reduce a binary expression where at least one of the operands
|
involves a zero-length array. Returns NULL if neither of the
|
involves a zero-length array. Returns NULL if neither of the
|
operands is a zero-length array. */
|
operands is a zero-length array. */
|
|
|
static gfc_expr *
|
static gfc_expr *
|
reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
|
reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
if (gfc_zero_size_array (op1))
|
if (gfc_zero_size_array (op1))
|
{
|
{
|
gfc_free_expr (op2);
|
gfc_free_expr (op2);
|
return op1;
|
return op1;
|
}
|
}
|
|
|
if (gfc_zero_size_array (op2))
|
if (gfc_zero_size_array (op2))
|
{
|
{
|
gfc_free_expr (op1);
|
gfc_free_expr (op1);
|
return op2;
|
return op2;
|
}
|
}
|
|
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
|
|
static gfc_expr *
|
static gfc_expr *
|
eval_intrinsic_f2 (gfc_intrinsic_op op,
|
eval_intrinsic_f2 (gfc_intrinsic_op op,
|
arith (*eval) (gfc_expr *, gfc_expr **),
|
arith (*eval) (gfc_expr *, gfc_expr **),
|
gfc_expr *op1, gfc_expr *op2)
|
gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
eval_f f;
|
eval_f f;
|
|
|
if (op2 == NULL)
|
if (op2 == NULL)
|
{
|
{
|
if (gfc_zero_size_array (op1))
|
if (gfc_zero_size_array (op1))
|
return eval_type_intrinsic0 (op, op1);
|
return eval_type_intrinsic0 (op, op1);
|
}
|
}
|
else
|
else
|
{
|
{
|
result = reduce_binary0 (op1, op2);
|
result = reduce_binary0 (op1, op2);
|
if (result != NULL)
|
if (result != NULL)
|
return eval_type_intrinsic0 (op, result);
|
return eval_type_intrinsic0 (op, result);
|
}
|
}
|
|
|
f.f2 = eval;
|
f.f2 = eval;
|
return eval_intrinsic (op, f, op1, op2);
|
return eval_intrinsic (op, f, op1, op2);
|
}
|
}
|
|
|
|
|
static gfc_expr *
|
static gfc_expr *
|
eval_intrinsic_f3 (gfc_intrinsic_op op,
|
eval_intrinsic_f3 (gfc_intrinsic_op op,
|
arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
|
gfc_expr *op1, gfc_expr *op2)
|
gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
eval_f f;
|
eval_f f;
|
|
|
result = reduce_binary0 (op1, op2);
|
result = reduce_binary0 (op1, op2);
|
if (result != NULL)
|
if (result != NULL)
|
return eval_type_intrinsic0(op, result);
|
return eval_type_intrinsic0(op, result);
|
|
|
f.f3 = eval;
|
f.f3 = eval;
|
return eval_intrinsic (op, f, op1, op2);
|
return eval_intrinsic (op, f, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_parentheses (gfc_expr *op)
|
gfc_parentheses (gfc_expr *op)
|
{
|
{
|
if (gfc_is_constant_expr (op))
|
if (gfc_is_constant_expr (op))
|
return op;
|
return op;
|
|
|
return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
|
return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
|
op, NULL);
|
op, NULL);
|
}
|
}
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_uplus (gfc_expr *op)
|
gfc_uplus (gfc_expr *op)
|
{
|
{
|
return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
|
return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_uminus (gfc_expr *op)
|
gfc_uminus (gfc_expr *op)
|
{
|
{
|
return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
|
return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_add (gfc_expr *op1, gfc_expr *op2)
|
gfc_add (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_subtract (gfc_expr *op1, gfc_expr *op2)
|
gfc_subtract (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_multiply (gfc_expr *op1, gfc_expr *op2)
|
gfc_multiply (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_divide (gfc_expr *op1, gfc_expr *op2)
|
gfc_divide (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_power (gfc_expr *op1, gfc_expr *op2)
|
gfc_power (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_concat (gfc_expr *op1, gfc_expr *op2)
|
gfc_concat (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_and (gfc_expr *op1, gfc_expr *op2)
|
gfc_and (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_or (gfc_expr *op1, gfc_expr *op2)
|
gfc_or (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_not (gfc_expr *op1)
|
gfc_not (gfc_expr *op1)
|
{
|
{
|
return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
|
return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_eqv (gfc_expr *op1, gfc_expr *op2)
|
gfc_eqv (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_neqv (gfc_expr *op1, gfc_expr *op2)
|
gfc_neqv (gfc_expr *op1, gfc_expr *op2)
|
{
|
{
|
return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
|
return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
|
return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
|
return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
|
return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
|
return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
|
return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
|
}
|
}
|
|
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
|
{
|
{
|
return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
|
return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
|
}
|
}
|
|
|
|
|
/* Convert an integer string to an expression node. */
|
/* Convert an integer string to an expression node. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
|
gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
const char *t;
|
const char *t;
|
|
|
e = gfc_constant_result (BT_INTEGER, kind, where);
|
e = gfc_constant_result (BT_INTEGER, kind, where);
|
/* A leading plus is allowed, but not by mpz_set_str. */
|
/* A leading plus is allowed, but not by mpz_set_str. */
|
if (buffer[0] == '+')
|
if (buffer[0] == '+')
|
t = buffer + 1;
|
t = buffer + 1;
|
else
|
else
|
t = buffer;
|
t = buffer;
|
mpz_set_str (e->value.integer, t, radix);
|
mpz_set_str (e->value.integer, t, radix);
|
|
|
return e;
|
return e;
|
}
|
}
|
|
|
|
|
/* Convert a real string to an expression node. */
|
/* Convert a real string to an expression node. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_convert_real (const char *buffer, int kind, locus *where)
|
gfc_convert_real (const char *buffer, int kind, locus *where)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
e = gfc_constant_result (BT_REAL, kind, where);
|
e = gfc_constant_result (BT_REAL, kind, where);
|
mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
|
mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
|
|
|
return e;
|
return e;
|
}
|
}
|
|
|
|
|
/* Convert a pair of real, constant expression nodes to a single
|
/* Convert a pair of real, constant expression nodes to a single
|
complex expression node. */
|
complex expression node. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
|
gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
|
e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
|
mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
|
mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
|
GFC_MPC_RND_MODE);
|
GFC_MPC_RND_MODE);
|
|
|
return e;
|
return e;
|
}
|
}
|
|
|
|
|
/******* Simplification of intrinsic functions with constant arguments *****/
|
/******* Simplification of intrinsic functions with constant arguments *****/
|
|
|
|
|
/* Deal with an arithmetic error. */
|
/* Deal with an arithmetic error. */
|
|
|
static void
|
static void
|
arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
|
arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
|
{
|
{
|
switch (rc)
|
switch (rc)
|
{
|
{
|
case ARITH_OK:
|
case ARITH_OK:
|
gfc_error ("Arithmetic OK converting %s to %s at %L",
|
gfc_error ("Arithmetic OK converting %s to %s at %L",
|
gfc_typename (from), gfc_typename (to), where);
|
gfc_typename (from), gfc_typename (to), where);
|
break;
|
break;
|
case ARITH_OVERFLOW:
|
case ARITH_OVERFLOW:
|
gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
|
gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
|
"can be disabled with the option -fno-range-check",
|
"can be disabled with the option -fno-range-check",
|
gfc_typename (from), gfc_typename (to), where);
|
gfc_typename (from), gfc_typename (to), where);
|
break;
|
break;
|
case ARITH_UNDERFLOW:
|
case ARITH_UNDERFLOW:
|
gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
|
gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
|
"can be disabled with the option -fno-range-check",
|
"can be disabled with the option -fno-range-check",
|
gfc_typename (from), gfc_typename (to), where);
|
gfc_typename (from), gfc_typename (to), where);
|
break;
|
break;
|
case ARITH_NAN:
|
case ARITH_NAN:
|
gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
|
gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
|
"can be disabled with the option -fno-range-check",
|
"can be disabled with the option -fno-range-check",
|
gfc_typename (from), gfc_typename (to), where);
|
gfc_typename (from), gfc_typename (to), where);
|
break;
|
break;
|
case ARITH_DIV0:
|
case ARITH_DIV0:
|
gfc_error ("Division by zero converting %s to %s at %L",
|
gfc_error ("Division by zero converting %s to %s at %L",
|
gfc_typename (from), gfc_typename (to), where);
|
gfc_typename (from), gfc_typename (to), where);
|
break;
|
break;
|
case ARITH_INCOMMENSURATE:
|
case ARITH_INCOMMENSURATE:
|
gfc_error ("Array operands are incommensurate converting %s to %s at %L",
|
gfc_error ("Array operands are incommensurate converting %s to %s at %L",
|
gfc_typename (from), gfc_typename (to), where);
|
gfc_typename (from), gfc_typename (to), where);
|
break;
|
break;
|
case ARITH_ASYMMETRIC:
|
case ARITH_ASYMMETRIC:
|
gfc_error ("Integer outside symmetric range implied by Standard Fortran"
|
gfc_error ("Integer outside symmetric range implied by Standard Fortran"
|
" converting %s to %s at %L",
|
" converting %s to %s at %L",
|
gfc_typename (from), gfc_typename (to), where);
|
gfc_typename (from), gfc_typename (to), where);
|
break;
|
break;
|
default:
|
default:
|
gfc_internal_error ("gfc_arith_error(): Bad error code");
|
gfc_internal_error ("gfc_arith_error(): Bad error code");
|
}
|
}
|
|
|
/* TODO: Do something about the error, i.e., throw exception, return
|
/* TODO: Do something about the error, i.e., throw exception, return
|
NaN, etc. */
|
NaN, etc. */
|
}
|
}
|
|
|
|
|
/* Convert integers to integers. */
|
/* Convert integers to integers. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_int2int (gfc_expr *src, int kind)
|
gfc_int2int (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
|
|
mpz_set (result->value.integer, src->value.integer);
|
mpz_set (result->value.integer, src->value.integer);
|
|
|
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
|
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
|
{
|
{
|
if (rc == ARITH_ASYMMETRIC)
|
if (rc == ARITH_ASYMMETRIC)
|
{
|
{
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
}
|
}
|
else
|
else
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert integers to reals. */
|
/* Convert integers to reals. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_int2real (gfc_expr *src, int kind)
|
gfc_int2real (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_REAL, kind, &src->where);
|
result = gfc_constant_result (BT_REAL, kind, &src->where);
|
|
|
mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
|
mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
|
|
|
if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
|
if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert default integer to default complex. */
|
/* Convert default integer to default complex. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_int2complex (gfc_expr *src, int kind)
|
gfc_int2complex (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
|
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
|
|
|
mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
|
mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
|
|
|
if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
|
if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
|
!= ARITH_OK)
|
!= ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert default real to default integer. */
|
/* Convert default real to default integer. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_real2int (gfc_expr *src, int kind)
|
gfc_real2int (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
|
|
gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
|
gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
|
|
|
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
|
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert real to real. */
|
/* Convert real to real. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_real2real (gfc_expr *src, int kind)
|
gfc_real2real (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_REAL, kind, &src->where);
|
result = gfc_constant_result (BT_REAL, kind, &src->where);
|
|
|
mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
|
mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
|
|
|
rc = gfc_check_real_range (result->value.real, kind);
|
rc = gfc_check_real_range (result->value.real, kind);
|
|
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
{
|
{
|
if (gfc_option.warn_underflow)
|
if (gfc_option.warn_underflow)
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
}
|
}
|
else if (rc != ARITH_OK)
|
else if (rc != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert real to complex. */
|
/* Convert real to complex. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_real2complex (gfc_expr *src, int kind)
|
gfc_real2complex (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
|
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
|
|
|
mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
|
mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
|
|
|
rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
|
rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
|
|
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
{
|
{
|
if (gfc_option.warn_underflow)
|
if (gfc_option.warn_underflow)
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
|
mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
|
}
|
}
|
else if (rc != ARITH_OK)
|
else if (rc != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert complex to integer. */
|
/* Convert complex to integer. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_complex2int (gfc_expr *src, int kind)
|
gfc_complex2int (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
|
|
gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
|
gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
|
&src->where);
|
&src->where);
|
|
|
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
|
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert complex to real. */
|
/* Convert complex to real. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_complex2real (gfc_expr *src, int kind)
|
gfc_complex2real (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_REAL, kind, &src->where);
|
result = gfc_constant_result (BT_REAL, kind, &src->where);
|
|
|
mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
|
mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
|
|
|
rc = gfc_check_real_range (result->value.real, kind);
|
rc = gfc_check_real_range (result->value.real, kind);
|
|
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
{
|
{
|
if (gfc_option.warn_underflow)
|
if (gfc_option.warn_underflow)
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
}
|
}
|
if (rc != ARITH_OK)
|
if (rc != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert complex to complex. */
|
/* Convert complex to complex. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_complex2complex (gfc_expr *src, int kind)
|
gfc_complex2complex (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
arith rc;
|
arith rc;
|
|
|
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
|
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
|
|
|
mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
|
mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
|
|
|
rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
|
rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
|
|
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
{
|
{
|
if (gfc_option.warn_underflow)
|
if (gfc_option.warn_underflow)
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
|
mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
|
}
|
}
|
else if (rc != ARITH_OK)
|
else if (rc != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
|
rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
|
|
|
if (rc == ARITH_UNDERFLOW)
|
if (rc == ARITH_UNDERFLOW)
|
{
|
{
|
if (gfc_option.warn_underflow)
|
if (gfc_option.warn_underflow)
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
gfc_warning (gfc_arith_error (rc), &src->where);
|
mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
|
mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
|
}
|
}
|
else if (rc != ARITH_OK)
|
else if (rc != ARITH_OK)
|
{
|
{
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
arith_error (rc, &src->ts, &result->ts, &src->where);
|
gfc_free_expr (result);
|
gfc_free_expr (result);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Logical kind conversion. */
|
/* Logical kind conversion. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_log2log (gfc_expr *src, int kind)
|
gfc_log2log (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
|
result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
|
result->value.logical = src->value.logical;
|
result->value.logical = src->value.logical;
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert logical to integer. */
|
/* Convert logical to integer. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_log2int (gfc_expr *src, int kind)
|
gfc_log2int (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
|
mpz_set_si (result->value.integer, src->value.logical);
|
mpz_set_si (result->value.integer, src->value.logical);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert integer to logical. */
|
/* Convert integer to logical. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_int2log (gfc_expr *src, int kind)
|
gfc_int2log (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
|
result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
|
result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
|
result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Helper function to set the representation in a Hollerith conversion.
|
/* Helper function to set the representation in a Hollerith conversion.
|
This assumes that the ts.type and ts.kind of the result have already
|
This assumes that the ts.type and ts.kind of the result have already
|
been set. */
|
been set. */
|
|
|
static void
|
static void
|
hollerith2representation (gfc_expr *result, gfc_expr *src)
|
hollerith2representation (gfc_expr *result, gfc_expr *src)
|
{
|
{
|
int src_len, result_len;
|
int src_len, result_len;
|
|
|
src_len = src->representation.length;
|
src_len = src->representation.length;
|
result_len = gfc_target_expr_size (result);
|
result_len = gfc_target_expr_size (result);
|
|
|
if (src_len > result_len)
|
if (src_len > result_len)
|
{
|
{
|
gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
|
gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
|
&src->where, gfc_typename(&result->ts));
|
&src->where, gfc_typename(&result->ts));
|
}
|
}
|
|
|
result->representation.string = XCNEWVEC (char, result_len + 1);
|
result->representation.string = XCNEWVEC (char, result_len + 1);
|
memcpy (result->representation.string, src->representation.string,
|
memcpy (result->representation.string, src->representation.string,
|
MIN (result_len, src_len));
|
MIN (result_len, src_len));
|
|
|
if (src_len < result_len)
|
if (src_len < result_len)
|
memset (&result->representation.string[src_len], ' ', result_len - src_len);
|
memset (&result->representation.string[src_len], ' ', result_len - src_len);
|
|
|
result->representation.string[result_len] = '\0'; /* For debugger */
|
result->representation.string[result_len] = '\0'; /* For debugger */
|
result->representation.length = result_len;
|
result->representation.length = result_len;
|
}
|
}
|
|
|
|
|
/* Convert Hollerith to integer. The constant will be padded or truncated. */
|
/* Convert Hollerith to integer. The constant will be padded or truncated. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_hollerith2int (gfc_expr *src, int kind)
|
gfc_hollerith2int (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_get_expr ();
|
result = gfc_get_expr ();
|
result->expr_type = EXPR_CONSTANT;
|
result->expr_type = EXPR_CONSTANT;
|
result->ts.type = BT_INTEGER;
|
result->ts.type = BT_INTEGER;
|
result->ts.kind = kind;
|
result->ts.kind = kind;
|
result->where = src->where;
|
result->where = src->where;
|
|
|
hollerith2representation (result, src);
|
hollerith2representation (result, src);
|
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
|
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
|
result->representation.length, result->value.integer);
|
result->representation.length, result->value.integer);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert Hollerith to real. The constant will be padded or truncated. */
|
/* Convert Hollerith to real. The constant will be padded or truncated. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_hollerith2real (gfc_expr *src, int kind)
|
gfc_hollerith2real (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_get_expr ();
|
result = gfc_get_expr ();
|
result->expr_type = EXPR_CONSTANT;
|
result->expr_type = EXPR_CONSTANT;
|
result->ts.type = BT_REAL;
|
result->ts.type = BT_REAL;
|
result->ts.kind = kind;
|
result->ts.kind = kind;
|
result->where = src->where;
|
result->where = src->where;
|
|
|
hollerith2representation (result, src);
|
hollerith2representation (result, src);
|
gfc_interpret_float (kind, (unsigned char *) result->representation.string,
|
gfc_interpret_float (kind, (unsigned char *) result->representation.string,
|
result->representation.length, result->value.real);
|
result->representation.length, result->value.real);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert Hollerith to complex. The constant will be padded or truncated. */
|
/* Convert Hollerith to complex. The constant will be padded or truncated. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_hollerith2complex (gfc_expr *src, int kind)
|
gfc_hollerith2complex (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_get_expr ();
|
result = gfc_get_expr ();
|
result->expr_type = EXPR_CONSTANT;
|
result->expr_type = EXPR_CONSTANT;
|
result->ts.type = BT_COMPLEX;
|
result->ts.type = BT_COMPLEX;
|
result->ts.kind = kind;
|
result->ts.kind = kind;
|
result->where = src->where;
|
result->where = src->where;
|
|
|
hollerith2representation (result, src);
|
hollerith2representation (result, src);
|
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
|
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
|
result->representation.length, result->value.complex);
|
result->representation.length, result->value.complex);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert Hollerith to character. */
|
/* Convert Hollerith to character. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_hollerith2character (gfc_expr *src, int kind)
|
gfc_hollerith2character (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_copy_expr (src);
|
result = gfc_copy_expr (src);
|
result->ts.type = BT_CHARACTER;
|
result->ts.type = BT_CHARACTER;
|
result->ts.kind = kind;
|
result->ts.kind = kind;
|
|
|
result->value.character.length = result->representation.length;
|
result->value.character.length = result->representation.length;
|
result->value.character.string
|
result->value.character.string
|
= gfc_char_to_widechar (result->representation.string);
|
= gfc_char_to_widechar (result->representation.string);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Convert Hollerith to logical. The constant will be padded or truncated. */
|
/* Convert Hollerith to logical. The constant will be padded or truncated. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_hollerith2logical (gfc_expr *src, int kind)
|
gfc_hollerith2logical (gfc_expr *src, int kind)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_get_expr ();
|
result = gfc_get_expr ();
|
result->expr_type = EXPR_CONSTANT;
|
result->expr_type = EXPR_CONSTANT;
|
result->ts.type = BT_LOGICAL;
|
result->ts.type = BT_LOGICAL;
|
result->ts.kind = kind;
|
result->ts.kind = kind;
|
result->where = src->where;
|
result->where = src->where;
|
|
|
hollerith2representation (result, src);
|
hollerith2representation (result, src);
|
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
|
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
|
result->representation.length, &result->value.logical);
|
result->representation.length, &result->value.logical);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
