/* 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;
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;
gfc_array_size (array, &size);
arraysize = mpz_get_ui (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_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, NULL);
+ return simplify_transformation (mask, dim, NULL, true, gfc_and);
}
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, NULL);
+ return simplify_transformation (mask, dim, NULL, false, gfc_or);
}
if (jn && n1 == 0)
{
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- mpfr_set_ui (e->value.real, 1.0, GFC_RND_MODE);
+ mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
gfc_constructor_append_expr (&result->value.constructor, e,
&x->where);
n1++;
{
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
if (jn)
- mpfr_set_ui (e->value.real, 0.0, GFC_RND_MODE);
+ 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,
return &gfc_bad_expr;
}
if (jn)
- gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
+ gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
else
gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
}
+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)
{
}
+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;
+
+ if (gfc_extract_int (shiftarg, &shift) != NULL)
+ {
+ gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg->where);
+ return &gfc_bad_expr;
+ }
+
+ gcc_assert (shift >= 0 && shift <= size);
+
+ /* 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_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ return simplify_transformation (array, dim, mask, -1, do_bit_and);
+}
+
+
+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);
+
+ mpz_ior (result->value.integer, result->value.integer, e->value.integer);
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ return simplify_transformation (array, dim, mask, 0, do_bit_ior);
+}
+
+
gfc_expr *
gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
{
gfc_internal_error ("IBITS: Bad bit");
}
- gfc_free (bits);
+ free (bits);
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
}
+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);
+ gfc_error ("Invalid second argument of %s at %L", name, &s->where);
return &gfc_bad_expr;
}
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;
+ }
+
+ shift = -shift;
+ }
- result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ ashift = (shift >= 0 ? shift : -shift);
- if (shift == 0)
+ 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;
convert_mpz_to_signed (result->value.integer, isize);
- gfc_free (bits);
+ free (bits);
return result;
}
/* 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))
+ || (coarray && d == as->rank + as->corank
+ && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
{
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;
+ return simplify_cobound (array, dim, kind, 0);
}
gfc_expr *
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));
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
gfc_expr *
gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
{
- gfc_expr *result;
+ return simplify_transformation (e, dim, NULL, 0, do_xor);
+}
- if (!is_constant_array_expr (e)
- || (dim != NULL && !gfc_is_constant_expr (dim)))
+
+gfc_expr *
+gfc_simplify_popcnt (gfc_expr *e)
+{
+ int res, k;
+ mpz_t x;
+
+ if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
- init_result_expr (result, 0, NULL);
+ 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;
+
+ popcnt = gfc_simplify_popcnt (e);
+ gcc_assert (popcnt);
+
+ s = gfc_extract_int (popcnt, &i);
+ gcc_assert (!s);
- return (!dim || e->rank == 1)
- ? simplify_transformation_to_scalar (result, e, NULL, do_xor)
- : simplify_transformation_to_array (result, e, dim, NULL, do_xor, NULL);
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
}
gfc_expr *
gfc_simplify_product (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, 1, NULL);
-
- return !dim || array->rank == 1 ?
- simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
- simplify_transformation_to_array (result, array, dim, mask, gfc_multiply, NULL);
+ 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_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);
+ result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
- result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ if (source->rank == 0)
+ return result;
if (source->expr_type == EXPR_VARIABLE)
{
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)
{
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);
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, NULL);
+ 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_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]);
int d;
if (!is_constant_array_expr (sub))
- goto not_implemented; /* return NULL;*/
+ return NULL;
/* Follow any component references. */
as = coarray->symtree->n.sym->as;
as = ref->u.ar.as;
if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
+ return NULL;
/* "valid sequence of cosubscripts" are required; thus, return 0 unless
the cosubscript addresses the first image. */
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;
- }
+ gcc_assert (sub_cons != NULL);
ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
NULL, true);
if (ca_bound == NULL)
- goto not_implemented; /* return NULL */
+ return NULL;
if (ca_bound == &gfc_bad_expr)
return 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;
- }
+ 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);
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_array_spec *as;
int d;
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ return NULL;
+
if (coarray == NULL)
{
gfc_expr *result;
as = ref->u.ar.as;
if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
+ return NULL;
if (dim == NULL)
{
for (j = 0; j < d; j++)
gfc_free_expr (bounds[j]);
- if (bounds[d] == NULL)
- goto not_implemented;
+
return bounds[d];
}
}
}
else
{
- gfc_expr *e;
/* A DIM argument is specified. */
if (dim->expr_type != EXPR_CONSTANT)
- goto not_implemented; /*return NULL;*/
+ return NULL;
d = mpz_get_si (dim->value.integer);
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;
+ return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
+ true);
}
-
-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_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;
+ return simplify_cobound (array, dim, kind, 1);
}
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
