arith.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

gfc_expr *
gfc_lt (gfc_expr * op1, gfc_expr * op2)
{
  return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
}

gfc_expr *
gfc_le (gfc_expr * op1, gfc_expr * op2)
{
  return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
}


/* Convert an integer string to an expression node.  */

gfc_expr *
gfc_convert_integer (const char *buffer, int kind, int radix, locus * where)
{
  gfc_expr *e;
  const char *t;

  e = gfc_constant_result (BT_INTEGER, kind, where);
  /* a leading plus is allowed, but not by mpz_set_str */
  if (buffer[0] == '+')
    t = buffer + 1;
  else
    t = buffer;
  mpz_set_str (e->value.integer, t, radix);

  return e;
}


/* Convert a real string to an expression node.  */

gfc_expr *
gfc_convert_real (const char *buffer, int kind, locus * where)
{
  gfc_expr *e;

  e = gfc_constant_result (BT_REAL, kind, where);
  mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);

  return e;
}


/* Convert a pair of real, constant expression nodes to a single
   complex expression node.  */

gfc_expr *
gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind)
{
  gfc_expr *e;

  e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
  mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
  mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);

  return e;
}


/******* Simplification of intrinsic functions with constant arguments *****/


/* Deal with an arithmetic error.  */

static void
arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
{
  switch (rc)
    {
    case ARITH_OK:
      gfc_error ("Arithmetic OK converting %s to %s at %L",
		 gfc_typename (from), gfc_typename (to), where);
      break;
    case ARITH_OVERFLOW:
      gfc_error ("Arithmetic overflow converting %s to %s at %L",
		 gfc_typename (from), gfc_typename (to), where);
      break;
    case ARITH_UNDERFLOW:
      gfc_error ("Arithmetic underflow converting %s to %s at %L",
		 gfc_typename (from), gfc_typename (to), where);
      break;
    case ARITH_NAN:
      gfc_error ("Arithmetic NaN converting %s to %s at %L",
		 gfc_typename (from), gfc_typename (to), where);
      break;
    case ARITH_DIV0:
      gfc_error ("Division by zero converting %s to %s at %L",
		 gfc_typename (from), gfc_typename (to), where);
      break;
    case ARITH_INCOMMENSURATE:
      gfc_error ("Array operands are incommensurate converting %s to %s at %L",
		 gfc_typename (from), gfc_typename (to), where);
      break;
    case ARITH_ASYMMETRIC:
      gfc_error ("Integer outside symmetric range implied by Standard Fortran"
	 	 " converting %s to %s at %L",
		 gfc_typename (from), gfc_typename (to), where);
      break;
    default:
      gfc_internal_error ("gfc_arith_error(): Bad error code");
    }

  /* TODO: Do something about the error, ie, throw exception, return
     NaN, etc.  */
}

/* Convert integers to integers.  */

gfc_expr *
gfc_int2int (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_INTEGER, kind, &src->where);

  mpz_set (result->value.integer, src->value.integer);

  if ((rc = gfc_check_integer_range (result->value.integer, kind))
      != ARITH_OK)
    {
      if (rc == ARITH_ASYMMETRIC)
        {
          gfc_warning (gfc_arith_error (rc), &src->where);
        }
      else
        {
          arith_error (rc, &src->ts, &result->ts, &src->where);
          gfc_free_expr (result);
          return NULL;
        }
    }

  return result;
}


/* Convert integers to reals.  */

gfc_expr *
gfc_int2real (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_REAL, kind, &src->where);

  mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);

  if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Convert default integer to default complex.  */

gfc_expr *
gfc_int2complex (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_COMPLEX, kind, &src->where);

  mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
  mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);

  if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Convert default real to default integer.  */

