From 55637e51b5d81cd3ceb51ec5d236a745e41c7bbc Mon Sep 17 00:00:00 2001 From: Lee Millward Date: Mon, 16 Jul 2007 19:12:44 +0000 Subject: [PATCH] re PR fortran/32222 (ICE in gfc_trans_assignment_1) PR fortran/32222 PR fortran/32238 PR fortran/32242 * 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. Update comment. (gfc_intrinsic_argument_list_length): New function. (gfc_conv_intrinsic_conversion): Call it. (gfc_conv_intrinsic_mnimax): Likewise. (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. * gfortran.dg/cmplx_intrinsic_1.f90: New test. PR fortran/32238 * gfortran.dg/pr32238.f90: New test. PR fortran/32222 * gfortran.dg/pr32222.f90: New test. PR fortran/32242 * gfortran.dg/pr32242.f90: New test. From-SVN: r126689 --- gcc/fortran/ChangeLog | 35 + gcc/fortran/trans-intrinsic.c | 636 +++++++++--------- gcc/testsuite/ChangeLog | 13 + .../gfortran.dg/cmplx_intrinsic_1.f90 | 16 + gcc/testsuite/gfortran.dg/pr32222.f90 | 18 + gcc/testsuite/gfortran.dg/pr32238.f90 | 22 + gcc/testsuite/gfortran.dg/pr32242.f90 | 39 ++ 7 files changed, 469 insertions(+), 310 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/cmplx_intrinsic_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr32222.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr32238.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr32242.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 67b31a6f62a..f88667cf0b8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,38 @@ +2007-07-16 Lee Millward + + PR fortran/32222 + PR fortran/32238 + PR fortran/32242 + * 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. Update comment. + (gfc_intrinsic_argument_list_length): New function. + (gfc_conv_intrinsic_conversion): Call it. + (gfc_conv_intrinsic_mnimax): Likewise. + (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. + 2007-07-16 Janne Blomqvist PR fortran/32748 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index d6209c34b55..e1383f65fb5 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -163,29 +163,36 @@ 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. */ +/* Evaluate the arguments to an intrinsic function. The value + of NARGS may be less than the actual number of arguments in EXPR + to allow optional "KIND" arguments that are not included in the + generated code to be ignored. */ -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; - args = NULL_TREE; formal = expr->value.function.isym->formal; + actual = expr->value.function.actual; - for (actual = expr->value.function.actual; actual; actual = actual->next, - formal = formal ? formal->next : NULL) + for (curr_arg = 0; curr_arg < nargs; curr_arg++, + actual = actual->next, + formal = formal ? formal->next : NULL) { + gcc_assert (actual); e = actual->expr; /* Skip omitted optional arguments. */ if (!e) - continue; + { + --curr_arg; + continue; + } /* Evaluate the parameter. This will substitute scalarized references automatically. */ @@ -195,7 +202,8 @@ gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr) { gfc_conv_expr (&argse, e); gfc_conv_string_parameter (&argse); - args = gfc_chainon_list (args, argse.string_length); + argarray[curr_arg++] = argse.string_length; + gcc_assert (curr_arg < nargs); } else gfc_conv_expr_val (&argse, e); @@ -210,9 +218,31 @@ gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr) 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); + argarray[curr_arg] = argse.expr; + } +} + +/* Count the number of actual arguments to the intrinsic function EXPR + including any "hidden" string length arguments. */ + +static unsigned int +gfc_intrinsic_argument_list_length (gfc_expr *expr) +{ + int n = 0; + gfc_actual_arglist *actual; + + for (actual = expr->value.function.actual; actual; actual = actual->next) + { + if (!actual->expr) + continue; + + if (actual->expr->ts.type == BT_CHARACTER) + n += 2; + else + n++; } - return args; + + return n; } @@ -223,26 +253,31 @@ static void gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) { tree type; - tree arg; + tree *args; + int nargs; - /* Evaluate the argument. */ + nargs = gfc_intrinsic_argument_list_length (expr); + args = alloca (sizeof (tree) * nargs); + + /* Evaluate all the arguments passed. Whilst we're only interested in the + first one here, there are other parts of the front-end that assume this + and will trigger an ICE if it's not the case. */ 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, nargs); /* 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 @@ -402,20 +437,19 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) /* 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, &arg, 1); /* 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, arg); 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); /* Test if the value is too large to handle sensibly. */ @@ -450,8 +484,7 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) /* 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, &arg, 1); if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE) { @@ -483,8 +516,7 @@ gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) { tree arg; - 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); } @@ -496,8 +528,7 @@ gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) { tree arg; - 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 +678,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; + unsigned int num_args; gfc_isym_id id; id = expr->value.function.isym->id; @@ -666,9 +699,15 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) } /* 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); } /* Generate code for EXPONENT(X) intrinsic function. */ @@ -676,10 +715,10 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) 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 +739,7 @@ gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr) 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 +943,16 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { - tree args; - tree val; + tree arg; 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 +971,7 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) 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: @@ -949,20 +985,23 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) { - tree arg; tree real; tree imag; tree type; + tree *args; + unsigned 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 @@ -978,8 +1017,6 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) 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 +1024,20 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) 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 +1065,17 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) /* 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 +1088,20 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) { 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 +1128,9 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) 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 +1144,16 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) 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]; - 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]); - 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 +1172,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 +1193,20 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) 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 +1214,7 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) /* 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 +1238,16 @@ gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) { - tree arg; - tree arg2; tree type; + 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); /* 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]); } @@ -1234,8 +1260,7 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) tree var; tree type; - arg = gfc_conv_intrinsic_function_args (se, expr); - arg = TREE_VALUE (arg); + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); /* We currently don't support character types != 1. */ gcc_assert (expr->ts.kind == 1); @@ -1255,21 +1280,27 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) 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; + unsigned 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); + 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); - tmp = build_function_call_expr (gfor_fndecl_ctime, arglist); + 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 +1321,27 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) 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; + unsigned 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); + 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); - tmp = build_function_call_expr (gfor_fndecl_fdate, arglist); + 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 +1364,27 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) 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; + unsigned 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); + 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); - tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist); + 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,14 +1424,16 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) tree val; tree thencase; tree elsecase; - tree arg, arg1, arg2; + tree *args; tree type; gfc_actual_arglist *argexpr; unsigned int i; + unsigned int nargs; - arg = gfc_conv_intrinsic_function_args (se, expr); - arg1 = TREE_VALUE (arg); - arg2 = TREE_VALUE (TREE_CHAIN (arg)); + nargs = gfc_intrinsic_argument_list_length (expr); + args = alloca (sizeof (tree) * nargs); + + gfc_conv_intrinsic_function_args (se, expr, args, nargs); type = gfc_typenode_for_spec (&expr->ts); /* The first and second arguments should be present, if they are @@ -1396,7 +1441,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) argexpr = expr->value.function.actual; if (argexpr->expr->expr_type == EXPR_VARIABLE && argexpr->expr->symtree->n.sym->attr.optional - && TREE_CODE (arg1) == INDIRECT_REF) + && TREE_CODE (args[0]) == INDIRECT_REF) { /* Check the first argument. */ tree cond; @@ -1404,15 +1449,15 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) asprintf (&msg, "First argument of '%s' intrinsic should be present", expr->symtree->n.sym->name); - cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (arg1, 0), - build_int_cst (TREE_TYPE (TREE_OPERAND (arg1, 0)), 0)); + cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[0], 0), + build_int_cst (TREE_TYPE (TREE_OPERAND (args[0], 0)), 0)); gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where); gfc_free (msg); } if (argexpr->next->expr->expr_type == EXPR_VARIABLE && argexpr->next->expr->symtree->n.sym->attr.optional - && TREE_CODE (arg2) == INDIRECT_REF) + && TREE_CODE (args[1]) == INDIRECT_REF) { /* Check the second argument. */ tree cond; @@ -1420,13 +1465,13 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) asprintf (&msg, "Second argument of '%s' intrinsic should be present", expr->symtree->n.sym->name); - cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (arg2, 0), - build_int_cst (TREE_TYPE (TREE_OPERAND (arg2, 0)), 0)); + cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[1], 0), + build_int_cst (TREE_TYPE (TREE_OPERAND (args[1], 0)), 0)); gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where); gfc_free (msg); } - limit = TREE_VALUE (arg); + limit = args[0]; if (TREE_TYPE (limit) != type) limit = convert (type, limit); /* Only evaluate the argument once. */ @@ -1435,12 +1480,11 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) mvar = gfc_create_var (type, "M"); elsecase = build2_v (MODIFY_EXPR, mvar, limit); - for (arg = TREE_CHAIN (arg), i = 0, argexpr = argexpr->next; - arg != NULL_TREE; arg = TREE_CHAIN (arg), i++) + for (i = 1, argexpr = argexpr->next; i < nargs; i++) { tree cond; - val = TREE_VALUE (arg); + val = args[i]; /* Handle absent optional arguments by ignoring the comparison. */ if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE @@ -2328,18 +2372,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) 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); @@ -2350,16 +2391,10 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) 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. */ @@ -2368,9 +2403,7 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) { tree arg; - arg = gfc_conv_intrinsic_function_args (se, expr); - arg = TREE_VALUE (arg); - + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg); } @@ -2378,18 +2411,15 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) 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 @@ -2397,7 +2427,7 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) 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. @@ -2405,25 +2435,19 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) 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); } @@ -2433,15 +2457,12 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) 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)) @@ -2451,8 +2472,7 @@ gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift) 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; @@ -2462,16 +2482,14 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) 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 = unsigned_type_for (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. @@ -2479,16 +2497,16 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) 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, @@ -2499,38 +2517,37 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) 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; + unsigned int num_args; - arg = gfc_conv_intrinsic_function_args (se, expr); - arg2 = TREE_CHAIN (arg); - arg3 = TREE_CHAIN (arg2); - if (arg3) + num_args = gfc_intrinsic_argument_list_length (expr); + args = alloca (sizeof (tree) * num_args); + + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + + 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) { @@ -2548,7 +2565,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) 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) @@ -2556,24 +2573,22 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) 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. */ @@ -2646,12 +2661,12 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) 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); } @@ -2662,44 +2677,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; + unsigned 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_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); } @@ -2709,32 +2725,33 @@ gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) 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; + unsigned 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; } @@ -2891,16 +2908,11 @@ static void 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)); @@ -2910,20 +2922,20 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) 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; @@ -3372,27 +3384,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; + unsigned 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_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); } @@ -3405,27 +3418,29 @@ 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; + unsigned 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_verify, args); + 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 = convert (type, se->expr); } @@ -3435,12 +3450,11 @@ gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr) { - tree args; + tree arg; - 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. */ @@ -3481,23 +3495,27 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) tree len; tree addr; tree tmp; - tree arglist; tree type; tree cond; + tree fndecl; + tree *args; + unsigned 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); + gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); + args[0] = build_fold_addr_expr (len); + args[1] = addr; - tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist); + 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. */ @@ -3517,18 +3535,16 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) 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))); - ncopies = gfc_evaluate_now (ncopies, &se->pre); + gfc_conv_intrinsic_function_args (se, expr, args, 3); + slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre)); + src = args[1]; + ncopies = gfc_evaluate_now (args[2], &se->pre); ncopies_type = TREE_TYPE (ncopies); /* Check that NCOPIES is not negative. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 70a92963d94..c025a088678 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,16 @@ +2007-07-16 Lee Millward + + * gfortran.dg/cmplx_intrinsic_1.f90: New test. + + PR fortran/32238 + * gfortran.dg/pr32238.f90: New test. + + PR fortran/32222 + * gfortran.dg/pr32222.f90: New test. + + PR fortran/32242 + * gfortran.dg/pr32242.f90: New test. + 2007-07-16 Sandra Loosemore David Ung diff --git a/gcc/testsuite/gfortran.dg/cmplx_intrinsic_1.f90 b/gcc/testsuite/gfortran.dg/cmplx_intrinsic_1.f90 new file mode 100644 index 00000000000..bc4b9dfb2f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/cmplx_intrinsic_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +CONTAINS +SUBROUTINE send_forward () + + INTEGER, DIMENSION(3) :: lz, ub, uz + REAL, ALLOCATABLE, DIMENSION(:, :, :) :: buffer + COMPLEX, DIMENSION ( :, :, : ), POINTER :: cc3d + + cc3d ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ) = & + CMPLX ( buffer ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ), & + KIND = SELECTED_REAL_KIND ( 14, 200 ) ) + +END SUBROUTINE send_forward +END + diff --git a/gcc/testsuite/gfortran.dg/pr32222.f90 b/gcc/testsuite/gfortran.dg/pr32222.f90 new file mode 100644 index 00000000000..1daac1ef178 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr32222.f90 @@ -0,0 +1,18 @@ +!PR fortran/32222 +! { dg-do compile } +! { dg-final { cleanup-modules "splinemod" } } + +module splinemod +implicit none +integer, parameter :: dl = KIND(1.d0) +Type lSamples + integer l(10) +end Type lSamples +end module splinemod + +subroutine InterpolateClArr(lSet) +use splinemod +type (lSamples), intent(in) :: lSet +real(dl) xl(10) +xl = real(lSet%l,dl) +end subroutine InterpolateClArr diff --git a/gcc/testsuite/gfortran.dg/pr32238.f90 b/gcc/testsuite/gfortran.dg/pr32238.f90 new file mode 100644 index 00000000000..2c88b356561 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr32238.f90 @@ -0,0 +1,22 @@ +!PR fortran/32238 +! { dg-do compile } +! { dg-final { cleanup-modules "bug_test" } } + +module bug_test + +contains + subroutine bug(c) + + implicit none + + integer, parameter :: fp = selected_real_kind(13) + complex(kind=fp) :: c(:,:) + where( abs( aimag( c ) ) < 1.e-10_fp ) & + & c = cmplx( real( c , fp ) , 0._fp , fp ) + where( abs( real( c , fp ) ) < 1.e-10_fp ) & + & c = cmplx( 0._fp , aimag( c ) , fp ) + + return + end subroutine bug + +end module bug_test diff --git a/gcc/testsuite/gfortran.dg/pr32242.f90 b/gcc/testsuite/gfortran.dg/pr32242.f90 new file mode 100644 index 00000000000..6928f4f52d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr32242.f90 @@ -0,0 +1,39 @@ +!PR fortran/32242 +! { dg-do compile } +! { dg-final { cleanup-modules "kahan_sum" } } + +MODULE kahan_sum + INTEGER, PARAMETER :: dp=KIND(0.0D0) + INTERFACE accurate_sum + MODULE PROCEDURE kahan_sum_d1, kahan_sum_z1 + END INTERFACE accurate_sum + TYPE pw_grid_type + REAL (KIND=dp), DIMENSION ( : ), POINTER :: gsq + END TYPE pw_grid_type + TYPE pw_type + REAL (KIND=dp), DIMENSION ( : ), POINTER :: cr + COMPLEX (KIND=dp), DIMENSION ( : ), POINTER :: cc + TYPE ( pw_grid_type ), POINTER :: pw_grid + END TYPE pw_type +CONTAINS + FUNCTION kahan_sum_d1(array,mask) RESULT(ks) + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: array + LOGICAL, DIMENSION(:), INTENT(IN), & + OPTIONAL :: mask + REAL(KIND=dp) :: ks + END FUNCTION kahan_sum_d1 + FUNCTION kahan_sum_z1(array,mask) RESULT(ks) + COMPLEX(KIND=dp), DIMENSION(:), & + INTENT(IN) :: array + LOGICAL, DIMENSION(:), INTENT(IN), & + OPTIONAL :: mask + COMPLEX(KIND=dp) :: ks + END FUNCTION kahan_sum_z1 + +FUNCTION pw_integral_a2b ( pw1, pw2 ) RESULT ( integral_value ) + TYPE(pw_type), INTENT(IN) :: pw1, pw2 + REAL(KIND=dp) :: integral_value + integral_value = accurate_sum ( REAL ( CONJG ( pw1 % cc ( : ) ) & + * pw2 % cc ( : ) ,KIND=dp) * pw1 % pw_grid % gsq ( : ) ) ! { dg-warning "Function return value not set" } +END FUNCTION pw_integral_a2b +END MODULE -- 2.30.2