From 0d52899f78e638f7a5e2a50954d3740d68907a91 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sun, 27 Jul 2008 12:45:44 +0200 Subject: [PATCH] re PR fortran/36132 (_gfortran_internal_pack on optional arguments) 2008-07-27 Tobias Burnus PR fortran/36132 PR fortran/29952 PR fortran/36909 * trans.c (gfc_trans_runtime_check): Allow run-time warning * besides run-time error. * trans.h (gfc_trans_runtime_check): Update declaration. * trans-array.c * (gfc_trans_array_ctor_element,gfc_trans_array_bound_check, gfc_conv_array_ref,gfc_conv_ss_startstride,gfc_trans_dummy_array_bias): Updated gfc_trans_runtime_check calls. (gfc_conv_array_parameter): Implement flag_check_array_temporaries, fix packing/unpacking for nonpresent optional actuals to optional formals. * trans-array.h (gfc_conv_array_parameter): Update declaration. * trans-expr.c (gfc_conv_substring,gfc_trans_arrayfunc_assign, gfc_conv_function_call): Updated gfc_trans_runtime_check calls. (gfc_conv_function_call): Update gfc_conv_array_parameter calls. * trans-expr.c (gfc_trans_goto): Updated gfc_trans_runtime_check calls. * trans-io.c (set_string,gfc_conv_intrinsic_repeat): Ditto. (gfc_conv_intrinsic_transfer,gfc_conv_intrinsic_loc): Same for gfc_conv_array_parameter. * trans-intrinsics.c (gfc_conv_intrinsic_bound): Ditto. * trans-decl.c (gfc_build_builtin_function_decls): Add gfor_fndecl_runtime_warning_at. * lang.opt: New option fcheck-array-temporaries. * gfortran.h (gfc_options): New flag_check_array_temporaries. * options.c (gfc_init_options, gfc_handle_option): Handle flag. * invoke.texi: New option fcheck-array-temporaries. 2008-07-27 Tobias Burnus PR fortran/36132 PR fortran/29952 PR fortran/36909 * runtime/error.c: New function runtime_error_at. * gfortran.map: Ditto. * libgfortran.h: Ditto. 2008-07-27 Tobias Burnus PR fortran/36132 PR fortran/29952 PR fortran/36909 gfortran.dg/internal_pack_4.f90: New. gfortran.dg/internal_pack_5.f90: New. gfortran.dg/array_temporaries_2.f90: New. From-SVN: r138186 --- gcc/fortran/ChangeLog | 31 +++++++ gcc/fortran/gfortran.h | 1 + gcc/fortran/invoke.texi | 13 ++- gcc/fortran/lang.opt | 4 + gcc/fortran/options.c | 5 ++ gcc/fortran/trans-array.c | 86 +++++++++++++++---- gcc/fortran/trans-array.h | 3 +- gcc/fortran/trans-decl.c | 5 ++ gcc/fortran/trans-expr.c | 14 +-- gcc/fortran/trans-intrinsic.c | 11 +-- gcc/fortran/trans-io.c | 2 +- gcc/fortran/trans-stmt.c | 4 +- gcc/fortran/trans.c | 37 ++++++-- gcc/fortran/trans.h | 6 +- gcc/testsuite/ChangeLog | 9 ++ .../gfortran.dg/array_temporaries_2.f90 | 15 ++++ gcc/testsuite/gfortran.dg/internal_pack_4.f90 | 31 +++++++ gcc/testsuite/gfortran.dg/internal_pack_5.f90 | 21 +++++ libgfortran/ChangeLog | 9 ++ libgfortran/gfortran.map | 1 + libgfortran/libgfortran.h | 3 + libgfortran/runtime/error.c | 15 ++++ 22 files changed, 285 insertions(+), 41 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/array_temporaries_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/internal_pack_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/internal_pack_5.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4569f523ca4..fd3cff552d3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,34 @@ +2008-07-27 Tobias Burnus + + PR fortran/36132 + PR fortran/29952 + PR fortran/36909 + * trans.c (gfc_trans_runtime_check): Allow run-time warning besides + run-time error. + * trans.h (gfc_trans_runtime_check): Update declaration. + * trans-array.c (gfc_trans_array_ctor_element,gfc_trans_array_bound_check, + gfc_conv_array_ref,gfc_conv_ss_startstride,gfc_trans_dummy_array_bias): + Updated gfc_trans_runtime_check calls. + (gfc_conv_array_parameter): Implement flag_check_array_temporaries, + fix packing/unpacking for nonpresent optional actuals to optional + formals. + * trans-array.h (gfc_conv_array_parameter): Update declaration. + * trans-expr.c (gfc_conv_substring,gfc_trans_arrayfunc_assign, + gfc_conv_function_call): Updated gfc_trans_runtime_check calls. + (gfc_conv_function_call): Update gfc_conv_array_parameter calls. + * trans-expr.c (gfc_trans_goto): Updated gfc_trans_runtime_check + calls. + * trans-io.c (set_string,gfc_conv_intrinsic_repeat): Ditto. + (gfc_conv_intrinsic_transfer,gfc_conv_intrinsic_loc): Same for + gfc_conv_array_parameter. + * trans-intrinsics.c (gfc_conv_intrinsic_bound): Ditto. + * trans-decl.c (gfc_build_builtin_function_decls): Add + gfor_fndecl_runtime_warning_at. + * lang.opt: New option fcheck-array-temporaries. + * gfortran.h (gfc_options): New flag_check_array_temporaries. + * options.c (gfc_init_options, gfc_handle_option): Handle flag. + * invoke.texi: New option fcheck-array-temporaries. + 2008-07-24 Jan Hubicka * fortran/options.c (gfc_post_options): Remove flag_unline_trees code. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 18af94e3b8d..398a9a69acb 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1895,6 +1895,7 @@ typedef struct int flag_automatic; int flag_backslash; int flag_backtrace; + int flag_check_array_temporaries; int flag_allow_leading_underscore; int flag_dump_core; int flag_external_blas; diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index ed3e1e70daf..f633187a01c 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -164,7 +164,7 @@ and warnings}. @xref{Code Gen Options,,Options for code generation conventions}. @gccoptlist{-fno-automatic -ff2c -fno-underscoring -fsecond-underscore @gol --fbounds-check -fmax-stack-var-size=@var{n} @gol +-fbounds-check -fcheck-array-temporaries -fmax-stack-var-size=@var{n} @gol -fpack-derived -frepack-arrays -fshort-enums -fexternal-blas @gol -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol -finit-integer=@var{n} -finit-real=@var{} @gol @@ -1168,6 +1168,17 @@ the compilation of the main program. In the future this may also include other forms of checking, e.g., checking substring references. + +@item fcheck-array-temporaries +@opindex @code{fcheck-array-temporaries} +@cindex checking array temporaries +Warns at run time when for passing an actual argument a temporary array +had to be generated. The information generated by this warning is +sometimes useful in optimization, in order to avoid such temporaries. + +Note: The warning is only printed once per location. + + @item -fmax-stack-var-size=@var{n} @opindex @code{fmax-stack-var-size} This option specifies the size in bytes of the largest array that will be put diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 7a067604e89..93211952c12 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -156,6 +156,10 @@ fblas-matmul-limit= Fortran RejectNegative Joined UInteger -fblas-matmul-limit= Size of the smallest matrix for which matmul will use BLAS +fcheck-array-temporaries +Fortran +Produce a warning at runtime if a array temporary has been created for a procedure argument + fconvert=big-endian Fortran RejectNegative Use big-endian format for unformatted files diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 9bbb39a35c0..1f05f35359f 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -101,6 +101,7 @@ gfc_init_options (unsigned int argc, const char **argv) gfc_option.flag_backslash = 0; gfc_option.flag_module_private = 0; gfc_option.flag_backtrace = 0; + gfc_option.flag_check_array_temporaries = 0; gfc_option.flag_allow_leading_underscore = 0; gfc_option.flag_dump_core = 0; gfc_option.flag_external_blas = 0; @@ -540,6 +541,10 @@ gfc_handle_option (size_t scode, const char *arg, int value) gfc_option.flag_backtrace = value; break; + case OPT_fcheck_array_temporaries: + gfc_option.flag_check_array_temporaries = value; + break; + case OPT_fdump_core: gfc_option.flag_dump_core = value; break; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 9ec8406c428..14bab8ead53 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1022,7 +1022,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, tree cond = fold_build2 (NE_EXPR, boolean_type_node, first_len_val, se->string_length); gfc_trans_runtime_check - (cond, &se->pre, &expr->where, + (true, false, cond, &se->pre, &expr->where, "Different CHARACTER lengths (%ld/%ld) in array constructor", fold_convert (long_integer_type_node, first_len_val), fold_convert (long_integer_type_node, se->string_length)); @@ -2235,7 +2235,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, else asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)", gfc_msg_fault, n+1); - gfc_trans_runtime_check (fault, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, tmp)); gfc_free (msg); @@ -2251,7 +2251,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, else asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)", gfc_msg_fault, n+1); - gfc_trans_runtime_check (fault, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, tmp)); gfc_free (msg); @@ -2445,7 +2445,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, asprintf (&msg, "%s for array '%s', " "lower bound of dimension %d exceeded (%%ld < %%ld)", gfc_msg_fault, sym->name, n+1); - gfc_trans_runtime_check (cond, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, fold_convert (long_integer_type_node, indexse.expr), fold_convert (long_integer_type_node, tmp)); @@ -2462,7 +2462,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, asprintf (&msg, "%s for array '%s', " "upper bound of dimension %d exceeded (%%ld > %%ld)", gfc_msg_fault, sym->name, n+1); - gfc_trans_runtime_check (cond, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, fold_convert (long_integer_type_node, indexse.expr), fold_convert (long_integer_type_node, tmp)); @@ -3026,7 +3026,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) asprintf (&msg, "Zero stride is not allowed, for dimension %d " "of array '%s'", info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg); + gfc_trans_runtime_check (true, false, tmp, &inner, + &ss->expr->where, msg); gfc_free (msg); desc = ss->data.info.descriptor; @@ -3068,7 +3069,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" " exceeded (%%ld < %%ld)", gfc_msg_fault, info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, + gfc_trans_runtime_check (true, false, tmp, &inner, + &ss->expr->where, msg, fold_convert (long_integer_type_node, info->start[n]), fold_convert (long_integer_type_node, @@ -3084,7 +3086,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) asprintf (&msg, "%s, upper bound of dimension %d of array " "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault, info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, + gfc_trans_runtime_check (true, false, tmp, &inner, + &ss->expr->where, msg, fold_convert (long_integer_type_node, info->start[n]), fold_convert (long_integer_type_node, ubound)); gfc_free (msg); @@ -3106,7 +3109,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" " exceeded (%%ld < %%ld)", gfc_msg_fault, info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, + gfc_trans_runtime_check (true, false, tmp, &inner, + &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp2), fold_convert (long_integer_type_node, @@ -3121,7 +3125,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) asprintf (&msg, "%s, upper bound of dimension %d of array " "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault, info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, + gfc_trans_runtime_check (true, false, tmp, &inner, + &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp2), fold_convert (long_integer_type_node, ubound)); gfc_free (msg); @@ -3144,7 +3149,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) asprintf (&msg, "%s, size mismatch for dimension %d " "of array '%s' (%%ld/%%ld)", gfc_msg_bounds, info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (tmp3, &inner, &ss->expr->where, msg, + gfc_trans_runtime_check (true, false, tmp3, &inner, + &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), fold_convert (long_integer_type_node, size[n])); gfc_free (msg); @@ -4383,7 +4389,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2); asprintf (&msg, "%s for dimension %d of array '%s'", gfc_msg_bounds, n+1, sym->name); - gfc_trans_runtime_check (tmp, &block, &loc, msg); + gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg); gfc_free (msg); } } @@ -5133,7 +5139,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) /* TODO: Optimize passing g77 arrays. */ void -gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) +gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, + const gfc_symbol *fsym, const char *proc_name) { tree ptr; tree desc; @@ -5230,17 +5237,59 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) /* Repack the array. */ if (gfc_option.warn_array_temp) - gfc_warning ("Creating array temporary at %L", &expr->where); + { + if (fsym) + gfc_warning ("Creating array temporary at %L for argument '%s'", + &expr->where, fsym->name); + else + gfc_warning ("Creating array temporary at %L", &expr->where); + } ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc); + + if (fsym && fsym->attr.optional && sym && sym->attr.optional) + { + tmp = gfc_conv_expr_present (sym); + ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp, ptr, + null_pointer_node); + } + ptr = gfc_evaluate_now (ptr, &se->pre); + se->expr = ptr; + if (gfc_option.flag_check_array_temporaries) + { + char * msg; + + if (fsym && proc_name) + asprintf (&msg, "An array temporary was created for argument " + "'%s' of procedure '%s'", fsym->name, proc_name); + else + asprintf (&msg, "An array temporary was created"); + + tmp = build_fold_indirect_ref (desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2 (NE_EXPR, boolean_type_node, + fold_convert (TREE_TYPE (tmp), ptr), tmp); + + if (fsym && fsym->attr.optional && sym && sym->attr.optional) + tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + gfc_conv_expr_present (sym), tmp); + + gfc_trans_runtime_check (false, true, tmp, &se->pre, + &expr->where, msg); + gfc_free (msg); + } + gfc_start_block (&block); /* Copy the data back. */ - tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr); - gfc_add_expr_to_block (&block, tmp); + if (fsym == NULL || fsym->attr.intent != INTENT_IN) + { + tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr); + gfc_add_expr_to_block (&block, tmp); + } /* Free the temporary. */ tmp = gfc_call_free (convert (pvoid_type_node, ptr)); @@ -5255,6 +5304,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) tmp = gfc_conv_array_data (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, fold_convert (TREE_TYPE (tmp), ptr), tmp); + + if (fsym && fsym->attr.optional && sym && sym->attr.optional) + tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + gfc_conv_expr_present (sym), tmp); + tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); gfc_add_expr_to_block (&block, tmp); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 1e34c9a9f28..145f4a82565 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -105,7 +105,8 @@ void gfc_conv_tmp_ref (gfc_se *); /* Evaluate an array expression. */ void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *); /* Convert an array for passing as an actual function parameter. */ -void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int); +void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int, + const gfc_symbol *, const char *); /* Evaluate and transpose a matrix expression. */ void gfc_conv_array_transpose (gfc_se *, gfc_expr *); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d2161f5c5c7..d2cb6a319c7 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -79,6 +79,7 @@ tree gfor_fndecl_stop_numeric; tree gfor_fndecl_stop_string; tree gfor_fndecl_runtime_error; tree gfor_fndecl_runtime_error_at; +tree gfor_fndecl_runtime_warning_at; tree gfor_fndecl_os_error; tree gfor_fndecl_generate_error; tree gfor_fndecl_set_fpe; @@ -2455,6 +2456,10 @@ gfc_build_builtin_function_decls (void) /* The runtime_error_at function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; + gfor_fndecl_runtime_warning_at = + gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")), + void_type_node, -2, pchar_type_node, + pchar_type_node); gfor_fndecl_generate_error = gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")), void_type_node, 3, pvoid_type_node, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3240d7f678c..e145c0ca01c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -328,7 +328,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, else asprintf (&msg, "Substring out of bounds: lower bound (%%ld)" "is less than one"); - gfc_trans_runtime_check (fault, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, start.expr)); gfc_free (msg); @@ -344,7 +344,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, else asprintf (&msg, "Substring out of bounds: upper bound (%%ld) " "exceeds string length (%%ld)"); - gfc_trans_runtime_check (fault, &se->pre, where, msg, + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, end.expr), fold_convert (long_integer_type_node, se->string_length)); @@ -2299,7 +2299,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, f = f || !sym->attr.always_explicit; argss = gfc_walk_expr (arg->expr); - gfc_conv_array_parameter (se, arg->expr, argss, f); + gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL); } /* TODO -- the following two lines shouldn't be necessary, but @@ -2535,7 +2535,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_conv_subref_array_arg (&parmse, e, f, fsym ? fsym->attr.intent : INTENT_INOUT); else - gfc_conv_array_parameter (&parmse, e, argss, f); + gfc_conv_array_parameter (&parmse, e, argss, f, fsym, + sym->name); /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ @@ -2836,7 +2837,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_conv_descriptor_data_get (info->descriptor); tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, info->data); - gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault); + gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL, + gfc_msg_fault); } se->expr = info->descriptor; /* Bundle in the string length. */ @@ -4143,7 +4145,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_start_block (&se.pre); se.want_pointer = 1; - gfc_conv_array_parameter (&se, expr1, ss, 0); + gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL); se.direct_byref = 1; se.ss = gfc_walk_expr (expr2); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b76dd76ce9c..2dc2d4f7a98 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -864,7 +864,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); - gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + gfc_msg_fault); } } @@ -3632,7 +3633,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) if (ss == gfc_ss_terminator) gfc_conv_expr_reference (&argse, arg->expr); else - gfc_conv_array_parameter (&argse, arg->expr, ss, 1); + gfc_conv_array_parameter (&argse, arg->expr, ss, 1, NULL, NULL); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); ptr = argse.expr; @@ -3958,7 +3959,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) /* Check that NCOPIES is not negative. */ cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies, build_int_cst (ncopies_type, 0)); - gfc_trans_runtime_check (cond, &se->pre, &expr->where, + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is negative " "(its value is %lld)", fold_convert (long_integer_type_node, ncopies)); @@ -3990,7 +3991,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) build_int_cst (size_type_node, 0)); cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node, cond); - gfc_trans_runtime_check (cond, &se->pre, &expr->where, + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is too large"); /* Compute the destination length. */ @@ -4094,7 +4095,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) if (ss == gfc_ss_terminator) gfc_conv_expr_reference (se, arg_expr); else - gfc_conv_array_parameter (se, arg_expr, ss, 1); + gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL); se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); /* Create a temporary variable for loc return value. Without this, diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 7f98e5c7c71..3d17a4c77da 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -668,7 +668,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format " "label", e->symtree->name); - gfc_trans_runtime_check (cond, &se.pre, &e->where, msg, + gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg, fold_convert (long_integer_type_node, tmp)); gfc_free (msg); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index e19695fdade..79a1446ebf1 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -154,7 +154,7 @@ gfc_trans_goto (gfc_code * code) tmp = GFC_DECL_STRING_LEN (se.expr); tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, build_int_cst (TREE_TYPE (tmp), -1)); - gfc_trans_runtime_check (tmp, &se.pre, &loc, + gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc, "Assigned label is not a target label"); assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); @@ -180,7 +180,7 @@ gfc_trans_goto (gfc_code * code) code = code->block; } while (code != NULL); - gfc_trans_runtime_check (boolean_true_node, &se.pre, &loc, + gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc, "Assigned label is not in the list"); return gfc_finish_block (&se.pre); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 1db628eff42..d6aef8769e7 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -351,13 +351,14 @@ gfc_build_array_ref (tree base, tree offset, tree decl) /* Generate a runtime error if COND is true. */ void -gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, - const char * msgid, ...) +gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, + locus * where, const char * msgid, ...) { va_list ap; stmtblock_t block; tree body; tree tmp; + tree tmpvar = NULL; tree arg, arg2; tree *argarray; tree fntype; @@ -377,6 +378,14 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, nargs++; } + if (once) + { + tmpvar = gfc_create_var (boolean_type_node, "print_warning"); + TREE_STATIC (tmpvar) = 1; + DECL_INITIAL (tmpvar) = boolean_true_node; + gfc_add_expr_to_block (pblock, tmpvar); + } + /* The code to generate the error. */ gfc_start_block (&block); @@ -408,16 +417,25 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, argarray[2+i] = va_arg (ap, tree); va_end (ap); - /* Build the function call to runtime_error_at; because of the variable - number of arguments, we can't use build_call_expr directly. */ - fntype = TREE_TYPE (gfor_fndecl_runtime_error_at); + /* Build the function call to runtime_(warning,error)_at; because of the + variable number of arguments, we can't use build_call_expr directly. */ + if (error) + fntype = TREE_TYPE (gfor_fndecl_runtime_error_at); + else + fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at); + tmp = fold_builtin_call_array (TREE_TYPE (fntype), fold_build1 (ADDR_EXPR, build_pointer_type (fntype), - gfor_fndecl_runtime_error_at), + error + ? gfor_fndecl_runtime_error_at + : gfor_fndecl_runtime_warning_at), nargs + 2, argarray); gfc_add_expr_to_block (&block, tmp); + if (once) + gfc_add_modify_expr (&block, tmpvar, boolean_false_node); + body = gfc_finish_block (&block); if (integer_onep (cond)) @@ -427,7 +445,12 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, else { /* Tell the compiler that this isn't likely. */ - cond = fold_convert (long_integer_type_node, cond); + if (once) + cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar, + cond); + else + cond = fold_convert (long_integer_type_node, cond); + tmp = build_int_cst (long_integer_type_node, 0); cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); cond = fold_convert (boolean_type_node, cond); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 98002a9f2f7..7704748d305 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -444,8 +444,9 @@ void gfc_generate_constructors (void); /* Get the string length of an array constructor. */ bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *); -/* Generate a runtime error check. */ -void gfc_trans_runtime_check (tree, stmtblock_t *, locus *, const char *, ...); +/* Generate a runtime warning/error check. */ +void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *, + const char *, ...); /* Generate a call to free() after checking that its arg is non-NULL. */ tree gfc_call_free (tree); @@ -510,6 +511,7 @@ extern GTY(()) tree gfor_fndecl_stop_numeric; extern GTY(()) tree gfor_fndecl_stop_string; extern GTY(()) tree gfor_fndecl_runtime_error; extern GTY(()) tree gfor_fndecl_runtime_error_at; +extern GTY(()) tree gfor_fndecl_runtime_warning_at; extern GTY(()) tree gfor_fndecl_os_error; extern GTY(()) tree gfor_fndecl_generate_error; extern GTY(()) tree gfor_fndecl_set_fpe; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f6e24218824..7bdc31bbeaa 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2008-07-27 Tobias Burnus + + PR fortran/36132 + PR fortran/29952 + PR fortran/36909 + gfortran.dg/internal_pack_4.f90: New. + gfortran.dg/internal_pack_5.f90: New. + gfortran.dg/array_temporaries_2.f90: New. + 2008-07-26 Thomas Koenig PR fortran/36934 diff --git a/gcc/testsuite/gfortran.dg/array_temporaries_2.f90 b/gcc/testsuite/gfortran.dg/array_temporaries_2.f90 new file mode 100644 index 00000000000..86e0a45e712 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_temporaries_2.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fcheck-array-temporaries" } + program test + implicit none + integer :: a(3,3) + call foo(a(:,1)) ! OK, no temporary created + call foo(a(1,:)) ! BAD, temporary var created +contains + subroutine foo(x) + integer :: x(3) + x = 5 + end subroutine foo +end program test + +! { dg-output "At line 7 of file .*array_temporaries_2.f90(\n|\r\n|\r)Fortran runtime warning: An array temporary was created for argument 'x' of procedure 'foo'" } diff --git a/gcc/testsuite/gfortran.dg/internal_pack_4.f90 b/gcc/testsuite/gfortran.dg/internal_pack_4.f90 new file mode 100644 index 00000000000..049931a4f4f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_pack_4.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/36132 +! +! Before invalid memory was accessed because an absent, optional +! argument was packed before passing it as absent actual. +! Getting it to crash is difficult, but valgrind shows the problem. +! +MODULE M1 + INTEGER, PARAMETER :: dp=KIND(0.0D0) +CONTAINS + SUBROUTINE S1(a) + REAL(dp), DIMENSION(45), INTENT(OUT), & + OPTIONAL :: a + if (present(a)) call abort() + END SUBROUTINE S1 + SUBROUTINE S2(a) + REAL(dp), DIMENSION(:, :), INTENT(OUT), & + OPTIONAL :: a + CALL S1(a) + END SUBROUTINE +END MODULE M1 + +USE M1 +CALL S2() +END + +! { dg-final { scan-tree-dump-times "a != 0B \\? _gfortran_internal_pack" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(a != 0B &&" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/internal_pack_5.f90 b/gcc/testsuite/gfortran.dg/internal_pack_5.f90 new file mode 100644 index 00000000000..87705fa716a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_pack_5.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/36909 +! +! Check that no unneeded internal_unpack is +! called (INTENT(IN)!). +! +program test + implicit none + integer :: a(3,3) + call foo(a(1,:)) +contains + subroutine foo(x) + integer,intent(in) :: x(3) + end subroutine foo +end program test + +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 2459b539096..0eb171ce4b0 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2008-07-27 Tobias Burnus + + PR fortran/36132 + PR fortran/29952 + PR fortran/36909 + * runtime/error.c: New function runtime_error_at. + * gfortran.map: Ditto. + * libgfortran.h: Ditto. + 2008-07-22 Jerry DeLisle PR fortran/36852 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 0671b60fb86..93973d5b338 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1072,6 +1072,7 @@ GFORTRAN_1.1 { _gfortran_pack_char4; _gfortran_pack_s_char4; _gfortran_reshape_char4; + _gfortran_runtime_warning_at; _gfortran_selected_char_kind; _gfortran_select_string_char4; _gfortran_spread_char4; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 10439bd3e5a..7c497004a81 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -643,6 +643,9 @@ extern void runtime_error_at (const char *, const char *, ...) __attribute__ ((noreturn, format (printf, 2, 3))); iexport_proto(runtime_error_at); +extern void runtime_warning_at (const char *, const char *, ...); +iexport_proto(runtime_warning_at); + extern void internal_error (st_parameter_common *, const char *) __attribute__ ((noreturn)); internal_proto(internal_error); diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c index 8cd966fa23f..0b9c16705eb 100644 --- a/libgfortran/runtime/error.c +++ b/libgfortran/runtime/error.c @@ -285,6 +285,21 @@ runtime_error_at (const char *where, const char *message, ...) iexport(runtime_error_at); +void +runtime_warning_at (const char *where, const char *message, ...) +{ + va_list ap; + + st_printf ("%s\n", where); + st_printf ("Fortran runtime warning: "); + va_start (ap, message); + st_vprintf (message, ap); + va_end (ap); + st_printf ("\n"); +} +iexport(runtime_warning_at); + + /* void internal_error()-- These are this-can't-happen errors * that indicate something deeply wrong. */ -- 2.30.2