diff --git a/include/flang/Error/errmsg-in.n b/include/flang/Error/errmsg-in.n index 15f9fea3058..1ec4be83911 100644 --- a/include/flang/Error/errmsg-in.n +++ b/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. diff --git a/runtime/flang/ieee_arithmetic.F95 b/runtime/flang/ieee_arithmetic.F95 index 1518b5be7e1..f25b72e08b9 100644 --- a/runtime/flang/ieee_arithmetic.F95 +++ b/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 diff --git a/runtime/flang/ieee_exceptions.F95 b/runtime/flang/ieee_exceptions.F95 index 827aa0b1e87..4e47871959f 100644 --- a/runtime/flang/ieee_exceptions.F95 +++ b/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 diff --git a/tools/flang1/flang1exe/rest.c b/tools/flang1/flang1exe/rest.c index 95430322469..3aa78e08b13 100644 --- a/tools/flang1/flang1exe/rest.c +++ b/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); } } } diff --git a/tools/flang1/flang1exe/semant.c b/tools/flang1/flang1exe/semant.c index 96276637265..ce4cc349606 100644 --- a/tools/flang1/flang1exe/semant.c +++ b/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 || diff --git a/tools/flang1/flang1exe/semant3.c b/tools/flang1/flang1exe/semant3.c index da0667552db..f42541673b0 100644 --- a/tools/flang1/flang1exe/semant3.c +++ b/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)); diff --git a/tools/flang1/flang1exe/semfin.c b/tools/flang1/flang1exe/semfin.c index 137cd3ca16e..1f34127545d 100644 --- a/tools/flang1/flang1exe/semfin.c +++ b/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));