[Patch, fortran] PR20893 - unconditional use of optional argument not detected

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

Once more, the standard:

 /* If it(the arg) is an array, it shall not be supplied as an actual 
argument
    to an elemental procedure unless an array of the same rank is supplied
    as an actual argument corresponding to a nonoptional dummy argument of
    that elemental procedure(12.4.1.5).  */

The patch to do this has been accomplished by drawing together the 
resolution of elemental functions and subroutines into a single 
function.  The implementation of the above is then straightforward, 
except for the different representations of elemental intrinsic 
functions, non-intrinsic elemental functions and elemental subroutines.  
However, this is a matter of perspiration rather than any intellectual 
stress.  Similarly, the testcase makes sure that the error is picked up 
in each case and that which should work is not broken.

Regtested on FC5/Athlon.  OK for trunk and 4.1?

Paul

2006-07-11  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/20893
   * resolve.c (resolve_elemental_actual): New function t combine
   all the checks of elemental procedure actual arguments. In
   addition, check of array valued optional args(this PR) has
   been added.
   (resolve_function, resolve_call): Remove parts that treated
   elemental procedure actual arguments and call the above.

2006-07-11  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/20893
   * gfortran.dg/elemental_optional_args_1.f90: New test.

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 115332)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_actual_arglist (gfc_actual_argli
*** 910,915 ****
--- 910,1056 ----
  }
  
  
+ /* Do the checks of the actual argument list that are specific to elemental
+    procedures.  If called with c == NULL, we have a function, otherwise if
+    expr == NULL, we have a subroutine.*/
+ static try
+ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
+ {
+   gfc_actual_arglist * arg0;
+   gfc_actual_arglist * arg;
+   gfc_symbol *esym = NULL;
+   gfc_intrinsic_sym *isym = NULL;
+   gfc_expr *e = NULL;
+   gfc_intrinsic_arg *iformal = NULL;
+   gfc_formal_arglist *eformal = NULL;
+   bool formal_optional = false;
+   bool set_by_optional = false;
+   int i;
+   int rank = 0;
+ 
+   /* Is this an elemental procedure?  */
+   if (expr && expr->value.function.actual != NULL)
+     {
+       if (expr->value.function.esym != NULL
+ 	    && expr->value.function.esym->attr.elemental)
+ 	{
+ 	  arg0 = expr->value.function.actual;
+ 	  esym = expr->value.function.esym;
+ 	}
+       else if (expr->value.function.isym != NULL
+ 		 && expr->value.function.isym->elemental)
+ 	{
+ 	  arg0 = expr->value.function.actual;
+ 	  isym = expr->value.function.isym;
+ 	}
+       else
+ 	return SUCCESS;
+     }
+   else if (c && c->ext.actual != NULL
+ 	     && c->symtree->n.sym->attr.elemental)
+     {
+       arg0 = c->ext.actual;
+       esym = c->symtree->n.sym;
+     }
+   else
+     return SUCCESS;
+ 
+   /* The rank of an elemental is the rank of its array argument(s).  */
+   for (arg = arg0; arg; arg = arg->next)
+     {
+       if (arg->expr != NULL && arg->expr->rank > 0)
+ 	{
+ 	  rank = arg->expr->rank;
+ 	  if (arg->expr->expr_type == EXPR_VARIABLE
+ 		&& arg->expr->symtree->n.sym->attr.optional)
+ 	    set_by_optional = true;
+ 
+ 	  /* Function specific; set the result rank and shape.  */
+ 	  if (expr)
+ 	    {
+ 	      expr->rank = rank;
+ 	      if (!expr->shape && arg->expr->shape)
+ 		{
+ 		  expr->shape = gfc_get_shape (rank);
+ 		  for (i = 0; i < rank; i++)
+ 		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
+ 		}
+ 	    }
+ 	  break;
+ 	}
+     }
+ 
+   /* If it is an array, it shall not be supplied as an actual argument
+      to an elemental procedure unless an array of the same rank is supplied
+      as an actual argument corresponding to a nonoptional dummy argument of
+      that elemental procedure(12.4.1.5).  */
+   formal_optional = false;
+   if (isym)
+     iformal = isym->formal;
+   else
+     eformal = esym->formal;
+ 
+   for (arg = arg0; arg; arg = arg->next)
+     {
+       if (eformal)
+ 	{
+ 	  if (eformal->sym && eformal->sym->attr.optional)
+ 	    formal_optional = true;
+ 	  eformal = eformal->next;
+ 	}
+       else if (isym && iformal)
+ 	{
+ 	  if (iformal->optional)
+ 	    formal_optional = true;
+ 	  iformal = iformal->next;
+ 	}
+       else if (isym)
+ 	formal_optional = true;
+ 
+       if (arg->expr !=NULL
+ 	    && arg->expr->expr_type == EXPR_VARIABLE
+ 	    && arg->expr->symtree->n.sym->attr.optional
+ 	    && formal_optional
+ 	    && arg->expr->rank
+ 	    && (set_by_optional || arg->expr->rank != rank)) 
+ 	{
+ 	  gfc_error ("'%s' at %L is an array and OPTIONAL; it cannot "
+ 		     "therefore be an actual argument of an ELEMENTAL " 
+ 		     "procedure unless there is a non-optional argument "
+ 		     "with the same rank (12.4.1.5)",
+ 		     arg->expr->symtree->n.sym->name, &arg->expr->where);
+ 	  return FAILURE;
+ 	}
+     }
+ 
+   for (arg = arg0; arg; arg = arg->next)
+     {
+       if (arg->expr == NULL || arg->expr->rank == 0)
+ 	continue;
+ 
+       /* Being elemental, the last upper bound of an assumed size array
+ 	 argument must be present.  */
+       if (resolve_assumed_size_actual (arg->expr))
+ 	return FAILURE;
+ 
+       if (expr)
+ 	continue;
+ 
+       /* Elemental subroutine array actual arguments must conform.  */
+       if (e != NULL)
+ 	{
+ 	  if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
+ 		== FAILURE)
+ 	    return FAILURE;
+ 	}
+       else
+ 	e = arg->expr;
+     }
+ 
+   return SUCCESS;
+ }
+ 
+ 
  /* Go through each actual argument in ACTUAL and see if it can be
     implemented as an inlined, non-copying intrinsic.  FNSYM is the
     function being called, or NULL if not known.  */
