re PR fortran/45197 ([F2008] Allow IMPURE elemental procedures)

2010-08-15  Daniel Kraft  <d@domob.eu>

	PR fortran/45197
	* decl.c (gfc_match_prefix): Match IMPURE prefix and mark ELEMENTAL
	routines not IMPURE also as PURE.
	* intrinsic.c (enum klass): New class `CLASS_PURE' and renamed
	`NO_CLASS' in `CLASS_IMPURE'.
	(add_sym): Set symbol-attributes `pure' and `elemental' correctly.
	(add_sym_0s): Renamed `NO_CLASS' in `CLASS_IMPURE'.
	(add_functions): Ditto.
	(add_subroutines): Ditto and mark `MOVE_ALLOC' as CLASS_PURE.
	* resolve.c (gfc_pure): Do not treat ELEMENTAL as automatically PURE.
	(resolve_formal_arglist): Check that arguments to ELEMENTAL procedures
	are not ALLOCATABLE and have their INTENT specified.

2010-08-15  Daniel Kraft  <d@domob.eu>

	PR fortran/45197
	* gfortran.dg/elemental_args_check_3.f90: New test.
	* gfortran.dg/impure_1.f08: New test.
	* gfortran.dg/impure_2.f08: New test.
	* gfortran.dg/impure_3.f90: New test.
	* gfortran.dg/typebound_proc_6.f03: Changed expected error message.

From-SVN: r163261

gcc/fortran/ChangeLog

+2010-08-15  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45197
+	* decl.c (gfc_match_prefix): Match IMPURE prefix and mark ELEMENTAL
+	routines not IMPURE also as PURE.
+	* intrinsic.c (enum klass): New class `CLASS_PURE' and renamed
+	`NO_CLASS' in `CLASS_IMPURE'.
+	(add_sym): Set symbol-attributes `pure' and `elemental' correctly.
+	(add_sym_0s): Renamed `NO_CLASS' in `CLASS_IMPURE'.
+	(add_functions): Ditto.
+	(add_subroutines): Ditto and mark `MOVE_ALLOC' as CLASS_PURE.
+	* resolve.c (gfc_pure): Do not treat ELEMENTAL as automatically PURE.
+	(resolve_formal_arglist): Check that arguments to ELEMENTAL procedures
+	are not ALLOCATABLE and have their INTENT specified.
+
 2010-08-13  Daniel Kraft  <d@domob.eu>
 
 	* gfortran.h (array_type): New type `AS_IMPLIED_SHAPE'.

gcc/fortran/decl.c