gfc_expr *
gfc_real2int (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_INTEGER, kind, &src->where);

  gfc_mpfr_to_mpz (result->value.integer, src->value.real);

  if ((rc = gfc_check_integer_range (result->value.integer, kind))
      != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Convert real to real.  */

gfc_expr *
gfc_real2real (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_REAL, kind, &src->where);

  mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);

  rc = gfc_check_real_range (result->value.real, kind);

  if (rc == ARITH_UNDERFLOW)
    {
      if (gfc_option.warn_underflow)
        gfc_warning (gfc_arith_error (rc), &src->where);
      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
    }
  else if (rc != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Convert real to complex.  */

gfc_expr *
gfc_real2complex (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_COMPLEX, kind, &src->where);

  mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
  mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);

  rc = gfc_check_real_range (result->value.complex.r, kind);

  if (rc == ARITH_UNDERFLOW)
    {
      if (gfc_option.warn_underflow)
        gfc_warning (gfc_arith_error (rc), &src->where);
      mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
    }
  else if (rc != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Convert complex to integer.  */

gfc_expr *
gfc_complex2int (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_INTEGER, kind, &src->where);

  gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r);

  if ((rc = gfc_check_integer_range (result->value.integer, kind))
      != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Convert complex to real.  */

gfc_expr *
gfc_complex2real (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_REAL, kind, &src->where);

  mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);

  rc = gfc_check_real_range (result->value.real, kind);

  if (rc == ARITH_UNDERFLOW)
    {
      if (gfc_option.warn_underflow)
        gfc_warning (gfc_arith_error (rc), &src->where);
      mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
    }
  if (rc != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Convert complex to complex.  */

gfc_expr *
gfc_complex2complex (gfc_expr * src, int kind)
{
  gfc_expr *result;
  arith rc;

  result = gfc_constant_result (BT_COMPLEX, kind, &src->where);

  mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE);
  mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE);

  rc = gfc_check_real_range (result->value.complex.r, kind);

  if (rc == ARITH_UNDERFLOW)
    {
      if (gfc_option.warn_underflow)
        gfc_warning (gfc_arith_error (rc), &src->where);
      mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
    }
  else if (rc != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  rc = gfc_check_real_range (result->value.complex.i, kind);

  if (rc == ARITH_UNDERFLOW)
    {
      if (gfc_option.warn_underflow)
        gfc_warning (gfc_arith_error (rc), &src->where);
      mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
    }
  else if (rc != ARITH_OK)
    {
      arith_error (rc, &src->ts, &result->ts, &src->where);
      gfc_free_expr (result);
      return NULL;
    }

  return result;
}


/* Logical kind conversion.  */

gfc_expr *
gfc_log2log (gfc_expr * src, int kind)
{
  gfc_expr *result;

  result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
  result->value.logical = src->value.logical;

  return result;
}

/* Convert logical to integer.  */

gfc_expr *
gfc_log2int (gfc_expr *src, int kind)
{
  gfc_expr *result;
  result = gfc_constant_result (BT_INTEGER, kind, &src->where);
  mpz_set_si (result->value.integer, src->value.logical);
  return result;
}

/* Convert integer to logical.  */

gfc_expr *
gfc_int2log (gfc_expr *src, int kind)
{
  gfc_expr *result;
  result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
  result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
  return result;
}

/* Convert Hollerith to integer. The constant will be padded or truncated.  */

gfc_expr *
gfc_hollerith2int (gfc_expr * src, int kind)
{
  gfc_expr *result;
  int len;

  len = src->value.character.length;

  result = gfc_get_expr ();
  result->expr_type = EXPR_CONSTANT;
  result->ts.type = BT_INTEGER;
  result->ts.kind = kind;
  result->where = src->where;
  result->from_H = 1;

  if (len > kind)
    {
      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
		&src->where, gfc_typename(&result->ts));
    }
  result->value.character.string = gfc_getmem (kind + 1);
  memcpy (result->value.character.string, src->value.character.string,
	MIN (kind, len));

  if (len < kind)
    memset (&result->value.character.string[len], ' ', kind - len);

  result->value.character.string[kind] = '\0'; /* For debugger */
  result->value.character.length = kind;

  return result;
}

/* Convert Hollerith to real. The constant will be padded or truncated.  */

