diff options
Diffstat (limited to 'gcc/fortran/simplify.c')
| -rw-r--r-- | gcc/fortran/simplify.c | 61 |
1 files changed, 56 insertions, 5 deletions
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 598ec57..ea807d1 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -740,7 +740,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) 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: @@ -761,7 +762,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) 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: @@ -773,6 +775,25 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) } } + /* Handle BOZ. */ + if (x->is_boz) + { + gfc_typespec ts; + ts.kind = result->ts.kind; + ts.type = BT_REAL; + gfc_convert_boz (x, &ts); + mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE); + } + + if (y && y->is_boz) + { + gfc_typespec ts; + ts.kind = result->ts.kind; + ts.type = BT_REAL; + gfc_convert_boz (y, &ts); + mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE); + } + return range_check (result, name); } @@ -918,7 +939,8 @@ gfc_simplify_dble (gfc_expr *e) 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: @@ -933,6 +955,15 @@ gfc_simplify_dble (gfc_expr *e) gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where); } + if (e->ts.type == BT_INTEGER && e->is_boz) + { + gfc_typespec ts; + ts.type = BT_REAL; + ts.kind = gfc_default_double_kind; + result = gfc_copy_expr (e); + gfc_convert_boz (result, &ts); + } + return range_check (result, "DBLE"); } @@ -1111,7 +1142,18 @@ gfc_simplify_float (gfc_expr *a) if (a->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_int2real (a, gfc_default_real_kind); + if (a->is_boz) + { + gfc_typespec ts; + + ts.type = BT_REAL; + ts.kind = gfc_default_real_kind; + + result = gfc_copy_expr (a); + gfc_convert_boz (result, &ts); + } + else + result = gfc_int2real (a, gfc_default_real_kind); return range_check (result, "FLOAT"); } @@ -2954,7 +2996,8 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) 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: @@ -2970,6 +3013,14 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) /* Not reached */ } + if (e->ts.type == BT_INTEGER && e->is_boz) + { + gfc_typespec ts; + ts.type = BT_REAL; + ts.kind = kind; + result = gfc_copy_expr (e); + gfc_convert_boz (result, &ts); + } return range_check (result, "REAL"); } |