@@ -4052,45 +4052,81 @@ match
 gfc_match_prefix (gfc_typespec *ts)
 {
   bool seen_type;
+  bool seen_impure;
+  bool found_prefix;
 
   gfc_clear_attr (&current_attr);
-  seen_type = 0;
+  seen_type = false;
+  seen_impure = false;
 
   gcc_assert (!gfc_matching_prefix);
   gfc_matching_prefix = true;
 
-loop:
-  if (!seen_type && ts != NULL
-      && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
-      && gfc_match_space () == MATCH_YES)
+  do
     {
+      found_prefix = false;
 
-      seen_type = 1;
-      goto loop;
-    }
+      if (!seen_type && ts != NULL
+	  && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
+	  && gfc_match_space () == MATCH_YES)
+	{
 
-  if (gfc_match ("elemental% ") == MATCH_YES)
-    {
-      if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
-	goto error;
+	  seen_type = true;
+	  found_prefix = true;
+	}
+
+      if (gfc_match ("elemental% ") == MATCH_YES)
+	{
+	  if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
+	    goto error;
 
-      goto loop;
+	  found_prefix = true;
+	}
+
+      if (gfc_match ("pure% ") == MATCH_YES)
+	{
+	  if (gfc_add_pure (&current_attr, NULL) == FAILURE)
+	    goto error;
+
+	  found_prefix = true;
+	}
+
+      if (gfc_match ("recursive% ") == MATCH_YES)
+	{
+	  if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
+	    goto error;
+
+	  found_prefix = true;
+	}
+
+      /* IMPURE is a somewhat special case, as it needs not set an actual
+	 attribute but rather only prevents ELEMENTAL routines from being
+	 automatically PURE.  */
+      if (gfc_match ("impure% ") == MATCH_YES)
+	{
+	  if (gfc_notify_std (GFC_STD_F2008,
+			      "Fortran 2008: IMPURE procedure at %C")
+		== FAILURE)
+	    goto error;
+
+	  seen_impure = true;
+	  found_prefix = true;
+	}
     }
+  while (found_prefix);
 
-  if (gfc_match ("pure% ") == MATCH_YES)
+  /* IMPURE and PURE must not both appear, of course.  */
+  if (seen_impure && current_attr.pure)
     {
-      if (gfc_add_pure (&current_attr, NULL) == FAILURE)
-	goto error;
-
-      goto loop;
+      gfc_error ("PURE and IMPURE must not appear both at %C");
+      goto error;
     }
 
-  if (gfc_match ("recursive% ") == MATCH_YES)
+  /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE.  */
+  if (!seen_impure && current_attr.elemental && !current_attr.pure)
     {
-      if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
+      if (gfc_add_pure (&current_attr, NULL) == FAILURE)
 	goto error;
-
-      goto loop;
     }
 
   /* At this point, the next item is not a prefix.  */

gcc/fortran/resolve.c

@@ -278,6 +278,14 @@ resolve_formal_arglist (gfc_symbol *proc)
 	      continue;
 	    }
 
+	  if (sym->attr.allocatable)
+	    {
+	      gfc_error ("Argument '%s' of elemental procedure at %L cannot "
+			 "have the ALLOCATABLE attribute", sym->name,
+			 &sym->declared_at);
+	      continue;
+	    }
+
 	  if (sym->attr.pointer)
 	    {
 	      gfc_error ("Argument '%s' of elemental procedure at %L cannot "
@@ -293,6 +301,14 @@ resolve_formal_arglist (gfc_symbol *proc)
 			 &sym->declared_at);
 	      continue;
 	    }
+
+	  if (sym->attr.intent == INTENT_UNKNOWN)
+	    {
+	      gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
+			 "have its INTENT specified", sym->name, proc->name,
+			 &sym->declared_at);
+	      continue;
+	    }
 	}
 
       /* Each dummy shall be specified to be scalar.  */
@@ -12474,7 +12490,7 @@ gfc_pure (gfc_symbol *sym)
 	  if (sym == NULL)
 	    return 0;
 	  attr = sym->attr;
-	  if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
+	  if (attr.flavor == FL_PROCEDURE && attr.pure)
 	    return 1;
 	}
       return 0;
@@ -12482,7 +12498,7 @@ gfc_pure (gfc_symbol *sym)
 
   attr = sym->attr;
 
-  return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
+  return attr.flavor == FL_PROCEDURE && attr.pure;
 }
 
 

gcc/testsuite/ChangeLog

+2010-08-15  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45197
+	* gfortran.dg/elemental_args_check_3.f90: New test.
+	* gfortran.dg/impure_1.f08: New test.
+	* gfortran.dg/impure_2.f08: New test.
+	* gfortran.dg/impure_3.f90: New test.
+	* gfortran.dg/typebound_proc_6.f03: Changed expected error message.
+
 2010-08-15  Ira Rosen  <irar@il.ibm.com>
 
 	* gcc.dg/vect/costmodel/ppc/costmodel-bb-slp-9a.c: New test.

gcc/testsuite/gfortran.dg/elemental_args_check_3.f90

+! { dg-do compile }
+
+! Check for constraints restricting arguments of ELEMENTAL procedures.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+
+CONTAINS
+
+  IMPURE ELEMENTAL SUBROUTINE foobar &
+    (a, & ! { dg-error "must be scalar" }
+     b, & ! { dg-error "POINTER attribute" }
+     c, & ! { dg-error "ALLOCATABLE attribute" }
+     d) ! { dg-error "INTENT specified" }
+    INTEGER, INTENT(IN) :: a(:)
+    INTEGER, POINTER, INTENT(IN) :: b
+    INTEGER, ALLOCATABLE, INTENT(IN) :: c
+    INTEGER :: d
+  END SUBROUTINE foobar
+
+END PROGRAM main

