[Patch, fortran]

[Paul Thomas <paulthomas2@wanadoo.fr>]

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

:ADDPATCH:

This patch consists of five patchlets, all of which are straightforward and
self-explanatory.

Regtested on FC5/Athlon1700 - OK for trunk and 4.1?

Paul

2006-06-24  Paul Thomas  <pault@gcc.gnu.org>
 
	PR fortran/25056
	* interface.c (compare_actual_formal): Signal an error if the formal
	argument is a pure procedure and the actual is not pure.

	PR fortran/27554
	* resolve.c (resolve_actual_arglist): If the type of procedure
	passed as an actual argument is not already declared, see if it is
	an intrinsic.

	PR fortran/25073
	* resolve.c (resolve_select): Use bits 1 and 2 of a new int to
	keep track of  the appearance of constant logical case expressions.
	Signal an error is either value appears more than once.

	PR fortran/20874
	* resolve.c (resolve_fl_procedure): Signal an error if an elemental
	function is not scalar valued.

	PR fortran/20867
	* match.c (recursive_stmt_fcn): Perform implicit typing of variables.


2006-06-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20867
	* gfortran.dg/stfunc_3.f90: New test.

	PR fortran/25056
	* gfortran.dg/impure_actual_1.f90: New test.

	PR fortran/20874
	* gfortran.dg/elemental_result_1.f90: New test.

	PR fortran/25073
	* gfortran.dg/select_7.f90: New test.

	PR fortran/27554
	* intrinsic_actual_1.f: New test.


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

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 114823)
--- gcc/fortran/interface.c	(working copy)
*************** compare_actual_formal (gfc_actual_arglis
*** 1296,1301 ****
--- 1296,1312 ----
  	    }
  	}
  
