/* 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)
/* Round a real value using the specified rounding mode.
We use a temporary integer of that same kind size as the result.
Values larger than those that can be represented by this kind are
- unchanged, as thay will not be accurate enough to represent the
+ unchanged, as they will not be accurate enough to represent the
rounding.
huge = HUGE (KIND (a))
aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
if (m->libm_name)
{
- gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
- || ts->kind == 16);
- snprintf (name, sizeof (name), "%s%s%s",
- ts->type == BT_COMPLEX ? "c" : "",
- m->name,
- ts->kind == 4 ? "f" : "");
+ if (ts->kind == 4)
+ snprintf (name, sizeof (name), "%s%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
+ else if (ts->kind == 8)
+ snprintf (name, sizeof (name), "%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name);
+ else
+ {
+ gcc_assert (ts->kind == 10 || ts->kind == 16);
+ snprintf (name, sizeof (name), "%s%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
+ }
}
else
{
tree type;
tree bound;
tree tmp;
- tree cond;
+ tree cond, cond1, cond2, cond3, size;
+ tree ubound;
+ tree lbound;
gfc_se argse;
gfc_ss *ss;
+ gfc_array_spec * as;
+ gfc_ref *ref;
int i;
arg = expr->value.function.actual;
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
- gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
+ gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL);
}
}
- if (upper)
- se->expr = gfc_conv_descriptor_ubound(desc, bound);
+ ubound = gfc_conv_descriptor_ubound (desc, bound);
+ lbound = gfc_conv_descriptor_lbound (desc, bound);
+
+ /* Follow any component references. */
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ || arg->expr->expr_type == EXPR_CONSTANT)
+ {
+ as = arg->expr->symtree->n.sym->as;
+ for (ref = arg->expr->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ continue;
+
+ case REF_ARRAY:
+ {
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ case AR_SECTION:
+ case AR_UNKNOWN:
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ break;
+ }
+ }
+ }
+ }
+ }
else
- se->expr = gfc_conv_descriptor_lbound(desc, bound);
+ as = NULL;
+
+ /* 13.14.53: Result value for LBOUND
+
+ Case (i): For an array section or for an array expression other than a
+ whole array or array structure component, LBOUND(ARRAY, DIM)
+ has the value 1. For a whole array or array structure
+ component, LBOUND(ARRAY, DIM) has the value:
+ (a) equal to the lower bound for subscript DIM of ARRAY if
+ dimension DIM of ARRAY does not have extent zero
+ or if ARRAY is an assumed-size array of rank DIM,
+ or (b) 1 otherwise.
+
+ 13.14.113: Result value for UBOUND
+
+ Case (i): For an array section or for an array expression other than a
+ whole array or array structure component, UBOUND(ARRAY, DIM)
+ has the value equal to the number of elements in the given
+ dimension; otherwise, it has a value equal to the upper bound
+ for subscript DIM of ARRAY if dimension DIM of ARRAY does
+ not have size zero and has value zero if dimension DIM has
+ size zero. */
+
+ if (as)
+ {
+ tree stride = gfc_conv_descriptor_stride (desc, bound);
+ cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
+ cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
+ cond3 = fold_build2 (GT_EXPR, boolean_type_node, stride,
+ gfc_index_zero_node);
+
+ if (upper)
+ {
+ cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+ cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond2);
+
+ se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ ubound, gfc_index_zero_node);
+ }
+ else
+ {
+ if (as->type == AS_ASSUMED_SIZE)
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank));
+ else
+ cond = boolean_false_node;
+
+ cond1 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+ cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond1, cond2);
+
+ cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
+
+ se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ lbound, gfc_index_one_node);
+ }
+ }
+ else
+ {
+ if (upper)
+ {
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+ se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
+ }
+ else
+ se->expr = gfc_index_one_node;
+ }
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
tree test;
tree test2;
mpfr_t huge;
- int n;
+ int n, ikind;
arg = gfc_conv_intrinsic_function_args (se, expr);
arg2 = TREE_VALUE (TREE_CHAIN (arg));
/* Test if the value is too large to handle sensibly. */
gfc_set_model_kind (expr->ts.kind);
mpfr_init (huge);
- n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+ n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
+ ikind = expr->ts.kind;
+ if (n < 0)
+ {
+ n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
+ ikind = gfc_max_integer_kind;
+ }
mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
test = build2 (GT_EXPR, boolean_type_node, tmp, test);
test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
- itype = gfc_get_int_type (expr->ts.kind);
+ itype = gfc_get_int_type (ikind);
if (modulo)
tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
else
gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
{
gfc_symbol *sym;
+ tree append_args;
gcc_assert (!se->ss || se->ss->expr == expr);
gcc_assert (expr->rank == 0);
sym = gfc_get_symbol_for_expr (expr);
- gfc_conv_function_call (se, sym, expr->value.function.actual);
+
+ /* Calls to libgfortran_matmul need to be appended special arguments,
+ to be able to call the BLAS ?gemm functions if required and possible. */
+ append_args = NULL_TREE;
+ if (expr->value.function.isym->generic_id == GFC_ISYM_MATMUL
+ && sym->ts.type != BT_LOGICAL)
+ {
+ tree cint = gfc_get_int_type (gfc_c_int_kind);
+
+ if (gfc_option.flag_external_blas
+ && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
+ && (sym->ts.kind == gfc_default_real_kind
+ || sym->ts.kind == gfc_default_double_kind))
+ {
+ tree gemm_fndecl;
+
+ if (sym->ts.type == BT_REAL)
+ {
+ if (sym->ts.kind == gfc_default_real_kind)
+ gemm_fndecl = gfor_fndecl_sgemm;
+ else
+ gemm_fndecl = gfor_fndecl_dgemm;
+ }
+ else
+ {
+ if (sym->ts.kind == gfc_default_real_kind)
+ gemm_fndecl = gfor_fndecl_cgemm;
+ else
+ gemm_fndecl = gfor_fndecl_zgemm;
+ }
+
+ append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
+ append_args = gfc_chainon_list
+ (append_args, build_int_cst
+ (cint, gfc_option.blas_matmul_limit));
+ append_args = gfc_chainon_list (append_args,
+ gfc_build_addr_expr (NULL_TREE,
+ gemm_fndecl));
+ }
+ else
+ {
+ append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
+ append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
+ append_args = gfc_chainon_list (append_args, null_pointer_node);
+ }
+ }
+
+ gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
gfc_free (sym);
}
se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
}
+/* RSHIFT (I, SHIFT) = I >> SHIFT
+ LSHIFT (I, SHIFT) = I << SHIFT */
+static void
+gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
+{
+ tree arg;
+ tree arg2;
+
+ arg = gfc_conv_intrinsic_function_args (se, expr);
+ arg2 = TREE_VALUE (TREE_CHAIN (arg));
+ arg = TREE_VALUE (arg);
+
+ se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
+ TREE_TYPE (arg), arg, arg2);
+}
+
/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
? 0
: ((shift >= 0) ? i << shift : i >> -shift)
len = build_int_cst (NULL_TREE, arg->value.character.length);
break;
+ case EXPR_ARRAY:
+ /* Obtain the string length from the function used by
+ trans-array.c(gfc_trans_array_constructor). */
+ len = NULL_TREE;
+ get_array_ctor_strlen (arg->value.constructor, &len);
+ break;
+
default:
if (arg->expr_type == EXPR_VARIABLE
&& (arg->ref == NULL || (arg->ref->next == NULL
}
+/* A helper function for gfc_conv_intrinsic_array_transfer to compute
+ the size of tree expressions in bytes. */
+static tree
+gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
+{
+ tree tmp;
+
+ if (e->ts.type == BT_CHARACTER)
+ tmp = se->string_length;
+ else
+ {
+ if (e->rank)
+ {
+ tmp = gfc_get_element_type (TREE_TYPE (se->expr));
+ tmp = size_in_bytes (tmp);
+ }
+ else
+ tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
+ }
+
+ return fold_convert (gfc_array_index_type, tmp);
+}
+
+
/* Array transfer statement.
DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
where:
tree lower;
tree stride;
tree stmt;
+ tree args;
gfc_actual_arglist *arg;
gfc_se argse;
gfc_ss *ss;
source = argse.expr;
/* Obtain the source word length. */
- tmp = size_in_bytes(TREE_TYPE(TREE_TYPE (source)));
- tmp = fold_convert (gfc_array_index_type, tmp);
+ tmp = gfc_size_in_bytes (&argse, arg->expr);
}
else
{
}
/* Obtain the source word length. */
- tmp = gfc_get_element_type (TREE_TYPE(argse.expr));
- tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+ tmp = gfc_size_in_bytes (&argse, arg->expr);
/* Obtain the size of the array in bytes. */
extent = gfc_create_var (gfc_array_index_type, NULL);
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg->expr);
- tmp = TREE_TYPE(TREE_TYPE (argse.expr));
- tmp = fold_convert (gfc_array_index_type, size_in_bytes(tmp));
+
+ /* Obtain the source word length. */
+ tmp = gfc_size_in_bytes (&argse, arg->expr);
}
else
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg->expr, ss);
- tmp = gfc_get_element_type (TREE_TYPE(argse.expr));
- tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+
+ /* Obtain the source word length. */
+ tmp = gfc_size_in_bytes (&argse, arg->expr);
}
dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
data field. This is already allocated so set callee_alloc. */
tmp = gfc_typenode_for_spec (&expr->ts);
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
- info, tmp, false, false, true);
+ info, tmp, false, true, false, false);
+ /* Use memcpy to do the transfer. */
+ tmp = gfc_conv_descriptor_data_get (info->descriptor);
+ args = gfc_chainon_list (NULL_TREE, tmp);
tmp = fold_convert (pvoid_type_node, source);
- gfc_conv_descriptor_data_set (&se->pre, info->descriptor, tmp);
+ args = gfc_chainon_list (args, source);
+ args = gfc_chainon_list (args, size_bytes);
+ tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = build_function_call_expr (tmp, args);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
se->expr = info->descriptor;
if (expr->ts.type == BT_CHARACTER)
se->string_length = dest_word_len;
tree tmp2;
tree tmp;
tree args, fndecl;
+ tree nonzero_charlen;
+ tree nonzero_arraylen;
gfc_ss *ss1, *ss2;
gfc_init_se (&arg1se, NULL);
gfc_conv_expr_lhs (&arg1se, arg1->expr);
tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
}
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
fold_convert (TREE_TYPE (tmp2), null_pointer_node));
se->expr = tmp;
{
/* An optional target. */
ss2 = gfc_walk_expr (arg2->expr);
+
+ nonzero_charlen = NULL_TREE;
+ if (arg1->expr->ts.type == BT_CHARACTER)
+ nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
+ arg1->expr->ts.cl->backend_decl,
+ integer_zero_node);
+
if (ss1 == gfc_ss_terminator)
{
/* A pointer to a scalar. */
gfc_conv_expr (&arg1se, arg1->expr);
arg2se.want_pointer = 1;
gfc_conv_expr (&arg2se, arg2->expr);
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
se->expr = tmp;
}
else
{
+
+ /* An array pointer of zero length is not associated if target is
+ present. */
+ arg1se.descriptor_only = 1;
+ gfc_conv_expr_lhs (&arg1se, arg1->expr);
+ tmp = gfc_conv_descriptor_stride (arg1se.expr,
+ gfc_rank_cst[arg1->expr->rank - 1]);
+ nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
+ tmp, integer_zero_node);
+
/* A pointer to an array, call library function _gfor_associated. */
gcc_assert (ss2 != gfc_ss_terminator);
args = NULL_TREE;
arg1se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
args = gfc_chainon_list (args, arg1se.expr);
+
arg2se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
args = gfc_chainon_list (args, arg2se.expr);
fndecl = gfor_fndecl_associated;
se->expr = build_function_call_expr (fndecl, args);
+ se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+ se->expr, nonzero_arraylen);
+
}
- }
+
+ /* If target is present zero character length pointers cannot
+ be associated. */
+ if (nonzero_charlen != NULL_TREE)
+ se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+ se->expr, nonzero_charlen);
+ }
+
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
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;
/* Integer conversions are handled separately to make sure we get the
correct rounding mode. */
case GFC_ISYM_INT:
+ case GFC_ISYM_INT2:
+ case GFC_ISYM_INT8:
+ case GFC_ISYM_LONG:
gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
break;
gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
break;
+ case GFC_ISYM_LSHIFT:
+ gfc_conv_intrinsic_rlshift (se, expr, 0);
+ break;
+
+ case GFC_ISYM_RSHIFT:
+ gfc_conv_intrinsic_rlshift (se, expr, 1);
+ break;
+
case GFC_ISYM_ISHFT:
gfc_conv_intrinsic_ishft (se, expr);
break;
gfc_conv_intrinsic_loc (se, expr);
break;
+ case GFC_ISYM_ACCESS:
case GFC_ISYM_CHDIR:
+ case GFC_ISYM_CHMOD:
case GFC_ISYM_ETIME:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
case GFC_ISYM_IRAND:
case GFC_ISYM_ISATTY:
case GFC_ISYM_LINK:
+ case GFC_ISYM_LSTAT:
case GFC_ISYM_MALLOC:
case GFC_ISYM_MATMUL:
+ case GFC_ISYM_MCLOCK:
+ case GFC_ISYM_MCLOCK8:
case GFC_ISYM_RAND:
case GFC_ISYM_RENAME:
case GFC_ISYM_SECOND: