/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
- Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
#include "arith.h"
#include "intrinsic.h"
#include "target-memory.h"
+#include "constructor.h"
+#include "version.h" /* For version_string. */
+
gfc_expr gfc_bad_expr;
be a part of the new expression.
NULL pointer indicating that no simplification was possible and
- the original expression should remain intact. If the
- simplification function sets the type and/or the function name
- via the pointer gfc_simple_expression, then this type is
- retained.
+ the original expression should remain intact.
An expression pointer to gfc_bad_expr (a static placeholder)
- indicating that some error has prevented simplification. For
- example, sqrt(-1.0). The error is generated within the function
- and should be propagated upwards
+ indicating that some error has prevented simplification. The
+ error is generated within the function and should be propagated
+ upwards
By the time a simplification function gets control, it has been
decided that the function call is really supposed to be the
subroutine may have to look at the type of an argument as part of
its processing.
- Array arguments are never passed to these subroutines.
+ Array arguments are only passed to these subroutines that implement
+ the simplification of transformational intrinsics.
The functions in this file don't have much comment with them, but
everything is reasonably straight-forward. The Standard, chapter 13
if (result == NULL)
return &gfc_bad_expr;
+ if (result->expr_type != EXPR_CONSTANT)
+ return result;
+
switch (gfc_range_check (result))
{
case ARITH_OK:
}
-/* Helper function to get an integer constant with a kind number given
- by an integer constant expression. */
-static gfc_expr *
-int_expr_with_kind (int i, gfc_expr *kind, const char *name)
-{
- gfc_expr *res = gfc_int_expr (i);
- res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
- if (res->ts.kind == -1)
- return NULL;
- else
- return res;
-}
-
-
/* Converts an mpz_t signed variable into an unsigned one, assuming
two's complement representations and a binary width of bitsize.
The conversion is a no-op unless x is negative; otherwise, it can
}
-/********************** Simplification functions *****************************/
+/* In-place convert BOZ to REAL of the specified kind. */
-gfc_expr *
-gfc_simplify_abs (gfc_expr *e)
+static gfc_expr *
+convert_boz (gfc_expr *x, int kind)
+{
+ if (x && x->ts.type == BT_INTEGER && x->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = kind;
+
+ if (!gfc_convert_boz (x, &ts))
+ return &gfc_bad_expr;
+ }
+
+ return x;
+}
+
+
+/* Test that the expression is an constant array. */
+
+static bool
+is_constant_array_expr (gfc_expr *e)
+{
+ gfc_constructor *c;
+
+ if (e == NULL)
+ return true;
+
+ if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
+ return false;
+
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ if (c->expr->expr_type != EXPR_CONSTANT
+ && c->expr->expr_type != EXPR_STRUCTURE)
+ return false;
+
+ return true;
+}
+
+
+/* Initialize a transformational result expression with a given value. */
+
+static void
+init_result_expr (gfc_expr *e, int init, gfc_expr *array)
+{
+ if (e && e->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
+ while (ctor)
+ {
+ init_result_expr (ctor->expr, init, array);
+ ctor = gfc_constructor_next (ctor);
+ }
+ }
+ else if (e && e->expr_type == EXPR_CONSTANT)
+ {
+ int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ int length;
+ gfc_char_t *string;
+
+ switch (e->ts.type)
+ {
+ case BT_LOGICAL:
+ e->value.logical = (init ? 1 : 0);
+ break;
+
+ case BT_INTEGER:
+ if (init == INT_MIN)
+ mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
+ else if (init == INT_MAX)
+ mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
+ else
+ mpz_set_si (e->value.integer, init);
+ break;
+
+ case BT_REAL:
+ if (init == INT_MIN)
+ {
+ mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
+ }
+ else if (init == INT_MAX)
+ mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ else
+ mpfr_set_si (e->value.real, init, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+ if (init == INT_MIN)
+ {
+ gfc_expr *len = gfc_simplify_len (array, NULL);
+ gfc_extract_int (len, &length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_memset (string, 0, length);
+ }
+ else if (init == INT_MAX)
+ {
+ gfc_expr *len = gfc_simplify_len (array, NULL);
+ gfc_extract_int (len, &length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_memset (string, 255, length);
+ }
+ else
+ {
+ length = 0;
+ string = gfc_get_wide_string (1);
+ }
+
+ string[length] = '\0';
+ e->value.character.length = length;
+ e->value.character.string = string;
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+ }
+ else
+ gcc_unreachable();
+}
+
+
+/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
+
+static gfc_expr *
+compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
+ gfc_expr *matrix_b, int stride_b, int offset_b)
+{
+ gfc_expr *result, *a, *b;
+
+ result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
+ &matrix_a->where);
+ init_result_expr (result, 0, NULL);
+
+ a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+ b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
+ while (a && b)
+ {
+ /* Copying of expressions is required as operands are free'd
+ by the gfc_arith routines. */
+ switch (result->ts.type)
+ {
+ case BT_LOGICAL:
+ result = gfc_or (result,
+ gfc_and (gfc_copy_expr (a),
+ gfc_copy_expr (b)));
+ break;
+
+ case BT_INTEGER:
+ case BT_REAL:
+ case BT_COMPLEX:
+ result = gfc_add (result,
+ gfc_multiply (gfc_copy_expr (a),
+ gfc_copy_expr (b)));
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+
+ offset_a += stride_a;
+ a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+
+ offset_b += stride_b;
+ b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
+ }
+
+ return result;
+}
+
+
+/* Build a result expression for transformational intrinsics,
+ depending on DIM. */
+
+static gfc_expr *
+transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
+ int kind, locus* where)
{
gfc_expr *result;
+ int i, nelem;
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
+ if (!dim || array->rank == 1)
+ return gfc_get_constant_expr (type, kind, where);
- switch (e->ts.type)
+ result = gfc_get_array_expr (type, kind, where);
+ result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+ result->rank = array->rank - 1;
+
+ /* gfc_array_size() would count the number of elements in the constructor,
+ we have not built those yet. */
+ nelem = 1;
+ for (i = 0; i < result->rank; ++i)
+ nelem *= mpz_get_ui (result->shape[i]);
+
+ for (i = 0; i < nelem; ++i)
{
- case BT_INTEGER:
- result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_get_constant_expr (type, kind, where),
+ NULL);
+ }
- mpz_abs (result->value.integer, e->value.integer);
+ return result;
+}
- result = range_check (result, "IABS");
- break;
- case BT_REAL:
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
- mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
+/* Wrapper function, implements 'op1 += 1'. Only called if MASK
+ of COUNT intrinsic is .TRUE..
- result = range_check (result, "ABS");
- break;
+ Interface and implimentation mimics arith functions as
+ gfc_add, gfc_multiply, etc. */
- case BT_COMPLEX:
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
+{
+ gfc_expr *result;
- gfc_set_model_kind (e->ts.kind);
+ gcc_assert (op1->ts.type == BT_INTEGER);
+ gcc_assert (op2->ts.type == BT_LOGICAL);
+ gcc_assert (op2->value.logical);
- mpfr_hypot (result->value.real, e->value.complex.r,
- e->value.complex.i, GFC_RND_MODE);
- result = range_check (result, "CABS");
- break;
+ result = gfc_copy_expr (op1);
+ mpz_add_ui (result->value.integer, result->value.integer, 1);
- default:
- gfc_internal_error ("gfc_simplify_abs(): Bad type");
+ gfc_free_expr (op1);
+ gfc_free_expr (op2);
+ return result;
+}
+
+
+/* Transforms an ARRAY with operation OP, according to MASK, to a
+ scalar RESULT. E.g. called if
+
+ REAL, PARAMETER :: array(n, m) = ...
+ REAL, PARAMETER :: s = SUM(array)
+
+ where OP == gfc_add(). */
+
+static gfc_expr *
+simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
+ transformational_op op)
+{
+ gfc_expr *a, *m;
+ gfc_constructor *array_ctor, *mask_ctor;
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ array_ctor = gfc_constructor_first (array->value.constructor);
+ mask_ctor = NULL;
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+
+ while (array_ctor)
+ {
+ a = array_ctor->expr;
+ array_ctor = gfc_constructor_next (array_ctor);
+
+ /* A constant MASK equals .TRUE. here and can be ignored. */
+ if (mask_ctor)
+ {
+ m = mask_ctor->expr;
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ if (!m->value.logical)
+ continue;
+ }
+
+ result = op (result, gfc_copy_expr (a));
}
return result;
}
-/* We use the processor's collating sequence, because all
- systems that gfortran currently works on are ASCII. */
+/* Transforms an ARRAY with operation OP, according to MASK, to an
+ array RESULT. E.g. called if
+
+ REAL, PARAMETER :: array(n, m) = ...
+ REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
+
+ 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,
+ transformational_op post_op)
+{
+ mpz_t size;
+ int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
+ gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
+ gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
+
+ int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+ sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
+ tmpstride[GFC_MAX_DIMENSIONS];
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ /* Build an indexed table for array element expressions to minimize
+ linked-list traversal. Masked elements are set to NULL. */
+ gfc_array_size (array, &size);
+ arraysize = mpz_get_ui (size);
+
+ arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
+
+ array_ctor = gfc_constructor_first (array->value.constructor);
+ mask_ctor = NULL;
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+
+ for (i = 0; i < arraysize; ++i)
+ {
+ arrayvec[i] = array_ctor->expr;
+ array_ctor = gfc_constructor_next (array_ctor);
+
+ if (mask_ctor)
+ {
+ if (!mask_ctor->expr->value.logical)
+ arrayvec[i] = NULL;
+
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
+ }
+
+ /* Same for the result expression. */
+ gfc_array_size (result, &size);
+ resultsize = mpz_get_ui (size);
+ mpz_clear (size);
+
+ resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
+ result_ctor = gfc_constructor_first (result->value.constructor);
+ for (i = 0; i < resultsize; ++i)
+ {
+ resultvec[i] = result_ctor->expr;
+ result_ctor = gfc_constructor_next (result_ctor);
+ }
+
+ gfc_extract_int (dim, &dim_index);
+ dim_index -= 1; /* zero-base index */
+ dim_extent = 0;
+ dim_stride = 0;
+
+ for (i = 0, n = 0; i < array->rank; ++i)
+ {
+ count[i] = 0;
+ tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
+ if (i == dim_index)
+ {
+ dim_extent = mpz_get_si (array->shape[i]);
+ dim_stride = tmpstride[i];
+ continue;
+ }
+
+ extent[n] = mpz_get_si (array->shape[i]);
+ sstride[n] = tmpstride[i];
+ dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
+ n += 1;
+ }
+
+ done = false;
+ base = arrayvec;
+ dest = resultvec;
+ while (!done)
+ {
+ for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
+ if (*src)
+ *dest = op (*dest, gfc_copy_expr (*src));
+
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+
+ n = 0;
+ while (!done && count[n] == extent[n])
+ {
+ count[n] = 0;
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+
+ n++;
+ if (n < result->rank)
+ {
+ count [n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ else
+ done = true;
+ }
+ }
+
+ /* Place updated expression in result constructor. */
+ result_ctor = gfc_constructor_first (result->value.constructor);
+ for (i = 0; i < resultsize; ++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);
+ 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_achar (gfc_expr *e, gfc_expr *k)
+gfc_simplify_abs (gfc_expr *e)
+{
+ gfc_expr *result;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ switch (e->ts.type)
+ {
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
+ mpz_abs (result->value.integer, e->value.integer);
+ return range_check (result, "IABS");
+
+ case BT_REAL:
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
+ return range_check (result, "ABS");
+
+ case BT_COMPLEX:
+ gfc_set_model_kind (e->ts.kind);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
+ return range_check (result, "CABS");
+
+ default:
+ gfc_internal_error ("gfc_simplify_abs(): Bad type");
+ }
+}
+
+
+static gfc_expr *
+simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
{
gfc_expr *result;
- int c, kind;
- const char *ch;
+ int kind;
+ bool too_large = false;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
+ kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
if (kind == -1)
return &gfc_bad_expr;
- ch = gfc_extract_int (e, &c);
+ if (mpz_cmp_si (e->value.integer, 0) < 0)
+ {
+ gfc_error ("Argument of %s function at %L is negative", name,
+ &e->where);
+ return &gfc_bad_expr;
+ }
- if (ch != NULL)
- gfc_internal_error ("gfc_simplify_achar: %s", ch);
+ if (ascii && gfc_option.warn_surprising
+ && mpz_cmp_si (e->value.integer, 127) > 0)
+ gfc_warning ("Argument of %s function at %L outside of range [0,127]",
+ name, &e->where);
- if (gfc_option.warn_surprising && (c < 0 || c > 127))
- gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
- &e->where);
+ if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
+ too_large = true;
+ else if (kind == 4)
+ {
+ mpz_t t;
+ mpz_init_set_ui (t, 2);
+ mpz_pow_ui (t, t, 32);
+ mpz_sub_ui (t, t, 1);
+ if (mpz_cmp (e->value.integer, t) > 0)
+ too_large = true;
+ mpz_clear (t);
+ }
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ if (too_large)
+ {
+ gfc_error ("Argument of %s function at %L is too large for the "
+ "collating sequence of kind %d", name, &e->where, kind);
+ return &gfc_bad_expr;
+ }
- result->value.character.string = gfc_getmem (2);
+ result = gfc_get_character_expr (kind, &e->where, NULL, 1);
+ result->value.character.string[0] = mpz_get_ui (e->value.integer);
- result->value.character.length = 1;
- result->value.character.string[0] = c;
- result->value.character.string[1] = '\0'; /* For debugger */
return result;
}
+
+/* We use the processor's collating sequence, because all
+ systems that gfortran currently works on are ASCII. */
+
+gfc_expr *
+gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+{
+ return simplify_achar_char (e, k, "ACHAR", true);
+}
+
+
gfc_expr *
gfc_simplify_acos (gfc_expr *x)
{
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) > 0
- || mpfr_cmp_si (x->value.real, -1) < 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ACOS at %L must be between -1 and 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error ("Argument of ACOS at %L must be between -1 and 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_acos(): Bad type");
+ }
return range_check (result, "ACOS");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) < 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ACOSH at %L must not be less than 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) < 0)
+ {
+ gfc_error ("Argument of ACOSH at %L must not be less than 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
+ }
return range_check (result, "ACOSH");
}
{
gfc_expr *result;
int count, i, len;
- char ch;
+ gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
len = e->value.character.length;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
- result->value.character.length = len;
- result->value.character.string = gfc_getmem (len + 1);
-
for (count = 0, i = 0; i < len; ++i)
{
ch = e->value.character.string[i];
++count;
}
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < len - count; ++i)
result->value.character.string[i] = e->value.character.string[count + i];
- for (i = len - count; i < len; ++i)
- result->value.character.string[i] = ' ';
-
- result->value.character.string[len] = '\0'; /* For debugger */
-
return result;
}
{
gfc_expr *result;
int count, i, len;
- char ch;
+ gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
len = e->value.character.length;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
- result->value.character.length = len;
- result->value.character.string = gfc_getmem (len + 1);
-
for (count = 0, i = len - 1; i >= 0; --i)
{
ch = e->value.character.string[i];
++count;
}
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < count; ++i)
result->value.character.string[i] = ' ';
for (i = count; i < len; ++i)
result->value.character.string[i] = e->value.character.string[i - count];
- result->value.character.string[len] = '\0'; /* For debugger */
-
return result;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
return range_check (result, "AIMAG");
}
return NULL;
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, kind);
+
gfc_free_expr (rtrunc);
return range_check (result, "AINT");
gfc_expr *
+gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
+{
+ return simplify_transformation (mask, dim, NULL, true, gfc_and);
+}
+
+
+gfc_expr *
gfc_simplify_dint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
return NULL;
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, gfc_default_double_kind);
+
gfc_free_expr (rtrunc);
return range_check (result, "DINT");
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, kind, &e->where);
-
+ result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "ANINT");
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_and (result->value.integer, x->value.integer, y->value.integer);
- }
- else /* BT_LOGICAL */
- {
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = x->value.logical && y->value.logical;
- }
- return range_check (result, "AND");
-}
+ switch (x->ts.type)
+ {
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_and (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "AND");
+
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ x->value.logical && y->value.logical);
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+gfc_expr *
+gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
+{
+ return simplify_transformation (mask, dim, NULL, false, gfc_or);
+}
gfc_expr *
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
-
+ result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "DNINT");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) > 0
- || mpfr_cmp_si (x->value.real, -1) < 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ASIN at %L must be between -1 and 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) > 0
+ || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error ("Argument of ASIN at %L must be between -1 and 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_asin(): Bad type");
+ }
return range_check (result, "ASIN");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
+ }
return range_check (result, "ASINH");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
-
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("in gfc_simplify_atan(): Bad type");
+ }
return range_check (result, "ATAN");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_cmp_si (x->value.real, 1) >= 0
- || mpfr_cmp_si (x->value.real, -1) <= 0)
+ switch (x->ts.type)
{
- gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
- &x->where);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_si (x->value.real, 1) >= 0
+ || mpfr_cmp_si (x->value.real, -1) <= 0)
+ {
+ gfc_error ("Argument of ATANH at %L must be inside the range -1 "
+ "to 1", &x->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
+ }
return range_check (result, "ATANH");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
{
gfc_error ("If first argument of ATAN2 %L is zero, then the "
"second argument must not be zero", &x->where);
- gfc_free_expr (result);
return &gfc_bad_expr;
}
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN2");
gfc_expr *
-gfc_simplify_bit_size (gfc_expr *e)
+gfc_simplify_bessel_j0 (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_J0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_j1 (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_J1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
+ long n;
+
+ if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ n = mpz_get_si (order->value.integer);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_JN");
+}
+
+
+/* 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;
- i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
- mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
+ 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 *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_Y0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y1 (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_Y1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
+{
+ gfc_expr *result;
+ long n;
+
+ if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ n = mpz_get_si (order->value.integer);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_YN");
+}
+
+
+gfc_expr *
+gfc_simplify_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);
+ return gfc_get_int_expr (e->ts.kind, &e->where,
+ gfc_integer_kinds[i].bit_size);
}
return NULL;
if (gfc_extract_int (bit, &b) != NULL || b < 0)
- return gfc_logical_expr (0, &e->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
+ mpz_tstbit (e->value.integer, b));
+}
+
+
+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);
- return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
+ res = mpz_cmp (x, y);
+ mpz_clear (x);
+ mpz_clear (y);
+ return res;
}
gfc_expr *
-gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
+gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
{
- gfc_expr *ceil, *result;
- int kind;
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+ return NULL;
- kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
- if (kind == -1)
- return &gfc_bad_expr;
+ return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+ compare_bitwise (i, j) >= 0);
+}
- if (e->expr_type != EXPR_CONSTANT)
+
+gfc_expr *
+gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
+{
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+ compare_bitwise (i, j) > 0);
+}
- ceil = gfc_copy_expr (e);
- mpfr_ceil (ceil->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
+gfc_expr *
+gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
+{
+ if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+ return NULL;
- gfc_free_expr (ceil);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+ compare_bitwise (i, j) <= 0);
+}
- return range_check (result, "CEILING");
+
+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_char (gfc_expr *e, gfc_expr *k)
+gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
- int c, kind;
- const char *ch;
+ gfc_expr *ceil, *result;
+ int kind;
- kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
+ kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- ch = gfc_extract_int (e, &c);
-
- if (ch != NULL)
- gfc_internal_error ("gfc_simplify_char: %s", ch);
+ ceil = gfc_copy_expr (e);
+ mpfr_ceil (ceil->value.real, e->value.real);
- if (c < 0 || c > UCHAR_MAX)
- gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
- &e->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
+ gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ gfc_free_expr (ceil);
- result->value.character.length = 1;
- result->value.character.string = gfc_getmem (2);
+ return range_check (result, "CEILING");
+}
- result->value.character.string[0] = c;
- result->value.character.string[1] = '\0'; /* For debugger */
- return result;
+gfc_expr *
+gfc_simplify_char (gfc_expr *e, gfc_expr *k)
+{
+ return simplify_achar_char (e, k, "CHAR", false);
}
-/* Common subroutine for simplifying CMPLX and DCMPLX. */
+/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
static gfc_expr *
simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
- result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
+ if (convert_boz (x, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ if (convert_boz (y, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ if (x->expr_type != EXPR_CONSTANT
+ || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ return NULL;
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
- break;
+ case BT_INTEGER:
+ mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
+ break;
- case BT_REAL:
- mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
- mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
- mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
- break;
+ case BT_COMPLEX:
+ mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
+ default:
+ gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
}
- if (y != NULL)
+ if (!y)
+ return range_check (result, name);
+
+ switch (y->ts.type)
{
- switch (y->ts.type)
- {
- case BT_INTEGER:
- mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
- break;
+ case BT_INTEGER:
+ mpfr_set_z (mpc_imagref (result->value.complex),
+ y->value.integer, GFC_RND_MODE);
+ break;
- case BT_REAL:
- mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_set (mpc_imagref (result->value.complex),
+ y->value.real, GFC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
- }
+ default:
+ gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
}
return range_check (result, name);
{
int kind;
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return NULL;
-
- kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
+ kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
if (kind == -1)
return &gfc_bad_expr;
{
int kind;
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
+ kind = gfc_default_complex_kind;
+ else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
+ kind = x->ts.kind;
+ else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
+ kind = y->ts.kind;
+ else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
+ kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
+ else
+ gcc_unreachable ();
+
+ return simplify_cmplx ("COMPLEX", x, y, kind);
+}
+
+
+gfc_expr *
+gfc_simplify_conjg (gfc_expr *e)
+{
+ gfc_expr *result;
+
+ if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (x->ts.type == BT_INTEGER)
+ result = gfc_copy_expr (e);
+ mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
+
+ return range_check (result, "CONJG");
+}
+
+
+gfc_expr *
+gfc_simplify_cos (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
{
- if (y->ts.type == BT_INTEGER)
- kind = gfc_default_real_kind;
- else
- kind = y->ts.kind;
+ case BT_REAL:
+ mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ gfc_set_model_kind (x->ts.kind);
+ mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
- else
+
+ return range_check (result, "COS");
+}
+
+
+gfc_expr *
+gfc_simplify_cosh (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
{
- if (y->ts.type == BT_REAL)
- kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
- else
- kind = x->ts.kind;
+ case BT_REAL:
+ mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
}
- return simplify_cmplx ("COMPLEX", x, y, kind);
+ return range_check (result, "COSH");
}
gfc_expr *
-gfc_simplify_conjg (gfc_expr *e)
+gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (mask)
+ || !gfc_is_constant_expr (dim)
+ || !gfc_is_constant_expr (kind))
+ return NULL;
+
+ result = transformational_result (mask, dim,
+ BT_INTEGER,
+ get_kind (BT_INTEGER, kind, "COUNT",
+ gfc_default_integer_kind),
+ &mask->where);
+
+ init_result_expr (result, 0, NULL);
+
+ /* Passing MASK twice, once as data array, once as mask.
+ 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, NULL);
+}
+
+
+gfc_expr *
+gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
+{
+ return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
+}
+
+
+gfc_expr *
+gfc_simplify_dble (gfc_expr *e)
+{
+ gfc_expr *result = NULL;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ return range_check (result, "DBLE");
+}
+
+
+gfc_expr *
+gfc_simplify_digits (gfc_expr *x)
+{
+ int i, digits;
+
+ i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
+ switch (x->ts.type)
+ {
+ case BT_INTEGER:
+ digits = gfc_integer_kinds[i].digits;
+ break;
+
+ case BT_REAL:
+ case BT_COMPLEX:
+ digits = gfc_real_kinds[i].digits;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
+}
+
+
+gfc_expr *
+gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
+ int kind;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
+
+ switch (x->ts.type)
+ {
+ case BT_INTEGER:
+ if (mpz_cmp (x->value.integer, y->value.integer) > 0)
+ mpz_sub (result->value.integer, x->value.integer, y->value.integer);
+ else
+ mpz_set_ui (result->value.integer, 0);
+
+ break;
+
+ case BT_REAL:
+ if (mpfr_cmp (x->value.real, y->value.real) > 0)
+ mpfr_sub (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
+ else
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+
+ break;
+
+ default:
+ gfc_internal_error ("gfc_simplify_dim(): Bad type");
+ }
+
+ return range_check (result, "DIM");
+}
+
+
+gfc_expr*
+gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
+{
+ if (!is_constant_array_expr (vector_a)
+ || !is_constant_array_expr (vector_b))
+ return NULL;
+
+ gcc_assert (vector_a->rank == 1);
+ gcc_assert (vector_b->rank == 1);
+ gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
+
+ return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
+}
+
+
+gfc_expr *
+gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *a1, *a2, *result;
- if (e->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_copy_expr (e);
- mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
+ a1 = gfc_real2real (x, gfc_default_double_kind);
+ a2 = gfc_real2real (y, gfc_default_double_kind);
- return range_check (result, "CONJG");
+ result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
+ mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
+
+ gfc_free_expr (a2);
+ gfc_free_expr (a1);
+
+ return range_check (result, "DPROD");
}
-gfc_expr *
-gfc_simplify_cos (gfc_expr *x)
+static gfc_expr *
+simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
+ bool right)
{
gfc_expr *result;
- mpfr_t xp, xq;
+ int i, k, size, shift;
- if (x->expr_type != EXPR_CONSTANT)
+ if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
+ || shiftarg->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
+ size = gfc_integer_kinds[k].bit_size;
- switch (x->ts.type)
+ if (gfc_extract_int (shiftarg, &shift) != NULL)
{
- case BT_REAL:
- mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
- break;
- case BT_COMPLEX:
- gfc_set_model_kind (x->ts.kind);
- mpfr_init (xp);
- mpfr_init (xq);
+ gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg->where);
+ return &gfc_bad_expr;
+ }
- mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
+ gcc_assert (shift >= 0 && shift <= size);
- mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (xp, xp, xq, GFC_RND_MODE);
- mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
+ /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
+ if (right)
+ shift = size - shift;
- mpfr_clear (xp);
- mpfr_clear (xq);
- break;
- default:
- gfc_internal_error ("in gfc_simplify_cos(): Bad type");
- }
+ result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
+ mpz_set_ui (result->value.integer, 0);
- return range_check (result, "COS");
+ 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_cosh (gfc_expr *x)
+gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
{
- gfc_expr *result;
-
- if (x->expr_type != EXPR_CONSTANT)
- return NULL;
-
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ return simplify_dshift (arg1, arg2, shiftarg, true);
+}
- mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
- return range_check (result, "COSH");
+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_dcmplx (gfc_expr *x, gfc_expr *y)
+gfc_simplify_erf (gfc_expr *x)
{
+ gfc_expr *result;
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ if (x->expr_type != EXPR_CONSTANT)
return NULL;
- return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ERF");
}
gfc_expr *
-gfc_simplify_dble (gfc_expr *e)
+gfc_simplify_erfc (gfc_expr *x)
{
gfc_expr *result;
- if (e->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT)
return NULL;
- switch (e->ts.type)
- {
- case BT_INTEGER:
- result = gfc_int2real (e, gfc_default_double_kind);
- break;
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
- case BT_REAL:
- result = gfc_real2real (e, gfc_default_double_kind);
- break;
+ return range_check (result, "ERFC");
+}
- case BT_COMPLEX:
- result = gfc_complex2real (e, gfc_default_double_kind);
- break;
- default:
- gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
- }
+/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
- return range_check (result, "DBLE");
-}
+#define MAX_ITER 200
+#define ARG_LIMIT 12
+/* Calculate ERFC_SCALED directly by its definition:
-gfc_expr *
-gfc_simplify_digits (gfc_expr *x)
+ ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
+
+ using a large precision for intermediate results. This is used for all
+ but large values of the argument. */
+static void
+fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
{
- int i, digits;
+ mp_prec_t prec;
+ mpfr_t a, b;
- i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- switch (x->ts.type)
- {
- case BT_INTEGER:
- digits = gfc_integer_kinds[i].digits;
- break;
+ prec = mpfr_get_default_prec ();
+ mpfr_set_default_prec (10 * prec);
- case BT_REAL:
- case BT_COMPLEX:
- digits = gfc_real_kinds[i].digits;
- break;
+ mpfr_init (a);
+ mpfr_init (b);
- default:
- gcc_unreachable ();
- }
+ mpfr_set (a, arg, GFC_RND_MODE);
+ mpfr_sqr (b, a, GFC_RND_MODE);
+ mpfr_exp (b, b, GFC_RND_MODE);
+ mpfr_erfc (a, a, GFC_RND_MODE);
+ mpfr_mul (a, a, b, GFC_RND_MODE);
- return gfc_int_expr (digits);
+ mpfr_set (res, a, GFC_RND_MODE);
+ mpfr_set_default_prec (prec);
+
+ mpfr_clear (a);
+ mpfr_clear (b);
}
+/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
-gfc_expr *
-gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
+ ERFC_SCALED(x) = 1 / (x * sqrt(pi))
+ * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
+ / (2 * x**2)**n)
+
+ This is used for large values of the argument. Intermediate calculations
+ are performed with twice the precision. We don't do a fixed number of
+ iterations of the sum, but stop when it has converged to the required
+ precision. */
+static void
+asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
{
- gfc_expr *result;
- int kind;
+ mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
+ mpz_t num;
+ mp_prec_t prec;
+ unsigned i;
- if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
- return NULL;
+ prec = mpfr_get_default_prec ();
+ mpfr_set_default_prec (2 * prec);
- kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- result = gfc_constant_result (x->ts.type, kind, &x->where);
+ mpfr_init (sum);
+ mpfr_init (x);
+ mpfr_init (u);
+ mpfr_init (v);
+ mpfr_init (w);
+ mpz_init (num);
- switch (x->ts.type)
- {
- case BT_INTEGER:
- if (mpz_cmp (x->value.integer, y->value.integer) > 0)
- mpz_sub (result->value.integer, x->value.integer, y->value.integer);
- else
- mpz_set_ui (result->value.integer, 0);
+ mpfr_init (oldsum);
+ mpfr_init (sumtrunc);
+ mpfr_set_prec (oldsum, prec);
+ mpfr_set_prec (sumtrunc, prec);
- break;
+ mpfr_set (x, arg, GFC_RND_MODE);
+ mpfr_set_ui (sum, 1, GFC_RND_MODE);
+ mpz_set_ui (num, 1);
- case BT_REAL:
- if (mpfr_cmp (x->value.real, y->value.real) > 0)
- mpfr_sub (result->value.real, x->value.real, y->value.real,
- GFC_RND_MODE);
- else
- mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ mpfr_set (u, x, GFC_RND_MODE);
+ mpfr_sqr (u, u, GFC_RND_MODE);
+ mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
+ mpfr_pow_si (u, u, -1, GFC_RND_MODE);
+
+ for (i = 1; i < MAX_ITER; i++)
+ {
+ mpfr_set (oldsum, sum, GFC_RND_MODE);
+ mpz_mul_ui (num, num, 2 * i - 1);
+ mpz_neg (num, num);
+
+ mpfr_set (w, u, GFC_RND_MODE);
+ mpfr_pow_ui (w, w, i, GFC_RND_MODE);
+
+ mpfr_set_z (v, num, GFC_RND_MODE);
+ mpfr_mul (v, v, w, GFC_RND_MODE);
+
+ mpfr_add (sum, sum, v, GFC_RND_MODE);
+
+ mpfr_set (sumtrunc, sum, GFC_RND_MODE);
+ if (mpfr_cmp (sumtrunc, oldsum) == 0)
break;
+ }
- default:
- gfc_internal_error ("gfc_simplify_dim(): Bad type");
- }
+ /* We should have converged by now; otherwise, ARG_LIMIT is probably
+ set too low. */
+ gcc_assert (i < MAX_ITER);
- return range_check (result, "DIM");
+ /* Divide by x * sqrt(Pi). */
+ mpfr_const_pi (u, GFC_RND_MODE);
+ mpfr_sqrt (u, u, GFC_RND_MODE);
+ mpfr_mul (u, u, x, GFC_RND_MODE);
+ mpfr_div (sum, sum, u, GFC_RND_MODE);
+
+ mpfr_set (res, sum, GFC_RND_MODE);
+ mpfr_set_default_prec (prec);
+
+ mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
+ mpz_clear (num);
}
gfc_expr *
-gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
+gfc_simplify_erfc_scaled (gfc_expr *x)
{
- gfc_expr *a1, *a2, *result;
+ gfc_expr *result;
- if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
-
- a1 = gfc_real2real (x, gfc_default_double_kind);
- a2 = gfc_real2real (y, gfc_default_double_kind);
-
- mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
-
- gfc_free_expr (a1);
- gfc_free_expr (a2);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
+ asympt_erfc_scaled (result->value.real, x->value.real);
+ else
+ fullprec_erfc_scaled (result->value.real, x->value.real);
- return range_check (result, "DPROD");
+ return range_check (result, "ERFC_SCALED");
}
+#undef MAX_ITER
+#undef ARG_LIMIT
+
gfc_expr *
gfc_simplify_epsilon (gfc_expr *e)
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
return range_check (result, "EPSILON");
gfc_simplify_exp (gfc_expr *x)
{
gfc_expr *result;
- mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
- gfc_set_model_kind (x->ts.kind);
- mpfr_init (xp);
- mpfr_init (xq);
- mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
- mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
- mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
- mpfr_clear (xp);
- mpfr_clear (xq);
- break;
+ case BT_COMPLEX:
+ gfc_set_model_kind (x->ts.kind);
+ mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("in gfc_simplify_exp(): Bad type");
+ default:
+ gfc_internal_error ("in gfc_simplify_exp(): Bad type");
}
return range_check (result, "EXP");
}
+
gfc_expr *
gfc_simplify_exponent (gfc_expr *x)
{
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &x->where);
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &x->where);
gfc_set_model (x->value.real);
if (a->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_int2real (a, gfc_default_real_kind);
+ if (a->is_boz)
+ {
+ if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ result = gfc_copy_expr (a);
+ }
+ else
+ result = gfc_int2real (a, gfc_default_real_kind);
+
return range_check (result, "FLOAT");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
gfc_set_model_kind (kind);
+
mpfr_init (floor);
mpfr_floor (floor, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, floor);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
+ gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
mpfr_clear (floor);
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
-
- gfc_set_model_kind (x->ts.kind);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
return result;
}
+ gfc_set_model_kind (x->ts.kind);
mpfr_init (exp);
mpfr_init (absv);
mpfr_init (pow2);
mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
- mpfr_clear (exp);
- mpfr_clear (absv);
- mpfr_clear (pow2);
+ mpfr_clears (exp, absv, pow2, NULL);
return range_check (result, "FRACTION");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
- gfc_set_model_kind (x->ts.kind);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "GAMMA");
int i;
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
switch (e->ts.type)
{
- case BT_INTEGER:
- mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
- break;
+ case BT_INTEGER:
+ mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
+ break;
- case BT_REAL:
- mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
return result;
}
+
+gfc_expr *
+gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
+ return range_check (result, "HYPOT");
+}
+
+
/* We use the processor's collating sequence, because all
systems that gfortran currently works on are ASCII. */
gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
- int index;
+ gfc_char_t index;
+ int k;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
return &gfc_bad_expr;
}
- index = (unsigned char) e->value.character.string[0];
+ index = e->value.character.string[0];
if (gfc_option.warn_surprising && index > 127)
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
&e->where);
- if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
+ k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
+ if (k == -1)
return &gfc_bad_expr;
- result->where = e->where;
+ result = gfc_get_int_expr (k, &e->where, index);
return range_check (result, "IACHAR");
}
+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;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_and (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IAND");
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
- return range_check (result, "IBCLR");
+ return result;
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
- bits = gfc_getmem (bitsize * sizeof (int));
+ bits = XCNEWVEC (int, bitsize);
for (i = 0; i < bitsize; i++)
bits[i] = 0;
gfc_free (bits);
- return range_check (result, "IBITS");
+ convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
+ return result;
}
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
- return range_check (result, "IBSET");
+ return result;
}
gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
- int index;
+ gfc_char_t index;
+ int k;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
return &gfc_bad_expr;
}
- index = (unsigned char) e->value.character.string[0];
+ index = e->value.character.string[0];
- if (index < 0 || index > UCHAR_MAX)
- gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
-
- if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
+ k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
+ if (k == -1)
return &gfc_bad_expr;
- result->where = e->where;
+ result = gfc_get_int_expr (k, &e->where, index);
+
return range_check (result, "ICHAR");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IEOR");
int back, len, lensub;
int i, j, k, count, index = 0, start;
- if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
+ || ( b != NULL && b->expr_type != EXPR_CONSTANT))
return NULL;
if (b != NULL && b->value.logical != 0)
if (k == -1)
return &gfc_bad_expr;
- result = gfc_constant_result (BT_INTEGER, k, &x->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
len = x->value.character.length;
lensub = y->value.character.length;
}
-gfc_expr *
-gfc_simplify_int (gfc_expr *e, gfc_expr *k)
-{
- gfc_expr *rpart, *rtrunc, *result;
- int kind;
-
- kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
- if (kind == -1)
- return &gfc_bad_expr;
-
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
-
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
- switch (e->ts.type)
- {
- case BT_INTEGER:
- mpz_set (result->value.integer, e->value.integer);
- break;
-
- case BT_REAL:
- rtrunc = gfc_copy_expr (e);
- mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rtrunc);
- break;
-
- case BT_COMPLEX:
- rpart = gfc_complex2real (e, kind);
- rtrunc = gfc_copy_expr (rpart);
- mpfr_trunc (rtrunc->value.real, rpart->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rpart);
- gfc_free_expr (rtrunc);
- break;
-
- default:
- gfc_error ("Argument of INT at %L is not a valid type", &e->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
-
- return range_check (result, "INT");
-}
-
-
static gfc_expr *
-gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
+simplify_intconv (gfc_expr *e, int kind, const char *name)
{
- gfc_expr *rpart, *rtrunc, *result;
-
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
-
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
- switch (e->ts.type)
- {
- case BT_INTEGER:
- mpz_set (result->value.integer, e->value.integer);
- break;
-
- case BT_REAL:
- rtrunc = gfc_copy_expr (e);
- mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rtrunc);
- break;
-
- case BT_COMPLEX:
- rpart = gfc_complex2real (e, kind);
- rtrunc = gfc_copy_expr (rpart);
- mpfr_trunc (rtrunc->value.real, rpart->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rpart);
- gfc_free_expr (rtrunc);
- break;
+ gfc_expr *result = NULL;
- default:
- gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_convert_constant (e, BT_INTEGER, kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
return range_check (result, name);
}
gfc_expr *
+gfc_simplify_int (gfc_expr *e, gfc_expr *k)
+{
+ int kind;
+
+ kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
+
+ return simplify_intconv (e, kind, "INT");
+}
+
+gfc_expr *
gfc_simplify_int2 (gfc_expr *e)
{
- return gfc_simplify_intconv (e, 2, "INT2");
+ return simplify_intconv (e, 2, "INT2");
}
gfc_expr *
gfc_simplify_int8 (gfc_expr *e)
{
- return gfc_simplify_intconv (e, 8, "INT8");
+ return simplify_intconv (e, 8, "INT8");
}
gfc_expr *
gfc_simplify_long (gfc_expr *e)
{
- return gfc_simplify_intconv (e, 4, "LONG");
+ return simplify_intconv (e, 4, "LONG");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
-
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &e->where);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
+
return range_check (result, "IFIX");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
-
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &e->where);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
+
return range_check (result, "IDINT");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+
return range_check (result, "IOR");
}
+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_ishft (gfc_expr *e, gfc_expr *s)
+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)
+{
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpz_cmp_si (x->value.integer,
+ LIBERROR_END) == 0);
+}
+
+
+gfc_expr *
+gfc_simplify_is_iostat_eor (gfc_expr *x)
+{
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpz_cmp_si (x->value.integer,
+ LIBERROR_EOR) == 0);
+}
+
+
+gfc_expr *
+gfc_simplify_isnan (gfc_expr *x)
+{
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpfr_nan_p (x->value.real));
+}
+
+
+/* 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_constant_result (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 = gfc_getmem (isize * sizeof (int));
- 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);
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;
return &gfc_bad_expr;
}
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
mpz_set (result->value.integer, e->value.integer);
convert_mpz_to_unsigned (result->value.integer, isize);
- bits = gfc_getmem (ssize * sizeof (int));
+ bits = XCNEWVEC (int, ssize);
for (i = 0; i < ssize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
gfc_expr *
gfc_simplify_kind (gfc_expr *e)
{
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
+}
+
+
+static gfc_expr *
+simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
+ gfc_array_spec *as, gfc_ref *ref, bool coarray)
+{
+ gfc_expr *l, *u, *result;
+ int k;
+
+ k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+ gfc_default_integer_kind);
+ if (k == -1)
+ return &gfc_bad_expr;
- if (e->ts.type == BT_DERIVED)
+ 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)
{
- gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
- return &gfc_bad_expr;
+ 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);
+
+ /* 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))
+ {
+ 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 (coarray || ref->u.ar.type == AR_FULL)
+ {
+ l = as->lower[d-1];
+ u = as->upper[d-1];
+
+ 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)
+ {
+ /* Zero extent. */
+ if (upper)
+ mpz_set_si (result->value.integer, 0);
+ else
+ mpz_set_si (result->value.integer, 1);
+ }
+ else
+ {
+ /* Nonzero extent. */
+ if (upper)
+ mpz_set (result->value.integer, u->value.integer);
+ else
+ mpz_set (result->value.integer, l->value.integer);
+ }
+ }
+ else
+ {
+ if (upper)
+ {
+ if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL)
+ != SUCCESS)
+ goto returnNull;
+ }
+ else
+ mpz_set_si (result->value.integer, (long int) 1);
}
- return gfc_int_expr (e->ts.kind);
+done:
+ return range_check (result, upper ? "UBOUND" : "LBOUND");
+
+returnNull:
+ gfc_free_expr (result);
+ return NULL;
}
static gfc_expr *
-simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
- gfc_array_spec *as)
+simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
{
- gfc_expr *l, *u, *result;
- int k;
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
+
+ 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)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ 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;
+ }
+ }
+
+ gcc_unreachable ();
+
+ done:
+
+ if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+ return NULL;
+
+ if (dim == NULL)
+ {
+ /* Multi-dimensional bounds. */
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+ int k;
+
+ /* UBOUND(ARRAY) is not valid for an assumed-size array. */
+ if (upper && as && as->type == AS_ASSUMED_SIZE)
+ {
+ /* An error message will be emitted in
+ check_assumed_size_reference (resolve.c). */
+ return &gfc_bad_expr;
+ }
+
+ /* 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,
+ false);
+ if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+ {
+ int j;
- /* 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;
- }
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ return bounds[d];
+ }
+ }
- /* Then, we need to know the extent of the given dimension. */
- l = as->lower[d-1];
- u = as->upper[d-1];
+ /* Allocate the result expression. */
+ k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+ gfc_default_integer_kind);
+ if (k == -1)
+ return &gfc_bad_expr;
- if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
- return NULL;
+ e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
- k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
- gfc_default_integer_kind);
- if (k == -1)
- return &gfc_bad_expr;
+ /* The result is a rank 1 array; its size is the rank of the first
+ argument to {L,U}BOUND. */
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], array->rank);
- result = gfc_constant_result (BT_INTEGER, k, &array->where);
+ /* Create the constructor for this array. */
+ for (d = 0; d < array->rank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
- if (mpz_cmp (l->value.integer, u->value.integer) > 0)
- {
- /* Zero extent. */
- if (upper)
- mpz_set_si (result->value.integer, 0);
- else
- mpz_set_si (result->value.integer, 1);
+ return e;
}
else
{
- /* Nonzero extent. */
- if (upper)
- mpz_set (result->value.integer, u->value.integer);
- else
- mpz_set (result->value.integer, l->value.integer);
- }
+ /* A DIM argument is specified. */
+ if (dim->expr_type != EXPR_CONSTANT)
+ return NULL;
- return range_check (result, upper ? "UBOUND" : "LBOUND");
+ d = mpz_get_si (dim->value.integer);
+
+ 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, false);
+ }
}
static gfc_expr *
-simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
{
gfc_ref *ref;
gfc_array_spec *as;
switch (ref->u.ar.type)
{
case AR_ELEMENT:
+ if (ref->next == NULL)
+ {
+ gcc_assert (ref->u.ar.as->corank > 0
+ && ref->u.ar.as->rank == 0);
+ as = ref->u.ar.as;
+ goto done;
+ }
as = NULL;
continue;
case AR_FULL:
/* We're done because 'as' has already been set in the
previous iteration. */
- goto done;
+ if (!ref->next)
+ goto done;
+
+ /* Fall through. */
- case AR_SECTION:
case AR_UNKNOWN:
return NULL;
+
+ case AR_SECTION:
+ as = ref->u.ar.as;
+ goto done;
}
gcc_unreachable ();
if (dim == NULL)
{
- /* Multi-dimensional bounds. */
+ /* Multi-dimensional cobounds. */
gfc_expr *bounds[GFC_MAX_DIMENSIONS];
gfc_expr *e;
- gfc_constructor *head, *tail;
int k;
- /* UBOUND(ARRAY) is not valid for an assumed-size array. */
- if (upper && as->type == AS_ASSUMED_SIZE)
- {
- /* An error message will be emitted in
- check_assumed_size_reference (resolve.c). */
- return &gfc_bad_expr;
- }
-
- /* Simplify the bounds for each dimension. */
- for (d = 0; d < array->rank; d++)
+ /* Simplify the cobounds for each dimension. */
+ for (d = 0; d < as->corank; d++)
{
- bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
+ bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
+ upper, as, ref, true);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
int j;
e->where = array->where;
e->expr_type = EXPR_ARRAY;
e->ts.type = BT_INTEGER;
- k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+ k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
gfc_default_integer_kind);
if (k == -1)
- return &gfc_bad_expr;
+ {
+ 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}BOUND. */
+ argument to {L,U}COBOUND. */
e->rank = 1;
e->shape = gfc_get_shape (1);
- mpz_init_set_ui (e->shape[0], array->rank);
+ mpz_init_set_ui (e->shape[0], as->corank);
/* Create the constructor for this array. */
- head = tail = NULL;
- for (d = 0; d < array->rank; d++)
- {
- /* Get a new constructor element. */
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = e->where;
- tail->expr = bounds[d];
- }
- e->value.constructor = head;
-
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
return e;
}
else
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 > 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, upper, as);
+ return simplify_bound_dim (array, kind, d+array->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;
+}
+
+gfc_expr *
+gfc_simplify_leadz (gfc_expr *e)
+{
+ unsigned long lz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ if (mpz_cmp_si (e->value.integer, 0) == 0)
+ lz = bs;
+ else if (mpz_cmp_si (e->value.integer, 0) < 0)
+ lz = 0;
+ else
+ lz = bs - mpz_sizeinbase (e->value.integer, 2);
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
+}
+
+
+gfc_expr *
gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
if (e->expr_type == EXPR_CONSTANT)
{
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
mpz_set_si (result->value.integer, e->value.character.length);
return range_check (result, "LEN");
}
-
- if (e->ts.cl != NULL && e->ts.cl->length != NULL
- && e->ts.cl->length->expr_type == EXPR_CONSTANT
- && e->ts.cl->length->ts.type == BT_INTEGER)
+ else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && e->ts.u.cl->length->ts.type == BT_INTEGER)
{
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
- mpz_set (result->value.integer, e->ts.cl->length->value.integer);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
+ mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
return range_check (result, "LEN");
}
-
- return NULL;
+ else
+ return NULL;
}
gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
- int count, len, lentrim, i;
+ int count, len, i;
int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
if (k == -1)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
len = e->value.character.length;
-
for (count = 0, i = 1; i <= len; i++)
if (e->value.character.string[len - i] == ' ')
count++;
else
break;
- lentrim = len - count;
-
- mpz_set_si (result->value.integer, lentrim);
+ result = gfc_get_int_expr (k, &e->where, len - count);
return range_check (result, "LEN_TRIM");
}
gfc_expr *
-gfc_simplify_lgamma (gfc_expr *x __attribute__((unused)))
+gfc_simplify_lgamma (gfc_expr *x)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
int sg;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
- gfc_set_model_kind (x->ts.kind);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
return range_check (result, "LGAMMA");
-#else
- return NULL;
-#endif
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) >= 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) > 0,
- &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) > 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) <= 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) < 0);
}
gfc_simplify_log (gfc_expr *x)
{
gfc_expr *result;
- mpfr_t xr, xi;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
- gfc_set_model_kind (x->ts.kind);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
break;
case BT_COMPLEX:
- if ((mpfr_sgn (x->value.complex.r) == 0)
- && (mpfr_sgn (x->value.complex.i) == 0))
+ if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
+ && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
{
gfc_error ("Complex argument of LOG at %L cannot be zero",
&x->where);
return &gfc_bad_expr;
}
- mpfr_init (xr);
- mpfr_init (xi);
-
- mpfr_atan2 (result->value.complex.i, x->value.complex.i,
- x->value.complex.r, GFC_RND_MODE);
-
- mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
- mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
- mpfr_add (xr, xr, xi, GFC_RND_MODE);
- mpfr_sqrt (xr, xr, GFC_RND_MODE);
- mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
-
- mpfr_clear (xr);
- mpfr_clear (xi);
-
+ gfc_set_model_kind (x->ts.kind);
+ mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- gfc_set_model_kind (x->ts.kind);
-
if (mpfr_sgn (x->value.real) <= 0)
{
gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "LOG10");
gfc_expr *
gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
int kind;
kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
+ return gfc_get_logical_expr (kind, &e->where, e->value.logical);
+}
+
+
+gfc_expr*
+gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
+{
+ gfc_expr *result;
+ int row, result_rows, col, result_columns;
+ int stride_a, offset_a, stride_b, offset_b;
+
+ if (!is_constant_array_expr (matrix_a)
+ || !is_constant_array_expr (matrix_b))
+ return NULL;
+
+ gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
+ result = gfc_get_array_expr (matrix_a->ts.type,
+ matrix_a->ts.kind,
+ &matrix_a->where);
+
+ if (matrix_a->rank == 1 && matrix_b->rank == 2)
+ {
+ result_rows = 1;
+ result_columns = mpz_get_si (matrix_b->shape[0]);
+ stride_a = 1;
+ stride_b = mpz_get_si (matrix_b->shape[0]);
+
+ result->rank = 1;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_init_set_si (result->shape[0], result_columns);
+ }
+ else if (matrix_a->rank == 2 && matrix_b->rank == 1)
+ {
+ result_rows = mpz_get_si (matrix_b->shape[0]);
+ result_columns = 1;
+ stride_a = mpz_get_si (matrix_a->shape[0]);
+ stride_b = 1;
+
+ result->rank = 1;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_init_set_si (result->shape[0], result_rows);
+ }
+ else if (matrix_a->rank == 2 && matrix_b->rank == 2)
+ {
+ result_rows = mpz_get_si (matrix_a->shape[0]);
+ result_columns = mpz_get_si (matrix_b->shape[1]);
+ stride_a = mpz_get_si (matrix_a->shape[1]);
+ stride_b = mpz_get_si (matrix_b->shape[0]);
+
+ result->rank = 2;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_init_set_si (result->shape[0], result_rows);
+ mpz_init_set_si (result->shape[1], result_columns);
+ }
+ else
+ gcc_unreachable();
+
+ 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);
+
+ 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
+ || fsource->expr_type != EXPR_CONSTANT
+ || mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_copy_expr (mask->value.logical ? tsource : fsource);
+}
+
+
+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);
- result->value.logical = e->value.logical;
+ /* 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)
+{
+ switch (arg->ts.type)
+ {
+ case BT_INTEGER:
+ if (mpz_cmp (arg->value.integer,
+ extremum->value.integer) * sign > 0)
+ mpz_set (extremum->value.integer, arg->value.integer);
+ break;
+
+ case BT_REAL:
+ /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
+ if (sign > 0)
+ mpfr_max (extremum->value.real, extremum->value.real,
+ arg->value.real, GFC_RND_MODE);
+ else
+ mpfr_min (extremum->value.real, extremum->value.real,
+ arg->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+#define LENGTH(x) ((x)->value.character.length)
+#define STRING(x) ((x)->value.character.string)
+ if (LENGTH(extremum) < LENGTH(arg))
+ {
+ gfc_char_t *tmp = STRING(extremum);
+
+ STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
+ memcpy (STRING(extremum), tmp,
+ LENGTH(extremum) * sizeof (gfc_char_t));
+ gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
+ LENGTH(arg) - LENGTH(extremum));
+ STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
+ LENGTH(extremum) = LENGTH(arg);
+ gfc_free (tmp);
+ }
+
+ if (gfc_compare_string (arg, extremum) * sign > 0)
+ {
+ gfc_free (STRING(extremum));
+ STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
+ memcpy (STRING(extremum), STRING(arg),
+ LENGTH(arg) * sizeof (gfc_char_t));
+ gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
+ LENGTH(extremum) - LENGTH(arg));
+ STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
+ }
+#undef LENGTH
+#undef STRING
+ break;
+
+ default:
+ gfc_internal_error ("simplify_min_max(): Bad type in arglist");
+ }
+}
+
+
/* This function is special since MAX() can take any number of
arguments. The simplified expression is a rewritten version of the
argument list containing at most one constant element. Other
arg = expr->value.function.actual;
- for (; arg; last = arg, arg = arg->next)
- {
- if (arg->expr->expr_type != EXPR_CONSTANT)
- continue;
-
- if (extremum == NULL)
- {
- extremum = arg;
- continue;
- }
-
- switch (arg->expr->ts.type)
- {
- case BT_INTEGER:
- if (mpz_cmp (arg->expr->value.integer,
- extremum->expr->value.integer) * sign > 0)
- mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
- break;
-
- case BT_REAL:
- if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
- * sign > 0)
- mpfr_set (extremum->expr->value.real, arg->expr->value.real,
- GFC_RND_MODE);
- break;
-
- case BT_CHARACTER:
-#define LENGTH(x) ((x)->expr->value.character.length)
-#define STRING(x) ((x)->expr->value.character.string)
- if (LENGTH(extremum) < LENGTH(arg))
- {
- char * tmp = STRING(extremum);
-
- STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
- memcpy (STRING(extremum), tmp, LENGTH(extremum));
- memset (&STRING(extremum)[LENGTH(extremum)], ' ',
- LENGTH(arg) - LENGTH(extremum));
- STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
- LENGTH(extremum) = LENGTH(arg);
- gfc_free (tmp);
- }
-
- if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
- {
- gfc_free (STRING(extremum));
- STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
- memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
- memset (&STRING(extremum)[LENGTH(arg)], ' ',
- LENGTH(extremum) - LENGTH(arg));
- STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
- }
-#undef LENGTH
-#undef STRING
- break;
-
-
- default:
- gfc_internal_error ("simplify_min_max(): Bad type in arglist");
+ for (; arg; last = arg, arg = arg->next)
+ {
+ if (arg->expr->expr_type != EXPR_CONSTANT)
+ continue;
+
+ if (extremum == NULL)
+ {
+ extremum = arg;
+ continue;
}
+ min_max_choose (arg->expr, extremum->expr, sign);
+
/* Delete the extra constant argument. */
if (last == NULL)
expr->value.function.actual = arg->next;
}
-gfc_expr *
-gfc_simplify_maxexponent (gfc_expr *x)
+/* This is a simplified version of simplify_min_max to provide
+ simplification of minval and maxval for a vector. */
+
+static gfc_expr *
+simplify_minval_maxval (gfc_expr *expr, int sign)
{
- gfc_expr *result;
- int i;
+ gfc_constructor *c, *extremum;
+ gfc_intrinsic_sym * specific;
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ extremum = NULL;
+ specific = expr->value.function.isym;
- result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
- result->where = x->where;
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
+ {
+ if (c->expr->expr_type != EXPR_CONSTANT)
+ return NULL;
- return result;
+ if (extremum == NULL)
+ {
+ extremum = c;
+ continue;
+ }
+
+ min_max_choose (c->expr, extremum->expr, sign);
+ }
+
+ if (extremum == NULL)
+ return NULL;
+
+ /* Convert to the correct type and kind. */
+ if (expr->ts.type != BT_UNKNOWN)
+ return gfc_convert_constant (extremum->expr,
+ expr->ts.type, expr->ts.kind);
+
+ if (specific->ts.type != BT_UNKNOWN)
+ return gfc_convert_constant (extremum->expr,
+ specific->ts.type, specific->ts.kind);
+
+ return gfc_copy_expr (extremum->expr);
}
gfc_expr *
-gfc_simplify_minexponent (gfc_expr *x)
+gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
{
- gfc_expr *result;
- int i;
+ if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+ return NULL;
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ return simplify_minval_maxval (array, -1);
+}
- result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
- result->where = x->where;
- return result;
+gfc_expr *
+gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+{
+ if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+ return NULL;
+
+ return simplify_minval_maxval (array, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_maxexponent (gfc_expr *x)
+{
+ int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+ gfc_real_kinds[i].max_exponent);
+}
+
+
+gfc_expr *
+gfc_simplify_minexponent (gfc_expr *x)
+{
+ int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+ gfc_real_kinds[i].min_exponent);
}
gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpfr_t quot, iquot, term;
+ mpfr_t tmp;
int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
return NULL;
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
- result = gfc_constant_result (a->ts.type, kind, &a->where);
+ result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp_ui (p->value.integer, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument MOD at %L is zero", &a->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
- break;
-
- case BT_REAL:
- if (mpfr_cmp_ui (p->value.real, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument of MOD at %L is zero", &p->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
-
- gfc_set_model_kind (kind);
- mpfr_init (quot);
- mpfr_init (iquot);
- mpfr_init (term);
-
- mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_trunc (iquot, quot);
- mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
+ case BT_INTEGER:
+ if (mpz_cmp_ui (p->value.integer, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument MOD at %L is zero", &a->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
+ break;
- mpfr_clear (quot);
- mpfr_clear (iquot);
- mpfr_clear (term);
- break;
+ case BT_REAL:
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument of MOD at %L is zero", &p->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+
+ gfc_set_model_kind (kind);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_trunc (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
+ default:
+ gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
}
return range_check (result, "MOD");
gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpfr_t quot, iquot, term;
+ mpfr_t tmp;
int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
return NULL;
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
- result = gfc_constant_result (a->ts.type, kind, &a->where);
+ result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp_ui (p->value.integer, 0) == 0)
- {
- /* Result is processor-dependent. This processor just opts
- to not handle it at all. */
- gfc_error ("Second argument of MODULO at %L is zero", &a->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
-
- break;
-
- case BT_REAL:
- if (mpfr_cmp_ui (p->value.real, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument of MODULO at %L is zero", &p->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
+ case BT_INTEGER:
+ if (mpz_cmp_ui (p->value.integer, 0) == 0)
+ {
+ /* Result is processor-dependent. This processor just opts
+ to not handle it at all. */
+ gfc_error ("Second argument of MODULO at %L is zero", &a->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
- gfc_set_model_kind (kind);
- mpfr_init (quot);
- mpfr_init (iquot);
- mpfr_init (term);
-
- mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_floor (iquot, quot);
- mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
+ break;
- mpfr_clear (quot);
- mpfr_clear (iquot);
- mpfr_clear (term);
- break;
+ case BT_REAL:
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument of MODULO at %L is zero", &p->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+
+ gfc_set_model_kind (kind);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_floor (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
+ default:
+ gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
}
return range_check (result, "MODULO");
return &gfc_bad_expr;
}
- gfc_set_model_kind (x->ts.kind);
result = gfc_copy_expr (x);
/* Save current values of emin and emax. */
mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
mpfr_get_prec(result->value.real) + 1);
mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
+ mpfr_check_range (result->value.real, 0, GMP_RNDU);
if (mpfr_sgn (s->value.real) > 0)
{
if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
{
gfc_error ("Result of NEAREST is NaN at %L", &result->where);
+ gfc_free_expr (result);
return &gfc_bad_expr;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
itrunc = gfc_copy_expr (e);
-
mpfr_round (itrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
+ gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
gfc_free_expr (itrunc);
{
gfc_expr *result;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
- result->value.character.string = gfc_getmem (2);
- result->value.character.length = 1;
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
result->value.character.string[0] = '\n';
- result->value.character.string[1] = '\0'; /* For debugger */
+
return result;
}
}
+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)
{
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
-
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
mpz_com (result->value.integer, e->value.integer);
return range_check (result, "NOT");
{
gfc_expr *result;
- if (mold == NULL)
+ if (mold)
{
- result = gfc_get_expr ();
- result->ts.type = BT_UNKNOWN;
+ result = gfc_copy_expr (mold);
+ result->expr_type = EXPR_NULL;
}
else
- result = gfc_copy_expr (mold);
- result->expr_type = EXPR_NULL;
+ result = gfc_get_null_expr (NULL);
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_num_images (void)
+{
+ gfc_expr *result;
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return &gfc_bad_expr;
+ }
+ /* FIXME: gfc_current_locus is wrong. */
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (result->value.integer, 1);
return result;
}
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
+
+ switch (x->ts.type)
+ {
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "OR");
+
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ x->value.logical || y->value.logical);
+ default:
+ gcc_unreachable();
+ }
+}
+
+
+gfc_expr *
+gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
+{
+ gfc_expr *result;
+ gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
+
+ if (!is_constant_array_expr(array)
+ || !is_constant_array_expr(vector)
+ || (!gfc_is_constant_expr (mask)
+ && !is_constant_array_expr(mask)))
+ 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_constructor_first (vector->value.constructor)
+ : NULL;
+
+ if (mask->expr_type == EXPR_CONSTANT
+ && mask->value.logical)
+ {
+ /* Copy all elements of ARRAY to RESULT. */
+ while (array_ctor)
+ {
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (array_ctor->expr),
+ NULL);
+
+ array_ctor = gfc_constructor_next (array_ctor);
+ vector_ctor = gfc_constructor_next (vector_ctor);
+ }
+ }
+ else if (mask->expr_type == EXPR_ARRAY)
{
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+ /* Copy only those elements of ARRAY to RESULT whose
+ MASK equals .TRUE.. */
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->value.logical)
+ {
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (array_ctor->expr),
+ NULL);
+ vector_ctor = gfc_constructor_next (vector_ctor);
+ }
+
+ array_ctor = gfc_constructor_next (array_ctor);
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
}
- else /* BT_LOGICAL */
+
+ /* Append any left-over elements from VECTOR to RESULT. */
+ while (vector_ctor)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = x->value.logical || y->value.logical;
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (vector_ctor->expr),
+ NULL);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
- return range_check (result, "OR");
+ result->shape = gfc_get_shape (1);
+ gfc_array_size (result, &result->shape[0]);
+
+ if (array->ts.type == BT_CHARACTER)
+ result->ts.u.cl = array->ts.u.cl;
+
+ return result;
+}
+
+
+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)
{
- gfc_expr *result;
+ return simplify_transformation (e, dim, NULL, 0, do_xor);
+}
+
+
+gfc_expr *
+gfc_simplify_popcnt (gfc_expr *e)
+{
+ int res, k;
+ mpz_t x;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return 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;
- i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
- result = gfc_int_expr (gfc_real_kinds[i].precision);
- result->where = e->where;
+ popcnt = gfc_simplify_popcnt (e);
+ gcc_assert (popcnt);
- return result;
+ 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_radix (gfc_expr *e)
{
- gfc_expr *result;
int i;
-
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
switch (e->ts.type)
{
- case BT_INTEGER:
- i = gfc_integer_kinds[i].radix;
- break;
+ case BT_INTEGER:
+ i = gfc_integer_kinds[i].radix;
+ break;
- case BT_REAL:
- i = gfc_real_kinds[i].radix;
- break;
+ case BT_REAL:
+ i = gfc_real_kinds[i].radix;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- result = gfc_int_expr (i);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
}
gfc_expr *
gfc_simplify_range (gfc_expr *e)
{
- gfc_expr *result;
int i;
- long j;
-
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
switch (e->ts.type)
{
- case BT_INTEGER:
- j = gfc_integer_kinds[i].range;
- break;
+ case BT_INTEGER:
+ i = gfc_integer_kinds[i].range;
+ break;
- case BT_REAL:
- case BT_COMPLEX:
- j = gfc_real_kinds[i].range;
- break;
+ case BT_REAL:
+ case BT_COMPLEX:
+ i = gfc_real_kinds[i].range;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- result = gfc_int_expr (j);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
}
gfc_expr *
gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
+ gfc_expr *result = NULL;
int kind;
if (e->ts.type == BT_COMPLEX)
kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
if (kind == -1)
- return &gfc_bad_expr;
-
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
-
- switch (e->ts.type)
- {
- case BT_INTEGER:
- result = gfc_int2real (e, kind);
- break;
+ return &gfc_bad_expr;
- case BT_REAL:
- result = gfc_real2real (e, kind);
- break;
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
- case BT_COMPLEX:
- result = gfc_complex2real (e, kind);
- break;
+ if (convert_boz (e, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
- default:
- gfc_internal_error ("bad type in REAL");
- /* Not reached */
- }
+ result = gfc_convert_constant (e, BT_REAL, kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
return range_check (result, "REAL");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
+ 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, "REALPART");
}
}
/* If we don't know the character length, we can do no more. */
- if (e->ts.cl && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+ if (e->ts.u.cl && e->ts.u.cl->length
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- len = mpz_get_si (e->ts.cl->length->value.integer);
+ len = mpz_get_si (e->ts.u.cl->length->value.integer);
have_length = true;
}
else if (e->expr_type == EXPR_CONSTANT
- && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+ && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
{
len = e->value.character.length;
}
if (have_length)
{
mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
- e->ts.cl->length->value.integer);
+ e->ts.u.cl->length->value.integer);
}
else
{
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
+ if (len ||
+ (e->ts.u.cl->length &&
+ mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
{
const char *res = gfc_extract_int (n, &ncop);
gcc_assert (res == NULL);
len = e->value.character.length;
nlen = ncop * len;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
if (ncop == 0)
- {
- result->value.character.string = gfc_getmem (1);
- result->value.character.length = 0;
- result->value.character.string[0] = '\0';
- return result;
- }
+ return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
- result->value.character.length = nlen;
- result->value.character.string = gfc_getmem (nlen + 1);
+ len = e->value.character.length;
+ nlen = ncop * len;
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
for (i = 0; i < ncop; i++)
for (j = 0; j < len; j++)
- result->value.character.string[j + i * len]
- = e->value.character.string[j];
+ result->value.character.string[j+i*len]= e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */
return result;
{
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
int i, rank, npad, x[GFC_MAX_DIMENSIONS];
- gfc_constructor *head, *tail;
mpz_t index, size;
unsigned long j;
size_t nsource;
- gfc_expr *e;
-
- /* Unpack the shape array. */
- if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
- return NULL;
-
- if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
- return NULL;
+ gfc_expr *e, *result;
- if (pad != NULL
- && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
+ /* Check that argument expression types are OK. */
+ if (!is_constant_array_expr (source)
+ || !is_constant_array_expr (shape_exp)
+ || !is_constant_array_expr (pad)
+ || !is_constant_array_expr (order_exp))
return NULL;
- if (order_exp != NULL
- && (order_exp->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (order_exp)))
- return NULL;
+ /* Proceed with simplification, unpacking the array. */
mpz_init (index);
rank = 0;
- head = tail = NULL;
for (;;)
{
- e = gfc_get_array_element (shape_exp, rank);
+ e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
if (e == NULL)
break;
- if (gfc_extract_int (e, &shape[rank]) != NULL)
- {
- gfc_error ("Integer too large in shape specification at %L",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
-
- gfc_free_expr (e);
-
- if (rank >= GFC_MAX_DIMENSIONS)
- {
- gfc_error ("Too many dimensions in shape specification for RESHAPE "
- "at %L", &e->where);
-
- goto bad_reshape;
- }
+ gfc_extract_int (e, &shape[rank]);
- if (shape[rank] < 0)
- {
- gfc_error ("Shape specification at %L cannot be negative",
- &e->where);
- goto bad_reshape;
- }
+ gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
+ gcc_assert (shape[rank] >= 0);
rank++;
}
- if (rank == 0)
- {
- gfc_error ("Shape specification at %L cannot be the null array",
- &shape_exp->where);
- goto bad_reshape;
- }
+ gcc_assert (rank > 0);
/* Now unpack the order array if present. */
if (order_exp == NULL)
for (i = 0; i < rank; i++)
{
- e = gfc_get_array_element (order_exp, i);
- if (e == NULL)
- {
- gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
- "size as SHAPE parameter", &order_exp->where);
- goto bad_reshape;
- }
-
- if (gfc_extract_int (e, &order[i]) != NULL)
- {
- gfc_error ("Error in ORDER parameter of RESHAPE at %L",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
+ e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
+ gcc_assert (e);
- gfc_free_expr (e);
-
- if (order[i] < 1 || order[i] > rank)
- {
- gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
- &e->where);
- goto bad_reshape;
- }
+ gfc_extract_int (e, &order[i]);
+ gcc_assert (order[i] >= 1 && order[i] <= rank);
order[i]--;
-
- if (x[order[i]])
- {
- gfc_error ("Invalid permutation in ORDER parameter at %L",
- &e->where);
- goto bad_reshape;
- }
-
+ gcc_assert (x[order[i]] == 0);
x[order[i]] = 1;
}
}
for (i = 0; i < rank; i++)
x[i] = 0;
- for (;;)
+ 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++)
+ mpz_init_set_ui (result->shape[i], shape[i]);
+
+ while (nsource > 0 || npad > 0)
{
/* Figure out which element to extract. */
mpz_set_ui (index, 0);
}
if (mpz_cmp_ui (index, INT_MAX) > 0)
- gfc_internal_error ("Reshaped array too large at %L", &e->where);
+ gfc_internal_error ("Reshaped array too large at %C");
j = mpz_get_ui (index);
if (j < nsource)
- e = gfc_get_array_element (source, j);
+ e = gfc_constructor_lookup_expr (source->value.constructor, j);
else
{
- j = j - nsource;
-
- if (npad == 0)
- {
- gfc_error ("PAD parameter required for short SOURCE parameter "
- "at %L", &source->where);
- goto bad_reshape;
- }
+ gcc_assert (npad > 0);
+ j = j - nsource;
j = j % npad;
- e = gfc_get_array_element (pad, j);
- }
-
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
+ e = gfc_constructor_lookup_expr (pad->value.constructor, j);
}
+ gcc_assert (e);
- if (e == NULL)
- goto bad_reshape;
-
- tail->where = e->where;
- tail->expr = e;
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (e), &e->where);
/* Calculate the next element. */
i = 0;
mpz_clear (index);
- e = gfc_get_expr ();
- e->where = source->where;
- e->expr_type = EXPR_ARRAY;
- e->value.constructor = head;
- e->shape = gfc_get_shape (rank);
-
- for (i = 0; i < rank; i++)
- mpz_init_set_ui (e->shape[i], shape[i]);
-
- e->ts = source->ts;
- e->rank = rank;
-
- return e;
-
-bad_reshape:
- gfc_free_constructor (head);
- mpz_clear (index);
- return &gfc_bad_expr;
+ return result;
}
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
/* Special case x = -0 and 0. */
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
|| mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
{
gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
+ gfc_free_expr (result);
return &gfc_bad_expr;
}
else
mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
- mpfr_clear (scale);
- mpfr_clear (radix);
+ mpfr_clears (scale, radix, NULL);
return range_check (result, "SCALE");
}
+/* Variants of strspn and strcspn that operate on wide characters. */
+
+static size_t
+wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+ size_t i = 0;
+ const gfc_char_t *c;
+
+ while (s1[i])
+ {
+ for (c = s2; *c; c++)
+ {
+ if (s1[i] == *c)
+ break;
+ }
+ if (*c == '\0')
+ break;
+ i++;
+ }
+
+ return i;
+}
+
+static size_t
+wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+ size_t i = 0;
+ const gfc_char_t *c;
+
+ while (s1[i])
+ {
+ for (c = s2; *c; c++)
+ {
+ if (s1[i] == *c)
+ break;
+ }
+ if (*c)
+ break;
+ i++;
+ }
+
+ return i;
+}
+
+
gfc_expr *
gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
{
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
-
len = e->value.character.length;
lenc = c->value.character.length;
{
if (back == 0)
{
- indx = strcspn (e->value.character.string, c->value.character.string)
- + 1;
+ indx = wide_strcspn (e->value.character.string,
+ c->value.character.string) + 1;
if (indx > len)
indx = 0;
}
}
}
}
- mpz_set_ui (result->value.integer, indx);
+
+ result = gfc_get_int_expr (k, &e->where, indx);
return range_check (result, "SCAN");
}
gfc_expr *
+gfc_simplify_selected_char_kind (gfc_expr *e)
+{
+ int kind;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (gfc_compare_with_Cstring (e, "ascii", false) == 0
+ || gfc_compare_with_Cstring (e, "default", false) == 0)
+ kind = 1;
+ else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
+ kind = 4;
+ else
+ kind = -1;
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
+}
+
+
+gfc_expr *
gfc_simplify_selected_int_kind (gfc_expr *e)
{
int i, kind, range;
- gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
return NULL;
if (kind == INT_MAX)
kind = -1;
- result = gfc_int_expr (kind);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
}
gfc_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;
- gfc_expr *result;
+ 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;
}
- result = gfc_int_expr (kind);
- result->where = (p != NULL) ? p->where : q->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
}
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
-
- gfc_set_model_kind (x->ts.kind);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
return result;
}
+ gfc_set_model_kind (x->ts.kind);
mpfr_init (absv);
mpfr_init (log2);
mpfr_init (exp);
exp2 = (unsigned long) mpz_get_d (i->value.integer);
mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
- mpfr_clear (absv);
- mpfr_clear (log2);
- mpfr_clear (pow2);
- mpfr_clear (frac);
+ mpfr_clears (absv, log2, pow2, frac, NULL);
return range_check (result, "SET_EXPONENT");
}
gfc_expr *result, *e, *f;
gfc_array_ref *ar;
int n;
- try t;
-
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
- return NULL;
+ gfc_try t;
- result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ if (source->rank == 0)
+ return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
- ar = gfc_find_array_ref (source);
+ result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
- 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_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
if (t == SUCCESS)
{
return NULL;
}
else
- {
- e = f;
- }
+ e = f;
}
- gfc_append_constructor (result, e);
+ gfc_constructor_append_expr (&result->value.constructor, e, NULL);
}
return result;
gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
mpz_t size;
- gfc_expr *result;
+ 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:
+ 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;
}
- result = gfc_constant_result (BT_INTEGER, k, &array->where);
- mpz_set (result->value.integer, size);
- return result;
+ return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+ mpz_clear (size);
+ return return_value;
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- mpz_abs (result->value.integer, x->value.integer);
- if (mpz_sgn (y->value.integer) < 0)
- mpz_neg (result->value.integer, result->value.integer);
-
- break;
-
- case BT_REAL:
- /* TODO: Handle -0.0 and +0.0 correctly on machines that support
- it. */
- mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
- if (mpfr_sgn (y->value.real) < 0)
- mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
+ case BT_INTEGER:
+ mpz_abs (result->value.integer, x->value.integer);
+ if (mpz_sgn (y->value.integer) < 0)
+ mpz_neg (result->value.integer, result->value.integer);
+ break;
- break;
+ case BT_REAL:
+ if (gfc_option.flag_sign_zero)
+ mpfr_copysign (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
+ else
+ mpfr_setsign (result->value.real, x->value.real,
+ mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("Bad type in gfc_simplify_sign");
+ default:
+ gfc_internal_error ("Bad type in gfc_simplify_sign");
}
return result;
gfc_simplify_sin (gfc_expr *x)
{
gfc_expr *result;
- mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
- break;
-
- case BT_COMPLEX:
- gfc_set_model (x->value.real);
- mpfr_init (xp);
- mpfr_init (xq);
-
- mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
-
- mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
- mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
- mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
+ case BT_REAL:
+ mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- mpfr_clear (xp);
- mpfr_clear (xq);
- break;
+ case BT_COMPLEX:
+ gfc_set_model (x->value.real);
+ mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("in gfc_simplify_sin(): Bad type");
+ default:
+ gfc_internal_error ("in gfc_simplify_sin(): Bad type");
}
return range_check (result, "SIN");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "SINH");
}
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
/* Special case x = 0 and -0. */
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
gfc_expr *
-gfc_simplify_sqrt (gfc_expr *e)
+gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
{
- gfc_expr *result;
- mpfr_t ac, ad, s, t, w;
+ gfc_expr *result = 0L;
+ int i, j, dim, ncopies;
+ mpz_t size;
- if (e->expr_type != EXPR_CONSTANT)
+ if ((!gfc_is_constant_expr (source)
+ && !is_constant_array_expr (source))
+ || !gfc_is_constant_expr (dim_expr)
+ || !gfc_is_constant_expr (ncopies_expr))
return NULL;
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ gcc_assert (dim_expr->ts.type == BT_INTEGER);
+ gfc_extract_int (dim_expr, &dim);
+ dim -= 1; /* zero-base DIM */
- switch (e->ts.type)
+ gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
+ gfc_extract_int (ncopies_expr, &ncopies);
+ ncopies = MAX (ncopies, 0);
+
+ /* Do not allow the array size to exceed the limit for an array
+ constructor. */
+ if (source->expr_type == EXPR_ARRAY)
{
- case BT_REAL:
- if (mpfr_cmp_si (e->value.real, 0) < 0)
- goto negative_arg;
- mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
+ if (gfc_array_size (source, &size) == FAILURE)
+ gfc_internal_error ("Failure getting length of a constant array.");
+ }
+ else
+ mpz_init_set_ui (size, 1);
- break;
+ if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
+ return NULL;
- case BT_COMPLEX:
- /* Formula taken from Numerical Recipes to avoid over- and
- underflow. */
-
- gfc_set_model (e->value.real);
- mpfr_init (ac);
- mpfr_init (ad);
- mpfr_init (s);
- mpfr_init (t);
- mpfr_init (w);
-
- if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
- && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
- {
- mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
- break;
- }
+ if (source->expr_type == EXPR_CONSTANT)
+ {
+ gcc_assert (dim == 0);
- mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
- mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
+ 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);
- if (mpfr_cmp (ac, ad) >= 0)
- {
- mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
- mpfr_mul (t, t, t, GFC_RND_MODE);
- mpfr_add_ui (t, t, 1, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_add_ui (t, t, 1, GFC_RND_MODE);
- mpfr_div_ui (t, t, 2, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_sqrt (s, ac, GFC_RND_MODE);
- mpfr_mul (w, s, t, GFC_RND_MODE);
- }
- else
- {
- mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
- mpfr_mul (t, s, s, GFC_RND_MODE);
- mpfr_add_ui (t, t, 1, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_abs (s, s, GFC_RND_MODE);
- mpfr_add (t, t, s, GFC_RND_MODE);
- mpfr_div_ui (t, t, 2, GFC_RND_MODE);
- mpfr_sqrt (t, t, GFC_RND_MODE);
- mpfr_sqrt (s, ad, GFC_RND_MODE);
- mpfr_mul (w, s, t, GFC_RND_MODE);
- }
+ for (i = 0; i < ncopies; ++i)
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (source), NULL);
+ }
+ else if (source->expr_type == EXPR_ARRAY)
+ {
+ int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
+ gfc_constructor *source_ctor;
- if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
- {
- mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
- mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
- mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
- }
- else if (mpfr_cmp_ui (w, 0) != 0
- && mpfr_cmp_ui (e->value.complex.r, 0) < 0
- && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
+ gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
+ gcc_assert (dim >= 0 && dim <= source->rank);
+
+ 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);
+
+ for (i = 0, j = 0; i < result->rank; ++i)
{
- mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
- mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
- mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
+ if (i != dim)
+ mpz_init_set (result->shape[i], source->shape[j++]);
+ else
+ mpz_init_set_si (result->shape[i], ncopies);
+
+ extent[i] = mpz_get_si (result->shape[i]);
+ rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
}
- else if (mpfr_cmp_ui (w, 0) != 0
- && mpfr_cmp_ui (e->value.complex.r, 0) < 0
- && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
+
+ offset = 0;
+ for (source_ctor = gfc_constructor_first (source->value.constructor);
+ source_ctor; source_ctor = gfc_constructor_next (source_ctor))
{
- mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
- mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
- mpfr_neg (w, w, GFC_RND_MODE);
- mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
+ for (i = 0; i < ncopies; ++i)
+ gfc_constructor_insert_expr (&result->value.constructor,
+ gfc_copy_expr (source_ctor->expr),
+ NULL, offset + i * rstride[dim]);
+
+ offset += (dim == 0 ? ncopies : 1);
}
- else
- gfc_internal_error ("invalid complex argument of SQRT at %L",
- &e->where);
+ }
+ else
+ /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
+ Replace NULL with gcc_unreachable() after implementing
+ gfc_simplify_cshift(). */
+ return NULL;
- mpfr_clear (s);
- mpfr_clear (t);
- mpfr_clear (ac);
- mpfr_clear (ad);
- mpfr_clear (w);
+ if (source->ts.type == BT_CHARACTER)
+ result->ts.u.cl = source->ts.u.cl;
- break;
+ return result;
+}
- default:
- gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
+
+gfc_expr *
+gfc_simplify_sqrt (gfc_expr *e)
+{
+ gfc_expr *result = NULL;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ switch (e->ts.type)
+ {
+ case BT_REAL:
+ if (mpfr_cmp_si (e->value.real, 0) < 0)
+ {
+ gfc_error ("Argument of SQRT at %L has a negative value",
+ &e->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ gfc_set_model (e->value.real);
+
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
}
return range_check (result, "SQRT");
+}
-negative_arg:
- gfc_free_expr (result);
- gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
- return &gfc_bad_expr;
+
+gfc_expr *
+gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ return simplify_transformation (array, dim, mask, 0, gfc_add);
}
gfc_expr *
gfc_simplify_tan (gfc_expr *x)
{
- int i;
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ case BT_COMPLEX:
+ mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "TAN");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- return range_check (result, "TANH");
+ case BT_COMPLEX:
+ mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ return range_check (result, "TANH");
}
i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
return result;
gfc_expr *
+gfc_simplify_trailz (gfc_expr *e)
+{
+ unsigned long tz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ tz = mpz_scan1 (e->value.integer, 0);
+
+ return gfc_get_int_expr (gfc_default_integer_kind,
+ &e->where, MIN (tz, bs));
+}
+
+
+gfc_expr *
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
gfc_expr *result;
unsigned char *buffer;
if (!gfc_is_constant_expr (source)
+ || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
|| !gfc_is_constant_expr (size))
return NULL;
source_size = gfc_target_expr_size (source);
/* Create an empty new expression with the appropriate characteristics. */
- result = gfc_constant_result (mold->ts.type, mold->ts.kind,
- &source->where);
+ result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
+ &source->where);
result->ts = mold->ts;
mold_element = mold->expr_type == EXPR_ARRAY
- ? mold->value.constructor->expr
+ ? gfc_constructor_first (mold->value.constructor)->expr
: mold;
/* Set result character length, if needed. Note that this needs to be
set even for array expressions, in order to pass this information into
gfc_target_interpret_expr. */
- if (result->ts.type == BT_CHARACTER)
+ if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
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;
/* Allocate the buffer to store the binary version of the source. */
buffer_size = MAX (source_size, result_size);
buffer = (unsigned char*)alloca (buffer_size);
+ memset (buffer, 0, buffer_size);
/* Now write source to the buffer. */
gfc_target_encode_expr (source, buffer, buffer_size);
gfc_expr *
+gfc_simplify_transpose (gfc_expr *matrix)
+{
+ int row, matrix_rows, col, matrix_cols;
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (matrix))
+ return NULL;
+
+ gcc_assert (matrix->rank == 2);
+
+ result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
+ &matrix->where);
+ result->rank = 2;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_set (result->shape[0], matrix->shape[1]);
+ mpz_set (result->shape[1], matrix->shape[0]);
+
+ if (matrix->ts.type == BT_CHARACTER)
+ result->ts.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]);
+ for (row = 0; row < matrix_rows; ++row)
+ for (col = 0; col < matrix_cols; ++col)
+ {
+ gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
+ col * matrix_rows + row);
+ gfc_constructor_insert_expr (&result->value.constructor,
+ gfc_copy_expr (e), &matrix->where,
+ row * matrix_cols + col);
+ }
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_trim (gfc_expr *e)
{
gfc_expr *result;
return NULL;
len = e->value.character.length;
-
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
for (count = 0, i = 1; i <= len; ++i)
{
if (e->value.character.string[len - i] == ' ')
lentrim = len - count;
- result->value.character.length = lentrim;
- result->value.character.string = gfc_getmem (lentrim + 1);
-
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
for (i = 0; i < lentrim; i++)
result->value.character.string[i] = e->value.character.string[i];
- result->value.character.string[lentrim] = '\0'; /* For debugger */
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+ gfc_expr *result;
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ gfc_constructor *sub_cons;
+ bool first_image;
+ int d;
+
+ if (!is_constant_array_expr (sub))
+ goto not_implemented; /* return NULL;*/
+
+ /* Follow any component references. */
+ as = coarray->symtree->n.sym->as;
+ for (ref = coarray->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ as = ref->u.ar.as;
+
+ if (as->type == AS_DEFERRED)
+ goto not_implemented; /* return NULL;*/
+
+ /* "valid sequence of cosubscripts" are required; thus, return 0 unless
+ the cosubscript addresses the first image. */
+
+ sub_cons = gfc_constructor_first (sub->value.constructor);
+ first_image = true;
+
+ for (d = 1; d <= as->corank; d++)
+ {
+ gfc_expr *ca_bound;
+ int cmp;
+
+ if (sub_cons == NULL)
+ {
+ gfc_error ("Too few elements in expression for SUB= argument at %L",
+ &sub->where);
+ return &gfc_bad_expr;
+ }
+
+ ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
+ NULL, true);
+ if (ca_bound == NULL)
+ goto not_implemented; /* return NULL */
+
+ if (ca_bound == &gfc_bad_expr)
+ return ca_bound;
+
+ cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
+
+ if (cmp == 0)
+ {
+ gfc_free_expr (ca_bound);
+ sub_cons = gfc_constructor_next (sub_cons);
+ continue;
+ }
+
+ first_image = false;
+
+ if (cmp > 0)
+ {
+ gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+ "SUB has %ld and COARRAY lower bound is %ld)",
+ &coarray->where, d,
+ mpz_get_si (sub_cons->expr->value.integer),
+ mpz_get_si (ca_bound->value.integer));
+ gfc_free_expr (ca_bound);
+ return &gfc_bad_expr;
+ }
+
+ gfc_free_expr (ca_bound);
+
+ /* Check whether upperbound is valid for the multi-images case. */
+ if (d < as->corank)
+ {
+ ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
+ NULL, true);
+ if (ca_bound == &gfc_bad_expr)
+ return ca_bound;
+
+ if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ca_bound->value.integer,
+ sub_cons->expr->value.integer) < 0)
+ {
+ gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+ "SUB has %ld and COARRAY upper bound is %ld)",
+ &coarray->where, d,
+ mpz_get_si (sub_cons->expr->value.integer),
+ mpz_get_si (ca_bound->value.integer));
+ gfc_free_expr (ca_bound);
+ return &gfc_bad_expr;
+ }
+
+ if (ca_bound)
+ gfc_free_expr (ca_bound);
+ }
+
+ sub_cons = gfc_constructor_next (sub_cons);
+ }
+
+ if (sub_cons != NULL)
+ {
+ gfc_error ("Too many elements in expression for SUB= argument at %L",
+ &sub->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
+ if (first_image)
+ mpz_set_si (result->value.integer, 1);
+ else
+ mpz_set_si (result->value.integer, 0);
return result;
+
+not_implemented:
+ gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
+ "cobounds at %L", &coarray->where);
+ return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+ gfc_ref *ref;
+ gfc_array_spec *as;
+ int d;
+
+ if (coarray == NULL)
+ {
+ gfc_expr *result;
+ /* FIXME: gfc_current_locus is wrong. */
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (result->value.integer, 1);
+ return result;
+ }
+
+ gcc_assert (coarray->expr_type == EXPR_VARIABLE);
+
+ /* Follow any component references. */
+ as = coarray->symtree->n.sym->as;
+ for (ref = coarray->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ as = ref->u.ar.as;
+
+ if (as->type == AS_DEFERRED)
+ goto not_implemented; /* return NULL;*/
+
+ if (dim == NULL)
+ {
+ /* Multi-dimensional bounds. */
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+
+ /* Simplify the bounds for each dimension. */
+ for (d = 0; d < as->corank; d++)
+ {
+ bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
+ as, NULL, true);
+ if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+ {
+ int j;
+
+ for (j = 0; j < d; j++)
+ gfc_free_expr (bounds[j]);
+ if (bounds[d] == NULL)
+ goto not_implemented;
+ return bounds[d];
+ }
+ }
+
+ /* Allocate the result expression. */
+ e = gfc_get_expr ();
+ e->where = coarray->where;
+ e->expr_type = EXPR_ARRAY;
+ e->ts.type = BT_INTEGER;
+ e->ts.kind = gfc_default_integer_kind;
+
+ e->rank = 1;
+ e->shape = gfc_get_shape (1);
+ mpz_init_set_ui (e->shape[0], as->corank);
+
+ /* Create the constructor for this array. */
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
+
+ return e;
+ }
+ else
+ {
+ gfc_expr *e;
+ /* A DIM argument is specified. */
+ if (dim->expr_type != EXPR_CONSTANT)
+ goto not_implemented; /*return NULL;*/
+
+ d = mpz_get_si (dim->value.integer);
+
+ if (d < 1 || d > as->corank)
+ {
+ gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+ return &gfc_bad_expr;
+ }
+
+ /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
+ e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
+ if (e != NULL)
+ return e;
+ else
+ goto not_implemented;
+ }
+
+not_implemented:
+ gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
+ "cobounds at %L", &coarray->where);
+ return &gfc_bad_expr;
}
return simplify_bound (array, dim, kind, 1);
}
+gfc_expr *
+gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ gfc_expr *e;
+ /* return simplify_cobound (array, dim, kind, 1);*/
+
+ e = simplify_cobound (array, dim, kind, 1);
+ if (e != NULL)
+ return e;
+
+ gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
+ "cobounds at %L", &array->where);
+ return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
+{
+ gfc_expr *result, *e;
+ gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
+
+ if (!is_constant_array_expr (vector)
+ || !is_constant_array_expr (mask)
+ || (!gfc_is_constant_expr (field)
+ && !is_constant_array_expr(field)))
+ return NULL;
+
+ 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);
+
+ if (vector->ts.type == BT_CHARACTER)
+ result->ts.u.cl = vector->ts.u.cl;
+
+ vector_ctor = gfc_constructor_first (vector->value.constructor);
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ field_ctor
+ = field->expr_type == EXPR_ARRAY
+ ? gfc_constructor_first (field->value.constructor)
+ : NULL;
+
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->value.logical)
+ {
+ gcc_assert (vector_ctor);
+ e = gfc_copy_expr (vector_ctor->expr);
+ vector_ctor = gfc_constructor_next (vector_ctor);
+ }
+ else if (field->expr_type == EXPR_ARRAY)
+ e = gfc_copy_expr (field_ctor->expr);
+ else
+ e = gfc_copy_expr (field);
+
+ gfc_constructor_append_expr (&result->value.constructor, e, NULL);
+
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ field_ctor = gfc_constructor_next (field_ctor);
+ }
+
+ return result;
+}
+
gfc_expr *
gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, k, &s->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
len = s->value.character.length;
lenset = set->value.character.length;
return result;
}
- index = strspn (s->value.character.string, set->value.character.string)
- + 1;
+ index = wide_strspn (s->value.character.string,
+ set->value.character.string) + 1;
if (index > len)
index = 0;
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_xor (result->value.integer, x->value.integer, y->value.integer);
- }
- else /* BT_LOGICAL */
+
+ switch (x->ts.type)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = (x->value.logical && !y->value.logical)
- || (!x->value.logical && y->value.logical);
- }
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "XOR");
- return range_check (result, "XOR");
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ (x->value.logical && !y->value.logical)
+ || (!x->value.logical && y->value.logical));
+
+ default:
+ gcc_unreachable ();
+ }
}
gfc_convert_constant (gfc_expr *e, bt type, int kind)
{
gfc_expr *g, *result, *(*f) (gfc_expr *, int);
- gfc_constructor *head, *c, *tail = NULL;
+ gfc_constructor *c;
switch (e->ts.type)
{
if (!gfc_is_constant_expr (e))
break;
- head = NULL;
+ result = gfc_get_array_expr (type, kind, &e->where);
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->rank = e->rank;
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
{
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = c->where;
-
+ gfc_expr *tmp;
if (c->iterator == NULL)
- tail->expr = f (c->expr, kind);
+ tmp = f (c->expr, kind);
else
{
g = gfc_convert_constant (c->expr, type, kind);
if (g == &gfc_bad_expr)
- return g;
- tail->expr = g;
+ {
+ gfc_free_expr (result);
+ return g;
+ }
+ tmp = g;
}
- if (tail->expr == NULL)
+ if (tmp == NULL)
{
- gfc_free_constructor (head);
+ gfc_free_expr (result);
return NULL;
}
+
+ gfc_constructor_append_expr (&result->value.constructor,
+ tmp, &c->where);
}
- result = gfc_get_expr ();
- result->ts.type = type;
- result->ts.kind = kind;
- result->expr_type = EXPR_ARRAY;
- result->value.constructor = head;
- result->shape = gfc_copy_shape (e->shape, e->rank);
- result->where = e->where;
- result->rank = e->rank;
break;
default:
return result;
}
+
+
+/* Function for converting character constants. */
+gfc_expr *
+gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
+{
+ gfc_expr *result;
+ int i;
+
+ if (!gfc_is_constant_expr (e))
+ return NULL;
+
+ if (e->expr_type == EXPR_CONSTANT)
+ {
+ /* Simple case of a scalar. */
+ result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
+ if (result == NULL)
+ return &gfc_bad_expr;
+
+ result->value.character.length = e->value.character.length;
+ result->value.character.string
+ = gfc_get_wide_string (e->value.character.length + 1);
+ memcpy (result->value.character.string, e->value.character.string,
+ (e->value.character.length + 1) * sizeof (gfc_char_t));
+
+ /* Check we only have values representable in the destination kind. */
+ for (i = 0; i < result->value.character.length; i++)
+ if (!gfc_check_character_range (result->value.character.string[i],
+ kind))
+ {
+ gfc_error ("Character '%s' in string at %L cannot be converted "
+ "into character kind %d",
+ gfc_print_wide_char (result->value.character.string[i]),
+ &e->where, kind);
+ return &gfc_bad_expr;
+ }
+
+ return result;
+ }
+ else if (e->expr_type == EXPR_ARRAY)
+ {
+ /* For an array constructor, we convert each constructor element. */
+ gfc_constructor *c;
+
+ result = gfc_get_array_expr (type, kind, &e->where);
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->rank = e->rank;
+ result->ts.u.cl = e->ts.u.cl;
+
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ {
+ gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
+ if (tmp == &gfc_bad_expr)
+ {
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+
+ if (tmp == NULL)
+ {
+ gfc_free_expr (result);
+ return NULL;
+ }
+
+ gfc_constructor_append_expr (&result->value.constructor,
+ tmp, &c->where);
+ }
+
+ return result;
+ }
+ 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));
+ gfc_free (str);
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_compiler_version (void)
+{
+ char *buffer;
+ size_t len;
+
+ len = strlen ("GCC version ") + strlen (version_string) + 1;
+ buffer = (char*) alloca (len);
+ snprintf (buffer, len, "GCC version %s", version_string);
+ return gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, buffer, len);
+}