+       if (f->sym->attr.flavor == FL_PROCEDURE
+ 	    && f->sym->attr.pure
+ 	    && a->expr->ts.type == BT_PROCEDURE
+ 	    && !a->expr->symtree->n.sym->attr.pure)
+ 	{
+ 	  if (where)
+ 	    gfc_error ("Expected a PURE procedure for argument '%s' at %L",
+ 		       f->sym->name, &a->expr->where);
+ 	  return 0;
+ 	}
+ 
        if (f->sym->as
  	  && f->sym->as->type == AS_ASSUMED_SHAPE
  	  && a->expr->expr_type == EXPR_VARIABLE
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 114823)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_actual_arglist (gfc_actual_argli
*** 829,834 ****
--- 829,842 ----
  	  || sym->attr.external)
  	{
  
+ 	  /* If a procedure is not already determined to be something else
+ 	     check if it is intrinsic.  */
+ 	  if (!sym->attr.intrinsic
+ 		&& !(sym->attr.external || sym->attr.use_assoc
+ 		       || sym->attr.if_source == IFSRC_IFBODY)
+ 		&& gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ 	    sym->attr.intrinsic = 1;
+ 
  	  if (sym->attr.proc == PROC_ST_FUNCTION)
  	    {
  	      gfc_error ("Statement function '%s' at %L is not allowed as an "
*************** resolve_select (gfc_code * code)
*** 3615,3620 ****
--- 3623,3629 ----
    gfc_expr *case_expr;
    gfc_case *cp, *default_case, *tail, *head;
    int seen_unreachable;
+   int seen_logical;
    int ncases;
    bt type;
    try t;
*************** resolve_select (gfc_code * code)
*** 3697,3702 ****
--- 3706,3712 ----
    default_case = NULL;
    head = tail = NULL;
    ncases = 0;
+   seen_logical = 0;
  
    for (body = code->block; body; body = body->block)
      {
*************** resolve_select (gfc_code * code)
*** 3749,3754 ****
--- 3759,3777 ----
  	      break;
  	    }
  
+ 	  if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
+ 	    {
+ 	      if (cp->low->value.logical & seen_logical)
+ 		{
+ 		  gfc_error ("constant logical value in CASE statement "
+ 			     "is repeated at %L",
+ 			     &cp->low->where);
+ 		  t = FAILURE;
+ 		  break;
+ 		}
+ 	      seen_logical |= cp->low->value.logical == 0 ? 2 : 1;
+ 	    }
+ 
  	  if (cp->low != NULL && cp->high != NULL
  	      && cp->low != cp->high
  	      && gfc_compare_expr (cp->low, cp->high) > 0)
*************** resolve_fl_procedure (gfc_symbol *sym, i
*** 5177,5182 ****
--- 5200,5215 ----
        return FAILURE;
      }
  
+   /* An elemental function is required to return a scalar 12.7.1  */
+   if (sym->attr.elemental && sym->attr.function && sym->as)
+     {
+       gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
+ 		 "result", sym->name, &sym->declared_at);
+       /* Reset so that the error only occurs once.  */
+       sym->attr.elemental = 0;
+       return FAILURE;
+     }
+ 
    /* 5.1.1.5 of the Standard: A function name declared with an asterisk
       char-len-param shall not be array-valued, pointer-valued, recursive
       or pure.  ....snip... A character value of * may only be used in the
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 114823)
--- gcc/fortran/match.c	(working copy)
*************** cleanup:
*** 2796,2802 ****
  
  /* Check that a statement function is not recursive. This is done by looking
     for the statement function symbol(sym) by looking recursively through its
!    expression(e).  If a reference to sym is found, true is returned.  */
  static bool
  recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
  {
--- 2796,2806 ----
  
  /* Check that a statement function is not recursive. This is done by looking
     for the statement function symbol(sym) by looking recursively through its
!    expression(e).  If a reference to sym is found, true is returned.  
!    12.5.4 requires that any variable of function that is implicitly typed
!    shall have that type confirmed by any subsequent type declaration.  The
!    implicit typing is conveniently done here.  */
! 
  static bool
  recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
  {
*************** recursive_stmt_fcn (gfc_expr *e, gfc_sym
*** 2830,2840 ****
--- 2834,2850 ----
  	    && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
  	return true;
  
+       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ 	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
+ 
        break;
  
      case EXPR_VARIABLE:
        if (e->symtree && sym->name == e->symtree->n.sym->name)
  	return true;
+ 
+       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ 	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
        break;
  
      case EXPR_OP:
Index: gcc/testsuite/gfortran.dg/stfunc_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/stfunc_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/stfunc_3.f90	(revision 0)
***************
*** 0 ****
--- 1,13 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR20867 in which implicit typing was not done within
+ ! statement functions and so was not confirmed or not by subsequent
+ ! type delarations.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+   REAL :: st1
+   st1(I)=I**2
+   REAL :: I ! { dg-error " already has basic type of INTEGER" }
+   END
+ 
+ 
Index: gcc/testsuite/gfortran.dg/impure_actual_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/impure_actual_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/impure_actual_1.f90	(revision 0)
***************
*** 0 ****
--- 1,25 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR25056 in which a non-PURE procedure could be
+ ! passed as the actual argument to a PURE procedure.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+ MODULE M1
+ CONTAINS
+  FUNCTION L()
+   L=1
+  END FUNCTION L
+  PURE FUNCTION J(K)
+    INTERFACE
+      PURE FUNCTION K()
+      END FUNCTION K
+    END INTERFACE
+    J=K()
+  END FUNCTION J
+ END MODULE M1
+ USE M1
+  write(6,*) J(L) ! { dg-error "Expected a PURE procedure for argument" }
+ END
+ 
+ ! { dg-final { cleanup-modules "M1" } }
+ 
Index: gcc/testsuite/gfortran.dg/elemental_result_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/elemental_result_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/elemental_result_1.f90	(revision 0)
***************
*** 0 ****
--- 1,21 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR20874 in which array valued elemental
+ ! functions were permitted.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+ MODULE Test
+ CONTAINS
+   ELEMENTAL FUNCTION LL(I) ! { dg-error "must have a scalar result" }
+     INTEGER, INTENT(IN) :: I
+     INTEGER  :: LL(2)
+   END FUNCTION LL
+ !
+ ! This was already OK.
+ !
+   ELEMENTAL FUNCTION MM(I)
+     INTEGER, INTENT(IN) :: I
+     INTEGER, pointer  :: MM ! { dg-error "conflicts with ELEMENTAL" }
+   END FUNCTION MM
+ END MODULE Test
+ 
Index: gcc/testsuite/gfortran.dg/select_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/select_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/select_7.f90	(revision 0)
***************
*** 0 ****
--- 1,13 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR25073 in which overlap in logical case
+ ! expressions was permitted.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+ LOGICAL :: L
+ SELECT CASE(L)
+ CASE(.true.)
+ CASE(.false.)
+ CASE(.true.) ! { dg-error "value in CASE statement is repeated" }
+ END SELECT
+ END
Index: gcc/testsuite/gfortran.dg/intrinsic_actual_1.f
===================================================================
*** gcc/testsuite/gfortran.dg/intrinsic_actual_1.f	(revision 0)
--- gcc/testsuite/gfortran.dg/intrinsic_actual_1.f	(revision 0)
***************
*** 0 ****
--- 1,49 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR27554, where the actual argument reference
+ ! to abs would not be recognised as being to an intrinsic
+ ! procedure and would produce junk in the assembler.
+ !
+ ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> 
+ !
+       subroutine foo (proc, z)
+         external proc
+         real proc, z
+         if ((proc(z) .ne. abs (z)) .and. 
+      &      (proc(z) .ne. alog10 (abs(z)))) call abort ()
+         return
+       end
+ 
+         external cos
+         interface
+           function sin (a)
+             real a, sin
+           end function sin
+         end interface
+ 
+ 
+         intrinsic alog10
+         real x
+         x = 100.
+ ! The reference here would prevent the actual arg from being seen
+ ! as an intrinsic procedure in the call to foo.
+         x = -abs(x)
+         call foo(abs, x)
+ ! The intrinsic function can be locally over-ridden by an interface
+         call foo(sin, x)
+ ! or an external declaration.
+         call foo(cos, x)
+ ! Just make sure with another intrinsic but this time not referenced.
+         call foo(alog10, -x)
+       end
+ 
+       function sin (a)
+         real a, sin
+         sin = -a
+         return
+       end
+ 
+       function cos (a)
+         real a, cos
+         cos = -a
+         return
+       end

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

2006-06-24  Paul Thomas  <pault@gcc.gnu.org>
 
	PR fortran/25056
	* interface.c (compare_actual_formal): Signal an error if the formal
	argument is a pure procedure and the actual is not pure.

	PR fortran/27554
	* resolve.c (resolve_actual_arglist): If the type of procedure
	passed as an actual argument is not already declared, see if it is
	an intrinsic.

	PR fortran/25073
	* resolve.c (resolve_select): Use bits 1 and 2 of a new int to
	keep track of  the appearance of constant logical case expressions.
	Signal an error is either value appears more than once.

	PR fortran/20874
	* resolve.c (resolve_fl_procedure): Signal an error if an elemental
	function is not scalar valued.

	PR fortran/20867
	* match.c (recursive_stmt_fcn): Perform implicit typing of variables.


2006-06-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20867
	* gfortran.dg/stfunc_3.f90: New test.

	PR fortran/25056
	* gfortran.dg/impure_actual_1.f90: New test.

	PR fortran/20874
	* gfortran.dg/elemental_result_1.f90: New test.

	PR fortran/25073
	* gfortran.dg/select_7.f90: New test.

	PR fortran/27554
	* intrinsic_actual_1.f: New test.