/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
- Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
#include "arith.h"
#include "intrinsic.h"
#include "target-memory.h"
+#include "constructor.h"
-/* Savely advance an array constructor by 'n' elements.
- Mainly used by simplifiers of transformational intrinsics. */
-#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0)
gfc_expr gfc_bad_expr;
be a part of the new expression.
NULL pointer indicating that no simplification was possible and
- the original expression should remain intact. If the
- simplification function sets the type and/or the function name
- via the pointer gfc_simple_expression, then this type is
- retained.
+ the original expression should remain intact.
An expression pointer to gfc_bad_expr (a static placeholder)
- indicating that some error has prevented simplification. For
- example, sqrt(-1.0). The error is generated within the function
- and should be propagated upwards
+ indicating that some error has prevented simplification. The
+ error is generated within the function and should be propagated
+ upwards
By the time a simplification function gets control, it has been
decided that the function call is really supposed to be the
subroutine may have to look at the type of an argument as part of
its processing.
- Array arguments are never passed to these subroutines.
+ Array arguments are only passed to these subroutines that implement
+ the simplification of transformational intrinsics.
The functions in this file don't have much comment with them, but
everything is reasonably straight-forward. The Standard, chapter 13
}
-/* Helper function to get an integer constant with a kind number given
- by an integer constant expression. */
-static gfc_expr *
-int_expr_with_kind (int i, gfc_expr *kind, const char *name)
-{
- gfc_expr *res = gfc_int_expr (i);
- res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
- if (res->ts.kind == -1)
- return NULL;
- else
- return res;
-}
-
-
/* Converts an mpz_t signed variable into an unsigned one, assuming
two's complement representations and a binary width of bitsize.
The conversion is a no-op unless x is negative; otherwise, it can
}
}
+
+/* In-place convert BOZ to REAL of the specified kind. */
+
+static gfc_expr *
+convert_boz (gfc_expr *x, int kind)
+{
+ if (x && x->ts.type == BT_INTEGER && x->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = kind;
+
+ if (!gfc_convert_boz (x, &ts))
+ return &gfc_bad_expr;
+ }
+
+ return x;
+}
+
+
/* Test that the expression is an constant array. */
static bool
if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
return false;
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
if (c->expr->expr_type != EXPR_CONSTANT)
return false;
{
if (e && e->expr_type == EXPR_ARRAY)
{
- gfc_constructor *ctor = e->value.constructor;
+ gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
while (ctor)
{
init_result_expr (ctor->expr, init, array);
- ctor = ctor->next;
+ ctor = gfc_constructor_next (ctor);
}
}
else if (e && e->expr_type == EXPR_CONSTANT)
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc
mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
-#else
- mpfr_set_si (e->value.complex.r, init, GFC_RND_MODE);
- mpfr_set_si (e->value.complex.i, 0, GFC_RND_MODE);
-#endif
break;
case BT_CHARACTER:
/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
static gfc_expr *
-compute_dot_product (gfc_constructor *ctor_a, int stride_a,
- gfc_constructor *ctor_b, int stride_b)
+compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
+ gfc_expr *matrix_b, int stride_b, int offset_b)
{
- gfc_expr *result;
- gfc_expr *a = ctor_a->expr, *b = ctor_b->expr;
-
- gcc_assert (gfc_compare_types (&a->ts, &b->ts));
+ gfc_expr *result, *a, *b;
- result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+ result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
+ &matrix_a->where);
init_result_expr (result, 0, NULL);
- while (ctor_a && ctor_b)
+ a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+ b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
+ while (a && b)
{
/* Copying of expressions is required as operands are free'd
by the gfc_arith routines. */
{
case BT_LOGICAL:
result = gfc_or (result,
- gfc_and (gfc_copy_expr (ctor_a->expr),
- gfc_copy_expr (ctor_b->expr)));
+ gfc_and (gfc_copy_expr (a),
+ gfc_copy_expr (b)));
break;
case BT_INTEGER:
case BT_REAL:
case BT_COMPLEX:
result = gfc_add (result,
- gfc_multiply (gfc_copy_expr (ctor_a->expr),
- gfc_copy_expr (ctor_b->expr)));
+ gfc_multiply (gfc_copy_expr (a),
+ gfc_copy_expr (b)));
break;
default:
gcc_unreachable();
}
- ADVANCE (ctor_a, stride_a);
- ADVANCE (ctor_b, stride_b);
+ offset_a += stride_a;
+ a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+
+ offset_b += stride_b;
+ b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
}
return result;
int i, nelem;
if (!dim || array->rank == 1)
- return gfc_constant_result (type, kind, where);
+ return gfc_get_constant_expr (type, kind, where);
- result = gfc_start_constructor (type, kind, where);
+ result = gfc_get_array_expr (type, kind, where);
result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
result->rank = array->rank - 1;
for (i = 0; i < nelem; ++i)
{
- gfc_expr *e = gfc_constant_result (type, kind, where);
- gfc_append_constructor (result, e);
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_get_constant_expr (type, kind, where),
+ NULL);
}
return result;
&& !mask->value.logical)
return result;
- array_ctor = array->value.constructor;
+ array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
if (mask && mask->expr_type == EXPR_ARRAY)
- mask_ctor = mask->value.constructor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (array_ctor)
{
a = array_ctor->expr;
- array_ctor = array_ctor->next;
+ array_ctor = gfc_constructor_next (array_ctor);
/* A constant MASK equals .TRUE. here and can be ignored. */
if (mask_ctor)
{
m = mask_ctor->expr;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
if (!m->value.logical)
continue;
}
arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
- array_ctor = array->value.constructor;
+ array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
if (mask && mask->expr_type == EXPR_ARRAY)
- mask_ctor = mask->value.constructor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
for (i = 0; i < arraysize; ++i)
{
arrayvec[i] = array_ctor->expr;
- array_ctor = array_ctor->next;
+ array_ctor = gfc_constructor_next (array_ctor);
if (mask_ctor)
{
if (!mask_ctor->expr->value.logical)
arrayvec[i] = NULL;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
}
mpz_clear (size);
resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
- result_ctor = result->value.constructor;
+ result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
resultvec[i] = result_ctor->expr;
- result_ctor = result_ctor->next;
+ result_ctor = gfc_constructor_next (result_ctor);
}
gfc_extract_int (dim, &dim_index);
}
/* Place updated expression in result constructor. */
- result_ctor = result->value.constructor;
+ result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
result_ctor->expr = resultvec[i];
- result_ctor = result_ctor->next;
+ result_ctor = gfc_constructor_next (result_ctor);
}
gfc_free (arrayvec);
switch (e->ts.type)
{
- case BT_INTEGER:
- result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
-
- mpz_abs (result->value.integer, e->value.integer);
-
- result = range_check (result, "IABS");
- break;
-
- case BT_REAL:
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-
- mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
-
- result = range_check (result, "ABS");
- break;
-
- case BT_COMPLEX:
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
+ mpz_abs (result->value.integer, e->value.integer);
+ return range_check (result, "IABS");
- gfc_set_model_kind (e->ts.kind);
+ case BT_REAL:
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
+ return range_check (result, "ABS");
-#ifdef HAVE_mpc
- mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
-#else
- mpfr_hypot (result->value.real, e->value.complex.r,
- e->value.complex.i, GFC_RND_MODE);
-#endif
- result = range_check (result, "CABS");
- break;
+ case BT_COMPLEX:
+ gfc_set_model_kind (e->ts.kind);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
+ return range_check (result, "CABS");
- default:
- gfc_internal_error ("gfc_simplify_abs(): Bad type");
+ default:
+ gfc_internal_error ("gfc_simplify_abs(): Bad type");
}
-
- return result;
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
- result->value.character.string = gfc_get_wide_string (2);
- result->value.character.length = 1;
+ result = gfc_get_character_expr (kind, &e->where, NULL, 1);
result->value.character.string[0] = mpz_get_ui (e->value.integer);
- result->value.character.string[1] = '\0'; /* For debugger */
+
return result;
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) > 0
- || mpfr_cmp_si (x->value.real, -1) < 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ACOS at %L must be between -1 and 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error ("Argument of ACOS at %L must be between -1 and 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_acos(): Bad type");
+ }
return range_check (result, "ACOS");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) < 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ACOSH at %L must not be less than 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) < 0)
+ {
+ gfc_error ("Argument of ACOSH at %L must not be less than 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
+ }
return range_check (result, "ACOSH");
}
len = e->value.character.length;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
- result->value.character.length = len;
- result->value.character.string = gfc_get_wide_string (len + 1);
-
for (count = 0, i = 0; i < len; ++i)
{
ch = e->value.character.string[i];
++count;
}
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < len - count; ++i)
result->value.character.string[i] = e->value.character.string[count + i];
- for (i = len - count; i < len; ++i)
- result->value.character.string[i] = ' ';
-
- result->value.character.string[len] = '\0'; /* For debugger */
-
return result;
}
len = e->value.character.length;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
- result->value.character.length = len;
- result->value.character.string = gfc_get_wide_string (len + 1);
-
for (count = 0, i = len - 1; i >= 0; --i)
{
ch = e->value.character.string[i];
++count;
}
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < count; ++i)
result->value.character.string[i] = ' ';
for (i = count; i < len; ++i)
result->value.character.string[i] = e->value.character.string[i - count];
- result->value.character.string[len] = '\0'; /* For debugger */
-
return result;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
return range_check (result, "AIMAG");
return NULL;
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, kind);
+
gfc_free_expr (rtrunc);
return range_check (result, "AINT");
return NULL;
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, gfc_default_double_kind);
+
gfc_free_expr (rtrunc);
return range_check (result, "DINT");
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, kind, &e->where);
-
+ result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "ANINT");
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_and (result->value.integer, x->value.integer, y->value.integer);
- return range_check (result, "AND");
- }
- else /* BT_LOGICAL */
+
+ switch (x->ts.type)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = x->value.logical && y->value.logical;
- return result;
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_and (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "AND");
+
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ x->value.logical && y->value.logical);
+
+ default:
+ gcc_unreachable ();
}
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
-
+ result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "DNINT");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) > 0
- || mpfr_cmp_si (x->value.real, -1) < 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ASIN at %L must be between -1 and 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error ("Argument of ASIN at %L must be between -1 and 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_asin(): Bad type");
+ }
return range_check (result, "ASIN");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
+ }
return range_check (result, "ASINH");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
-
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("in gfc_simplify_atan(): Bad type");
+ }
return range_check (result, "ATAN");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) >= 0
- || mpfr_cmp_si (x->value.real, -1) <= 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) >= 0
+ || mpfr_cmp_si (x->value.real, -1) <= 0)
+ {
+ gfc_error ("Argument of ATANH at %L must be inside the range -1 "
+ "to 1", &x->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
+ }
return range_check (result, "ATANH");
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN2");
gfc_expr *
-gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_j0 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J0");
gfc_expr *
-gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_j1 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J1");
gfc_expr *
-gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
- gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
long n;
return NULL;
n = mpz_get_si (order->value.integer);
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_JN");
gfc_expr *
-gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_y0 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y0");
gfc_expr *
-gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_y1 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y1");
gfc_expr *
-gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
- gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
long n;
return NULL;
n = mpz_get_si (order->value.integer);
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_YN");
gfc_expr *
gfc_simplify_bit_size (gfc_expr *e)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
- mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
-
- return result;
+ int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ return gfc_get_int_expr (e->ts.kind, &e->where,
+ gfc_integer_kinds[i].bit_size);
}
return NULL;
if (gfc_extract_int (bit, &b) != NULL || b < 0)
- return gfc_logical_expr (0, &e->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
- return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
+ mpz_tstbit (e->value.integer, b));
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
ceil = gfc_copy_expr (e);
-
mpfr_ceil (ceil->value.real, e->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
gfc_free_expr (ceil);
}
-/* Common subroutine for simplifying CMPLX and DCMPLX. */
+/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
static gfc_expr *
simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
- result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
+ if (convert_boz (x, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ if (convert_boz (y, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ if (x->expr_type != EXPR_CONSTANT
+ || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ return NULL;
-#ifndef HAVE_mpc
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
-#endif
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- if (!x->is_boz)
-#ifdef HAVE_mpc
+ case BT_INTEGER:
mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
-#else
- mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
-#endif
- break;
+ break;
- case BT_REAL:
-#ifdef HAVE_mpc
- mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
-#else
- mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
-#endif
- break;
+ case BT_REAL:
+ mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
-#ifdef HAVE_mpc
- mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
- mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
-#endif
- break;
+ case BT_COMPLEX:
+ mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
+ default:
+ gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
}
- if (y != NULL)
- {
- switch (y->ts.type)
- {
- case BT_INTEGER:
- if (!y->is_boz)
- mpfr_set_z (mpc_imagref (result->value.complex),
- y->value.integer, GFC_RND_MODE);
- break;
-
- case BT_REAL:
- mpfr_set (mpc_imagref (result->value.complex),
- y->value.real, GFC_RND_MODE);
- break;
-
- default:
- gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
- }
- }
+ if (!y)
+ return range_check (result, name);
- /* Handle BOZ. */
- if (x->is_boz)
+ switch (y->ts.type)
{
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.kind = result->ts.kind;
- ts.type = BT_REAL;
- if (!gfc_convert_boz (x, &ts))
- return &gfc_bad_expr;
- mpfr_set (mpc_realref (result->value.complex),
- x->value.real, GFC_RND_MODE);
- }
+ case BT_INTEGER:
+ mpfr_set_z (mpc_imagref (result->value.complex),
+ y->value.integer, GFC_RND_MODE);
+ break;
- if (y && y->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.kind = result->ts.kind;
- ts.type = BT_REAL;
- if (!gfc_convert_boz (y, &ts))
- return &gfc_bad_expr;
- mpfr_set (mpc_imagref (result->value.complex),
- y->value.real, GFC_RND_MODE);
+ case BT_REAL:
+ mpfr_set (mpc_imagref (result->value.complex),
+ y->value.real, GFC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
}
return range_check (result, name);
}
-/* Function called when we won't simplify an expression like CMPLX (or
- COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
-
-static gfc_expr *
-only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
-{
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = kind;
-
- if (x->is_boz && !gfc_convert_boz (x, &ts))
- return &gfc_bad_expr;
-
- if (y && y->is_boz && !gfc_convert_boz (y, &ts))
- return &gfc_bad_expr;
-
- return NULL;
-}
-
-
gfc_expr *
gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
{
int kind;
- kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
+ kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
if (kind == -1)
return &gfc_bad_expr;
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return only_convert_cmplx_boz (x, y, kind);
-
return simplify_cmplx ("CMPLX", x, y, kind);
}
{
int kind;
- if (x->ts.type == BT_INTEGER)
- {
- if (y->ts.type == BT_INTEGER)
- kind = gfc_default_real_kind;
- else
- kind = y->ts.kind;
- }
+ if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
+ kind = gfc_default_complex_kind;
+ else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
+ kind = x->ts.kind;
+ else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
+ kind = y->ts.kind;
+ else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
+ kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
else
- {
- if (y->ts.type == BT_REAL)
- kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
- else
- kind = x->ts.kind;
- }
-
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return only_convert_cmplx_boz (x, y, kind);
+ gcc_unreachable ();
return simplify_cmplx ("COMPLEX", x, y, kind);
}
return NULL;
result = gfc_copy_expr (e);
-#ifdef HAVE_mpc
mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
-#else
- mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
-#endif
return range_check (result, "CONJG");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
- break;
- case BT_COMPLEX:
- gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
- mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- {
- mpfr_t xp, xq;
- mpfr_init (xp);
- mpfr_init (xq);
-
- mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
+ case BT_REAL:
+ mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (xp, xp, xq, GFC_RND_MODE);
- mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
+ case BT_COMPLEX:
+ gfc_set_model_kind (x->ts.kind);
+ mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_clears (xp, xq, NULL);
- }
-#endif
- break;
- default:
- gfc_internal_error ("in gfc_simplify_cos(): Bad type");
+ default:
+ gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
return range_check (result, "COS");
-
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
+ case BT_COMPLEX:
+ mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "COSH");
}
gfc_expr *
gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
{
-
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
-
return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- switch (e->ts.type)
- {
- case BT_INTEGER:
- if (!e->is_boz)
- result = gfc_int2real (e, gfc_default_double_kind);
- break;
+ if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
- case BT_REAL:
- result = gfc_real2real (e, gfc_default_double_kind);
- break;
+ result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
- case BT_COMPLEX:
- result = gfc_complex2real (e, gfc_default_double_kind);
- break;
-
- default:
- gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
- }
-
- if (e->ts.type == BT_INTEGER && e->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = gfc_default_double_kind;
- result = gfc_copy_expr (e);
- if (!gfc_convert_boz (result, &ts))
- {
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- }
-
- return range_check (result, "DBLE");
-}
+ return range_check (result, "DBLE");
+}
gfc_expr *
int i, digits;
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
switch (x->ts.type)
{
- case BT_INTEGER:
- digits = gfc_integer_kinds[i].digits;
- break;
+ case BT_INTEGER:
+ digits = gfc_integer_kinds[i].digits;
+ break;
- case BT_REAL:
- case BT_COMPLEX:
- digits = gfc_real_kinds[i].digits;
- break;
+ case BT_REAL:
+ case BT_COMPLEX:
+ digits = gfc_real_kinds[i].digits;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- return gfc_int_expr (digits);
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
}
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- result = gfc_constant_result (x->ts.type, kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp (x->value.integer, y->value.integer) > 0)
- mpz_sub (result->value.integer, x->value.integer, y->value.integer);
- else
- mpz_set_ui (result->value.integer, 0);
+ case BT_INTEGER:
+ if (mpz_cmp (x->value.integer, y->value.integer) > 0)
+ mpz_sub (result->value.integer, x->value.integer, y->value.integer);
+ else
+ mpz_set_ui (result->value.integer, 0);
- break;
+ break;
- case BT_REAL:
- if (mpfr_cmp (x->value.real, y->value.real) > 0)
- mpfr_sub (result->value.real, x->value.real, y->value.real,
- GFC_RND_MODE);
- else
- mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ case BT_REAL:
+ if (mpfr_cmp (x->value.real, y->value.real) > 0)
+ mpfr_sub (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
+ else
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
- break;
+ break;
- default:
- gfc_internal_error ("gfc_simplify_dim(): Bad type");
+ default:
+ gfc_internal_error ("gfc_simplify_dim(): Bad type");
}
return range_check (result, "DIM");
gfc_expr*
gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
{
- gfc_expr *result;
-
if (!is_constant_array_expr (vector_a)
|| !is_constant_array_expr (vector_b))
return NULL;
gcc_assert (vector_b->rank == 1);
gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
- if (vector_a->value.constructor && vector_b->value.constructor)
- return compute_dot_product (vector_a->value.constructor, 1,
- vector_b->value.constructor, 1);
-
- /* Zero sized array ... */
- result = gfc_constant_result (vector_a->ts.type,
- vector_a->ts.kind,
- &vector_a->where);
- init_result_expr (result, 0, NULL);
- return result;
+ return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
-
a1 = gfc_real2real (x, gfc_default_double_kind);
a2 = gfc_real2real (y, gfc_default_double_kind);
+ result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
- gfc_free_expr (a1);
gfc_free_expr (a2);
+ gfc_free_expr (a1);
return range_check (result, "DPROD");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ERF");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ERFC");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
asympt_erfc_scaled (result->value.real, x->value.real);
else
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
return range_check (result, "EPSILON");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
- gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
- mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- {
- mpfr_t xp, xq;
- mpfr_init (xp);
- mpfr_init (xq);
- mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
- mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
- mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
- mpfr_clears (xp, xq, NULL);
- }
-#endif
- break;
+ case BT_COMPLEX:
+ gfc_set_model_kind (x->ts.kind);
+ mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("in gfc_simplify_exp(): Bad type");
+ default:
+ gfc_internal_error ("in gfc_simplify_exp(): Bad type");
}
return range_check (result, "EXP");
}
+
gfc_expr *
gfc_simplify_exponent (gfc_expr *x)
{
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &x->where);
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &x->where);
gfc_set_model (x->value.real);
if (a->is_boz)
{
- gfc_typespec ts;
- gfc_clear_ts (&ts);
-
- ts.type = BT_REAL;
- ts.kind = gfc_default_real_kind;
+ if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
result = gfc_copy_expr (a);
- if (!gfc_convert_boz (result, &ts))
- {
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
}
else
result = gfc_int2real (a, gfc_default_real_kind);
+
return range_check (result, "FLOAT");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
gfc_set_model_kind (kind);
+
mpfr_init (floor);
mpfr_floor (floor, e->value.real);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
mpfr_clear (floor);
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "GAMMA");
int i;
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
switch (e->ts.type)
{
- case BT_INTEGER:
- mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
- break;
+ case BT_INTEGER:
+ mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
+ break;
- case BT_REAL:
- mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
return result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
return range_check (result, "HYPOT");
}
{
gfc_expr *result;
gfc_char_t index;
+ int k;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
&e->where);
- if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
+ k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
+ if (k == -1)
return &gfc_bad_expr;
- result->where = e->where;
+ result = gfc_get_int_expr (k, &e->where, index);
return range_check (result, "IACHAR");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_and (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IAND");
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
convert_mpz_to_unsigned (result->value.integer,
gfc_integer_kinds[k].bit_size);
{
gfc_expr *result;
gfc_char_t index;
+ int k;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
index = e->value.character.string[0];
- if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
+ k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
+ if (k == -1)
return &gfc_bad_expr;
- result->where = e->where;
+ result = gfc_get_int_expr (k, &e->where, index);
+
return range_check (result, "ICHAR");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IEOR");
if (k == -1)
return &gfc_bad_expr;
- result = gfc_constant_result (BT_INTEGER, k, &x->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
len = x->value.character.length;
lensub = y->value.character.length;
}
-gfc_expr *
-gfc_simplify_int (gfc_expr *e, gfc_expr *k)
+static gfc_expr *
+simplify_intconv (gfc_expr *e, int kind, const char *name)
{
gfc_expr *result = NULL;
- int kind;
-
- kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
- if (kind == -1)
- return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- switch (e->ts.type)
- {
- case BT_INTEGER:
- result = gfc_int2int (e, kind);
- break;
-
- case BT_REAL:
- result = gfc_real2int (e, kind);
- break;
-
- case BT_COMPLEX:
- result = gfc_complex2int (e, kind);
- break;
-
- default:
- gfc_error ("Argument of INT at %L is not a valid type", &e->where);
- return &gfc_bad_expr;
- }
+ result = gfc_convert_constant (e, BT_INTEGER, kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
- return range_check (result, "INT");
+ return range_check (result, name);
}
-static gfc_expr *
-simplify_intconv (gfc_expr *e, int kind, const char *name)
+gfc_expr *
+gfc_simplify_int (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result = NULL;
-
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
-
- switch (e->ts.type)
- {
- case BT_INTEGER:
- result = gfc_int2int (e, kind);
- break;
-
- case BT_REAL:
- result = gfc_real2int (e, kind);
- break;
-
- case BT_COMPLEX:
- result = gfc_complex2int (e, kind);
- break;
+ int kind;
- default:
- gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
- return &gfc_bad_expr;
- }
+ kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
- return range_check (result, name);
+ return simplify_intconv (e, kind, "INT");
}
-
gfc_expr *
gfc_simplify_int2 (gfc_expr *e)
{
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
-
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &e->where);
gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
+
return range_check (result, "IFIX");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
-
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &e->where);
gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
+
return range_check (result, "IDINT");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+
return range_check (result, "IOR");
}
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
- gfc_expr *result;
-
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &x->where);
- result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_END) == 0);
-
- return result;
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpz_cmp_si (x->value.integer,
+ LIBERROR_END) == 0);
}
gfc_expr *
gfc_simplify_is_iostat_eor (gfc_expr *x)
{
- gfc_expr *result;
-
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &x->where);
- result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_EOR) == 0);
-
- return result;
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpz_cmp_si (x->value.integer,
+ LIBERROR_EOR) == 0);
}
gfc_expr *
gfc_simplify_isnan (gfc_expr *x)
{
- gfc_expr *result;
-
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &x->where);
- result->value.logical = mpfr_nan_p (x->value.real);
-
- return result;
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpfr_nan_p (x->value.real));
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
if (shift == 0)
{
return &gfc_bad_expr;
}
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
mpz_set (result->value.integer, e->value.integer);
gfc_expr *
gfc_simplify_kind (gfc_expr *e)
{
-
- if (e->ts.type == BT_DERIVED)
- {
- gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
- return &gfc_bad_expr;
- }
-
- return gfc_int_expr (e->ts.kind);
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
}
static gfc_expr *
simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
- gfc_array_spec *as, gfc_ref *ref)
+ gfc_array_spec *as, gfc_ref *ref, bool coarray)
{
gfc_expr *l, *u, *result;
int k;
/* The last dimension of an assumed-size array is special. */
- if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+ if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+ || (coarray && d == as->rank + as->corank))
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
return gfc_copy_expr (as->lower[d-1]);
if (k == -1)
return &gfc_bad_expr;
- result = gfc_constant_result (BT_INTEGER, k, &array->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
/* Then, we need to know the extent of the given dimension. */
- if (ref->u.ar.type == AR_FULL)
+ if (coarray || ref->u.ar.type == AR_FULL)
{
l = as->lower[d-1];
u = as->upper[d-1];
- if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
+ if (l->expr_type != EXPR_CONSTANT || u == NULL
+ || u->expr_type != EXPR_CONSTANT)
return NULL;
if (mpz_cmp (l->value.integer, u->value.integer) > 0)
/* Multi-dimensional bounds. */
gfc_expr *bounds[GFC_MAX_DIMENSIONS];
gfc_expr *e;
- gfc_constructor *head, *tail;
int k;
/* UBOUND(ARRAY) is not valid for an assumed-size array. */
/* Simplify the bounds for each dimension. */
for (d = 0; d < array->rank; d++)
{
- bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
+ bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
+ false);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
int j;
}
/* Allocate the result expression. */
- e = gfc_get_expr ();
- e->where = array->where;
- e->expr_type = EXPR_ARRAY;
- e->ts.type = BT_INTEGER;
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
- gfc_default_integer_kind);
+ gfc_default_integer_kind);
if (k == -1)
- {
- gfc_free_expr (e);
- return &gfc_bad_expr;
- }
- e->ts.kind = k;
+ return &gfc_bad_expr;
+
+ e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
/* The result is a rank 1 array; its size is the rank of the first
argument to {L,U}BOUND. */
mpz_init_set_ui (e->shape[0], array->rank);
/* Create the constructor for this array. */
- head = tail = NULL;
for (d = 0; d < array->rank; d++)
- {
- /* Get a new constructor element. */
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = e->where;
- tail->expr = bounds[d];
- }
- e->value.constructor = head;
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
return e;
}
return &gfc_bad_expr;
}
- return simplify_bound_dim (array, kind, d, upper, as, ref);
+ return simplify_bound_dim (array, kind, d, upper, as, ref, false);
}
}
-gfc_expr *
-gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
-{
- return simplify_bound (array, dim, kind, 0);
-}
-
-
-gfc_expr *
-gfc_simplify_leadz (gfc_expr *e)
+static gfc_expr *
+simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
{
- gfc_expr *result;
- unsigned long lz, bs;
- int i;
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
- if (e->expr_type != EXPR_CONSTANT)
+ if (array->expr_type != EXPR_VARIABLE)
return NULL;
- i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- bs = gfc_integer_kinds[i].bit_size;
- if (mpz_cmp_si (e->value.integer, 0) == 0)
- lz = bs;
- else if (mpz_cmp_si (e->value.integer, 0) < 0)
- lz = 0;
- else
- lz = bs - mpz_sizeinbase (e->value.integer, 2);
+ /* Follow any component references. */
+ as = array->symtree->n.sym->as;
+ for (ref = array->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ as = NULL;
+ continue;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
- mpz_set_ui (result->value.integer, lz);
+ case AR_FULL:
+ /* We're done because 'as' has already been set in the
+ previous iteration. */
+ if (!ref->next)
+ goto done;
- return result;
-}
+ /* Fall through. */
+ case AR_UNKNOWN:
+ return NULL;
-gfc_expr *
-gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
-{
- gfc_expr *result;
- int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
+ case AR_SECTION:
+ as = ref->u.ar.as;
+ goto done;
+ }
- if (k == -1)
- return &gfc_bad_expr;
+ gcc_unreachable ();
- if (e->expr_type == EXPR_CONSTANT)
- {
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
- mpz_set_si (result->value.integer, e->value.character.length);
- if (gfc_range_check (result) == ARITH_OK)
- return result;
- else
- {
- gfc_free_expr (result);
- return NULL;
- }
- }
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
- if (e->ts.cl != NULL && e->ts.cl->length != NULL
- && e->ts.cl->length->expr_type == EXPR_CONSTANT
- && e->ts.cl->length->ts.type == BT_INTEGER)
+ case REF_SUBSTRING:
+ continue;
+ }
+ }
+
+ gcc_unreachable ();
+
+ done:
+
+ if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+ return NULL;
+
+ if (dim == NULL)
{
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
- mpz_set (result->value.integer, e->ts.cl->length->value.integer);
- if (gfc_range_check (result) == ARITH_OK)
- return result;
- else
+ /* Multi-dimensional cobounds. */
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+ int k;
+
+ /* Simplify the cobounds for each dimension. */
+ for (d = 0; d < as->corank; d++)
{
- gfc_free_expr (result);
- return NULL;
+ bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
+ upper, as, ref, true);
+ if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+ {
+ int j;
+
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ return bounds[d];
+ }
+ }
+
+ /* Allocate the result expression. */
+ e = gfc_get_expr ();
+ e->where = array->where;
+ e->expr_type = EXPR_ARRAY;
+ e->ts.type = BT_INTEGER;
+ k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
+ gfc_default_integer_kind);
+ if (k == -1)
+ {
+ gfc_free_expr (e);
+ return &gfc_bad_expr;
+ }
+ e->ts.kind = k;
+
+ /* The result is a rank 1 array; its size is the rank of the first
+ argument to {L,U}COBOUND. */
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], as->corank);
+
+ /* Create the constructor for this array. */
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
+ return e;
+ }
+ else
+ {
+ /* A DIM argument is specified. */
+ if (dim->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ d = mpz_get_si (dim->value.integer);
+
+ if (d < 1 || d > as->corank)
+ {
+ gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+ return &gfc_bad_expr;
}
+
+ return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
}
+}
- return NULL;
+
+gfc_expr *
+gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ return simplify_bound (array, dim, kind, 0);
+}
+
+
+gfc_expr *
+gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ gfc_expr *e;
+ /* return simplify_cobound (array, dim, kind, 0);*/
+
+ e = simplify_cobound (array, dim, kind, 0);
+ if (e != NULL)
+ return e;
+
+ gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
+ "cobounds at %L", &array->where);
+ return &gfc_bad_expr;
+}
+
+gfc_expr *
+gfc_simplify_leadz (gfc_expr *e)
+{
+ unsigned long lz, bs;
+ int i;
+
+ if (array->expr_type != EXPR_VARIABLE)
+ return NULL;
+
+ /* Follow any component references. */
+ as = array->symtree->n.sym->as;
+ for (ref = array->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ if (ref->next == NULL)
+ {
+ gcc_assert (ref->u.ar.as->corank > 0
+ && ref->u.ar.as->rank == 0);
+ as = ref->u.ar.as;
+ goto done;
+ }
+ as = NULL;
+ continue;
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
+}
+
+ case AR_UNKNOWN:
+ return NULL;
+
+ case AR_SECTION:
+ as = ref->u.ar.as;
+ goto done;
+ }
+
+ gcc_unreachable ();
+
+ if (e->expr_type == EXPR_CONSTANT)
+ {
+ result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
+ mpz_set_si (result->value.integer, e->value.character.length);
+ return range_check (result, "LEN");
+ }
+ else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && e->ts.u.cl->length->ts.type == BT_INTEGER)
+ {
+ result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
+ mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
+ return range_check (result, "LEN");
+ }
+ else
+ return NULL;
}
gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
- int count, len, lentrim, i;
+ int count, len, i;
int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
- if (k == -1)
- return &gfc_bad_expr;
+ done:
- if (e->expr_type != EXPR_CONSTANT)
+ if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
return NULL;
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
len = e->value.character.length;
-
for (count = 0, i = 1; i <= len; i++)
if (e->value.character.string[len - i] == ' ')
count++;
else
break;
- lentrim = len - count;
-
- mpz_set_si (result->value.integer, lentrim);
+ result = gfc_get_int_expr (k, &e->where, len - count);
return range_check (result, "LEN_TRIM");
}
gfc_expr *
-gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_lgamma (gfc_expr *x)
{
gfc_expr *result;
int sg;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
return range_check (result, "LGAMMA");
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) >= 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) > 0,
- &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) > 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) <= 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) < 0);
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
}
gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- {
- mpfr_t xr, xi;
- mpfr_init (xr);
- mpfr_init (xi);
-
- mpfr_atan2 (result->value.complex.i, x->value.complex.i,
- x->value.complex.r, GFC_RND_MODE);
-
- mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
- mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
- mpfr_add (xr, xr, xi, GFC_RND_MODE);
- mpfr_sqrt (xr, xr, GFC_RND_MODE);
- mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
-
- mpfr_clears (xr, xi, NULL);
- }
-#endif
break;
default:
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "LOG10");
gfc_expr *
gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
int kind;
kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
-
- result->value.logical = e->value.logical;
-
- return result;
+ return gfc_get_logical_expr (kind, &e->where, e->value.logical);
}
gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
{
gfc_expr *result;
- gfc_constructor *ma_ctor, *mb_ctor;
- int row, result_rows, col, result_columns, stride_a, stride_b;
+ int row, result_rows, col, result_columns;
+ int stride_a, offset_a, stride_b, offset_b;
if (!is_constant_array_expr (matrix_a)
|| !is_constant_array_expr (matrix_b))
return NULL;
gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
- result = gfc_start_constructor (matrix_a->ts.type,
- matrix_a->ts.kind,
- &matrix_a->where);
+ result = gfc_get_array_expr (matrix_a->ts.type,
+ matrix_a->ts.kind,
+ &matrix_a->where);
if (matrix_a->rank == 1 && matrix_b->rank == 2)
{
else
gcc_unreachable();
- ma_ctor = matrix_a->value.constructor;
- mb_ctor = matrix_b->value.constructor;
-
+ offset_a = offset_b = 0;
for (col = 0; col < result_columns; ++col)
{
- ma_ctor = matrix_a->value.constructor;
+ offset_a = 0;
for (row = 0; row < result_rows; ++row)
{
- gfc_expr *e;
- e = compute_dot_product (ma_ctor, stride_a,
- mb_ctor, 1);
+ gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
+ matrix_b, 1, offset_b);
+ gfc_constructor_append_expr (&result->value.constructor,
+ e, NULL);
- gfc_append_constructor (result, e);
-
- ADVANCE (ma_ctor, 1);
- }
+ offset_a += 1;
+ }
- ADVANCE (mb_ctor, stride_b);
+ offset_b += stride_b;
}
return result;
static gfc_expr *
simplify_minval_maxval (gfc_expr *expr, int sign)
{
- gfc_constructor *ctr, *extremum;
+ gfc_constructor *c, *extremum;
gfc_intrinsic_sym * specific;
extremum = NULL;
specific = expr->value.function.isym;
- ctr = expr->value.constructor;
-
- for (; ctr; ctr = ctr->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
- if (ctr->expr->expr_type != EXPR_CONSTANT)
+ if (c->expr->expr_type != EXPR_CONSTANT)
return NULL;
if (extremum == NULL)
{
- extremum = ctr;
+ extremum = c;
continue;
}
- min_max_choose (ctr->expr, extremum->expr, sign);
+ min_max_choose (c->expr, extremum->expr, sign);
}
if (extremum == NULL)
{
if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
return NULL;
-
+
return simplify_minval_maxval (array, -1);
}
{
if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
return NULL;
+
return simplify_minval_maxval (array, 1);
}
gfc_expr *
gfc_simplify_maxexponent (gfc_expr *x)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
-
- result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
- result->where = x->where;
-
- return result;
+ int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+ gfc_real_kinds[i].max_exponent);
}
gfc_expr *
gfc_simplify_minexponent (gfc_expr *x)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
-
- result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
- result->where = x->where;
-
- return result;
+ int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+ gfc_real_kinds[i].min_exponent);
}
return NULL;
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
- result = gfc_constant_result (a->ts.type, kind, &a->where);
+ result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp_ui (p->value.integer, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument MOD at %L is zero", &a->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
- break;
+ case BT_INTEGER:
+ if (mpz_cmp_ui (p->value.integer, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument MOD at %L is zero", &a->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
+ break;
- case BT_REAL:
- if (mpfr_cmp_ui (p->value.real, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument of MOD at %L is zero", &p->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument of MOD at %L is zero", &p->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
- gfc_set_model_kind (kind);
- mpfr_init (tmp);
- mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_trunc (tmp, tmp);
- mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
- mpfr_clear (tmp);
- break;
+ gfc_set_model_kind (kind);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_trunc (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
+ default:
+ gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
}
return range_check (result, "MOD");
return NULL;
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
- result = gfc_constant_result (a->ts.type, kind, &a->where);
+ result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp_ui (p->value.integer, 0) == 0)
- {
- /* Result is processor-dependent. This processor just opts
- to not handle it at all. */
- gfc_error ("Second argument of MODULO at %L is zero", &a->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
+ case BT_INTEGER:
+ if (mpz_cmp_ui (p->value.integer, 0) == 0)
+ {
+ /* Result is processor-dependent. This processor just opts
+ to not handle it at all. */
+ gfc_error ("Second argument of MODULO at %L is zero", &a->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
- break;
+ break;
- case BT_REAL:
- if (mpfr_cmp_ui (p->value.real, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument of MODULO at %L is zero", &p->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument of MODULO at %L is zero", &p->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
- gfc_set_model_kind (kind);
- mpfr_init (tmp);
- mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_floor (tmp, tmp);
- mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
- mpfr_clear (tmp);
- break;
+ gfc_set_model_kind (kind);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_floor (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
+ default:
+ gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
}
return range_check (result, "MODULO");
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
itrunc = gfc_copy_expr (e);
-
mpfr_round (itrunc->value.real, e->value.real);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
gfc_free_expr (itrunc);
{
gfc_expr *result;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
- result->value.character.string = gfc_get_wide_string (2);
- result->value.character.length = 1;
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
result->value.character.string[0] = '\n';
- result->value.character.string[1] = '\0'; /* For debugger */
+
return result;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
-
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
mpz_com (result->value.integer, e->value.integer);
return range_check (result, "NOT");
{
gfc_expr *result;
- if (mold == NULL)
+ if (mold)
{
- result = gfc_get_expr ();
- result->ts.type = BT_UNKNOWN;
+ result = gfc_copy_expr (mold);
+ result->expr_type = EXPR_NULL;
}
else
- result = gfc_copy_expr (mold);
- result->expr_type = EXPR_NULL;
+ result = gfc_get_null_expr (NULL);
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_num_images (void)
+{
+ gfc_expr *result;
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return &gfc_bad_expr;
+ }
+
+ /* FIXME: gfc_current_locus is wrong. */
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (result->value.integer, 1);
return result;
}
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_ior (result->value.integer, x->value.integer, y->value.integer);
- return range_check (result, "OR");
- }
- else /* BT_LOGICAL */
+
+ switch (x->ts.type)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = x->value.logical || y->value.logical;
- return result;
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "OR");
+
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ x->value.logical || y->value.logical);
+ default:
+ gcc_unreachable();
}
}
&& !is_constant_array_expr(mask)))
return NULL;
- result = gfc_start_constructor (array->ts.type,
- array->ts.kind,
- &array->where);
+ result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
- array_ctor = array->value.constructor;
- vector_ctor = vector ? vector->value.constructor : NULL;
+ array_ctor = gfc_constructor_first (array->value.constructor);
+ vector_ctor = vector
+ ? gfc_constructor_first (vector->value.constructor)
+ : NULL;
if (mask->expr_type == EXPR_CONSTANT
&& mask->value.logical)
/* Copy all elements of ARRAY to RESULT. */
while (array_ctor)
{
- gfc_append_constructor (result,
- gfc_copy_expr (array_ctor->expr));
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (array_ctor->expr),
+ NULL);
- ADVANCE (array_ctor, 1);
- ADVANCE (vector_ctor, 1);
+ array_ctor = gfc_constructor_next (array_ctor);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
}
else if (mask->expr_type == EXPR_ARRAY)
{
/* Copy only those elements of ARRAY to RESULT whose
MASK equals .TRUE.. */
- mask_ctor = mask->value.constructor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor)
{
if (mask_ctor->expr->value.logical)
{
- gfc_append_constructor (result,
- gfc_copy_expr (array_ctor->expr));
- ADVANCE (vector_ctor, 1);
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (array_ctor->expr),
+ NULL);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
- ADVANCE (array_ctor, 1);
- ADVANCE (mask_ctor, 1);
+ array_ctor = gfc_constructor_next (array_ctor);
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
}
/* Append any left-over elements from VECTOR to RESULT. */
while (vector_ctor)
{
- gfc_append_constructor (result,
- gfc_copy_expr (vector_ctor->expr));
- ADVANCE (vector_ctor, 1);
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (vector_ctor->expr),
+ NULL);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
result->shape = gfc_get_shape (1);
gfc_array_size (result, &result->shape[0]);
if (array->ts.type == BT_CHARACTER)
- result->ts.cl = array->ts.cl;
+ result->ts.u.cl = array->ts.u.cl;
return result;
}
gfc_expr *
gfc_simplify_precision (gfc_expr *e)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-
- result = gfc_int_expr (gfc_real_kinds[i].precision);
- result->where = e->where;
-
- return result;
+ int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+ gfc_real_kinds[i].precision);
}
gfc_expr *
gfc_simplify_radix (gfc_expr *e)
{
- gfc_expr *result;
int i;
-
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
switch (e->ts.type)
{
- case BT_INTEGER:
- i = gfc_integer_kinds[i].radix;
- break;
+ case BT_INTEGER:
+ i = gfc_integer_kinds[i].radix;
+ break;
- case BT_REAL:
- i = gfc_real_kinds[i].radix;
- break;
+ case BT_REAL:
+ i = gfc_real_kinds[i].radix;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- result = gfc_int_expr (i);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
}
gfc_expr *
gfc_simplify_range (gfc_expr *e)
{
- gfc_expr *result;
int i;
- long j;
-
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
switch (e->ts.type)
{
- case BT_INTEGER:
- j = gfc_integer_kinds[i].range;
- break;
+ case BT_INTEGER:
+ i = gfc_integer_kinds[i].range;
+ break;
- case BT_REAL:
- case BT_COMPLEX:
- j = gfc_real_kinds[i].range;
- break;
+ case BT_REAL:
+ case BT_COMPLEX:
+ i = gfc_real_kinds[i].range;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- result = gfc_int_expr (j);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- switch (e->ts.type)
- {
- case BT_INTEGER:
- if (!e->is_boz)
- result = gfc_int2real (e, kind);
- break;
-
- case BT_REAL:
- result = gfc_real2real (e, kind);
- break;
-
- case BT_COMPLEX:
- result = gfc_complex2real (e, kind);
- break;
-
- default:
- gfc_internal_error ("bad type in REAL");
- /* Not reached */
- }
+ if (convert_boz (e, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
- if (e->ts.type == BT_INTEGER && e->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = kind;
- result = gfc_copy_expr (e);
- if (!gfc_convert_boz (result, &ts))
- {
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- }
+ result = gfc_convert_constant (e, BT_REAL, kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
return range_check (result, "REAL");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-#ifdef HAVE_mpc
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
-#else
- mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
-#endif
return range_check (result, "REALPART");
}
}
/* If we don't know the character length, we can do no more. */
- if (e->ts.cl && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+ if (e->ts.u.cl && e->ts.u.cl->length
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- len = mpz_get_si (e->ts.cl->length->value.integer);
+ len = mpz_get_si (e->ts.u.cl->length->value.integer);
have_length = true;
}
else if (e->expr_type == EXPR_CONSTANT
- && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+ && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
{
len = e->value.character.length;
}
if (have_length)
{
mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
- e->ts.cl->length->value.integer);
+ e->ts.u.cl->length->value.integer);
}
else
{
return NULL;
if (len ||
- (e->ts.cl->length &&
- mpz_sgn (e->ts.cl->length->value.integer)) != 0)
+ (e->ts.u.cl->length &&
+ mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
{
const char *res = gfc_extract_int (n, &ncop);
gcc_assert (res == NULL);
len = e->value.character.length;
nlen = ncop * len;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
if (ncop == 0)
- {
- result->value.character.string = gfc_get_wide_string (1);
- result->value.character.length = 0;
- result->value.character.string[0] = '\0';
- return result;
- }
+ return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
- result->value.character.length = nlen;
- result->value.character.string = gfc_get_wide_string (nlen + 1);
+ len = e->value.character.length;
+ nlen = ncop * len;
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
for (i = 0; i < ncop; i++)
for (j = 0; j < len; j++)
result->value.character.string[j+i*len]= e->value.character.string[j];
{
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
int i, rank, npad, x[GFC_MAX_DIMENSIONS];
- gfc_constructor *head, *tail;
mpz_t index, size;
unsigned long j;
size_t nsource;
- gfc_expr *e;
+ gfc_expr *e, *result;
/* Check that argument expression types are OK. */
if (!is_constant_array_expr (source)
mpz_init (index);
rank = 0;
- head = tail = NULL;
for (;;)
{
- e = gfc_get_array_element (shape_exp, rank);
+ e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
if (e == NULL)
break;
gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
gcc_assert (shape[rank] >= 0);
- gfc_free_expr (e);
rank++;
}
for (i = 0; i < rank; i++)
{
- e = gfc_get_array_element (order_exp, i);
+ e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
gcc_assert (e);
gfc_extract_int (e, &order[i]);
- gfc_free_expr (e);
gcc_assert (order[i] >= 1 && order[i] <= rank);
order[i]--;
for (i = 0; i < rank; i++)
x[i] = 0;
+ result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+ &source->where);
+ result->rank = rank;
+ result->shape = gfc_get_shape (rank);
+ for (i = 0; i < rank; i++)
+ mpz_init_set_ui (result->shape[i], shape[i]);
+
while (nsource > 0 || npad > 0)
{
/* Figure out which element to extract. */
j = mpz_get_ui (index);
if (j < nsource)
- e = gfc_get_array_element (source, j);
+ e = gfc_constructor_lookup_expr (source->value.constructor, j);
else
{
gcc_assert (npad > 0);
j = j - nsource;
j = j % npad;
- e = gfc_get_array_element (pad, j);
+ e = gfc_constructor_lookup_expr (pad->value.constructor, j);
}
gcc_assert (e);
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = e->where;
- tail->expr = e;
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (e), &e->where);
/* Calculate the next element. */
i = 0;
mpz_clear (index);
- e = gfc_get_expr ();
- e->where = source->where;
- e->expr_type = EXPR_ARRAY;
- e->value.constructor = head;
- e->shape = gfc_get_shape (rank);
-
- for (i = 0; i < rank; i++)
- mpz_init_set_ui (e->shape[i], shape[i]);
-
- e->ts = source->ts;
- e->rank = rank;
-
- return e;
+ return result;
}
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
/* Special case x = -0 and 0. */
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
-
len = e->value.character.length;
lenc = c->value.character.length;
}
}
}
- mpz_set_ui (result->value.integer, indx);
+
+ result = gfc_get_int_expr (k, &e->where, indx);
return range_check (result, "SCAN");
}
gfc_simplify_selected_char_kind (gfc_expr *e)
{
int kind;
- gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
else
kind = -1;
- result = gfc_int_expr (kind);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
}
gfc_simplify_selected_int_kind (gfc_expr *e)
{
int i, kind, range;
- gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
return NULL;
if (kind == INT_MAX)
kind = -1;
- result = gfc_int_expr (kind);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
}
gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
{
int range, precision, i, kind, found_precision, found_range;
- gfc_expr *result;
if (p == NULL)
precision = 0;
kind -= 2;
}
- result = gfc_int_expr (kind);
- result->where = (p != NULL) ? p->where : q->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind,
+ p ? &p->where : &q->where, kind);
}
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
gfc_try t;
if (source->rank == 0)
- return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
if (source->expr_type != EXPR_VARIABLE)
return NULL;
- result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
ar = gfc_find_array_ref (source);
for (n = 0; n < source->rank; n++)
{
- e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
if (t == SUCCESS)
{
}
}
- gfc_append_constructor (result, e);
+ gfc_constructor_append_expr (&result->value.constructor, e, NULL);
}
return result;
gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
mpz_t size;
- gfc_expr *result;
int d;
int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
return NULL;
}
- result = gfc_constant_result (BT_INTEGER, k, &array->where);
- mpz_set (result->value.integer, size);
- return result;
+ return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- mpz_abs (result->value.integer, x->value.integer);
- if (mpz_sgn (y->value.integer) < 0)
- mpz_neg (result->value.integer, result->value.integer);
- break;
+ case BT_INTEGER:
+ mpz_abs (result->value.integer, x->value.integer);
+ if (mpz_sgn (y->value.integer) < 0)
+ mpz_neg (result->value.integer, result->value.integer);
+ break;
- case BT_REAL:
- if (gfc_option.flag_sign_zero)
- mpfr_copysign (result->value.real, x->value.real, y->value.real,
- GFC_RND_MODE);
- else
- mpfr_setsign (result->value.real, x->value.real,
- mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ if (gfc_option.flag_sign_zero)
+ mpfr_copysign (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
+ else
+ mpfr_setsign (result->value.real, x->value.real,
+ mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("Bad type in gfc_simplify_sign");
+ default:
+ gfc_internal_error ("Bad type in gfc_simplify_sign");
}
return result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
- break;
-
- case BT_COMPLEX:
- gfc_set_model (x->value.real);
-#ifdef HAVE_mpc
- mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
-#else
- {
- mpfr_t xp, xq;
- mpfr_init (xp);
- mpfr_init (xq);
-
- mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
-
- mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
+ case BT_REAL:
+ mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- mpfr_clears (xp, xq, NULL);
- }
-#endif
- break;
+ case BT_COMPLEX:
+ gfc_set_model (x->value.real);
+ mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("in gfc_simplify_sin(): Bad type");
+ default:
+ gfc_internal_error ("in gfc_simplify_sin(): Bad type");
}
return range_check (result, "SIN");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "SINH");
}
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
/* Special case x = 0 and -0. */
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
{
gcc_assert (dim == 0);
- result = gfc_start_constructor (source->ts.type,
- source->ts.kind,
- &source->where);
+ result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+ &source->where);
result->rank = 1;
result->shape = gfc_get_shape (result->rank);
mpz_init_set_si (result->shape[0], ncopies);
for (i = 0; i < ncopies; ++i)
- gfc_append_constructor (result, gfc_copy_expr (source));
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (source), NULL);
}
else if (source->expr_type == EXPR_ARRAY)
{
- int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
- gfc_constructor *ctor, *source_ctor, *result_ctor;
+ int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
+ gfc_constructor *source_ctor;
gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
gcc_assert (dim >= 0 && dim <= source->rank);
- result = gfc_start_constructor (source->ts.type,
- source->ts.kind,
- &source->where);
+ result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+ &source->where);
result->rank = source->rank + 1;
result->shape = gfc_get_shape (result->rank);
- result_size = 1;
for (i = 0, j = 0; i < result->rank; ++i)
{
if (i != dim)
extent[i] = mpz_get_si (result->shape[i]);
rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
- result_size *= extent[i];
}
- for (i = 0; i < result_size; ++i)
- gfc_append_constructor (result, NULL);
-
- source_ctor = source->value.constructor;
- result_ctor = result->value.constructor;
- while (source_ctor)
+ offset = 0;
+ for (source_ctor = gfc_constructor_first (source->value.constructor);
+ source_ctor; source_ctor = gfc_constructor_next (source_ctor))
{
- ctor = result_ctor;
-
for (i = 0; i < ncopies; ++i)
- {
- ctor->expr = gfc_copy_expr (source_ctor->expr);
- ADVANCE (ctor, rstride[dim]);
- }
+ gfc_constructor_insert_expr (&result->value.constructor,
+ gfc_copy_expr (source_ctor->expr),
+ NULL, offset + i * rstride[dim]);
- ADVANCE (result_ctor, (dim == 0 ? ncopies : 1));
- ADVANCE (source_ctor, 1);
+ offset += (dim == 0 ? ncopies : 1);
}
}
else
return NULL;
if (source->ts.type == BT_CHARACTER)
- result->ts.cl = source->ts.cl;
+ result->ts.u.cl = source->ts.u.cl;
return result;
}
gfc_expr *
gfc_simplify_sqrt (gfc_expr *e)
{
- gfc_expr *result;
+ gfc_expr *result = NULL;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
-
switch (e->ts.type)
{
- case BT_REAL:
- if (mpfr_cmp_si (e->value.real, 0) < 0)
- goto negative_arg;
- mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
-
- break;
-
- case BT_COMPLEX:
- gfc_set_model (e->value.real);
-#ifdef HAVE_mpc
- mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
-#else
- {
- /* Formula taken from Numerical Recipes to avoid over- and
- underflow. */
-
- mpfr_t ac, ad, s, t, w;
- mpfr_init (ac);
- mpfr_init (ad);
- mpfr_init (s);
- mpfr_init (t);
- mpfr_init (w);
-
- if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
- && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
- {
- mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
- break;
- }
-
- mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
- mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
-
- if (mpfr_cmp (ac, ad) >= 0)
- {
- mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
- mpfr_mul (t, t, t, GFC_RND_MODE);
- mpfr_add_ui (t, t, 1, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_add_ui (t, t, 1, GFC_RND_MODE);
- mpfr_div_ui (t, t, 2, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_sqrt (s, ac, GFC_RND_MODE);
- mpfr_mul (w, s, t, GFC_RND_MODE);
- }
- else
- {
- mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
- mpfr_mul (t, s, s, GFC_RND_MODE);
- mpfr_add_ui (t, t, 1, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_abs (s, s, GFC_RND_MODE);
- mpfr_add (t, t, s, GFC_RND_MODE);
- mpfr_div_ui (t, t, 2, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_sqrt (s, ad, GFC_RND_MODE);
- mpfr_mul (w, s, t, GFC_RND_MODE);
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (e->value.real, 0) < 0)
+ {
+ gfc_error ("Argument of SQRT at %L has a negative value",
+ &e->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
+ break;
- if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
- {
- mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
- mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
- mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
- }
- else if (mpfr_cmp_ui (w, 0) != 0
- && mpfr_cmp_ui (e->value.complex.r, 0) < 0
- && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
- {
- mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
- mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
- mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
- }
- else if (mpfr_cmp_ui (w, 0) != 0
- && mpfr_cmp_ui (e->value.complex.r, 0) < 0
- && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
- {
- mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
- mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
- mpfr_neg (w, w, GFC_RND_MODE);
- mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
- }
- else
- gfc_internal_error ("invalid complex argument of SQRT at %L",
- &e->where);
+ case BT_COMPLEX:
+ gfc_set_model (e->value.real);
- mpfr_clears (s, t, ac, ad, w, NULL);
- }
-#endif
- break;
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
+ default:
+ gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
}
return range_check (result, "SQRT");
-
-negative_arg:
- gfc_free_expr (result);
- gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
- return &gfc_bad_expr;
}
gfc_expr *
gfc_simplify_tan (gfc_expr *x)
{
- int i;
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
+ case BT_COMPLEX:
+ mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "TAN");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "TANH");
-
}
i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
return result;
gfc_expr *
gfc_simplify_trailz (gfc_expr *e)
{
- gfc_expr *result;
unsigned long tz, bs;
int i;
bs = gfc_integer_kinds[i].bit_size;
tz = mpz_scan1 (e->value.integer, 0);
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
- mpz_set_ui (result->value.integer, MIN (tz, bs));
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind,
+ &e->where, MIN (tz, bs));
}
unsigned char *buffer;
if (!gfc_is_constant_expr (source)
- || (gfc_init_expr && !gfc_is_constant_expr (mold))
+ || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
|| !gfc_is_constant_expr (size))
return NULL;
source_size = gfc_target_expr_size (source);
/* Create an empty new expression with the appropriate characteristics. */
- result = gfc_constant_result (mold->ts.type, mold->ts.kind,
- &source->where);
+ result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
+ &source->where);
result->ts = mold->ts;
mold_element = mold->expr_type == EXPR_ARRAY
- ? mold->value.constructor->expr
+ ? gfc_constructor_first (mold->value.constructor)->expr
: mold;
/* Set result character length, if needed. Note that this needs to be
gfc_expr *
gfc_simplify_transpose (gfc_expr *matrix)
{
- int i, matrix_rows;
+ int row, matrix_rows, col, matrix_cols;
gfc_expr *result;
- gfc_constructor *matrix_ctor;
if (!is_constant_array_expr (matrix))
return NULL;
gcc_assert (matrix->rank == 2);
- result = gfc_start_constructor (matrix->ts.type, matrix->ts.kind, &matrix->where);
+ result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
+ &matrix->where);
result->rank = 2;
result->shape = gfc_get_shape (result->rank);
mpz_set (result->shape[0], matrix->shape[1]);
mpz_set (result->shape[1], matrix->shape[0]);
if (matrix->ts.type == BT_CHARACTER)
- result->ts.cl = matrix->ts.cl;
+ result->ts.u.cl = matrix->ts.u.cl;
matrix_rows = mpz_get_si (matrix->shape[0]);
- matrix_ctor = matrix->value.constructor;
- for (i = 0; i < matrix_rows; ++i)
- {
- gfc_constructor *column_ctor = matrix_ctor;
- while (column_ctor)
- {
- gfc_append_constructor (result,
- gfc_copy_expr (column_ctor->expr));
-
- ADVANCE (column_ctor, matrix_rows);
- }
-
- ADVANCE (matrix_ctor, 1);
- }
+ matrix_cols = mpz_get_si (matrix->shape[1]);
+ for (row = 0; row < matrix_rows; ++row)
+ for (col = 0; col < matrix_cols; ++col)
+ {
+ gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
+ col * matrix_rows + row);
+ gfc_constructor_insert_expr (&result->value.constructor,
+ gfc_copy_expr (e), &matrix->where,
+ row * matrix_cols + col);
+ }
return result;
}
return NULL;
len = e->value.character.length;
-
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
for (count = 0, i = 1; i <= len; ++i)
{
if (e->value.character.string[len - i] == ' ')
lentrim = len - count;
- result->value.character.length = lentrim;
- result->value.character.string = gfc_get_wide_string (lentrim + 1);
-
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
for (i = 0; i < lentrim; i++)
result->value.character.string[i] = e->value.character.string[i];
- result->value.character.string[lentrim] = '\0'; /* For debugger */
+ return result;
+
+not_implemented:
+ gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
+ "cobounds at %L", &coarray->where);
+ return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
+
+ if (coarray == NULL)
+ {
+ gfc_expr *result;
+ /* FIXME: gfc_current_locus is wrong. */
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (result->value.integer, 1);
+ return result;
+ }
+
+ gcc_assert (coarray->expr_type == EXPR_VARIABLE);
+
+ /* Follow any component references. */
+ as = coarray->symtree->n.sym->as;
+ for (ref = coarray->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ as = ref->u.ar.as;
+
+ if (as->type == AS_DEFERRED)
+ goto not_implemented; /* return NULL;*/
+
+ if (dim == NULL)
+ {
+ /* Multi-dimensional bounds. */
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+
+ /* Simplify the bounds for each dimension. */
+ for (d = 0; d < as->corank; d++)
+ {
+ bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
+ as, NULL, true);
+ if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+ {
+ int j;
+
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ if (bounds[d] == NULL)
+ goto not_implemented;
+ return bounds[d];
+ }
+ }
+
+ /* Allocate the result expression. */
+ e = gfc_get_expr ();
+ e->where = coarray->where;
+ e->expr_type = EXPR_ARRAY;
+ e->ts.type = BT_INTEGER;
+ e->ts.kind = gfc_default_integer_kind;
+
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], as->corank);
+
+ /* Create the constructor for this array. */
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
+
+ return e;
+ }
+ else
+ {
+ gfc_expr *e;
+ /* A DIM argument is specified. */
+ if (dim->expr_type != EXPR_CONSTANT)
+ goto not_implemented; /*return NULL;*/
+
+ d = mpz_get_si (dim->value.integer);
+
+ if (d < 1 || d > as->corank)
+ {
+ gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+ return &gfc_bad_expr;
+ }
+
+ /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
+ e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
+ if (e != NULL)
+ return e;
+ else
+ goto not_implemented;
+ }
+
+not_implemented:
+ gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
+ "cobounds at %L", &coarray->where);
+ return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+ gfc_expr *result;
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ gfc_constructor *sub_cons;
+ bool first_image;
+ int d;
+
+ if (!is_constant_array_expr (sub))
+ goto not_implemented; /* return NULL;*/
+
+ /* Follow any component references. */
+ as = coarray->symtree->n.sym->as;
+ for (ref = coarray->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ as = ref->u.ar.as;
+
+ if (as->type == AS_DEFERRED)
+ goto not_implemented; /* return NULL;*/
+
+ /* "valid sequence of cosubscripts" are required; thus, return 0 unless
+ the cosubscript addresses the first image. */
+
+ sub_cons = gfc_constructor_first (sub->value.constructor);
+ first_image = true;
+
+ for (d = 1; d <= as->corank; d++)
+ {
+ gfc_expr *ca_bound;
+ int cmp;
+
+ if (sub_cons == NULL)
+ {
+ gfc_error ("Too few elements in expression for SUB= argument at %L",
+ &sub->where);
+ return &gfc_bad_expr;
+ }
+
+ ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
+ NULL, true);
+ if (ca_bound == NULL)
+ goto not_implemented; /* return NULL */
+
+ if (ca_bound == &gfc_bad_expr)
+ return ca_bound;
+
+ cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
+
+ if (cmp == 0)
+ {
+ gfc_free_expr (ca_bound);
+ sub_cons = gfc_constructor_next (sub_cons);
+ continue;
+ }
+
+ first_image = false;
+
+ if (cmp > 0)
+ {
+ gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+ "SUB has %ld and COARRAY lower bound is %ld)",
+ &coarray->where, d,
+ mpz_get_si (sub_cons->expr->value.integer),
+ mpz_get_si (ca_bound->value.integer));
+ gfc_free_expr (ca_bound);
+ return &gfc_bad_expr;
+ }
+
+ gfc_free_expr (ca_bound);
+
+ /* Check whether upperbound is valid for the multi-images case. */
+ if (d < as->corank)
+ {
+ ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
+ NULL, true);
+ if (ca_bound == &gfc_bad_expr)
+ return ca_bound;
+
+ if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ca_bound->value.integer,
+ sub_cons->expr->value.integer) < 0)
+ {
+ gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+ "SUB has %ld and COARRAY upper bound is %ld)",
+ &coarray->where, d,
+ mpz_get_si (sub_cons->expr->value.integer),
+ mpz_get_si (ca_bound->value.integer));
+ gfc_free_expr (ca_bound);
+ return &gfc_bad_expr;
+ }
+
+ if (ca_bound)
+ gfc_free_expr (ca_bound);
+ }
+
+ sub_cons = gfc_constructor_next (sub_cons);
+ }
+
+ if (sub_cons != NULL)
+ {
+ gfc_error ("Too many elements in expression for SUB= argument at %L",
+ &sub->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
+ if (first_image)
+ mpz_set_si (result->value.integer, 1);
+ else
+ mpz_set_si (result->value.integer, 0);
return result;
+
+not_implemented:
+ gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
+ "cobounds at %L", &coarray->where);
+ return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
+
+ if (coarray == NULL)
+ {
+ gfc_expr *result;
+ /* FIXME: gfc_current_locus is wrong. */
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (result->value.integer, 1);
+ return result;
+ }
+
+ gcc_assert (coarray->expr_type == EXPR_VARIABLE);
+
+ /* Follow any component references. */
+ as = coarray->symtree->n.sym->as;
+ for (ref = coarray->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ as = ref->u.ar.as;
+
+ if (as->type == AS_DEFERRED)
+ goto not_implemented; /* return NULL;*/
+
+ if (dim == NULL)
+ {
+ /* Multi-dimensional bounds. */
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+
+ /* Simplify the bounds for each dimension. */
+ for (d = 0; d < as->corank; d++)
+ {
+ bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
+ as, NULL, true);
+ if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+ {
+ int j;
+
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ if (bounds[d] == NULL)
+ goto not_implemented;
+ return bounds[d];
+ }
+ }
+
+ /* Allocate the result expression. */
+ e = gfc_get_expr ();
+ e->where = coarray->where;
+ e->expr_type = EXPR_ARRAY;
+ e->ts.type = BT_INTEGER;
+ e->ts.kind = gfc_default_integer_kind;
+
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], as->corank);
+
+ /* Create the constructor for this array. */
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
+
+ return e;
+ }
+ else
+ {
+ gfc_expr *e;
+ /* A DIM argument is specified. */
+ if (dim->expr_type != EXPR_CONSTANT)
+ goto not_implemented; /*return NULL;*/
+
+ d = mpz_get_si (dim->value.integer);
+
+ if (d < 1 || d > as->corank)
+ {
+ gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+ return &gfc_bad_expr;
+ }
+
+ /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
+ e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
+ if (e != NULL)
+ return e;
+ else
+ goto not_implemented;
+ }
+
+not_implemented:
+ gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
+ "cobounds at %L", &coarray->where);
+ return &gfc_bad_expr;
}
return simplify_bound (array, dim, kind, 1);
}
+gfc_expr *
+gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ gfc_expr *e;
+ /* return simplify_cobound (array, dim, kind, 1);*/
+
+ e = simplify_cobound (array, dim, kind, 1);
+ if (e != NULL)
+ return e;
+
+ gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
+ "cobounds at %L", &array->where);
+ return &gfc_bad_expr;
+}
+
gfc_expr *
gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
&& !is_constant_array_expr(field)))
return NULL;
- result = gfc_start_constructor (vector->ts.type,
- vector->ts.kind,
- &vector->where);
+ result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
+ &vector->where);
result->rank = mask->rank;
result->shape = gfc_copy_shape (mask->shape, mask->rank);
if (vector->ts.type == BT_CHARACTER)
- result->ts.cl = vector->ts.cl;
+ result->ts.u.cl = vector->ts.u.cl;
- vector_ctor = vector->value.constructor;
- mask_ctor = mask->value.constructor;
- field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL;
+ vector_ctor = gfc_constructor_first (vector->value.constructor);
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ field_ctor
+ = field->expr_type == EXPR_ARRAY
+ ? gfc_constructor_first (field->value.constructor)
+ : NULL;
while (mask_ctor)
{
{
gcc_assert (vector_ctor);
e = gfc_copy_expr (vector_ctor->expr);
- ADVANCE (vector_ctor, 1);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
else if (field->expr_type == EXPR_ARRAY)
e = gfc_copy_expr (field_ctor->expr);
else
e = gfc_copy_expr (field);
- gfc_append_constructor (result, e);
+ gfc_constructor_append_expr (&result->value.constructor, e, NULL);
- ADVANCE (mask_ctor, 1);
- ADVANCE (field_ctor, 1);
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ field_ctor = gfc_constructor_next (field_ctor);
}
return result;
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, k, &s->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
len = s->value.character.length;
lenset = set->value.character.length;
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_xor (result->value.integer, x->value.integer, y->value.integer);
- return range_check (result, "XOR");
- }
- else /* BT_LOGICAL */
+
+ switch (x->ts.type)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = (x->value.logical && !y->value.logical)
- || (!x->value.logical && y->value.logical);
- return result;
- }
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "XOR");
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ (x->value.logical && !y->value.logical)
+ || (!x->value.logical && y->value.logical));
+
+ default:
+ gcc_unreachable ();
+ }
}
gfc_convert_constant (gfc_expr *e, bt type, int kind)
{
gfc_expr *g, *result, *(*f) (gfc_expr *, int);
- gfc_constructor *head, *c, *tail = NULL;
+ gfc_constructor *c;
switch (e->ts.type)
{
if (!gfc_is_constant_expr (e))
break;
- head = NULL;
+ result = gfc_get_array_expr (type, kind, &e->where);
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->rank = e->rank;
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
{
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = c->where;
-
+ gfc_expr *tmp;
if (c->iterator == NULL)
- tail->expr = f (c->expr, kind);
+ tmp = f (c->expr, kind);
else
{
g = gfc_convert_constant (c->expr, type, kind);
if (g == &gfc_bad_expr)
- return g;
- tail->expr = g;
+ {
+ gfc_free_expr (result);
+ return g;
+ }
+ tmp = g;
}
- if (tail->expr == NULL)
+ if (tmp == NULL)
{
- gfc_free_constructor (head);
+ gfc_free_expr (result);
return NULL;
}
+
+ gfc_constructor_append_expr (&result->value.constructor,
+ tmp, &c->where);
}
- result = gfc_get_expr ();
- result->ts.type = type;
- result->ts.kind = kind;
- result->expr_type = EXPR_ARRAY;
- result->value.constructor = head;
- result->shape = gfc_copy_shape (e->shape, e->rank);
- result->where = e->where;
- result->rank = e->rank;
break;
default:
if (e->expr_type == EXPR_CONSTANT)
{
/* Simple case of a scalar. */
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
if (result == NULL)
return &gfc_bad_expr;
else if (e->expr_type == EXPR_ARRAY)
{
/* For an array constructor, we convert each constructor element. */
- gfc_constructor *head = NULL, *tail = NULL, *c;
+ gfc_constructor *c;
- for (c = e->value.constructor; c; c = c->next)
- {
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ result = gfc_get_array_expr (type, kind, &e->where);
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->rank = e->rank;
+ result->ts.u.cl = e->ts.u.cl;
- tail->where = c->where;
- tail->expr = gfc_convert_char_constant (c->expr, type, kind);
- if (tail->expr == &gfc_bad_expr)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ {
+ gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
+ if (tmp == &gfc_bad_expr)
{
- tail->expr = NULL;
+ gfc_free_expr (result);
return &gfc_bad_expr;
}
- if (tail->expr == NULL)
+ if (tmp == NULL)
{
- gfc_free_constructor (head);
+ gfc_free_expr (result);
return NULL;
}
- }
- result = gfc_get_expr ();
- result->ts.type = type;
- result->ts.kind = kind;
- result->expr_type = EXPR_ARRAY;
- result->value.constructor = head;
- result->shape = gfc_copy_shape (e->shape, e->rank);
- result->where = e->where;
- result->rank = e->rank;
- result->ts.cl = e->ts.cl;
+ gfc_constructor_append_expr (&result->value.constructor,
+ tmp, &c->where);
+ }
return result;
}