*************** resolve_function (gfc_expr * expr)
*** 1237,1243 ****
    const char *name;
    try t;
    int temp;
-   int i;
  
    sym = NULL;
    if (expr->symtree)
--- 1378,1383 ----
*************** resolve_function (gfc_expr * expr)
*** 1313,1350 ****
    temp = need_full_assumed_size;
    need_full_assumed_size = 0;
  
!   if (expr->value.function.actual != NULL
!       && ((expr->value.function.esym != NULL
! 	   && expr->value.function.esym->attr.elemental)
! 	  || (expr->value.function.isym != NULL
! 	      && expr->value.function.isym->elemental)))
!     {
!       /* The rank of an elemental is the rank of its array argument(s).  */
!       for (arg = expr->value.function.actual; arg; arg = arg->next)
! 	{
! 	  if (arg->expr != NULL && arg->expr->rank > 0)
! 	    {
! 	      expr->rank = arg->expr->rank;
! 	      if (!expr->shape && arg->expr->shape)
! 		{
! 		  expr->shape = gfc_get_shape (expr->rank);
! 		  for (i = 0; i < expr->rank; i++)
! 		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
! 	        }
! 	      break;
! 	    }
! 	}
  
-       /* Being elemental, the last upper bound of an assumed size array
- 	 argument must be present.  */
-       for (arg = expr->value.function.actual; arg; arg = arg->next)
- 	{
- 	  if (arg->expr != NULL
- 		&& arg->expr->rank > 0
- 		&& resolve_assumed_size_actual (arg->expr))
- 	    return FAILURE;
- 	}
-     }
    if (omp_workshare_flag
        && expr->value.function.esym
        && ! gfc_elemental (expr->value.function.esym))
