/* 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;
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_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)
{
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;
- }
+ 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 IBCLR exceeds bit size at %L",
- &y->where);
- return &gfc_bad_expr;
- }
-
result = gfc_copy_expr (x);
convert_mpz_to_unsigned (result->value.integer,
|| 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;
}
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))
+ || (coarray && d == as->rank + as->corank
+ && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
{
{
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)
goto returnNull;
}
gfc_array_spec *as;
int d;
+ if (array->ts.type == BT_CLASS)
+ return NULL;
+
if (array->expr_type != EXPR_VARIABLE)
{
as = NULL;
return NULL;
/* Follow any component references. */
- as = array->symtree->n.sym->as;
+ 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)
switch (ref->u.ar.type)
{
case AR_ELEMENT:
- if (ref->next == NULL)
+ if (ref->u.ar.as->corank > 0)
{
- gcc_assert (ref->u.ar.as->corank > 0
- && ref->u.ar.as->rank == 0);
- as = ref->u.ar.as;
+ gcc_assert (as == ref->u.ar.as);
goto done;
}
as = NULL;
}
}
- gcc_unreachable ();
+ if (!as)
+ gcc_unreachable ();
done:
- if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+ if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
return NULL;
if (dim == NULL)
/* Simplify the cobounds for each dimension. */
for (d = 0; d < as->corank; d++)
{
- bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
+ bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
upper, as, ref, true);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
return &gfc_bad_expr;
}
- return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
+ 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)
{
- 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 *
else
gcc_unreachable();
- offset_a = offset_b = 0;
- for (col = 0; col < result_columns; ++col)
- {
- offset_a = 0;
+ offset_a = offset_b = 0;
+ for (col = 0; col < result_columns; ++col)
+ {
+ offset_a = 0;
+
+ for (row = 0; row < result_rows; ++row)
+ {
+ 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);
+
+ offset_a += 1;
+ }
+
+ offset_b += stride_b;
+ }
+
+ return result;
+}
+
+
+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);
- for (row = 0; row < result_rows; ++row)
- {
- 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);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
- offset_a += 1;
- }
+ /* 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);
- offset_b += stride_b;
- }
+ convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
return result;
}
}
-/* 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));
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;
- }
-
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)
{
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_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);
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
replacement = array->value.op.op1;
break;
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_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_expr *
gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
{
- gfc_ref *ref;
- gfc_array_spec *as;
- int d;
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ return NULL;
if (coarray == NULL)
{
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;
+ /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
+ return simplify_cobound (coarray, dim, NULL, 0);
}
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