gcc/testsuite/gfortran.dg/impure_1.f08

+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! PR fortran/45197
+! Check that IMPURE and IMPURE ELEMENTAL in particular works.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+MODULE m
+  IMPLICIT NONE
+
+  INTEGER, PARAMETER :: n = 5
+
+  INTEGER :: i
+  INTEGER :: arr(n)
+
+CONTAINS
+
+  ! This ought to work (without any effect).
+  IMPURE SUBROUTINE foobar ()
+  END SUBROUTINE foobar
+
+  IMPURE ELEMENTAL SUBROUTINE impureSub (a)
+    INTEGER, INTENT(IN) :: a
+
+    arr(i) = a
+    i = i + 1
+
+    PRINT *, a
+  END SUBROUTINE impureSub
+
+END MODULE m
+
+PROGRAM main
+  USE :: m
+  IMPLICIT NONE
+
+  INTEGER :: a(n), b(n), s
+
+  a = (/ (i, i = 1, n) /)
+
+  ! Traverse in forward order.
+  s = 0
+  b = accumulate (a, s)
+  IF (ANY (b /= (/ 1, 3, 6, 10, 15 /))) CALL abort ()
+
+  ! And now backward.
+  s = 0
+  b = accumulate (a(n:1:-1), s)
+  IF (ANY (b /= (/ 5, 9, 12, 14, 15 /))) CALL abort ()
+
+  ! Use subroutine.
+  i = 1
+  arr = 0
+  CALL impureSub (a)
+  IF (ANY (arr /= a)) CALL abort ()
+
+CONTAINS
+
+  IMPURE ELEMENTAL FUNCTION accumulate (a, s)
+    INTEGER, INTENT(IN) :: a
+    INTEGER, INTENT(INOUT) :: s
+    INTEGER :: accumulate
+    
+    s = s + a
+    accumulate = s
+  END FUNCTION accumulate
+
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/impure_2.f08

+! { dg-do compile }
+! { dg-options "-std=f2008" }
+
+! PR fortran/45197
+! Check for errors with IMPURE.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+MODULE m
+  IMPLICIT NONE
+
+CONTAINS
+
+  IMPURE PURE SUBROUTINE foobar () ! { dg-error "must not appear both" }
+
+  PURE ELEMENTAL IMPURE FUNCTION xyz () ! { dg-error "must not appear both" }
+
+  IMPURE ELEMENTAL SUBROUTINE mysub ()
+  END SUBROUTINE mysub
+
+  PURE SUBROUTINE purified ()
+    CALL mysub () ! { dg-error "is not PURE" }
+  END SUBROUTINE purified
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/impure_3.f90

+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! PR fortran/45197
+! Check that IMPURE gets rejected without F2008.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+IMPURE SUBROUTINE foobar () ! { dg-error "Fortran 2008" }
+
+IMPURE ELEMENTAL FUNCTION xyz () ! { dg-error "Fortran 2008" }

gcc/testsuite/gfortran.dg/typebound_proc_6.f03

@@ -59,7 +59,7 @@ MODULE testmod
     PROCEDURE, NOPASS :: pure2 => proc_sub ! { dg-error "must also be PURE" }
     PROCEDURE, NOPASS :: nonpure => proc_pure ! Ok, overridden not pure.
     PROCEDURE, NOPASS :: elemental1 => proc_elemental ! Ok, both elemental.
-    PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be ELEMENTAL" }
+    PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be" }
     PROCEDURE, NOPASS :: nonelem1 => proc_nonelem ! Ok, non elemental.
     PROCEDURE, NOPASS :: nonelem2 => proc_elemental ! { dg-error "must not be ELEMENTAL" }