OSDN Git Service

2008-07-27 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 27 Jul 2008 10:45:44 +0000 (10:45 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sun, 27 Jul 2008 10:45:44 +0000 (10:45 +0000)
        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  <burnus@net-b.de>

        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  <burnus@net-b.de>

        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@138186 138bc75d-0d04-0410-961f-82ee72b054a4

22 files changed:
gcc/fortran/ChangeLog
gcc/fortran/gfortran.h
gcc/fortran/invoke.texi
gcc/fortran/lang.opt
gcc/fortran/options.c
gcc/fortran/trans-array.c
gcc/fortran/trans-array.h
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-io.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/array_temporaries_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/internal_pack_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/internal_pack_5.f90 [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/gfortran.map
libgfortran/libgfortran.h
libgfortran/runtime/error.c

index 4569f52..fd3cff5 100644 (file)
@@ -1,3 +1,34 @@
+2008-07-27  Tobias Burnus  <burnus@net-b.de>
+
+       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  <jh@suse.cz>
 
        * fortran/options.c (gfc_post_options): Remove flag_unline_trees code.
index 18af94e..398a9a6 100644 (file)
@@ -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;
index ed3e1e7..f633187 100644 (file)
@@ -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{<zero|inf|-inf|nan>} @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
index 7a06760..9321195 100644 (file)
@@ -156,6 +156,10 @@ fblas-matmul-limit=
 Fortran RejectNegative Joined UInteger
 -fblas-matmul-limit=<n>        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
index 9bbb39a..1f05f35 100644 (file)
@@ -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;
index 9ec8406..14bab8e 100644 (file)
@@ -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);
index 1e34c9a..145f4a8 100644 (file)
@@ -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 *);
 
index d2161f5..d2cb6a3 100644 (file)
@@ -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,
index 3240d7f..e145c0c 100644 (file)
@@ -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);
index b76dd76..2dc2d4f 100644 (file)
@@ -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, 
index 7f98e5c..3d17a4c 100644 (file)
@@ -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);
 
index e19695f..79a1446 100644 (file)
@@ -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); 
index 1db628e..d6aef87 100644 (file)
@@ -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);
index 98002a9..7704748 100644 (file)
@@ -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;
index f6e2421..7bdc31b 100644 (file)
@@ -1,3 +1,12 @@
+2008-07-27  Tobias Burnus  <burnus@net-b.de>
+
+       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  <tkoenig@gcc.gnu.org>
 
        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 (file)
index 0000000..86e0a45
--- /dev/null
@@ -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 (file)
index 0000000..049931a
--- /dev/null
@@ -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 (file)
index 0000000..87705fa
--- /dev/null
@@ -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" } }
index 2459b53..0eb171c 100644 (file)
@@ -1,3 +1,12 @@
+2008-07-27  Tobias Burnus  <burnus@net-b.de>
+
+       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  <jvdelisle@gcc.gnu.org>
 
        PR fortran/36852
index 0671b60..93973d5 100644 (file)
@@ -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;
index 10439bd..7c49700 100644 (file)
@@ -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);
index 8cd966f..0b9c167 100644 (file)
@@ -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. */