--- 1453,1461 ----
    temp = need_full_assumed_size;
    need_full_assumed_size = 0;
  
!   if (resolve_elemental_actual (expr, NULL) == FAILURE)
!     return FAILURE;
  
    if (omp_workshare_flag
        && expr->value.function.esym
        && ! gfc_elemental (expr->value.function.esym))
*************** resolve_call (gfc_code * c)
*** 1730,1764 ****
  	gfc_internal_error ("resolve_subroutine(): bad function type");
        }
  
!   /* Some checks of elemental subroutines.  */
!   if (c->ext.actual != NULL
!       && c->symtree->n.sym->attr.elemental)
!     {
!       gfc_actual_arglist * a;
!       gfc_expr * e;
!       e = NULL;
! 
!       for (a = c->ext.actual; a; a = a->next)
! 	{
! 	  if (a->expr == NULL || a->expr->rank == 0)
! 	    continue;
! 
! 	 /* The last upper bound of an assumed size array argument must
! 	    be present.  */
! 	  if (resolve_assumed_size_actual (a->expr))
! 	    return FAILURE;
! 
! 	  /* Array actual arguments must conform.  */
! 	  if (e != NULL)
! 	    {
! 	      if (gfc_check_conformance ("elemental subroutine", a->expr, e)
! 			== FAILURE)
! 		return FAILURE;
! 	    }
! 	  else
! 	    e = a->expr;
! 	}
!     }
  
    if (t == SUCCESS)
      find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
--- 1841,1849 ----
  	gfc_internal_error ("resolve_subroutine(): bad function type");
        }
  
!   /* Some checks of elemental subroutine actual arguments.  */
!   if (resolve_elemental_actual (NULL, c) == FAILURE)
!     return FAILURE;
  
    if (t == SUCCESS)
      find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);

! { dg-do compile }
! Check the fix for PR20893, in which actual arguments could violate: 
! "(5) If it is an array, it shall not be supplied as an actual argument to
! an elemental procedure unless an array of the same rank is supplied as an
! actual argument corresponding to a nonoptional dummy argument of that 
! elemental procedure." (12.4.1.5)
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
  CALL T1(1,2)
CONTAINS
  SUBROUTINE T1(A1,A2,A3)
    INTEGER           :: A1,A2, A4(2)
    INTEGER, OPTIONAL :: A3(2)
    interface
      elemental function efoo (B1,B2,B3) result(bar)
        INTEGER, intent(in)           :: B1, B2
        integer           :: bar
        INTEGER, OPTIONAL, intent(in) :: B3
      end function efoo
    end interface

! check an intrinsic function
    write(6,*) MAX(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
    write(6,*) MAX(A1,A3,A2)
    write(6,*) MAX(A1,A4,A3)
! check an internal elemental function
    write(6,*) foo(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
    write(6,*) foo(A1,A3,A2)
    write(6,*) foo(A1,A4,A3)
! check an external elemental function
    write(6,*) efoo(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
    write(6,*) efoo(A1,A3,A2)
    write(6,*) efoo(A1,A4,A3)
! check an elemental subroutine
    call foobar (A1,A2,A3) ! { dg-error "array and OPTIONAL" } 
    call foobar (A1,A2,A4)
    call foobar (A1,A4,A4)
  END SUBROUTINE
  elemental function foo (B1,B2,B3) result(bar)
    INTEGER, intent(in)           :: B1, B2
    integer           :: bar
    INTEGER, OPTIONAL, intent(in) :: B3
    bar = 1
  end function foo
  elemental subroutine foobar (B1,B2,B3)
    INTEGER, intent(OUT)           :: B1
    INTEGER, optional, intent(in)  :: B2, B3
    B1 = 1
  end subroutine foobar

END

2006-07-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20893
	* resolve.c (resolve_elemental_actual): New function t combine
	all the checks of elemental procedure actual arguments. In
	addition, check of array valued optional args(this PR) has
	been added.
	(resolve_function, resolve_call): Remove parts that treated
	elemental procedure actual arguments and call the above.

2006-07-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20893
	* gfortran.dg/elemental_optional_args_1.f90: New test.