/* Simplify intrinsic functions at compile-time.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010 Free Software Foundation, Inc.
+ 2010, 2011 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
#include "intrinsic.h"
#include "target-memory.h"
#include "constructor.h"
+#include "version.h" /* For version_string. */
gfc_expr gfc_bad_expr;
if (result == NULL)
return &gfc_bad_expr;
+ if (result->expr_type != EXPR_CONSTANT)
+ return result;
+
switch (gfc_range_check (result))
{
case ARITH_OK:
for (c = gfc_constructor_first (e->value.constructor);
c; c = gfc_constructor_next (c))
- if (c->expr->expr_type != EXPR_CONSTANT)
+ if (c->expr->expr_type != EXPR_CONSTANT
+ && c->expr->expr_type != EXPR_STRUCTURE)
return false;
return true;
REAL, PARAMETER :: array(n, m) = ...
REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
- where OP == gfc_multiply(). */
+ where OP == gfc_multiply(). The result might be post processed using post_op. */
static gfc_expr *
simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
- gfc_expr *mask, transformational_op op)
+ gfc_expr *mask, transformational_op op,
+ transformational_op post_op)
{
mpz_t size;
int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
linked-list traversal. Masked elements are set to NULL. */
gfc_array_size (array, &size);
arraysize = mpz_get_ui (size);
+ mpz_clear (size);
- arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
+ arrayvec = XCNEWVEC (gfc_expr*, arraysize);
array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
resultsize = mpz_get_ui (size);
mpz_clear (size);
- resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
+ resultvec = XCNEWVEC (gfc_expr*, resultsize);
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
- result_ctor->expr = resultvec[i];
+ if (post_op)
+ result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
+ else
+ result_ctor->expr = resultvec[i];
result_ctor = gfc_constructor_next (result_ctor);
}
- gfc_free (arrayvec);
- gfc_free (resultvec);
+ free (arrayvec);
+ free (resultvec);
return result;
}
+static gfc_expr *
+simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
+ int init_val, transformational_op op)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (array)
+ || !gfc_is_constant_expr (dim))
+ return NULL;
+
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = transformational_result (array, dim, array->ts.type,
+ array->ts.kind, &array->where);
+ init_result_expr (result, init_val, NULL);
+
+ return !dim || array->rank == 1 ?
+ simplify_transformation_to_scalar (result, array, mask, op) :
+ simplify_transformation_to_array (result, array, dim, mask, op, NULL);
+}
+
/********************** Simplification functions *****************************/
gfc_expr *
gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
{
- gfc_expr *result;
-
- if (!is_constant_array_expr (mask)
- || !gfc_is_constant_expr (dim))
- return NULL;
-
- result = transformational_result (mask, dim, mask->ts.type,
- mask->ts.kind, &mask->where);
- init_result_expr (result, true, NULL);
-
- return !dim || mask->rank == 1 ?
- simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
- simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
+ return simplify_transformation (mask, dim, NULL, true, gfc_and);
}
gfc_expr *
+gfc_simplify_dreal (gfc_expr *e)
+{
+ gfc_expr *result = NULL;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
+
+ return range_check (result, "DREAL");
+}
+
+
+gfc_expr *
gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
gfc_expr *
gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
{
- gfc_expr *result;
-
- if (!is_constant_array_expr (mask)
- || !gfc_is_constant_expr (dim))
- return NULL;
-
- result = transformational_result (mask, dim, mask->ts.type,
- mask->ts.kind, &mask->where);
- init_result_expr (result, false, NULL);
-
- return !dim || mask->rank == 1 ?
- simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
- simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
+ return simplify_transformation (mask, dim, NULL, false, gfc_or);
}
}
+/* Simplify transformational form of JN and YN. */
+
+static gfc_expr *
+gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
+ bool jn)
+{
+ gfc_expr *result;
+ gfc_expr *e;
+ long n1, n2;
+ int i;
+ mpfr_t x2rev, last1, last2;
+
+ if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
+ || order2->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ n1 = mpz_get_si (order1->value.integer);
+ n2 = mpz_get_si (order2->value.integer);
+ result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
+ result->rank = 1;
+ result->shape = gfc_get_shape (1);
+ mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
+
+ if (n2 < n1)
+ return result;
+
+ /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
+ YN(N, 0.0) = -Inf. */
+
+ if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
+ {
+ if (!jn && gfc_option.flag_range_check)
+ {
+ gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+
+ if (jn && n1 == 0)
+ {
+ e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
+ gfc_constructor_append_expr (&result->value.constructor, e,
+ &x->where);
+ n1++;
+ }
+
+ for (i = n1; i <= n2; i++)
+ {
+ e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ if (jn)
+ mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+ else
+ mpfr_set_inf (e->value.real, -1);
+ gfc_constructor_append_expr (&result->value.constructor, e,
+ &x->where);
+ }
+
+ return result;
+ }
+
+ /* Use the faster but more verbose recurrence algorithm. Bessel functions
+ are stable for downward recursion and Neumann functions are stable
+ for upward recursion. It is
+ x2rev = 2.0/x,
+ J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
+ Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
+ Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
+
+ gfc_set_model_kind (x->ts.kind);
+
+ /* Get first recursion anchor. */
+
+ mpfr_init (last1);
+ if (jn)
+ mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
+ else
+ mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
+
+ e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_set (e->value.real, last1, GFC_RND_MODE);
+ if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
+ {
+ mpfr_clear (last1);
+ gfc_free_expr (e);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
+
+ if (n1 == n2)
+ {
+ mpfr_clear (last1);
+ return result;
+ }
+
+ /* Get second recursion anchor. */
+
+ mpfr_init (last2);
+ if (jn)
+ mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
+ else
+ mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
+
+ e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_set (e->value.real, last2, GFC_RND_MODE);
+ if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
+ {
+ mpfr_clear (last1);
+ mpfr_clear (last2);
+ gfc_free_expr (e);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ if (jn)
+ gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
+ else
+ gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
+
+ if (n1 + 1 == n2)
+ {
+ mpfr_clear (last1);
+ mpfr_clear (last2);
+ return result;
+ }
+
+ /* Start actual recursion. */
+
+ mpfr_init (x2rev);
+ mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
+
+ for (i = 2; i <= n2-n1; i++)
+ {
+ e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ /* Special case: For YN, if the previous N gave -INF, set
+ also N+1 to -INF. */
+ if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2))
+ {
+ mpfr_set_inf (e->value.real, -1);
+ gfc_constructor_append_expr (&result->value.constructor, e,
+ &x->where);
+ continue;
+ }
+
+ mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
+ GFC_RND_MODE);
+ mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
+ mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
+
+ if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
+ goto error;
+
+ if (jn)
+ gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
+ -i-1);
+ else
+ gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
+
+ mpfr_set (last1, last2, GFC_RND_MODE);
+ mpfr_set (last2, e->value.real, GFC_RND_MODE);
+ }
+
+ mpfr_clear (last1);
+ mpfr_clear (last2);
+ mpfr_clear (x2rev);
+ return result;
+
+error:
+ mpfr_clear (last1);
+ mpfr_clear (last2);
+ mpfr_clear (x2rev);
+ gfc_free_expr (e);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
+{
+ return gfc_simplify_bessel_n2 (order1, order2, x, true);
+}
+
+
gfc_expr *
gfc_simplify_bessel_y0 (gfc_expr *x)
{
gfc_expr *
+gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
+{
+ return gfc_simplify_bessel_n2 (order1, order2, x, false);
+}
+
+
+gfc_expr *
gfc_simplify_bit_size (gfc_expr *e)
{
int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
}
+static int
+compare_bitwise (gfc_expr *i, gfc_expr *j)
+{
+ mpz_t x, y;
+ int k, res;
+
+ gcc_assert (i->ts.type == BT_INTEGER);
+ gcc_assert (j->ts.type == BT_INTEGER);
+
+ mpz_init_set (x, i->value.integer);
+ k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
+ convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+
+ mpz_init_set (y, j->value.integer);
+ k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
+ convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
+
+ res = mpz_cmp (x, y);
+ mpz_clear (x);
+ mpz_clear (y);
+ return res;
+}
+
+
+gfc_expr *
+gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
+{
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+ compare_bitwise (i, j) >= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
+{
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+ compare_bitwise (i, j) > 0);
+}
+
+
+gfc_expr *
+gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
+{
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+ compare_bitwise (i, j) <= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
+{
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+ compare_bitwise (i, j) < 0);
+}
+
+
gfc_expr *
gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
Whenever gfc_count is called, '1' is added to the result. */
return !dim || mask->rank == 1 ?
simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
- simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
+ simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
}
}
+static gfc_expr *
+simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
+ bool right)
+{
+ gfc_expr *result;
+ int i, k, size, shift;
+
+ if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
+ || shiftarg->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
+ size = gfc_integer_kinds[k].bit_size;
+
+ gfc_extract_int (shiftarg, &shift);
+
+ /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
+ if (right)
+ shift = size - shift;
+
+ result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
+ mpz_set_ui (result->value.integer, 0);
+
+ for (i = 0; i < shift; i++)
+ if (mpz_tstbit (arg2->value.integer, size - shift + i))
+ mpz_setbit (result->value.integer, i);
+
+ for (i = 0; i < size - shift; i++)
+ if (mpz_tstbit (arg1->value.integer, i))
+ mpz_setbit (result->value.integer, shift + i);
+
+ /* Convert to a signed value. */
+ convert_mpz_to_signed (result->value.integer, size);
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
+{
+ return simplify_dshift (arg1, arg2, shiftarg, true);
+}
+
+
+gfc_expr *
+gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
+{
+ return simplify_dshift (arg1, arg2, shiftarg, false);
+}
+
+
gfc_expr *
gfc_simplify_erf (gfc_expr *x)
{
}
+static bool
+is_last_ref_vtab (gfc_expr *e)
+{
+ gfc_ref *ref;
+ gfc_component *comp = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ comp = ref->u.c.component;
+
+ if (!e->ref || !comp)
+ return e->symtree->n.sym->attr.vtab;
+
+ if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
+ return true;
+
+ return false;
+}
+
+
+gfc_expr *
+gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
+{
+ /* Avoid simplification of resolved symbols. */
+ if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
+ return NULL;
+
+ if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_type_is_extension_of (mold->ts.u.derived,
+ a->ts.u.derived));
+ /* Return .false. if the dynamic type can never be the same. */
+ if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
+ && !gfc_type_is_extension_of
+ (mold->ts.u.derived->components->ts.u.derived,
+ a->ts.u.derived->components->ts.u.derived)
+ && !gfc_type_is_extension_of
+ (a->ts.u.derived->components->ts.u.derived,
+ mold->ts.u.derived->components->ts.u.derived))
+ || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
+ && !gfc_type_is_extension_of
+ (a->ts.u.derived,
+ mold->ts.u.derived->components->ts.u.derived)
+ && !gfc_type_is_extension_of
+ (mold->ts.u.derived->components->ts.u.derived,
+ a->ts.u.derived))
+ || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
+ && !gfc_type_is_extension_of
+ (mold->ts.u.derived,
+ a->ts.u.derived->components->ts.u.derived)))
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+ if (mold->ts.type == BT_DERIVED
+ && gfc_type_is_extension_of (mold->ts.u.derived,
+ a->ts.u.derived->components->ts.u.derived))
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
+
+ return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+ /* Avoid simplification of resolved symbols. */
+ if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
+ return NULL;
+
+ /* Return .false. if the dynamic type can never be the
+ same. */
+ if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
+ && !gfc_type_compatible (&a->ts, &b->ts)
+ && !gfc_type_compatible (&b->ts, &a->ts))
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+ if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_derived_types (a->ts.u.derived,
+ b->ts.u.derived));
+}
+
+
gfc_expr *
gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
{
}
+static gfc_expr *
+do_bit_and (gfc_expr *result, gfc_expr *e)
+{
+ gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+ gcc_assert (result->ts.type == BT_INTEGER
+ && result->expr_type == EXPR_CONSTANT);
+
+ mpz_and (result->value.integer, result->value.integer, e->value.integer);
+ return result;
+}
+
+
gfc_expr *
-gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
+gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
- gfc_expr *result;
+ return simplify_transformation (array, dim, mask, -1, do_bit_and);
+}
- if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
- return NULL;
- result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
- mpz_and (result->value.integer, x->value.integer, y->value.integer);
+static gfc_expr *
+do_bit_ior (gfc_expr *result, gfc_expr *e)
+{
+ gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+ gcc_assert (result->ts.type == BT_INTEGER
+ && result->expr_type == EXPR_CONSTANT);
- return range_check (result, "IAND");
+ mpz_ior (result->value.integer, result->value.integer, e->value.integer);
+ return result;
}
gfc_expr *
-gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
+gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
- gfc_expr *result;
- int k, pos;
+ return simplify_transformation (array, dim, mask, 0, do_bit_ior);
+}
+
+
+gfc_expr *
+gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (y, &pos) != NULL || pos < 0)
- {
- gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
- return &gfc_bad_expr;
- }
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+ mpz_and (result->value.integer, x->value.integer, y->value.integer);
- k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+ return range_check (result, "IAND");
+}
- if (pos >= gfc_integer_kinds[k].bit_size)
- {
- gfc_error ("Second argument of IBCLR exceeds bit size at %L",
- &y->where);
- return &gfc_bad_expr;
- }
+
+gfc_expr *
+gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *result;
+ int k, pos;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ gfc_extract_int (y, &pos);
+
+ k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
result = gfc_copy_expr (x);
|| z->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (y, &pos) != NULL || pos < 0)
- {
- gfc_error ("Invalid second argument of IBITS at %L", &y->where);
- return &gfc_bad_expr;
- }
-
- if (gfc_extract_int (z, &len) != NULL || len < 0)
- {
- gfc_error ("Invalid third argument of IBITS at %L", &z->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (y, &pos);
+ gfc_extract_int (z, &len);
k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
gfc_internal_error ("IBITS: Bad bit");
}
- gfc_free (bits);
+ free (bits);
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (y, &pos) != NULL || pos < 0)
- {
- gfc_error ("Invalid second argument of IBSET at %L", &y->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (y, &pos);
k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- if (pos >= gfc_integer_kinds[k].bit_size)
- {
- gfc_error ("Second argument of IBSET exceeds bit size at %L",
- &y->where);
- return &gfc_bad_expr;
- }
-
result = gfc_copy_expr (x);
convert_mpz_to_unsigned (result->value.integer,
}
+static gfc_expr *
+do_bit_xor (gfc_expr *result, gfc_expr *e)
+{
+ gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+ gcc_assert (result->ts.type == BT_INTEGER
+ && result->expr_type == EXPR_CONSTANT);
+
+ mpz_xor (result->value.integer, result->value.integer, e->value.integer);
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ return simplify_transformation (array, dim, mask, 0, do_bit_xor);
+}
+
+
+
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
}
-gfc_expr *
-gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
+/* Performs a shift on its first argument. Depending on the last
+ argument, the shift can be arithmetic, i.e. with filling from the
+ left like in the SHIFTA intrinsic. */
+static gfc_expr *
+simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
+ bool arithmetic, int direction)
{
gfc_expr *result;
- int shift, ashift, isize, k, *bits, i;
+ int ashift, *bits, i, k, bitsize, shift;
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (s, &shift) != NULL)
- {
- gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (s, &shift);
k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
+ bitsize = gfc_integer_kinds[k].bit_size;
- isize = gfc_integer_kinds[k].bit_size;
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
- if (shift >= 0)
- ashift = shift;
- else
- ashift = -shift;
+ if (shift == 0)
+ {
+ mpz_set (result->value.integer, e->value.integer);
+ return result;
+ }
- if (ashift > isize)
+ if (direction > 0 && shift < 0)
{
- gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
- "at %L", &s->where);
+ /* Left shift, as in SHIFTL. */
+ gfc_error ("Second argument of %s is negative at %L", name, &e->where);
return &gfc_bad_expr;
}
+ else if (direction < 0)
+ {
+ /* Right shift, as in SHIFTR or SHIFTA. */
+ if (shift < 0)
+ {
+ gfc_error ("Second argument of %s is negative at %L",
+ name, &e->where);
+ return &gfc_bad_expr;
+ }
- result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ shift = -shift;
+ }
- if (shift == 0)
+ ashift = (shift >= 0 ? shift : -shift);
+
+ if (ashift > bitsize)
{
- mpz_set (result->value.integer, e->value.integer);
- return range_check (result, "ISHFT");
+ gfc_error ("Magnitude of second argument of %s exceeds bit size "
+ "at %L", name, &e->where);
+ return &gfc_bad_expr;
}
-
- bits = XCNEWVEC (int, isize);
- for (i = 0; i < isize; i++)
+ bits = XCNEWVEC (int, bitsize);
+
+ for (i = 0; i < bitsize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
if (shift > 0)
{
+ /* Left shift. */
for (i = 0; i < shift; i++)
mpz_clrbit (result->value.integer, i);
- for (i = 0; i < isize - shift; i++)
+ for (i = 0; i < bitsize - shift; i++)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i + shift);
}
else
{
- for (i = isize - 1; i >= isize - ashift; i--)
- mpz_clrbit (result->value.integer, i);
+ /* Right shift. */
+ if (arithmetic && bits[bitsize - 1])
+ for (i = bitsize - 1; i >= bitsize - ashift; i--)
+ mpz_setbit (result->value.integer, i);
+ else
+ for (i = bitsize - 1; i >= bitsize - ashift; i--)
+ mpz_clrbit (result->value.integer, i);
- for (i = isize - 1; i >= ashift; i--)
+ for (i = bitsize - 1; i >= ashift; i--)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i - ashift);
}
}
- convert_mpz_to_signed (result->value.integer, isize);
+ convert_mpz_to_signed (result->value.integer, bitsize);
+ free (bits);
- gfc_free (bits);
return result;
}
gfc_expr *
+gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
+{
+ return simplify_shift (e, s, "ISHFT", false, 0);
+}
+
+
+gfc_expr *
+gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
+{
+ return simplify_shift (e, s, "LSHIFT", false, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
+{
+ return simplify_shift (e, s, "RSHIFT", true, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
+{
+ return simplify_shift (e, s, "SHIFTA", true, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
+{
+ return simplify_shift (e, s, "SHIFTL", false, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
+{
+ return simplify_shift (e, s, "SHIFTR", false, -1);
+}
+
+
+gfc_expr *
gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
{
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (s, &shift) != NULL)
- {
- gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (s, &shift);
k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
isize = gfc_integer_kinds[k].bit_size;
if (sz->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
- {
- gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (sz, &ssize);
- if (ssize > isize)
- {
- gfc_error ("Magnitude of third argument of ISHFTC exceeds "
- "BIT_SIZE of first argument at %L", &s->where);
- return &gfc_bad_expr;
- }
}
else
ssize = isize;
if (ashift > ssize)
{
- if (sz != NULL)
- gfc_error ("Magnitude of second argument of ISHFTC exceeds "
- "third argument at %L", &s->where);
- else
+ if (sz == NULL)
gfc_error ("Magnitude of second argument of ISHFTC exceeds "
"BIT_SIZE of first argument at %L", &s->where);
return &gfc_bad_expr;
convert_mpz_to_signed (result->value.integer, isize);
- gfc_free (bits);
+ free (bits);
return result;
}
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 (as->lower[d-1]->expr_type == EXPR_CONSTANT)
- return gfc_copy_expr (as->lower[d-1]);
- else
- return NULL;
- }
-
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
gfc_default_integer_kind);
if (k == -1)
result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
+ /* For non-variables, LBOUND(expr, DIM=n) = 1 and
+ UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
+ if (!coarray && array->expr_type != EXPR_VARIABLE)
+ {
+ if (upper)
+ {
+ gfc_expr* dim = result;
+ mpz_set_si (dim->value.integer, d);
+
+ result = gfc_simplify_size (array, dim, kind);
+ gfc_free_expr (dim);
+ if (!result)
+ goto returnNull;
+ }
+ else
+ mpz_set_si (result->value.integer, 1);
+
+ goto done;
+ }
+
+ /* Otherwise, we have a variable expression. */
+ gcc_assert (array->expr_type == EXPR_VARIABLE);
+ gcc_assert (as);
+
+ if (gfc_resolve_array_spec (as, 0) == FAILURE)
+ return NULL;
+
+ /* The last dimension of an assumed-size array is special. */
+ if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+ || (coarray && d == as->rank + as->corank
+ && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
+ {
+ if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
+ {
+ gfc_free_expr (result);
+ return gfc_copy_expr (as->lower[d-1]);
+ }
+
+ goto returnNull;
+ }
+
+ 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)
- return NULL;
+ if (l->expr_type != EXPR_CONSTANT || u == NULL
+ || u->expr_type != EXPR_CONSTANT)
+ goto returnNull;
if (mpz_cmp (l->value.integer, u->value.integer) > 0)
{
{
if (upper)
{
- if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
+ if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL)
!= SUCCESS)
- return NULL;
+ goto returnNull;
}
else
mpz_set_si (result->value.integer, (long int) 1);
}
+done:
return range_check (result, upper ? "UBOUND" : "LBOUND");
+
+returnNull:
+ gfc_free_expr (result);
+ return NULL;
}
gfc_array_spec *as;
int d;
- if (array->expr_type != EXPR_VARIABLE)
+ if (array->ts.type == BT_CLASS)
return NULL;
+ if (array->expr_type != EXPR_VARIABLE)
+ {
+ as = NULL;
+ ref = NULL;
+ goto done;
+ }
+
/* Follow any component references. */
as = array->symtree->n.sym->as;
for (ref = array->ref; ref; ref = ref->next)
/* We're done because 'as' has already been set in the
previous iteration. */
if (!ref->next)
- goto done;
+ goto done;
/* Fall through. */
done:
- if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+ if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
return NULL;
if (dim == NULL)
int k;
/* UBOUND(ARRAY) is not valid for an assumed-size array. */
- if (upper && as->type == AS_ASSUMED_SIZE)
+ if (upper && as && as->type == AS_ASSUMED_SIZE)
{
/* An error message will be emitted in
check_assumed_size_reference (resolve.c). */
/* 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;
d = mpz_get_si (dim->value.integer);
- if (d < 1 || d > as->rank
- || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
+ if (d < 1 || d > array->rank
+ || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
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);
+ }
+}
+
+
+static gfc_expr *
+simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+{
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
+
+ if (array->expr_type != EXPR_VARIABLE)
+ return NULL;
+
+ /* Follow any component references. */
+ as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
+ ? array->ts.u.derived->components->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->u.ar.as->corank > 0)
+ {
+ gcc_assert (as == ref->u.ar.as);
+ goto done;
+ }
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ /* We're done because 'as' has already been set in the
+ previous iteration. */
+ if (!ref->next)
+ goto done;
+
+ /* Fall through. */
+
+ case AR_UNKNOWN:
+ return NULL;
+
+ case AR_SECTION:
+ as = ref->u.ar.as;
+ goto done;
+ }
+
+ gcc_unreachable ();
+
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ continue;
+ }
+ }
+
+ if (!as)
+ gcc_unreachable ();
+
+ done:
+
+ if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
+ return NULL;
+
+ if (dim == NULL)
+ {
+ /* 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++)
+ {
+ bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->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+as->rank, upper, as, ref, true);
}
}
gfc_expr *
+gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ return simplify_cobound (array, dim, kind, 0);
+}
+
+gfc_expr *
gfc_simplify_leadz (gfc_expr *e)
{
unsigned long lz, bs;
gfc_expr *
+gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
+{
+ gfc_expr *result;
+ int kind, arg, k;
+ const char *s;
+
+ if (i->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
+ k = gfc_validate_kind (BT_INTEGER, kind, false);
+
+ s = gfc_extract_int (i, &arg);
+ gcc_assert (!s);
+
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
+
+ /* MASKR(n) = 2^n - 1 */
+ mpz_set_ui (result->value.integer, 1);
+ mpz_mul_2exp (result->value.integer, result->value.integer, arg);
+ mpz_sub_ui (result->value.integer, result->value.integer, 1);
+
+ convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
+{
+ gfc_expr *result;
+ int kind, arg, k;
+ const char *s;
+ mpz_t z;
+
+ if (i->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
+ k = gfc_validate_kind (BT_INTEGER, kind, false);
+
+ s = gfc_extract_int (i, &arg);
+ gcc_assert (!s);
+
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
+
+ /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
+ mpz_init_set_ui (z, 1);
+ mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
+ mpz_set_ui (result->value.integer, 1);
+ mpz_mul_2exp (result->value.integer, result->value.integer,
+ gfc_integer_kinds[k].bit_size - arg);
+ mpz_sub (result->value.integer, z, result->value.integer);
+ mpz_clear (z);
+
+ convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
if (tsource->expr_type != EXPR_CONSTANT
}
-/* Selects bewteen current value and extremum for simplify_min_max
+gfc_expr *
+gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
+{
+ mpz_t arg1, arg2, mask;
+ gfc_expr *result;
+
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
+ || mask_expr->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
+
+ /* Convert all argument to unsigned. */
+ mpz_init_set (arg1, i->value.integer);
+ mpz_init_set (arg2, j->value.integer);
+ mpz_init_set (mask, mask_expr->value.integer);
+
+ /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
+ mpz_and (arg1, arg1, mask);
+ mpz_com (mask, mask);
+ mpz_and (arg2, arg2, mask);
+ mpz_ior (result->value.integer, arg1, arg2);
+
+ mpz_clear (arg1);
+ mpz_clear (arg2);
+ mpz_clear (mask);
+
+ return result;
+}
+
+
+/* Selects between current value and extremum for simplify_min_max
and simplify_minval_maxval. */
static void
min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
LENGTH(arg) - LENGTH(extremum));
STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
LENGTH(extremum) = LENGTH(arg);
- gfc_free (tmp);
+ free (tmp);
}
if (gfc_compare_string (arg, extremum) * sign > 0)
{
- gfc_free (STRING(extremum));
+ free (STRING(extremum));
STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
memcpy (STRING(extremum), STRING(arg),
LENGTH(arg) * sizeof (gfc_char_t));
mp_exp_t emin, emax;
int kind;
- if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
- return NULL;
-
- if (mpfr_sgn (s->value.real) == 0)
- {
- gfc_error ("Second argument of NEAREST at %L shall not be zero",
- &s->where);
- return &gfc_bad_expr;
- }
-
+ if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
+ return NULL;
+
result = gfc_copy_expr (x);
/* Save current values of emin and emax. */
}
+static gfc_expr *
+add_squared (gfc_expr *result, gfc_expr *e)
+{
+ mpfr_t tmp;
+
+ gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+ gcc_assert (result->ts.type == BT_REAL
+ && result->expr_type == EXPR_CONSTANT);
+
+ gfc_set_model_kind (result->ts.kind);
+ mpfr_init (tmp);
+ mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
+ mpfr_add (result->value.real, result->value.real, tmp,
+ GFC_RND_MODE);
+ mpfr_clear (tmp);
+
+ return result;
+}
+
+
+static gfc_expr *
+do_sqrt (gfc_expr *result, gfc_expr *e)
+{
+ gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+ gcc_assert (result->ts.type == BT_REAL
+ && result->expr_type == EXPR_CONSTANT);
+
+ mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
+ mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (e)
+ || (dim != NULL && !gfc_is_constant_expr (dim)))
+ return NULL;
+
+ result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
+ init_result_expr (result, 0, NULL);
+
+ if (!dim || e->rank == 1)
+ {
+ result = simplify_transformation_to_scalar (result, e, NULL,
+ add_squared);
+ mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+ }
+ else
+ result = simplify_transformation_to_array (result, e, dim, NULL,
+ add_squared, &do_sqrt);
+
+ return result;
+}
+
+
gfc_expr *
gfc_simplify_not (gfc_expr *e)
{
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;
+ }
+
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ return NULL;
+
/* FIXME: gfc_current_locus is wrong. */
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
return NULL;
result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
+ if (array->ts.type == BT_DERIVED)
+ result->ts.u.derived = array->ts.u.derived;
array_ctor = gfc_constructor_first (array->value.constructor);
vector_ctor = vector
}
+static gfc_expr *
+do_xor (gfc_expr *result, gfc_expr *e)
+{
+ gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
+ gcc_assert (result->ts.type == BT_LOGICAL
+ && result->expr_type == EXPR_CONSTANT);
+
+ result->value.logical = result->value.logical != e->value.logical;
+ return result;
+}
+
+
+
gfc_expr *
-gfc_simplify_precision (gfc_expr *e)
+gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
{
- 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);
+ return simplify_transformation (e, dim, NULL, 0, do_xor);
}
gfc_expr *
-gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+gfc_simplify_popcnt (gfc_expr *e)
{
- gfc_expr *result;
+ int res, k;
+ mpz_t x;
- if (!is_constant_array_expr (array)
- || !gfc_is_constant_expr (dim))
+ if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (mask
- && !is_constant_array_expr (mask)
- && mask->expr_type != EXPR_CONSTANT)
+ k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
+ /* Convert argument to unsigned, then count the '1' bits. */
+ mpz_init_set (x, e->value.integer);
+ convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+ res = mpz_popcount (x);
+ mpz_clear (x);
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
+}
+
+
+gfc_expr *
+gfc_simplify_poppar (gfc_expr *e)
+{
+ gfc_expr *popcnt;
+ const char *s;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = transformational_result (array, dim, array->ts.type,
- array->ts.kind, &array->where);
- init_result_expr (result, 1, NULL);
+ popcnt = gfc_simplify_popcnt (e);
+ gcc_assert (popcnt);
- return !dim || array->rank == 1 ?
- simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
- simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
+ s = gfc_extract_int (popcnt, &i);
+ gcc_assert (!s);
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
+}
+
+
+gfc_expr *
+gfc_simplify_precision (gfc_expr *e)
+{
+ 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_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ return simplify_transformation (array, dim, mask, 1, gfc_multiply);
}
gfc_expr *
+gfc_simplify_rank (gfc_expr *e)
+{
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
+}
+
+
+gfc_expr *
gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result = NULL;
result = gfc_get_array_expr (source->ts.type, source->ts.kind,
&source->where);
+ if (source->ts.type == BT_DERIVED)
+ result->ts.u.derived = source->ts.u.derived;
result->rank = rank;
result->shape = gfc_get_shape (rank);
for (i = 0; i < rank; i++)
gfc_expr *
-gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
+gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
{
- int range, precision, i, kind, found_precision, found_range;
+ int range, precision, radix, i, kind, found_precision, found_range,
+ found_radix;
+ locus *loc = &gfc_current_locus;
if (p == NULL)
precision = 0;
if (p->expr_type != EXPR_CONSTANT
|| gfc_extract_int (p, &precision) != NULL)
return NULL;
+ loc = &p->where;
}
if (q == NULL)
if (q->expr_type != EXPR_CONSTANT
|| gfc_extract_int (q, &range) != NULL)
return NULL;
+
+ if (!loc)
+ loc = &q->where;
+ }
+
+ if (rdx == NULL)
+ radix = 0;
+ else
+ {
+ if (rdx->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rdx, &radix) != NULL)
+ return NULL;
+
+ if (!loc)
+ loc = &rdx->where;
}
kind = INT_MAX;
found_precision = 0;
found_range = 0;
+ found_radix = 0;
for (i = 0; gfc_real_kinds[i].kind != 0; i++)
{
if (gfc_real_kinds[i].range >= range)
found_range = 1;
+ if (gfc_real_kinds[i].radix >= radix)
+ found_radix = 1;
+
if (gfc_real_kinds[i].precision >= precision
- && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
+ && gfc_real_kinds[i].range >= range
+ && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
if (kind == INT_MAX)
{
- kind = 0;
-
- if (!found_precision)
+ if (found_radix && found_range && !found_precision)
kind = -1;
- if (!found_range)
- kind -= 2;
+ else if (found_radix && found_precision && !found_range)
+ kind = -2;
+ else if (found_radix && !found_precision && !found_range)
+ kind = -3;
+ else if (found_radix)
+ kind = -4;
+ else
+ kind = -5;
}
- return gfc_get_int_expr (gfc_default_integer_kind,
- p ? &p->where : &q->where, kind);
+ return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
}
gfc_expr *
-gfc_simplify_shape (gfc_expr *source)
+gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
gfc_expr *result, *e, *f;
gfc_array_ref *ar;
int n;
gfc_try t;
+ int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
- if (source->rank == 0)
- return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
-
- if (source->expr_type != EXPR_VARIABLE)
- return NULL;
-
- result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
- ar = gfc_find_array_ref (source);
+ if (source->rank == 0)
+ return result;
- t = gfc_array_ref_shape (ar, shape);
+ if (source->expr_type == EXPR_VARIABLE)
+ {
+ ar = gfc_find_array_ref (source);
+ t = gfc_array_ref_shape (ar, shape);
+ }
+ else if (source->shape)
+ {
+ t = SUCCESS;
+ for (n = 0; n < source->rank; n++)
+ {
+ mpz_init (shape[n]);
+ mpz_set (shape[n], source->shape[n]);
+ }
+ }
+ else
+ t = FAILURE;
for (n = 0; n < source->rank; n++)
{
- e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
if (t == SUCCESS)
{
return NULL;
}
else
- {
- e = f;
- }
+ e = f;
}
gfc_constructor_append_expr (&result->value.constructor, e, NULL);
gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
mpz_t size;
+ gfc_expr *return_value;
int d;
int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
+ /* For unary operations, the size of the result is given by the size
+ of the operand. For binary ones, it's the size of the first operand
+ unless it is scalar, then it is the size of the second. */
+ if (array->expr_type == EXPR_OP && !array->value.op.uop)
+ {
+ gfc_expr* replacement;
+ gfc_expr* simplified;
+
+ switch (array->value.op.op)
+ {
+ /* Unary operations. */
+ case INTRINSIC_NOT:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
+ replacement = array->value.op.op1;
+ break;
+
+ /* Binary operations. If any one of the operands is scalar, take
+ the other one's size. If both of them are arrays, it does not
+ matter -- try to find one with known shape, if possible. */
+ default:
+ if (array->value.op.op1->rank == 0)
+ replacement = array->value.op.op2;
+ else if (array->value.op.op2->rank == 0)
+ replacement = array->value.op.op1;
+ else
+ {
+ simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
+ if (simplified)
+ return simplified;
+
+ replacement = array->value.op.op2;
+ }
+ break;
+ }
+
+ /* Try to reduce it directly if possible. */
+ simplified = gfc_simplify_size (replacement, dim, kind);
+
+ /* Otherwise, we build a new SIZE call. This is hopefully at least
+ simpler than the original one. */
+ if (!simplified)
+ simplified = gfc_build_intrinsic_call ("size", array->where, 3,
+ gfc_copy_expr (replacement),
+ gfc_copy_expr (dim),
+ gfc_copy_expr (kind));
+
+ return simplified;
+ }
+
if (dim == NULL)
{
if (gfc_array_size (array, &size) == FAILURE)
return NULL;
}
- return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+ return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+ mpz_clear (size);
+ return return_value;
}
result = gfc_get_array_expr (source->ts.type, source->ts.kind,
&source->where);
+ if (source->ts.type == BT_DERIVED)
+ result->ts.u.derived = source->ts.u.derived;
result->rank = 1;
result->shape = gfc_get_shape (result->rank);
mpz_init_set_si (result->shape[0], ncopies);
result = gfc_get_array_expr (source->ts.type, source->ts.kind,
&source->where);
+ if (source->ts.type == BT_DERIVED)
+ result->ts.u.derived = source->ts.u.derived;
result->rank = source->rank + 1;
result->shape = gfc_get_shape (result->rank);
gfc_expr *
gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
- gfc_expr *result;
-
- if (!is_constant_array_expr (array)
- || !gfc_is_constant_expr (dim))
- return NULL;
-
- if (mask
- && !is_constant_array_expr (mask)
- && mask->expr_type != EXPR_CONSTANT)
- return NULL;
-
- result = transformational_result (array, dim, array->ts.type,
- array->ts.kind, &array->where);
- init_result_expr (result, 0, NULL);
-
- return !dim || array->rank == 1 ?
- simplify_transformation_to_scalar (result, array, mask, gfc_add) :
- simplify_transformation_to_array (result, array, dim, mask, gfc_add);
+ return simplify_transformation (array, dim, mask, 0, gfc_add);
}
gfc_expr *mold_element;
size_t source_size;
size_t result_size;
- size_t result_elt_size;
size_t buffer_size;
mpz_t tmp;
unsigned char *buffer;
+ size_t result_length;
+
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;
- if (source->expr_type == EXPR_FUNCTION)
+ if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+ &result_size, &result_length) == FAILURE)
return NULL;
/* Calculate the size of the source. */
&& gfc_array_size (source, &tmp) == FAILURE)
gfc_internal_error ("Failure getting length of a constant array.");
- source_size = gfc_target_expr_size (source);
-
/* Create an empty new expression with the appropriate characteristics. */
result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
&source->where);
result->value.character.length = mold_element->value.character.length;
/* Set the number of elements in the result, and determine its size. */
- result_elt_size = gfc_target_expr_size (mold_element);
- if (result_elt_size == 0)
- {
- gfc_free_expr (result);
- return NULL;
- }
if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
{
- int result_length;
-
result->expr_type = EXPR_ARRAY;
result->rank = 1;
-
- if (size)
- result_length = (size_t)mpz_get_ui (size->value.integer);
- else
- {
- result_length = source_size / result_elt_size;
- if (result_length * result_elt_size < source_size)
- result_length += 1;
- }
-
result->shape = gfc_get_shape (1);
mpz_init_set_ui (result->shape[0], result_length);
-
- result_size = result_length * result_elt_size;
}
else
- {
- result->rank = 0;
- result_size = result_elt_size;
- }
-
- if (gfc_option.warn_surprising && source_size < result_size)
- gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
- "source size %ld < result size %ld", &source->where,
- (long) source_size, (long) result_size);
+ result->rank = 0;
/* Allocate the buffer to store the binary version of the source. */
buffer_size = MAX (source_size, result_size);
gfc_target_encode_expr (source, buffer, buffer_size);
/* And read the buffer back into the new expression. */
- gfc_target_interpret_expr (buffer, buffer_size, result);
+ gfc_target_interpret_expr (buffer, buffer_size, result, false);
return result;
}
if (matrix->ts.type == BT_CHARACTER)
result->ts.u.cl = matrix->ts.u.cl;
+ else if (matrix->ts.type == BT_DERIVED)
+ result->ts.u.derived = matrix->ts.u.derived;
matrix_rows = mpz_get_si (matrix->shape[0]);
matrix_cols = mpz_get_si (matrix->shape[1]);
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))
+ 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)
+ 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;
+
+ gcc_assert (sub_cons != NULL);
+
+ ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
+ NULL, true);
+ if (ca_bound == NULL)
+ 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);
+ }
+
+ gcc_assert (sub_cons == NULL);
+
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
+ return NULL;
+
+ 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;
+}
+
+
+gfc_expr *
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ return NULL;
+
+ 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;
+ }
+
+ /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
+ return simplify_cobound (coarray, dim, NULL, 0);
+}
+
+
+gfc_expr *
gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
return simplify_bound (array, dim, kind, 1);
}
+gfc_expr *
+gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ return simplify_cobound (array, dim, kind, 1);
+}
+
gfc_expr *
gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
&vector->where);
+ if (vector->ts.type == BT_DERIVED)
+ result->ts.u.derived = vector->ts.u.derived;
result->rank = mask->rank;
result->shape = gfc_copy_shape (mask->shape, mask->rank);
else
return NULL;
}
+
+
+gfc_expr *
+gfc_simplify_compiler_options (void)
+{
+ char *str;
+ gfc_expr *result;
+
+ str = gfc_get_option_string ();
+ result = gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, str, strlen (str));
+ free (str);
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_compiler_version (void)
+{
+ char *buffer;
+ size_t len;
+
+ len = strlen ("GCC version ") + strlen (version_string);
+ buffer = XALLOCAVEC (char, len + 1);
+ snprintf (buffer, len + 1, "GCC version %s", version_string);
+ return gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, buffer, len);
+}
OSDN Git Service
