This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran] PR fortran/45197: F2008: Allow IMPURE elemental procedures


Hi,

the small patch attached implements the F2008 attribute IMPURE that may
be given to procedures; this may be used to get ELEMENTAL procedures
that are not also PURE (as is the default).

Instead of checking (attr.pure || attr.elemental) in gfc_pure, only
attr.pure is checked -- which seems also cleaner to me.  Instead,
attr.pure is set if ELEMENTAL but not IMPURE was parsed.

No regressions on GNU/Linux-x86-32. Ok for trunk?

Daniel

--
http://www.pro-vegan.info/
--
Done:  Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri

2010-08-05  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.
	* resolve.c (gfc_pure): Do not treat ELEMENTAL as automatically PURE.

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

	PR fortran/45197
	* 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.

Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 162915)
+++ gcc/fortran/decl.c	(working copy)
@@ -3979,45 +3979,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;
+
+	  found_prefix = true;
+	}
+
+      if (gfc_match ("pure% ") == MATCH_YES)
+	{
+	  if (gfc_add_pure (&current_attr, NULL) == FAILURE)
+	    goto error;
+
+	  found_prefix = true;
+	}
 
-      goto loop;
+      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.  */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 162915)
+++ gcc/fortran/resolve.c	(working copy)
@@ -12438,7 +12438,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;
@@ -12446,7 +12446,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;
 }
 
 
Index: gcc/testsuite/gfortran.dg/impure_2.f08
===================================================================
--- gcc/testsuite/gfortran.dg/impure_2.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/impure_2.f08	(revision 0)
@@ -0,0 +1,27 @@
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/impure_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/impure_1.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/impure_1.f08	(revision 0)
@@ -0,0 +1,71 @@
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/impure_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/impure_3.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/impure_3.f90	(revision 0)
@@ -0,0 +1,11 @@
+! { 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" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_6.f03	(revision 162915)
+++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03	(working copy)
@@ -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" }
 


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]