Pure/elemental violation detection

include/flang/Error/errmsg-in.n

@@ -1346,6 +1346,7 @@ This OpenMP feature is not yet implemented.
 An unlimited repetition count (*) is allowed by the Fortran 2008 standard
 only on a parenthesized list of edit descriptors that appears as the the last
 (or only) item at the top level of a FORMAT.
+.MS S 600 "\x1b[31m\x1b[1m Severe Error\x1b[0m: Dummy argument \x1b[39m\x1b[1m'$'\x1b[0m in PURE procedure \x1b[39m\x1b[1m'$'\x1b[0m must be INTENT(IN)"
 .MS S 901 "#elif after #else"
 A preprocessor #elif directive was found after a #else directive; only
 #endif is allowed in this context.

runtime/flang/ieee_arithmetic.F95

@@ -370,7 +370,7 @@ elemental logical function ieee_arithmetic_netr(ra, rb)
     return
   end function
 
-  pure subroutine ieee_arithmetic_eqct(ca, cb)
+  subroutine ieee_arithmetic_eqct(ca, cb)
     type(ieee_class_type), intent(out) :: ca
     type(ieee_class_type), intent(in)  :: cb
     ca%ct = cb%ct
@@ -411,7 +411,7 @@ end function ieee_support_datatypenox
   pure logical function ieee_support_datatyper(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
     ieee_support_datatyper = .true.
     return 
   end function ieee_support_datatyper
@@ -428,7 +428,7 @@ end function ieee_support_denormalnox
   pure logical function ieee_support_denormalr(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
 #if defined TARGET_LINUX_ARM || defined TARGET_LINUX_POWER || defined PGFLANG
     ieee_support_denormalr = .false.
 #else
@@ -445,7 +445,7 @@ end function ieee_support_dividenox
   pure logical function ieee_support_divider(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
     ieee_support_divider = .true.
     return 
   end function ieee_support_divider
@@ -458,7 +458,7 @@ end function ieee_support_infnox
   pure logical function ieee_support_infr(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
     ieee_support_infr = .true.
     return 
   end function ieee_support_infr
@@ -471,23 +471,23 @@ end function ieee_support_nannox
   pure logical function ieee_support_nanr(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
     ieee_support_nanr = .true.
     return 
   end function ieee_support_nanr
 
   pure logical function ieee_support_roundingnox(rv)
 !pgi$ defaultkind
-    type(ieee_round_type) :: rv
+    type(ieee_round_type), intent(in) :: rv
     i = rv%rt
     ieee_support_roundingnox = ((i.ge.0).and.(i.le.3))
     return
   end function ieee_support_roundingnox
   pure logical function ieee_support_roundingr(rv,x)
 !pgi$ defaultkind
-    type(ieee_round_type) :: rv
+    type(ieee_round_type), intent(in) :: rv
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
     i = rv%rt
     ieee_support_roundingr = ((i.ge.0).and.(i.le.3))
     return 
@@ -501,7 +501,7 @@ end function ieee_support_sqrtnox
   pure logical function ieee_support_sqrtr(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
     ieee_support_sqrtr = .true.
     return 
   end function ieee_support_sqrtr
@@ -514,7 +514,7 @@ end function ieee_support_standardnox
   pure logical function ieee_support_standardr(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
     ieee_support_standardr = .true.
     return 
   end function ieee_support_standardr
@@ -531,7 +531,7 @@ end function ieee_support_uflowctrlnox
   pure logical function ieee_support_uflowctrlr(x)
 !pgi$ defaultkind
 !dir$ ignore_tkr (kr) x
-    real :: x
+    real, intent(in) :: x
 #if defined TARGET_LINUX_ARM || defined TARGET_LINUX_POWER || defined PGFLANG
     ieee_support_uflowctrlr = .false.
 #else
@@ -627,7 +627,7 @@ subroutine ieee_set_underflow_model8(uflow)
   end subroutine
 
   !-----------------------------------------------------------------
-  elemental type(ieee_class_type) function ieee_classr4(x)
+  type(ieee_class_type) function ieee_classr4(x)
     real*4 x, ex
     integer*4 ix, iexp, imant
 #if 0
@@ -671,7 +671,7 @@ elemental type(ieee_class_type) function ieee_classr4(x)
     return
   end function
 
-  elemental type(ieee_class_type) function ieee_classr8(x)
+  type(ieee_class_type) function ieee_classr8(x)
     real*8 x, ex
     integer*4 iz(2), ix, iy, iexp, imant
 #if 0
@@ -825,7 +825,7 @@ elemental real*8 function ieee_copy_signr8(x, y)
 #endif
   end function
 
-  elemental logical function ieee_is_finiter4(x)
+  logical function ieee_is_finiter4(x)
 !pgi$ defaultkind
     real*4 x
     type(ieee_class_type) :: cl
@@ -837,7 +837,7 @@ elemental logical function ieee_is_finiter4(x)
     end if
   end function
 
-  elemental logical function ieee_is_finiter8(x)
+  logical function ieee_is_finiter8(x)
 !pgi$ defaultkind
     real*8 x
     type(ieee_class_type) :: cl
@@ -849,7 +849,7 @@ elemental logical function ieee_is_finiter8(x)
     end if
   end function
 
-  elemental logical function ieee_is_nanr4(x)
+  logical function ieee_is_nanr4(x)
 !pgi$ defaultkind
     real*4 x
     type(ieee_class_type) :: cl
@@ -861,7 +861,7 @@ elemental logical function ieee_is_nanr4(x)
     end if
   end function
 
-  elemental logical function ieee_is_nanr8(x)
+  logical function ieee_is_nanr8(x)
 !pgi$ defaultkind
     real*8 x
     type(ieee_class_type) :: cl
@@ -873,19 +873,19 @@ elemental logical function ieee_is_nanr8(x)
     end if
   end function
 
-  elemental logical function ieee_unorderedr4(x, y)
+  logical function ieee_unorderedr4(x, y)
 !pgi$ defaultkind
     real*4 x, y
     ieee_unorderedr4 = (ieee_is_nanr4(x) .or. ieee_is_nanr4(y))
   end function
 
-  elemental logical function ieee_unorderedr8(x, y)
+  logical function ieee_unorderedr8(x, y)
 !pgi$ defaultkind
     real*8 x, y
     ieee_unorderedr8 = (ieee_is_nanr8(x) .or. ieee_is_nanr8(y))
   end function
 
-  elemental logical function ieee_is_negativer4(x)
+  logical function ieee_is_negativer4(x)
 !pgi$ defaultkind
     real*4 x
     type(ieee_class_type) :: cl
@@ -897,7 +897,7 @@ elemental logical function ieee_is_negativer4(x)
     end if
   end function
 
-  elemental logical function ieee_is_negativer8(x)
+  logical function ieee_is_negativer8(x)
 !pgi$ defaultkind
     real*8 x
     type(ieee_class_type) :: cl
@@ -909,7 +909,7 @@ elemental logical function ieee_is_negativer8(x)
     end if
   end function
 
-  elemental logical function ieee_is_normalr4(x)
+  logical function ieee_is_normalr4(x)
 !pgi$ defaultkind
     real*4 x
     type(ieee_class_type) :: cl
@@ -921,7 +921,7 @@ elemental logical function ieee_is_normalr4(x)
     end if
   end function
 
-  elemental logical function ieee_is_normalr8(x)
+  logical function ieee_is_normalr8(x)
 !pgi$ defaultkind
     real*8 x
     type(ieee_class_type) :: cl

runtime/flang/ieee_exceptions.F95

@@ -151,7 +151,7 @@ module IEEE_EXCEPTIONS
 
     pure integer function __fenv_fesetexceptflag(flagp, exc) bind(c)
       use, intrinsic :: iso_c_binding
-      integer(c_int)        :: flagp
+      integer(c_int), intent(in) :: flagp
       integer(c_int), value :: exc
     end function __fenv_fesetexceptflag
 
@@ -248,7 +248,7 @@ elemental subroutine ieee_get_halting_mode_l8(flag, halting)
 
 !--------------------------------------------------------------------------
   pure subroutine ieee_set_flag_scalar(flag, flag_value)
-    type(ieee_flag_type) :: flag
+    type(ieee_flag_type), intent(in) :: flag
     logical, intent(in)  :: flag_value
     if (flag_value) then
       i = __fenv_feraiseexcept(flag%ft)
@@ -258,7 +258,7 @@ pure subroutine ieee_set_flag_scalar(flag, flag_value)
   end subroutine ieee_set_flag_scalar
 
   pure subroutine ieee_set_flag_array(flag, flag_value)
-    type(ieee_flag_type), dimension(:) :: flag
+    type(ieee_flag_type), intent(in), dimension(:) :: flag
     logical, intent(in), dimension(:)  :: flag_value
     integer flagp, flagv
     flagp = 0
@@ -273,7 +273,7 @@ pure subroutine ieee_set_flag_array(flag, flag_value)
   end subroutine ieee_set_flag_array
 
   pure subroutine ieee_set_flag_arrscal(flag, flag_value)
-    type(ieee_flag_type), dimension(:) :: flag
+    type(ieee_flag_type), intent(in), dimension(:) :: flag
     logical, intent(in) :: flag_value
     integer flagp, flagv
     flagp = 0
@@ -333,7 +333,7 @@ end subroutine ieee_set_halting_mode_arrscal
 
 !--------------------------------------------------------------------------
   pure subroutine ieee_set_flag_scalar_l8(flag, flag_value)
-    type(ieee_flag_type) :: flag
+    type(ieee_flag_type), intent(in) :: flag
     logical*8, intent(in)  :: flag_value
     if (flag_value) then
       i = __fenv_feraiseexcept(flag%ft)
@@ -343,7 +343,7 @@ pure subroutine ieee_set_flag_scalar_l8(flag, flag_value)
   end subroutine ieee_set_flag_scalar_l8
 
   pure subroutine ieee_set_flag_array_l8(flag, flag_value)
-    type(ieee_flag_type), dimension(:) :: flag
+    type(ieee_flag_type), intent(in), dimension(:) :: flag
     logical*8, intent(in), dimension(:)  :: flag_value
     integer flagp, flagv
     flagp = 0
@@ -358,7 +358,7 @@ pure subroutine ieee_set_flag_array_l8(flag, flag_value)
   end subroutine ieee_set_flag_array_l8
 
   pure subroutine ieee_set_flag_arrscal_l8(flag, flag_value)
-    type(ieee_flag_type), dimension(:) :: flag
+    type(ieee_flag_type), intent(in), dimension(:) :: flag
     logical*8, intent(in) :: flag_value
     integer flagp, flagv
     flagp = 0

tools/flang1/flang1exe/rest.c

@@ -2106,7 +2106,7 @@ check_pure_interface(int entry, int std, int ast)
     case ST_PD:
       break;
     default:
-      error(473, 2, gbl.lineno, SYMNAME(entry), CNULL);
+      error(473, 3, gbl.lineno, SYMNAME(entry), CNULL);
     }
   }
 }

tools/flang1/flang1exe/semant.c

@@ -8198,8 +8198,8 @@ semant1(int rednum, SST *top)
             error(155, 3, gbl.lineno,
                   "An automatic array cannot have the SAVE attribute -",
                   SYMNAME(sptr));
-        } else if (flg.standard && gbl.currsub && PUREG(gbl.currsub)) {
-          error(170, 2, gbl.lineno,
+        } else if (gbl.currsub && PUREG(gbl.currsub)) {
+          error(170, 3, gbl.lineno,
                 "SAVE attribute for a local variable of a PURE subroutine",
                 CNULL);
         } else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||

tools/flang1/flang1exe/semant3.c

@@ -1479,7 +1479,7 @@ semant3(int rednum, SST *top)
     if (not_in_forall("STOP"))
       break;
     if (gbl.currsub && PUREG(gbl.currsub))
-      error(155, 2, gbl.lineno, SYMNAME(gbl.currsub),
+      error(155, 3, gbl.lineno, SYMNAME(gbl.currsub),
             "- PURE subprograms may not contain STOP statements");
     ast1 = SST_TMPG(RHS(2));
     ast2 = SST_ASTG(RHS(2));

tools/flang1/flang1exe/semfin.c

@@ -1075,11 +1075,18 @@ fix_args(int sptr, LOGICAL is_func)
       default:
         break;
       }
+
+      /* intent(in) variable cannot be redefined. */
       if (ASSNG(arg) && INTENTG(arg) == INTENT_IN) {
-        error(194, 2, gbl.lineno, SYMNAME(arg), CNULL);
+        error(194, 3, gbl.lineno, SYMNAME(arg), CNULL);
         INTENTP(arg, INTENT_DFLT);
       }
 
+      /* dummy argument in pure procedure must be defined as intent(in) 
+       * - error code = 600 */ 
+      if (PUREG(sptr) && !PASSBYVALG(arg) && INTENTG(arg) != INTENT_IN) 
+	error(600, 3, gbl.lineno, SYMNAME(arg), SYMNAME(sptr));
+
       if (sptr == gbl.currsub && ALLOCATTRG(arg) &&
           INTENTG(arg) == INTENT_OUT) {
         gen_conditional_dealloc_for_sym(arg, ENTSTDG(sptr));