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

gcc/fortran/ChangeLog

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

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;

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

gcc/fortran/lang.opt

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

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;

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);

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 *);
 

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,

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);

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, 

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);
 

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); 

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);

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;

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/array_temporaries_2.f90

+! { 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'" }

gcc/testsuite/gfortran.dg/internal_pack_4.f90

+! { 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" } }

gcc/testsuite/gfortran.dg/internal_pack_5.f90

+! { 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" } }

libgfortran/ChangeLog

+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

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;

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);

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