===================================================================
@@ -3979,45 +3979,81 @@ match
gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
+ bool seen_impure;
+ bool found_prefix;
gfc_clear_attr (¤t_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 (¤t_attr, NULL) == FAILURE)
- goto error;
+ seen_type = true;
+ found_prefix = true;
+ }
+
+ if (gfc_match ("elemental% ") == MATCH_YES)
+ {
+ if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ if (gfc_match ("pure% ") == MATCH_YES)
+ {
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
- goto loop;
+ if (gfc_match ("recursive% ") == MATCH_YES)
+ {
+ if (gfc_add_recursive (¤t_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 (¤t_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 (¤t_attr, NULL) == FAILURE)
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
goto error;
-
- goto loop;
}
/* At this point, the next item is not a prefix. */
===================================================================
@@ -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;
}
===================================================================
@@ -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" } }
===================================================================
@@ -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" } }
===================================================================
@@ -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" }
===================================================================
@@ -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" }