gfc_expr *
gfc_hollerith2real (gfc_expr * src, int kind)
{
  gfc_expr *result;
  int len;

  len = src->value.character.length;

  result = gfc_get_expr ();
  result->expr_type = EXPR_CONSTANT;
  result->ts.type = BT_REAL;
  result->ts.kind = kind;
  result->where = src->where;
  result->from_H = 1;

  if (len > kind)
    {
      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
		&src->where, gfc_typename(&result->ts));
    }
  result->value.character.string = gfc_getmem (kind + 1);
  memcpy (result->value.character.string, src->value.character.string,
	MIN (kind, len));

  if (len < kind)
    memset (&result->value.character.string[len], ' ', kind - len);

  result->value.character.string[kind] = '\0'; /* For debugger */
  result->value.character.length = kind;

  return result;
}

/* Convert Hollerith to complex. The constant will be padded or truncated.  */

gfc_expr *
gfc_hollerith2complex (gfc_expr * src, int kind)
{
  gfc_expr *result;
  int len;

  len = src->value.character.length;

  result = gfc_get_expr ();
  result->expr_type = EXPR_CONSTANT;
  result->ts.type = BT_COMPLEX;
  result->ts.kind = kind;
  result->where = src->where;
  result->from_H = 1;

  kind = kind * 2;

  if (len > kind)
    {
      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
		&src->where, gfc_typename(&result->ts));
    }
  result->value.character.string = gfc_getmem (kind + 1);
  memcpy (result->value.character.string, src->value.character.string,
	MIN (kind, len));

  if (len < kind)
    memset (&result->value.character.string[len], ' ', kind - len);

  result->value.character.string[kind] = '\0'; /* For debugger */
  result->value.character.length = kind;

  return result;
}

/* Convert Hollerith to character. */

gfc_expr *
gfc_hollerith2character (gfc_expr * src, int kind)
{
  gfc_expr *result;

  result = gfc_copy_expr (src);
  result->ts.type = BT_CHARACTER;
  result->ts.kind = kind;
  result->from_H = 1;

  return result;
}

/* Convert Hollerith to logical. The constant will be padded or truncated.  */

gfc_expr *
gfc_hollerith2logical (gfc_expr * src, int kind)
{
  gfc_expr *result;
  int len;

  len = src->value.character.length;

  result = gfc_get_expr ();
  result->expr_type = EXPR_CONSTANT;
  result->ts.type = BT_LOGICAL;
  result->ts.kind = kind;
  result->where = src->where;
  result->from_H = 1;

  if (len > kind)
    {
      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
		&src->where, gfc_typename(&result->ts));
    }
  result->value.character.string = gfc_getmem (kind + 1);
  memcpy (result->value.character.string, src->value.character.string,
	MIN (kind, len));

  if (len < kind)
    memset (&result->value.character.string[len], ' ', kind - len);

  result->value.character.string[kind] = '\0'; /* For debugger */
  result->value.character.length = kind;

  return result;
}

/* Returns an initializer whose value is one higher than the value of the
   LAST_INITIALIZER argument.  If that is argument is NULL, the
   initializers value will be set to zero.  The initializer's kind
   will be set to gfc_c_int_kind.

   If -fshort-enums is given, the appropriate kind will be selected
   later after all enumerators have been parsed.  A warning is issued
   here if an initializer exceeds gfc_c_int_kind.  */

gfc_expr *
gfc_enum_initializer (gfc_expr *last_initializer, locus where)
{
  gfc_expr *result;

  result = gfc_get_expr ();
  result->expr_type = EXPR_CONSTANT;
  result->ts.type = BT_INTEGER;
  result->ts.kind = gfc_c_int_kind;
  result->where = where;

  mpz_init (result->value.integer);

  if (last_initializer != NULL)
    {
      mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
      result->where = last_initializer->where;

      if (gfc_check_integer_range (result->value.integer,
             gfc_c_int_kind) != ARITH_OK)
        {
          gfc_error ("Enumerator exceeds the C integer type at %C");
          return NULL;
        }
    }
  else
    {
      /* Control comes here, if it's the very first enumerator and no
         initializer has been given.  It will be initialized to ZERO (0). */
      mpz_set_si (result->value.integer, 0);
    }

  return result;
}