re PR testsuite/26981 (g++.old-deja/g++.other/init18.C fails)

2006-04-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26981
	* trans.h : Prototype for gfc_conv_missing_dummy.
	* trans-expr (gfc_conv_missing_dummy): New function
	(gfc_conv_function_call): Call it and tidy up some of the code.
	* trans-intrinsic (gfc_conv_intrinsic_function_args): The same.

	PR fortran/26976
	* array.c (gfc_array_dimen_size): If available, return shape[dimen].
	* resolve.c (resolve_function): If available, use the argument shape for the
	function expression.
	* iresolve.c (gfc_resolve_transfer): Set shape[0] = size.

2006-04-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26981
	* gfortran.dg/missing_optional_dummy_1.f90: New test.

	PR fortran/26976
	* gfortran.dg/compliant_elemental_intrinsics_1.f90: New test.
	* gfortran.dg/initialization_1.f90: Make assignment compliant.
	* gfortran.dg/transfer_array_intrinsic_1.f90: Simplify.
	* gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments compliant and detect
	bigendian-ness.

From-SVN: r112634

1 files changed, 55 insertions, 19 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 94921bc..1e1802e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -142,6 +142,31 @@ gfc_conv_expr_present (gfc_symbol * sym)
 }
 
 
+/* Converts a missing, dummy argument into a null or zero.  */
+
+void
+gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
+{
+  tree present;
+  tree tmp;
+
+  present = gfc_conv_expr_present (arg->symtree->n.sym);
+  tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
+		convert (TREE_TYPE (se->expr), integer_zero_node));
+  tmp = gfc_evaluate_now (tmp, &se->pre);
+  se->expr = tmp;
+  if (ts.type == BT_CHARACTER)
+    {
+      tmp = convert (gfc_charlen_type_node, integer_zero_node);
+      tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
+		    se->string_length, tmp);
+      tmp = gfc_evaluate_now (tmp, &se->pre);
+      se->string_length = tmp;
+    }
+  return;
+}
+
+
 /* Get the character length of an expression, looking through gfc_refs
    if necessary.  */
 
@@ -1805,6 +1830,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   bool callee_alloc;
   gfc_typespec ts;
   gfc_charlen cl;
+  gfc_expr *e;
+  gfc_symbol *fsym;
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -1844,7 +1871,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
     {
-      if (arg->expr == NULL)
+      e = arg->expr;
+      fsym = formal ? formal->sym : NULL;
+      if (e == NULL)
 	{
 
 	  if (se->ignore_optional)
@@ -1872,19 +1901,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	{
 	  /* An elemental function inside a scalarized loop.  */
           gfc_init_se (&parmse, se);
-          gfc_conv_expr_reference (&parmse, arg->expr);
+          gfc_conv_expr_reference (&parmse, e);
 	}
       else
 	{
 	  /* A scalar or transformational function.  */
 	  gfc_init_se (&parmse, NULL);
-	  argss = gfc_walk_expr (arg->expr);
+	  argss = gfc_walk_expr (e);
 
 	  if (argss == gfc_ss_terminator)
             {
-	      gfc_conv_expr_reference (&parmse, arg->expr);
-              if (formal && formal->sym->attr.pointer
-		  && arg->expr->expr_type != EXPR_NULL)
+	      gfc_conv_expr_reference (&parmse, e);
+              if (fsym && fsym->attr.pointer
+		  && e->expr_type != EXPR_NULL)
                 {
                   /* Scalar pointer dummy args require an extra level of
 		  indirection. The null pointer already contains
@@ -1901,27 +1930,27 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                  convention, and pass the address of the array descriptor
                  instead. Otherwise we use g77's calling convention.  */
 	      int f;
-	      f = (formal != NULL)
-		  && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
-		  && formal->sym->as->type != AS_ASSUMED_SHAPE;
+	      f = (fsym != NULL)
+		  && !(fsym->attr.pointer || fsym->attr.allocatable)
+		  && fsym->as->type != AS_ASSUMED_SHAPE;
 	      f = f || !sym->attr.always_explicit;
-	      if (arg->expr->expr_type == EXPR_VARIABLE
-		    && is_aliased_array (arg->expr))
+	      if (e->expr_type == EXPR_VARIABLE
+		    && is_aliased_array (e))
 		/* The actual argument is a component reference to an
 		   array of derived types.  In this case, the argument
 		   is converted to a temporary, which is passed and then
 		   written back after the procedure call.  */
-		gfc_conv_aliased_arg (&parmse, arg->expr, f);
+		gfc_conv_aliased_arg (&parmse, e, f);
 	      else
-	        gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+	        gfc_conv_array_parameter (&parmse, e, argss, f);
 
               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
                  allocated on entry, it must be deallocated.  */
-              if (formal && formal->sym->attr.allocatable
-                  && formal->sym->attr.intent == INTENT_OUT)
+              if (fsym && fsym->attr.allocatable
+                  && fsym->attr.intent == INTENT_OUT)
                 {
-		  tmp = arg->expr->symtree->n.sym->backend_decl;
-		  if (arg->expr->symtree->n.sym->attr.dummy)
+		  tmp = e->symtree->n.sym->backend_decl;
+		  if (e->symtree->n.sym->attr.dummy)
                     tmp = build_fold_indirect_ref (tmp);
                   tmp = gfc_trans_dealloc_allocated (tmp);
                   gfc_add_expr_to_block (&se->pre, tmp);
@@ -1930,8 +1959,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    } 
 	}
 
-      if (formal && need_interface_mapping)
-	gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
+      /* If an optional argument is itself an optional dummy argument,
+	 check its presence and substitute a null if absent.  */
+      if (e && e->expr_type == EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.optional
+	    && fsym && fsym->attr.optional)
+	gfc_conv_missing_dummy (&parmse, e, fsym->ts);
+
+      if (fsym && need_interface_mapping)
+	gfc_add_interface_mapping (&mapping, fsym, &parmse);
 
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&se->post, &parmse.post);