re PR fortran/25056 (non-PURE function should not be a valid argument)

2006-06-25  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.

	PR fortran/22038
	* match.c (match_forall_iterator): Mark new variables as
	FL_UNKNOWN if the match fails.

	PR fortran/28119
	* match.c (gfc_match_forall): Remove extraneous call to
	gfc_match_eos.

	PR fortran/25072
	* resolve.c (resolve_code, resolve_function): Rework
	forall_flag scheme so that it is set and has a value of
	2, when the code->expr (ie. the forall mask) is resolved.
	This is used to change "block" to "mask" in the non-PURE
	error message.


2006-06-25  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.

	PR fortran/22038
	PR fortran/28119
	* gfortran.dg/forall_4.f90: New test.

	PR fortran/25072
	* gfortran.dg/forall_5.f90: New test.

From-SVN: r114987

12 files changed, 361 insertions, 9 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6e5e492..bae2a2b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,41 @@
+2006-06-25  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.
+
+	PR fortran/22038
+	* match.c (match_forall_iterator): Mark new variables as
+	FL_UNKNOWN if the match fails.
+
+	PR fortran/28119
+	* match.c (gfc_match_forall): Remove extraneous call to
+	gfc_match_eos.
+
+	PR fortran/25072
+	* resolve.c (resolve_code, resolve_function): Rework
+	forall_flag scheme so that it is set and has a value of
+	2, when the code->expr (ie. the forall mask) is resolved.
+	This is used to change "block" to "mask" in the non-PURE
+	error message.
+
 2006-06-24  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR fortran/28081
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 521876e..bc99aab 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1296,6 +1296,17 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 	    }
 	}
 
+      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
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0ad5e13..77594cb 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2802,7 +2802,11 @@ cleanup:
 
 /* 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.  */
