[Patch, fortran] PR26891 - Automatic conversion for optional parameters of missing dummies

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

This patch fixes PR26891, in which missing, optional, dummy arguments 
cause a segfault when used as optional actual arguments.  The original 
involved intrinsic functions such as scan and verify but the same occurs 
for non-intrinsic functions too.

According to the standard:
__________________________

12.4.1.5 Restriction on dummy arguments not present.

.....

Except as noted in the list above, it may be supplied as an actual 
argument corresponding to an optional dummy argument, which is also 
considered not to be associated with an actual argument.

.....

The patch and the testcase are straightforward.  On the condition that 
the argument is both an optional dummy, not present and an optional 
formal argument, a null is passed for the expression and the 
string_length, if present.

This does not fix all intrinsic calls because some of the optional 
arguments are passed by value and zero does not always mean the same as 
the argument not being there.  However, ICEs no longer occur and most of 
the bad cases produce error messages.  This can only be fixed in the 
longer run by going through the intrinsics and making sure that they do 
the right thing; signalling a missing value with a null is about all 
that can be done.  It works in all cases for non-intrinsic functions.

I took the opportunity to prettify the code a bit in 
gfc_conv_intrinsic_function_args and gfc_conv_function_call; I reduced 
some of the deeply nested structure component references by introducing 
new gfc_exprs and a new gfc_symbol.

Regtested on FC3/Athlon.

OK for trunk and 4.1?

Paul

2005-03-31  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.

2005-03-31  Paul Thomas  <pault@gcc.gnu.org>

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




Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(révision 112529)
+++ gcc/fortran/trans.h	(copie de travail)
@@ -317,6 +317,8 @@
 
 /* Return an expression which determines if a dummy parameter is present.  */
 tree gfc_conv_expr_present (gfc_symbol *);
+/* Convert a missing, dummy argument into a null or zero.  */
+void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec);
 
 /* Generate code to allocate a string temporary.  */
 tree gfc_conv_string_tmp (gfc_se *, tree, tree);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(révision 112529)
+++ gcc/fortran/trans-intrinsic.c	(copie de travail)
@@ -165,29 +165,43 @@
 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
 {
   gfc_actual_arglist *actual;
+  gfc_expr *e;
+  gfc_intrinsic_arg  *formal;
+  gfc_se argse;
   tree args;
-  gfc_se argse;
 
   args = NULL_TREE;
-  for (actual = expr->value.function.actual; actual; actual = actual->next)
+  formal = expr->value.function.isym->formal;
+
+  for (actual = expr->value.function.actual; actual; actual = actual->next,
+       formal = formal ? formal->next : NULL)
     {
+      e = actual->expr;
       /* Skip omitted optional arguments.  */
-      if (!actual->expr)
+      if (!e)
 	continue;
 
       /* Evaluate the parameter.  This will substitute scalarized
          references automatically.  */
       gfc_init_se (&argse, se);
 
-      if (actual->expr->ts.type == BT_CHARACTER)
+      if (e->ts.type == BT_CHARACTER)
 	{
-	  gfc_conv_expr (&argse, actual->expr);
+	  gfc_conv_expr (&argse, e);
 	  gfc_conv_string_parameter (&argse);
 	  args = gfc_chainon_list (args, argse.string_length);
 	}
       else
-        gfc_conv_expr_val (&argse, actual->expr);
+        gfc_conv_expr_val (&argse, e);
 
+      /* If an optional argument is itself an optional dummy argument,
+	 check its presence and substitute a null if absent.  */
+      if (e->expr_type ==EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.optional
+	    && formal
+	    && formal->optional)
+	gfc_conv_missing_dummy (&argse, e, formal->ts);
+
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);
       args = gfc_chainon_list (args, argse.expr);
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(révision 112529)
+++ gcc/fortran/trans-expr.c	(copie de travail)
@@ -142,6 +142,31 @@
 }
 
 
+/* 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 @@
   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 @@
   /* 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 @@
 	{
 	  /* 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,35 +1930,42 @@
                  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 = gfc_trans_dealloc_allocated (arg->expr->symtree->n.sym);
+                  tmp = gfc_trans_dealloc_allocated (e->symtree->n.sym);
                   gfc_add_expr_to_block (&se->pre, tmp);
                 }
 
 	    } 
 	}
 
-      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);
 

! { dg-do run }
! Test the fix for PR26891, in which an optional argument, whose actual
! is a missing dummy argument would cause a segfault.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
  logical :: back =.false.

! This was the case that would fail - PR case was an intrinsic call.
  if (scan ("A quick brown fox jumps over the lazy dog", "lazy", back) &
      .ne. myscan ("A quick brown fox jumps over the lazy dog", "lazy")) &
    call abort ()

! Check that the patch works with non-intrinsic functions.
  if (myscan ("A quick brown fox jumps over the lazy dog", "fox", back) &
      .ne. thyscan ("A quick brown fox jumps over the lazy dog", "fox")) &
    call abort ()

! Check that missing, optional character actual arguments are OK.
  if (scan ("A quick brown fox jumps over the lazy dog", "over", back) &
      .ne. thyscan ("A quick brown fox jumps over the lazy dog")) &
    call abort ()

contains
  integer function myscan (str, substr, back)
    character(*), intent(in) :: str, substr
    logical, optional, intent(in) :: back
    myscan = scan (str, substr, back)
  end function myscan

  integer function thyscan (str, substr, back)
    character(*), intent(in) :: str
    character(*), optional, intent(in) :: substr
    logical, optional, intent(in) :: back
    thyscan = isscan (str, substr, back)
  end function thyscan

  integer function isscan (str, substr, back)
    character(*), intent(in) :: str
    character(*), optional :: substr
    logical, optional, intent(in) :: back
    if (.not.present(substr)) then
      isscan = myscan (str, "over", back)
    else
      isscan = myscan (str, substr, back)
    end if
  end function isscan

end