/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
switch (x->ts.type)
{
case BT_INTEGER:
- mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
+ if (!x->is_boz)
+ mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
switch (y->ts.type)
{
case BT_INTEGER:
- mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
+ if (!y->is_boz)
+ mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
}
}
+ /* Handle BOZ. */
+ if (x->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.kind = result->ts.kind;
+ ts.type = BT_REAL;
+ if (!gfc_convert_boz (x, &ts))
+ return &gfc_bad_expr;
+ mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+ }
+
+ if (y && y->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.kind = result->ts.kind;
+ ts.type = BT_REAL;
+ if (!gfc_convert_boz (y, &ts))
+ return &gfc_bad_expr;
+ mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+ }
+
return range_check (result, name);
}
switch (e->ts.type)
{
case BT_INTEGER:
- result = gfc_int2real (e, gfc_default_double_kind);
+ if (!e->is_boz)
+ result = gfc_int2real (e, gfc_default_double_kind);
break;
case BT_REAL:
gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
}
+ if (e->ts.type == BT_INTEGER && e->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = gfc_default_double_kind;
+ result = gfc_copy_expr (e);
+ if (!gfc_convert_boz (result, &ts))
+ return &gfc_bad_expr;
+ }
+
return range_check (result, "DBLE");
}
}
+gfc_expr *
+gfc_simplify_erf (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ERF");
+}
+
+
+gfc_expr *
+gfc_simplify_erfc (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ERFC");
+}
+
+
gfc_expr *
gfc_simplify_epsilon (gfc_expr *e)
{
if (a->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_int2real (a, gfc_default_real_kind);
+ if (a->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+
+ ts.type = BT_REAL;
+ ts.kind = gfc_default_real_kind;
+
+ result = gfc_copy_expr (a);
+ if (!gfc_convert_boz (result, &ts))
+ return &gfc_bad_expr;
+ }
+ else
+ result = gfc_int2real (a, gfc_default_real_kind);
return range_check (result, "FLOAT");
}
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_constant_result (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. */
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
- return range_check (result, "IBCLR");
+ return result;
}
}
result = gfc_constant_result (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));
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;
}
switch (e->ts.type)
{
case BT_INTEGER:
- result = gfc_int2real (e, kind);
+ if (!e->is_boz)
+ result = gfc_int2real (e, kind);
break;
case BT_REAL:
/* Not reached */
}
+ if (e->ts.type == BT_INTEGER && e->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = kind;
+ result = gfc_copy_expr (e);
+ if (!gfc_convert_boz (result, &ts))
+ return &gfc_bad_expr;
+ }
return range_check (result, "REAL");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
+ if (len ||
+ (e->ts.cl->length &&
+ mpz_sgn (e->ts.cl->length->value.integer)) != 0)
{
const char *res = gfc_extract_int (n, &ncop);
gcc_assert (res == NULL);
}
+/* 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;
+
+ if (e->value.constructor == NULL)
+ return false;
+
+ for (c = e->value.constructor; c; c = c->next)
+ if (c->expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ return true;
+}
+
+
/* This one is a bear, but mainly has to do with shuffling elements. */
gfc_expr *
size_t nsource;
gfc_expr *e;
- /* Unpack the shape array. */
- if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
+ /* Check that argument expression types are OK. */
+ if (!is_constant_array_expr (source))
return NULL;
- if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
+ if (!is_constant_array_expr (shape_exp))
return NULL;
- if (pad != NULL
- && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
+ if (!is_constant_array_expr (pad))
return NULL;
- if (order_exp != NULL
- && (order_exp->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (order_exp)))
+ if (!is_constant_array_expr (order_exp))
return NULL;
+ /* Proceed with simplification, unpacking the array. */
+
mpz_init (index);
rank = 0;
head = tail = NULL;
int n;
try t;
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
+ if (source->rank == 0)
+ return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
+
+ if (source->expr_type != EXPR_VARIABLE)
return NULL;
result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
unsigned char *buffer;
if (!gfc_is_constant_expr (source)
+ || (gfc_init_expr && !gfc_is_constant_expr (mold))
|| !gfc_is_constant_expr (size))
return NULL;
/* 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;
projects / gcc.git / blobdiff