public inbox for fortran@gcc.gnu.org
 help / color / mirror / Atom feed
* [Patch, fortran] PR20893 - unconditional use of optional argument  not detected
@ 2006-07-11 14:34 Paul Thomas
  2006-07-14 17:34 ` Paul Thomas
  2006-07-15  4:50 ` [Patch, fortran] PR20893 - unconditional use of optional argument not detected Steve Kargl
  0 siblings, 2 replies; 6+ messages in thread
From: Paul Thomas @ 2006-07-11 14:34 UTC (permalink / raw)
  To: 'fortran@gcc.gnu.org', patch

[-- Attachment #1: Type: text/plain, Size: 1451 bytes --]

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


[-- Attachment #2: pr20893.diff --]
[-- Type: text/x-patch, Size: 7562 bytes --]

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

[-- Attachment #3: elemental_optional_args_1.f90 --]
[-- Type: text/x-fortran, Size: 1768 bytes --]

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

[-- Attachment #4: Change.Logs --]
[-- Type: text/plain, Size: 501 bytes --]

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.

^ permalink raw reply	[flat|nested] 6+ messages in thread
end of thread, other threads:[~2006-07-15  4:22 UTC | newest]

Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2006-07-11 14:34 [Patch, fortran] PR20893 - unconditional use of optional argument not detected Paul Thomas
2006-07-14 17:34 ` Paul Thomas
2006-07-14 18:00   ` Internal Compiler Error Ray Nachlinger
2006-07-14 20:00     ` Paul Thomas
2006-07-14 20:05       ` Steve Kargl
2006-07-15  4:50 ` [Patch, fortran] PR20893 - unconditional use of optional argument not detected Steve Kargl

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).