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

1 files changed, 43 insertions, 5 deletions

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