+   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)
 {
@@ -2836,11 +2840,17 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
 	    && 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:
@@ -3392,6 +3402,13 @@ syntax:
   m = MATCH_ERROR;
 
 cleanup:
+  /* Make sure that potential internal function references in the
+     mask do not get messed up.  */
+  if (iter->var
+	&& iter->var->expr_type == EXPR_VARIABLE
+	&& iter->var->symtree->n.sym->refs == 1)
+    iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
+
   gfc_current_locus = where;
   gfc_free_forall_iterator (iter);
   return m;
@@ -3586,9 +3603,6 @@ gfc_match_forall (gfc_statement * st)
   *c = new_st;
   c->loc = gfc_current_locus;
 
-  if (gfc_match_eos () != MATCH_YES)
-    goto syntax;
-
   gfc_clear_new_st ();
   new_st.op = EXEC_FORALL;
   new_st.expr = mask;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fe37f2c..0e9916a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -829,6 +829,14 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	  || 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 "
@@ -1381,8 +1389,9 @@ resolve_function (gfc_expr * expr)
       if (forall_flag)
 	{
 	  gfc_error
-	    ("Function reference to '%s' at %L is inside a FORALL block",
-	     name, &expr->where);
+	    ("reference to non-PURE function '%s' at %L inside a "
+	     "FORALL %s", name, &expr->where, forall_flag == 2 ?
+	     "mask" : "block");
 	  t = FAILURE;
 	}
       else if (gfc_pure (NULL))
@@ -3619,6 +3628,7 @@ resolve_select (gfc_code * code)
   gfc_expr *case_expr;
   gfc_case *cp, *default_case, *tail, *head;
   int seen_unreachable;
+  int seen_logical;
   int ncases;
   bt type;
   try t;
@@ -3701,6 +3711,7 @@ resolve_select (gfc_code * code)
   default_case = NULL;
   head = tail = NULL;
   ncases = 0;
+  seen_logical = 0;
 
   for (body = code->block; body; body = body->block)
     {
@@ -3753,6 +3764,21 @@ resolve_select (gfc_code * code)
 	      break;
 	    }
 
+	  if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
+	    {
+	      int value;
+	      value = cp->low->value.logical == 0 ? 2 : 1;
+	      if (value & seen_logical)
+		{
+		  gfc_error ("constant logical value in CASE statement "
+			     "is repeated at %L",
+			     &cp->low->where);
+		  t = FAILURE;
+		  break;
+		}
+	      seen_logical |= value;
+	    }
+
 	  if (cp->low != NULL && cp->high != NULL
 	      && cp->low != cp->high
 	      && gfc_compare_expr (cp->low, cp->high) > 0)
@@ -4513,6 +4539,7 @@ static void
 resolve_code (gfc_code * code, gfc_namespace * ns)
 {
   int omp_workshare_save;
+  int forall_save;
   code_stack frame;
   gfc_alloc *a;
   try t;
@@ -4524,14 +4551,13 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
   for (; code; code = code->next)
     {
       frame.current = code;
+      forall_save = forall_flag;
 
       if (code->op == EXEC_FORALL)
 	{
-	  int forall_save = forall_flag;
-
 	  forall_flag = 1;
 	  gfc_resolve_forall (code, ns, forall_save);
-	  forall_flag = forall_save;
+	  forall_flag = 2;
 	}
       else if (code->block)
 	{
@@ -4567,6 +4593,8 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
 	}
 
       t = gfc_resolve_expr (code->expr);
+      forall_flag = forall_save;
+
       if (gfc_resolve_expr (code->expr2) == FAILURE)
 	t = FAILURE;
 
@@ -5181,6 +5209,16 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
       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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8e66a79..644b44ea 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,27 @@
+2006-06-25  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.
+
+	PR fortran/22038
+	PR fortran/28119
+	* gfortran.dg/forall_4.f90: New test.
+
+	PR fortran/25072
+	* gfortran.dg/forall_5.f90: New test.
+
 2006-06-25  Lee Millward  <lee.millward@gmail.com>
 
 	PR c++/28051
diff --git a/gcc/testsuite/gfortran.dg/elemental_result_1.f90 b/gcc/testsuite/gfortran.dg/elemental_result_1.f90
new file mode 100644
index 0000000..c94e08e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_result_1.f90
@@ -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
+
diff --git a/gcc/testsuite/gfortran.dg/forall_4.f90 b/gcc/testsuite/gfortran.dg/forall_4.f90
new file mode 100644
index 0000000..0b0d731
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/forall_4.f90
@@ -0,0 +1,66 @@
+! { dg-do run }
+! Tests the fix for PR25072, in which mask expressions
+! that start with an internal or intrinsic function 
+! reference would give a syntax error.
+!
+! The fix for PR28119 is tested as well; here, the forall
+! statement could not be followed by another statement on
+! the same line.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module foo
+  integer, parameter :: n = 4
+contains
+  pure logical function foot (i)
+    integer, intent(in) :: i
+    foot = (i == 2) .or. (i == 3)
+  end function foot
+end module foo
+
+  use foo
+  integer :: i, a(n)
+  logical :: s(n)
+  s = (/(foot (i), i=1, n)/)
+
+! Check that non-mask case is still OK and the fix for PR28119
+  a = 0
+  forall (i=1:n) a(i) = i ; if (any (a .ne. (/1,2,3,4/))) call abort ()
+
+! Now a mask using a function with an explicit interface
+! via use association.
+  a = 0
+  forall (i=1:n, foot (i)) a(i) = i
+  if (any (a .ne. (/0,2,3,0/))) call abort ()
+
+! Now an array variable mask
+  a = 0
+  forall (i=1:n, .not. s(i)) a(i) = i
+  if (any (a .ne. (/1,0,0,4/))) call abort ()
+
+! This was the PR - an internal function mask
+  a = 0
+  forall (i=1:n, t (i)) a(i) = i
+  if (any (a .ne. (/0,2,0,4/))) call abort ()
+
+! Check that an expression is OK - this also gave a syntax
+! error
+  a = 0
+  forall (i=1:n, mod (i, 2) == 0) a(i) = i
+  if (any (a .ne. (/0,2,0,4/))) call abort ()
+
+! And that an expression that used to work is OK
+  a = 0
+  forall (i=1:n, s (i) .or. t(i)) a(i) = w (i)
+  if (any (a .ne. (/0,3,2,1/))) call abort ()
+
+contains
+  pure logical function t(i)
+    integer, intent(in) :: i
+    t = (mod (i, 2) == 0)
+  end function t
+  pure integer function w(i)
+    integer, intent(in) :: i
+    w = 5 - i
+  end function w
+end
diff --git a/gcc/testsuite/gfortran.dg/forall_5.f90 b/gcc/testsuite/gfortran.dg/forall_5.f90
new file mode 100644
index 0000000..43ed2b5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/forall_5.f90
@@ -0,0 +1,40 @@
+! { dg-do compile }
+! Tests the fix for PR25072, in which non-PURE functions could
+! be referenced inside a FORALL mask.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module foo
+  integer, parameter :: n = 4
+contains
+  logical function foot (i)
+    integer, intent(in) :: i
+    foot = (i == 2) .or. (i == 3)
+  end function foot
+end module foo
+
+  use foo
+  integer :: i, a(n)
+  logical :: s(n)
+
+  a = 0
+  forall (i=1:n, foot (i)) a(i) = i  ! { dg-error "non-PURE" }
+  if (any (a .ne. (/0,2,3,0/))) call abort ()
+
+  forall (i=1:n, s (i) .or. t(i)) a(i) = i  ! { dg-error "non-PURE|LOGICAL" }
+  if (any (a .ne. (/0,3,2,1/))) call abort ()
+
+  a = 0
+  forall (i=1:n, mod (i, 2) == 0) a(i) = w (i)  ! { dg-error "non-PURE" }
+  if (any (a .ne. (/0,2,0,4/))) call abort ()
+
+contains
+  logical function t(i)
+    integer, intent(in) :: i
+    t = (mod (i, 2) == 0)
+  end function t
+  integer function w(i)
+    integer, intent(in) :: i
+    w = 5 - i
+  end function w
+end
diff --git a/gcc/testsuite/gfortran.dg/impure_actual_1.f90 b/gcc/testsuite/gfortran.dg/impure_actual_1.f90
new file mode 100644
index 0000000..43711d4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/impure_actual_1.f90
@@ -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" } }
+
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_actual_1.f b/gcc/testsuite/gfortran.dg/intrinsic_actual_1.f
new file mode 100644
index 0000000..7596e32
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_actual_1.f
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/select_7.f90 b/gcc/testsuite/gfortran.dg/select_7.f90
new file mode 100644
index 0000000..15b0750
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_7.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/stfunc_3.f90 b/gcc/testsuite/gfortran.dg/stfunc_3.f90
new file mode 100644
index 0000000..42eedf8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/stfunc_3.f90
@@ -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
+
+