re PR fortran/36132 (_gfortran_internal_pack on optional arguments)

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-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.

From-SVN: r138186

1 files changed, 30 insertions, 7 deletions

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 1db628e..d6aef87 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);