int gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size, mpfr_t real) { mpfr_init (real); gfc_conv_tree_to_mpfr (real, native_interpret_expr (gfc_get_real_type (kind), buffer, buffer_size)); return size_float (kind); }
tree gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan) { tree type; int n; REAL_VALUE_TYPE real; n = gfc_validate_kind (BT_REAL, kind, false); gcc_assert (gfc_real_kinds[n].radix == 2); type = gfc_get_real_type (kind); if (mpfr_nan_p (f) && is_snan) real_from_string (&real, "SNaN"); else real_from_mpfr (&real, f, type, GFC_RND_MODE); return build_real (type, real); }
tree gfc_conv_constant_to_tree (gfc_expr * expr) { tree res; gcc_assert (expr->expr_type == EXPR_CONSTANT); /* If it is has a prescribed memory representation, we build a string constant and VIEW_CONVERT to its type. */ switch (expr->ts.type) { case BT_INTEGER: if (expr->representation.string) return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_int_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); else return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); case BT_REAL: if (expr->representation.string) return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_real_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); else return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan); case BT_LOGICAL: if (expr->representation.string) { tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_int_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); if (!integer_zerop (tmp) && !integer_onep (tmp)) gfc_warning ("Assigning value other than 0 or 1 to LOGICAL" " has undefined result at %L", &expr->where); return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp); } else return build_int_cst (gfc_get_logical_type (expr->ts.kind), expr->value.logical); case BT_COMPLEX: if (expr->representation.string) return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_complex_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); else { tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex), expr->ts.kind, expr->is_snan); tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex), expr->ts.kind, expr->is_snan); return build_complex (gfc_typenode_for_spec (&expr->ts), real, imag); } case BT_CHARACTER: res = gfc_build_wide_string_const (expr->ts.kind, expr->value.character.length, expr->value.character.string); return res; case BT_HOLLERITH: return gfc_build_string_const (expr->representation.length, expr->representation.string); default: fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s", gfc_typename (&expr->ts)); } }
static size_t size_float (int kind) { return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));; }
tree gfc_conv_mpfr_to_tree (mpfr_t f, int kind) { tree res; tree type; mp_exp_t exp; char *p; char *q; int n; int edigits; for (n = 0; gfc_real_kinds[n].kind != 0; n++) { if (gfc_real_kinds[n].kind == kind) break; } gcc_assert (gfc_real_kinds[n].kind); n = MAX (abs (gfc_real_kinds[n].min_exponent), abs (gfc_real_kinds[n].max_exponent)); edigits = 1; while (n > 0) { n = n / 10; edigits += 3; } if (kind == gfc_default_double_kind) p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE); else p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE); /* We also have one minus sign, "e", "." and a null terminator. */ q = (char *) gfc_getmem (strlen (p) + edigits + 4); if (p[0]) { if (p[0] == '-') { strcpy (&q[2], &p[1]); q[0] = '-'; q[1] = '.'; } else { strcpy (&q[1], p); q[0] = '.'; } strcat (q, "e"); sprintf (&q[strlen (q)], "%d", (int) exp); } else { strcpy (q, "0"); } type = gfc_get_real_type (kind); res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type))); gfc_free (q); gfc_free (p); return res; }