/* Functions in libgfortran. */
LIBF_FUNCTION (FRACTION, "fraction", false),
LIBF_FUNCTION (NEAREST, "nearest", false),
+ LIBF_FUNCTION (RRSPACING, "rrspacing", false),
LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
+ LIBF_FUNCTION (SPACING, "spacing", false),
/* End the list. */
LIBF_FUNCTION (NONE, NULL, false)
se->expr = convert (type, se->expr);
}
-/* Prepare components and related information of a real number which is
- the first argument of a elemental functions to manipulate reals. */
-
-static void
-prepare_arg_info (gfc_se * se, gfc_expr * expr,
- real_compnt_info * rcs, int all)
-{
- tree arg;
- tree masktype;
- tree tmp;
- tree wbits;
- tree one;
- tree exponent, fraction;
- int n;
- gfc_expr *a1;
-
- if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
- gfc_todo_error ("Non-IEEE floating format");
-
- gcc_assert (expr->expr_type == EXPR_FUNCTION);
-
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
- rcs->type = TREE_TYPE (arg);
-
- /* Force arg'type to integer by unaffected convert */
- a1 = expr->value.function.actual->expr;
- masktype = gfc_get_int_type (a1->ts.kind);
- rcs->mtype = masktype;
- tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
- arg = gfc_create_var (masktype, "arg");
- gfc_add_modify_expr(&se->pre, arg, tmp);
- rcs->arg = arg;
-
- /* Calculate the numbers of bits of exponent, fraction and word */
- n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
- tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
- rcs->fdigits = convert (masktype, tmp);
- wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
- wbits = convert (masktype, wbits);
- rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
-
- /* Form masks for exponent/fraction/sign */
- one = gfc_build_const (masktype, integer_one_node);
- rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
- rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
- rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
- rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
- /* Form bias. */
- tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
- tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
- rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
-
- if (all)
- {
- /* exponent, and fraction */
- tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
- tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
- exponent = gfc_create_var (masktype, "exponent");
- gfc_add_modify_expr(&se->pre, exponent, tmp);
- rcs->expn = exponent;
-
- tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
- fraction = gfc_create_var (masktype, "fraction");
- gfc_add_modify_expr(&se->pre, fraction, tmp);
- rcs->frac = fraction;
- }
-}
-
-/* Build a call to __builtin_clz. */
-
-static tree
-call_builtin_clz (tree result_type, tree op0)
-{
- tree fn, parms, call;
- enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
-
- if (op0_mode == TYPE_MODE (integer_type_node))
- fn = built_in_decls[BUILT_IN_CLZ];
- else if (op0_mode == TYPE_MODE (long_integer_type_node))
- fn = built_in_decls[BUILT_IN_CLZL];
- else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
- fn = built_in_decls[BUILT_IN_CLZLL];
- else
- gcc_unreachable ();
-
- parms = tree_cons (NULL, op0, NULL);
- call = build_function_call_expr (fn, parms);
-
- return convert (result_type, call);
-}
-
-
-/* Generate code for SPACING (X) intrinsic function.
- SPACING (X) = POW (2, e-p)
-
- We generate:
-
- t = expn - fdigits // e - p.
- res = t << fdigits // Form the exponent. Fraction is zero.
- if (t < 0) // The result is out of range. Denormalized case.
- res = tiny(X)
- */
-
-static void
-gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
-{
- tree arg;
- tree masktype;
- tree tmp, t1, cond;
- tree tiny, zero;
- tree fdigits;
- real_compnt_info rcs;
-
- prepare_arg_info (se, expr, &rcs, 0);
- arg = rcs.arg;
- masktype = rcs.mtype;
- fdigits = rcs.fdigits;
- tiny = rcs.f1;
- zero = gfc_build_const (masktype, integer_zero_node);
- tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
- tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
- cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
- t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
- tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
-
- se->expr = tmp;
-}
-
-/* Generate code for RRSPACING (X) intrinsic function.
- RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
-
- So the result's exponent is p. And if X is normalized, X's fraction part
- is the result's fraction. If X is denormalized, to get the X's fraction we
- shift X's fraction part to left until the first '1' is removed.
-
- We generate:
-
- if (expn == 0 && frac == 0)
- res = 0;
- else
- {
- // edigits is the number of exponent bits. Add the sign bit.
- sedigits = edigits + 1;
-
- if (expn == 0) // Denormalized case.
- {
- t1 = leadzero (frac);
- frac = frac << (t1 + 1); //Remove the first '1'.
- frac = frac >> (sedigits); //Form the fraction.
- }
-
- //fdigits is the number of fraction bits. Form the exponent.
- t = bias + fdigits;
-
- res = (t << fdigits) | frac;
- }
-*/
-
-static void
-gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
-{
- tree masktype;
- tree tmp, t1, t2, cond, cond2;
- tree one, zero;
- tree fdigits, fraction;
- real_compnt_info rcs;
-
- prepare_arg_info (se, expr, &rcs, 1);
- masktype = rcs.mtype;
- fdigits = rcs.fdigits;
- fraction = rcs.frac;
- one = gfc_build_const (masktype, integer_one_node);
- zero = gfc_build_const (masktype, integer_zero_node);
- t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
-
- t1 = call_builtin_clz (masktype, fraction);
- tmp = build2 (PLUS_EXPR, masktype, t1, one);
- tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
- tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
- cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
- fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
-
- tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
- tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
-
- cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
- cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
- tmp = build3 (COND_EXPR, masktype, cond,
- build_int_cst (masktype, 0), tmp);
-
- tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
- se->expr = tmp;
-}
/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
gfc_conv_intrinsic_exponent (se, expr);
break;
- case GFC_ISYM_SPACING:
- gfc_conv_intrinsic_spacing (se, expr);
- break;
-
- case GFC_ISYM_RRSPACING:
- gfc_conv_intrinsic_rrspacing (se, expr);
- break;
-
case GFC_ISYM_SCAN:
gfc_conv_intrinsic_scan (se, expr);
break;
OSDN Git Service
