[fortran patch] Don't use TREE_LISTs for storing arguments to intrinsic functions
Lee Millward
lee.millward@codesourcery.com
Mon May 7 22:20:00 GMT 2007
Hi,
This patch modifies the handing of intrinsic functions to not use a
TREE_LIST for storing the arguments to instead use a stack allocated
array and use the new CALL_EXPR constructors. In order to make this
work, I've modifed gfc_conv_intrinsic_function_args to take two new
parameters - a pre-allocated array of arguments to be populated and a
length parameter to denote the number of elements. All callers of this
function have been modifed to allocate an array of the correct size to
pass into this function and update uses of the arguments with them
accordingly.
For most of the callers, the number of arguments required is already
known. However, in some cases this isn't true so a new function
(gfc_intrinsic_argument_list_length) has been added that returns the
number of arguments for an intrinsic function to use for allocating
the arguments array.
Bootstrapped and regression tested with no new failures on
i686-pc-linux-gnu, ok to apply?
Cheers,
Lee.
2007-05-07 Lee Millward <lee.millward@codesourcery.com>
* trans-intrinsic.c (gfc_conv_intrinsic_function_args): Adjust
to operate on a stack allocated array for the intrinsic arguments
instead of creating a TREE_LIST. Add two new parameters for the
array and the number of elements. Update all callers to allocate
an array of the correct length to pass in.
(gfc_intrinsic_argument_list_length): New function.
(gfc_conv_intrinsic_mnimax): Call it.
(gfc_conv_intrinsic_merge): Likewise.
(gfc_conv_intrinsic_lib_function): Call it. Use new CALL_EXPR
constructors.
(gfc_conv_intrinsic_cmplx): Likewise.
(gfc_conv_intrinsic_ctime): Likewise.
(gfc_covn_intrinsic_fdate): Likewise.
(gfc_conv_intrinsic_ttynam): Likewise.
(gfc_conv_intrinsic_ishftc): Likewise.
(gfc_conv_intrinsic_index): Likewise.
(gfc_conv_intrinsic_scan): Likewise.
(gfc_conv_intrinsic_verify): Likewise.
(gfc_conv_intrinsic_trim): Likewise.
(gfc_conv_intrinsic_aint): Use new CALL_EXPR constructors.
(gfc_conv_intrinsic_exponent): Likewise.
(gfc_conv_intrinsic_bound): Likewise.
(gfc_conv_intrinsic_abs): Likewise.
(gfc_conv_intrinsic_mod): Likewise.
(gfc_conv_intrinsic_sign): Likewise.
(gfc_conv_intrinsic_len): Likewise.
(gfc_conv_intrinsic_adjust): Likewise.
(gfc_conv_intrinsic_si_kind): Likewise.
-------------- next part --------------
Index: trans-intrinsic.c
===================================================================
--- trans-intrinsic.c (revision 124499)
+++ trans-intrinsic.c (working copy)
@@ -164,19 +164,17 @@ real_compnt_info;
enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
/* Evaluate the arguments to an intrinsic function. */
-/* FIXME: This function and its callers should be rewritten so that it's
- not necessary to cons up a list to hold the arguments. */
-static tree
-gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
+static void
+gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr,
+ tree *argarray, int nargs)
{
gfc_actual_arglist *actual;
gfc_expr *e;
gfc_intrinsic_arg *formal;
gfc_se argse;
- tree args;
+ int curr_arg = 0;
- args = NULL_TREE;
formal = expr->value.function.isym->formal;
for (actual = expr->value.function.actual; actual; actual = actual->next,
@@ -195,7 +193,8 @@ gfc_conv_intrinsic_function_args (gfc_se
{
gfc_conv_expr (&argse, e);
gfc_conv_string_parameter (&argse);
- args = gfc_chainon_list (args, argse.string_length);
+ gcc_assert (curr_arg < nargs);
+ argarray[curr_arg++] = argse.string_length;
}
else
gfc_conv_expr_val (&argse, e);
@@ -210,9 +209,34 @@ gfc_conv_intrinsic_function_args (gfc_se
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- args = gfc_chainon_list (args, argse.expr);
+ gcc_assert (curr_arg < nargs);
+ argarray[curr_arg++] = argse.expr;
}
- return args;
+}
+
+/* Count the number of actual arguments to the intrinsic function EXPR
+ including any "hidden" string length arguments. */
+
+static int
+gfc_intrinsic_argument_list_length (gfc_expr * expr)
+{
+ int n = 0;
+ gfc_actual_arglist *actual;
+ gfc_intrinsic_arg *formal = expr->value.function.isym->formal;;
+
+ for (actual = expr->value.function.actual; actual; actual = actual->next,
+ formal = formal ? formal->next : NULL)
+ {
+ if(!actual->expr)
+ continue;
+
+ if (actual->expr->ts.type == BT_CHARACTER)
+ n += 2;
+ else
+ n++;
+ }
+
+ return n;
}
@@ -223,26 +247,25 @@ static void
gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
{
tree type;
- tree arg;
+ tree args[2];
/* Evaluate the argument. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
/* Conversion from complex to non-complex involves taking the real
component of the value. */
- if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
&& expr->ts.type != BT_COMPLEX)
{
tree artype;
- artype = TREE_TYPE (TREE_TYPE (arg));
- arg = build1 (REALPART_EXPR, artype, arg);
+ artype = TREE_TYPE (TREE_TYPE (args[0]));
+ args[0] = build1 (REALPART_EXPR, artype, args[0]);
}
- se->expr = convert (type, arg);
+ se->expr = convert (type, args[0]);
}
/* This is needed because the gcc backend only implements
@@ -347,7 +370,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gf
{
tree type;
tree itype;
- tree arg;
+ tree args[2];
tree tmp;
tree cond;
mpfr_t huge;
@@ -402,21 +425,20 @@ gfc_conv_intrinsic_aint (gfc_se * se, gf
/* Evaluate the argument. */
gcc_assert (expr->value.function.actual->expr);
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
/* Use a builtin function if one exists. */
if (n != END_BUILTINS)
{
tmp = built_in_decls[n];
- se->expr = build_function_call_expr (tmp, arg);
+ se->expr = build_call_expr (tmp, 1, args[0]);
return;
}
/* This code is probably redundant, but we'll keep it lying around just
in case. */
type = gfc_typenode_for_spec (&expr->ts);
- arg = TREE_VALUE (arg);
- arg = gfc_evaluate_now (arg, &se->pre);
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
/* Test if the value is too large to handle sensibly. */
gfc_set_model_kind (kind);
@@ -424,17 +446,17 @@ gfc_conv_intrinsic_aint (gfc_se * se, gf
n = gfc_validate_kind (BT_INTEGER, kind, false);
mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
tmp = gfc_conv_mpfr_to_tree (huge, kind);
- cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
+ cond = build2 (LT_EXPR, boolean_type_node, args[0], tmp);
mpfr_neg (huge, huge, GFC_RND_MODE);
tmp = gfc_conv_mpfr_to_tree (huge, kind);
- tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
+ tmp = build2 (GT_EXPR, boolean_type_node, args[0], tmp);
cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
itype = gfc_get_int_type (kind);
- tmp = build_fix_expr (&se->pre, arg, itype, op);
+ tmp = build_fix_expr (&se->pre, args[0], itype, op);
tmp = convert (type, tmp);
- se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
+ se->expr = build3 (COND_EXPR, type, cond, tmp, args[0]);
mpfr_clear (huge);
}
@@ -445,33 +467,32 @@ static void
gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
{
tree type;
- tree arg;
+ tree args[2];
/* Evaluate the argument. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
- if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
+ if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
{
/* Conversion to a different integer kind. */
- se->expr = convert (type, arg);
+ se->expr = convert (type, args[0]);
}
else
{
/* Conversion from complex to non-complex involves taking the real
component of the value. */
- if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
&& expr->ts.type != BT_COMPLEX)
{
tree artype;
- artype = TREE_TYPE (TREE_TYPE (arg));
- arg = build1 (REALPART_EXPR, artype, arg);
+ artype = TREE_TYPE (TREE_TYPE (args[0]));
+ args[0] = build1 (REALPART_EXPR, artype, args[0]);
}
- se->expr = build_fix_expr (&se->pre, arg, type, op);
+ se->expr = build_fix_expr (&se->pre, args[0], type, op);
}
}
@@ -481,10 +502,9 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc
static void
gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
{
- tree arg;
+ tree arg = NULL_TREE;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
}
@@ -494,10 +514,9 @@ gfc_conv_intrinsic_imagpart (gfc_se * se
static void
gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
{
- tree arg;
+ tree arg = NULL_TREE;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
}
@@ -647,8 +666,10 @@ static void
gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
{
gfc_intrinsic_map_t *m;
- tree args;
tree fndecl;
+ tree rettype;
+ tree *args;
+ int num_args;
gfc_generic_isym_id id;
id = expr->value.function.isym->generic_id;
@@ -666,9 +687,16 @@ gfc_conv_intrinsic_lib_function (gfc_se
}
/* Get the decl and generate the call. */
- args = gfc_conv_intrinsic_function_args (se, expr);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * num_args);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
- se->expr = build_function_call_expr (fndecl, args);
+ rettype = TREE_TYPE (TREE_TYPE (fndecl));
+
+ fndecl = build_addr (fndecl, current_function_decl);
+ se->expr = build_call_array (rettype, fndecl, num_args, args);
+ se->expr = se->expr;
}
/* Generate code for EXPONENT(X) intrinsic function. */
@@ -676,10 +704,10 @@ gfc_conv_intrinsic_lib_function (gfc_se
static void
gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
{
- tree args, fndecl;
+ tree arg, fndecl;
gfc_expr *a1;
- args = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
a1 = expr->value.function.actual->expr;
switch (a1->ts.kind)
@@ -700,7 +728,7 @@ gfc_conv_intrinsic_exponent (gfc_se * se
gcc_unreachable ();
}
- se->expr = build_function_call_expr (fndecl, args);
+ se->expr = build_call_expr (fndecl, 1, arg);
}
/* Evaluate a single upper or lower bound. */
@@ -904,19 +932,16 @@ gfc_conv_intrinsic_bound (gfc_se * se, g
static void
gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
{
- tree args;
- tree val;
+ tree arg = NULL_TREE;
int n;
- args = gfc_conv_intrinsic_function_args (se, expr);
- gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
- val = TREE_VALUE (args);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
switch (expr->value.function.actual->expr->ts.type)
{
case BT_INTEGER:
case BT_REAL:
- se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
+ se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);
break;
case BT_COMPLEX:
@@ -935,7 +960,7 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc
default:
gcc_unreachable ();
}
- se->expr = build_function_call_expr (built_in_decls[n], args);
+ se->expr = build_call_expr (built_in_decls[n], 1, arg);
break;
default:
@@ -946,23 +971,27 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc
/* Create a complex value from one or two real components. */
+
static void
gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
{
- tree arg;
tree real;
tree imag;
tree type;
+ tree *args;
+ int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length(expr);
+ args = alloca (sizeof(tree) * num_args);
type = gfc_typenode_for_spec (&expr->ts);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- real = convert (TREE_TYPE (type), TREE_VALUE (arg));
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+ real = convert (TREE_TYPE (type), args[0]);
if (both)
- imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
- else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
+ imag = convert (TREE_TYPE (type), args[1]);
+ else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
{
- arg = TREE_VALUE (arg);
- imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
+ imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);
imag = convert (TREE_TYPE (type), imag);
}
else
@@ -971,6 +1000,7 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, g
se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
}
+
/* Remainder function MOD(A, P) = A - INT(A / P) * P
MODULO(A, P) = A - FLOOR (A / P) * P */
/* TODO: MOD(x, 0) */
@@ -978,8 +1008,6 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, g
static void
gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
{
- tree arg;
- tree arg2;
tree type;
tree itype;
tree tmp;
@@ -987,21 +1015,20 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
tree test2;
mpfr_t huge;
int n, ikind;
+ tree args[2];
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
switch (expr->ts.type)
{
case BT_INTEGER:
/* Integer case is easy, we've got a builtin op. */
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ type = TREE_TYPE (args[0]);
if (modulo)
- se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
+ se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
else
- se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
+ se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
break;
case BT_REAL:
@@ -1029,18 +1056,17 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
/* Use it if it exists. */
if (n != END_BUILTINS)
{
- tmp = built_in_decls[n];
- se->expr = build_function_call_expr (tmp, arg);
+ tmp = build_addr (built_in_decls[n], current_function_decl);
+ se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
+ tmp, 2, args);
if (modulo == 0)
return;
}
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ type = TREE_TYPE (args[0]);
- arg = gfc_evaluate_now (arg, &se->pre);
- arg2 = gfc_evaluate_now (arg2, &se->pre);
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
+ args[1] = gfc_evaluate_now (args[1], &se->pre);
/* Definition:
modulo = arg - floor (arg/arg2) * arg2, so
@@ -1053,20 +1079,20 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
{
tree zero = gfc_build_const (type, integer_zero_node);
tmp = gfc_evaluate_now (se->expr, &se->pre);
- test = build2 (LT_EXPR, boolean_type_node, arg, zero);
- test2 = build2 (LT_EXPR, boolean_type_node, arg2, zero);
+ test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
+ test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
test = gfc_evaluate_now (test, &se->pre);
se->expr = build3 (COND_EXPR, type, test,
- build2 (PLUS_EXPR, type, tmp, arg2), tmp);
+ build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
return;
}
/* If we do not have a built_in fmod, the calculation is going to
have to be done longhand. */
- tmp = build2 (RDIV_EXPR, type, arg, arg2);
+ tmp = build2 (RDIV_EXPR, type, args[0], args[1]);
/* Test if the value is too large to handle sensibly. */
gfc_set_model_kind (expr->ts.kind);
@@ -1093,9 +1119,9 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
else
tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
tmp = convert (type, tmp);
- tmp = build3 (COND_EXPR, type, test2, tmp, arg);
- tmp = build2 (MULT_EXPR, type, tmp, arg2);
- se->expr = build2 (MINUS_EXPR, type, arg, tmp);
+ tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
+ tmp = build2 (MULT_EXPR, type, tmp, args[1]);
+ se->expr = build2 (MINUS_EXPR, type, args[0], tmp);
mpfr_clear (huge);
break;
@@ -1109,19 +1135,16 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
static void
gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
tree val;
tree tmp;
tree type;
tree zero;
+ tree args[2];
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
-
- val = build2 (MINUS_EXPR, type, arg, arg2);
+ val = build2 (MINUS_EXPR, type, args[0], args[1]);
val = gfc_evaluate_now (val, &se->pre);
zero = gfc_build_const (type, integer_zero_node);
@@ -1140,11 +1163,10 @@ static void
gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
{
tree tmp;
- tree arg;
- tree arg2;
tree type;
+ tree args[2];
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
if (expr->ts.type == BT_REAL)
{
switch (expr->ts.kind)
@@ -1162,22 +1184,20 @@ gfc_conv_intrinsic_sign (gfc_se * se, gf
default:
gcc_unreachable ();
}
- se->expr = build_function_call_expr (tmp, arg);
+ se->expr = build_call_expr (tmp, 2, args[0], args[1]);
return;
}
/* Having excluded floating point types, we know we are now dealing
with signed integer types. */
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ type = TREE_TYPE (args[0]);
- /* Arg is used multiple times below. */
- arg = gfc_evaluate_now (arg, &se->pre);
+ /* Args[0] is used multiple times below. */
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
/* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
the signs of A and B are the same, and of all ones if they differ. */
- tmp = fold_build2 (BIT_XOR_EXPR, type, arg, arg2);
+ tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
build_int_cst (type, TYPE_PRECISION (type) - 1));
tmp = gfc_evaluate_now (tmp, &se->pre);
@@ -1185,7 +1205,7 @@ gfc_conv_intrinsic_sign (gfc_se * se, gf
/* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
is all ones (i.e. -1). */
se->expr = fold_build2 (BIT_XOR_EXPR, type,
- fold_build2 (PLUS_EXPR, type, arg, tmp),
+ fold_build2 (PLUS_EXPR, type, args[0], tmp),
tmp);
}
@@ -1209,19 +1229,16 @@ gfc_conv_intrinsic_present (gfc_se * se,
static void
gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
tree type;
-
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
+ tree args[2];
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
/* Convert the args to double precision before multiplying. */
type = gfc_typenode_for_spec (&expr->ts);
- arg = convert (type, arg);
- arg2 = convert (type, arg2);
- se->expr = build2 (MULT_EXPR, type, arg, arg2);
+ args[0] = convert (type, args[0]);
+ args[1] = convert (type, args[1]);
+ se->expr = build2 (MULT_EXPR, type, args[0], args[1]);
}
@@ -1230,20 +1247,19 @@ gfc_conv_intrinsic_dprod (gfc_se * se, g
static void
gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
{
- tree arg;
+ tree args[2];
tree var;
tree type;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
/* We currently don't support character types != 1. */
gcc_assert (expr->ts.kind == 1);
type = gfc_character1_type_node;
var = gfc_create_var (type, "char");
- arg = convert (type, arg);
- gfc_add_modify_expr (&se->pre, var, arg);
+ args[0] = convert (type, args[0]);
+ gfc_add_modify_expr (&se->pre, var, args[0]);
se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
se->string_length = integer_one_node;
}
@@ -1255,21 +1271,27 @@ gfc_conv_intrinsic_ctime (gfc_se * se, g
tree var;
tree len;
tree tmp;
- tree arglist;
tree type;
tree cond;
tree gfc_int8_type_node = gfc_get_int_type (8);
+ tree fndecl;
+ tree *args;
+ int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = alloca (sizeof (tree) * num_args);
type = build_pointer_type (gfc_character1_type_node);
var = gfc_create_var (type, "pstr");
len = gfc_create_var (gfc_int8_type_node, "len");
- tmp = gfc_conv_intrinsic_function_args (se, expr);
- arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
- arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
- arglist = chainon (arglist, tmp);
-
- tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = build_fold_addr_expr (var);
+ args[1] = build_fold_addr_expr (len);
+
+ fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
+ fndecl, num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
@@ -1290,21 +1312,27 @@ gfc_conv_intrinsic_fdate (gfc_se * se, g
tree var;
tree len;
tree tmp;
- tree arglist;
tree type;
tree cond;
tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree fndecl;
+ tree *args;
+ int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = alloca (sizeof (tree) * num_args);
type = build_pointer_type (gfc_character1_type_node);
var = gfc_create_var (type, "pstr");
len = gfc_create_var (gfc_int4_type_node, "len");
- tmp = gfc_conv_intrinsic_function_args (se, expr);
- arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
- arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
- arglist = chainon (arglist, tmp);
-
- tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = build_fold_addr_expr (var);
+ args[1] = build_fold_addr_expr (len);
+
+ fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
+ fndecl, num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
@@ -1327,21 +1355,27 @@ gfc_conv_intrinsic_ttynam (gfc_se * se,
tree var;
tree len;
tree tmp;
- tree arglist;
tree type;
tree cond;
+ tree fndecl;
tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree *args;
+ int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = alloca (sizeof (tree) * num_args);
type = build_pointer_type (gfc_character1_type_node);
var = gfc_create_var (type, "pstr");
len = gfc_create_var (gfc_int4_type_node, "len");
- tmp = gfc_conv_intrinsic_function_args (se, expr);
- arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
- arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
- arglist = chainon (arglist, tmp);
-
- tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = build_fold_addr_expr (var);
+ args[1] = build_fold_addr_expr (len);
+
+ fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
+ fndecl, num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
@@ -1381,13 +1415,18 @@ gfc_conv_intrinsic_minmax (gfc_se * se,
tree val;
tree thencase;
tree elsecase;
- tree arg;
tree type;
+ tree *args;
+ int num_args;
+ int i;
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * num_args);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
type = gfc_typenode_for_spec (&expr->ts);
- limit = TREE_VALUE (arg);
+ limit = args[0];
if (TREE_TYPE (limit) != type)
limit = convert (type, limit);
/* Only evaluate the argument once. */
@@ -1396,9 +1435,9 @@ gfc_conv_intrinsic_minmax (gfc_se * se,
mvar = gfc_create_var (type, "M");
elsecase = build2_v (MODIFY_EXPR, mvar, limit);
- for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
+ for (i = 0; i < num_args; i++)
{
- val = TREE_VALUE (arg);
+ val = args[i];
if (TREE_TYPE (val) != type)
val = convert (type, val);
@@ -2262,18 +2301,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
static void
gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
+ tree args[2];
tree type;
tree tmp;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
- tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
- tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
+ tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
+ tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (type, 0));
type = gfc_typenode_for_spec (&expr->ts);
@@ -2284,27 +2320,19 @@ gfc_conv_intrinsic_btest (gfc_se * se, g
static void
gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
{
- tree arg;
- tree arg2;
- tree type;
-
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ tree args[2];
- se->expr = fold_build2 (op, type, arg, arg2);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
}
/* Bitwise not. */
static void
gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
{
- tree arg;
-
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ tree arg = NULL_TREE;
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
}
@@ -2312,18 +2340,15 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc
static void
gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
{
- tree arg;
- tree arg2;
+ tree args[2];
tree type;
tree tmp;
int op;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
- tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
+ tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
if (set)
op = BIT_IOR_EXPR;
else
@@ -2331,7 +2356,7 @@ gfc_conv_intrinsic_singlebitop (gfc_se *
op = BIT_AND_EXPR;
tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
}
- se->expr = fold_build2 (op, type, arg, tmp);
+ se->expr = fold_build2 (op, type, args[0], tmp);
}
/* Extract a sequence of bits.
@@ -2339,25 +2364,19 @@ gfc_conv_intrinsic_singlebitop (gfc_se *
static void
gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
- tree arg3;
+ tree args[3];
tree type;
tree tmp;
tree mask;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_CHAIN (arg);
- arg3 = TREE_VALUE (TREE_CHAIN (arg2));
- arg = TREE_VALUE (arg);
- arg2 = TREE_VALUE (arg2);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 3);
+ type = TREE_TYPE (args[0]);
mask = build_int_cst (type, -1);
- mask = build2 (LSHIFT_EXPR, type, mask, arg3);
+ mask = build2 (LSHIFT_EXPR, type, mask, args[2]);
mask = build1 (BIT_NOT_EXPR, type, mask);
- tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
+ tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);
se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
}
@@ -2367,15 +2386,12 @@ gfc_conv_intrinsic_ibits (gfc_se * se, g
static void
gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
{
- tree arg;
- tree arg2;
+ tree args[2];
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
- TREE_TYPE (arg), arg, arg2);
+ TREE_TYPE (args[0]), args[0], args[1]);
}
/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
@@ -2385,8 +2401,7 @@ gfc_conv_intrinsic_rlshift (gfc_se * se,
static void
gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
+ tree args[2];
tree type;
tree utype;
tree tmp;
@@ -2396,16 +2411,14 @@ gfc_conv_intrinsic_ishft (gfc_se * se, g
tree lshift;
tree rshift;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
utype = gfc_unsigned_type (type);
- width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
+ width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
/* Left shift if positive. */
- lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
+ lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
/* Right shift if negative.
We convert to an unsigned type because we want a logical shift.
@@ -2413,16 +2426,16 @@ gfc_conv_intrinsic_ishft (gfc_se * se, g
numbers, and we try to be compatible with other compilers, most
notably g77, here. */
rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
- convert (utype, arg), width));
+ convert (utype, args[0]), width));
- tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
- build_int_cst (TREE_TYPE (arg2), 0));
+ tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
+ build_int_cst (TREE_TYPE (args[1]), 0));
tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
gcc requires a shift width < BIT_SIZE(I), so we have to catch this
special case. */
- num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
+ num_bits = build_int_cst (TREE_TYPE (args[0]), TYPE_PRECISION (type));
cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
se->expr = fold_build3 (COND_EXPR, type, cond,
@@ -2433,38 +2446,37 @@ gfc_conv_intrinsic_ishft (gfc_se * se, g
static void
gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
- tree arg3;
+ tree *args;
tree type;
tree tmp;
tree lrot;
tree rrot;
tree zero;
+ int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * num_args);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_CHAIN (arg);
- arg3 = TREE_CHAIN (arg2);
- if (arg3)
+ if (num_args == 3)
{
/* Use a library function for the 3 parameter version. */
tree int4type = gfc_get_int_type (4);
- type = TREE_TYPE (TREE_VALUE (arg));
+ type = TREE_TYPE (args[0]);
/* We convert the first argument to at least 4 bytes, and
convert back afterwards. This removes the need for library
functions for all argument sizes, and function will be
aligned to at least 32 bits, so there's no loss. */
if (expr->ts.kind < 4)
- {
- tmp = convert (int4type, TREE_VALUE (arg));
- TREE_VALUE (arg) = tmp;
- }
+ args[0] = convert (int4type, args[0]);
+
/* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
need loads of library functions. They cannot have values >
BIT_SIZE (I) so the conversion is safe. */
- TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
- TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
+ args[1] = convert (int4type, args[1]);
+ args[2] = convert (int4type, args[2]);
switch (expr->ts.kind)
{
@@ -2482,7 +2494,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se,
default:
gcc_unreachable ();
}
- se->expr = build_function_call_expr (tmp, arg);
+ se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
/* Convert the result back to the original type, if we extended
the first argument's width above. */
if (expr->ts.kind < 4)
@@ -2490,24 +2502,22 @@ gfc_conv_intrinsic_ishftc (gfc_se * se,
return;
}
- arg = TREE_VALUE (arg);
- arg2 = TREE_VALUE (arg2);
- type = TREE_TYPE (arg);
+ type = TREE_TYPE (args[0]);
/* Rotate left if positive. */
- lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
+ lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
/* Rotate right if negative. */
- tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
- rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
+ rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
- zero = build_int_cst (TREE_TYPE (arg2), 0);
- tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
+ zero = build_int_cst (TREE_TYPE (args[1]), 0);
+ tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
/* Do nothing if shift == 0. */
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
- se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
+ se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
}
/* The length of a character string. */
@@ -2580,12 +2590,12 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc
static void
gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
{
- tree args;
+ tree args[2];
tree type;
- args = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
+ se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
se->expr = convert (type, se->expr);
}
@@ -2596,44 +2606,45 @@ static void
gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
{
tree logical4_type_node = gfc_get_logical_type (4);
- tree args;
- tree back;
tree type;
- tree tmp;
+ tree fndecl;
+ tree *args;
+ int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * 5);
- args = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
type = gfc_typenode_for_spec (&expr->ts);
- tmp = gfc_advance_chain (args, 3);
- if (TREE_CHAIN (tmp) == NULL_TREE)
- {
- back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
- NULL_TREE);
- TREE_CHAIN (tmp) = back;
- }
+
+ if (num_args == 4)
+ args[4] = build_int_cst (logical4_type_node, 0);
else
{
- back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
+ gcc_assert (num_args == 5);
+ args[4] = convert (logical4_type_node, args[4]);
}
- se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
+ fndecl = build_addr (gfor_fndecl_string_index, current_function_decl);
+ se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_index)),
+ fndecl, 5, args);
se->expr = convert (type, se->expr);
+
}
/* The ascii value for a single character. */
static void
gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
{
- tree arg;
+ tree args[2];
tree type;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (TREE_CHAIN (arg));
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
- arg = build1 (NOP_EXPR, pchar_type_node, arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
+ args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_fold_indirect_ref (arg);
+ se->expr = build_fold_indirect_ref (args[1]);
se->expr = convert (type, se->expr);
}
@@ -2643,32 +2654,33 @@ gfc_conv_intrinsic_ichar (gfc_se * se, g
static void
gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
{
- tree arg;
tree tsource;
tree fsource;
tree mask;
tree type;
tree len;
+ tree *args;
+ int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * num_args);
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
if (expr->ts.type != BT_CHARACTER)
{
- tsource = TREE_VALUE (arg);
- arg = TREE_CHAIN (arg);
- fsource = TREE_VALUE (arg);
- mask = TREE_VALUE (TREE_CHAIN (arg));
+ tsource = args[0];
+ fsource = args[1];
+ mask = args[2];
}
else
{
/* We do the same as in the non-character case, but the argument
list is different because of the string length arguments. We
also have to set the string length for the result. */
- len = TREE_VALUE (arg);
- arg = TREE_CHAIN (arg);
- tsource = TREE_VALUE (arg);
- arg = TREE_CHAIN (TREE_CHAIN (arg));
- fsource = TREE_VALUE (arg);
- mask = TREE_VALUE (TREE_CHAIN (arg));
+ len = args[0];
+ tsource = args[1];
+ fsource = args[3];
+ mask = args[4];
se->string_length = len;
}
@@ -2751,16 +2763,11 @@ gfc_conv_intrinsic_size (gfc_se * se, gf
gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
{
tree type;
- tree args;
- tree arg2;
+ tree args[4];
- args = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_CHAIN (TREE_CHAIN (args));
-
- se->expr = gfc_build_compare_string (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
- TREE_VALUE (TREE_CHAIN (arg2)));
+ gfc_conv_intrinsic_function_args (se, expr, args, 4);
+ se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
type = gfc_typenode_for_spec (&expr->ts);
se->expr = fold_build2 (op, type, se->expr,
build_int_cst (TREE_TYPE (se->expr), 0));
@@ -2770,20 +2777,20 @@ gfc_conv_intrinsic_strcmp (gfc_se * se,
static void
gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
{
- tree args;
+ tree args[3];
tree len;
tree type;
tree var;
tree tmp;
- args = gfc_conv_intrinsic_function_args (se, expr);
- len = TREE_VALUE (args);
+ gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
+ len = args[1];
- type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
+ type = TREE_TYPE (args[2]);
var = gfc_conv_string_tmp (se, type, len);
- args = tree_cons (NULL_TREE, var, args);
+ args[0] = var;
- tmp = build_function_call_expr (fndecl, args);
+ tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = var;
se->string_length = len;
@@ -3233,27 +3240,28 @@ static void
gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
{
tree logical4_type_node = gfc_get_logical_type (4);
- tree args;
- tree back;
tree type;
- tree tmp;
+ tree fndecl;
+ tree *args;
+ int num_args;
- args = gfc_conv_intrinsic_function_args (se, expr);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * 5);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
type = gfc_typenode_for_spec (&expr->ts);
- tmp = gfc_advance_chain (args, 3);
- if (TREE_CHAIN (tmp) == NULL_TREE)
- {
- back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
- NULL_TREE);
- TREE_CHAIN (tmp) = back;
- }
+
+ if (num_args == 4)
+ args[4] = build_int_cst (logical4_type_node, 0);
else
{
- back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
+ gcc_assert (num_args == 5);
+ args[4] = convert (logical4_type_node, args[4]);
}
- se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
+ fndecl = build_addr (gfor_fndecl_string_scan, current_function_decl);
+ se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan)),
+ fndecl, 5, args);
se->expr = convert (type, se->expr);
}
@@ -3266,27 +3274,26 @@ static void
gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
{
tree logical4_type_node = gfc_get_logical_type (4);
- tree args;
- tree back;
tree type;
- tree tmp;
+ tree fndecl;
+ tree *args;
+ int num_args;
- args = gfc_conv_intrinsic_function_args (se, expr);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = alloca (sizeof (tree) * 5);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
type = gfc_typenode_for_spec (&expr->ts);
- tmp = gfc_advance_chain (args, 3);
- if (TREE_CHAIN (tmp) == NULL_TREE)
- {
- back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
- NULL_TREE);
- TREE_CHAIN (tmp) = back;
- }
+
+ if (num_args == 4)
+ args[4] = build_int_cst (logical4_type_node, 0);
else
- {
- back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
- }
+ args[4] = convert (logical4_type_node, args[4]);
+
+ fndecl = build_addr (gfor_fndecl_string_verify, current_function_decl);
+ se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify)),
+ fndecl, 5, args);
- se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
se->expr = convert (type, se->expr);
}
@@ -3296,12 +3303,11 @@ gfc_conv_intrinsic_verify (gfc_se * se,
static void
gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
{
- tree args;
+ tree arg = NULL_TREE;
- args = gfc_conv_intrinsic_function_args (se, expr);
- args = TREE_VALUE (args);
- args = build_fold_addr_expr (args);
- se->expr = build_call_expr (gfor_fndecl_si_kind, 1, args);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ arg = build_fold_addr_expr (arg);
+ se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
}
/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
@@ -3342,23 +3348,27 @@ gfc_conv_intrinsic_trim (gfc_se * se, gf
tree len;
tree addr;
tree tmp;
- tree arglist;
tree type;
tree cond;
+ tree fndecl;
+ tree *args;
+ int num_args;
- arglist = NULL_TREE;
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = alloca (sizeof (tree) * num_args);
type = build_pointer_type (gfc_character1_type_node);
var = gfc_create_var (type, "pstr");
addr = gfc_build_addr_expr (ppvoid_type_node, var);
len = gfc_create_var (gfc_int4_type_node, "len");
- tmp = gfc_conv_intrinsic_function_args (se, expr);
- arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
- arglist = gfc_chainon_list (arglist, addr);
- arglist = chainon (arglist, tmp);
-
- tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = build_fold_addr_expr (len);
+ args[1] = addr;
+
+ fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
+ fndecl, num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
@@ -3378,17 +3388,16 @@ gfc_conv_intrinsic_trim (gfc_se * se, gf
static void
gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
{
- tree args, ncopies, dest, dlen, src, slen, ncopies_type;
+ tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
tree type, cond, tmp, count, exit_label, n, max, largest;
stmtblock_t block, body;
int i;
/* Get the arguments. */
- args = gfc_conv_intrinsic_function_args (se, expr);
- slen = fold_convert (size_type_node, gfc_evaluate_now (TREE_VALUE (args),
- &se->pre));
- src = TREE_VALUE (TREE_CHAIN (args));
- ncopies = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args)));
+ gfc_conv_intrinsic_function_args (se, expr, args, 4);
+ slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
+ src = args[1];
+ ncopies = args[2];
ncopies = gfc_evaluate_now (ncopies, &se->pre);
ncopies_type = TREE_TYPE (ncopies);
More information about the Fortran
mailing list