[flang] Semantics limits on kP scale factors

[vdonaldson]

Summary

When known at compile time, Ew.d and Dw.d output edit descriptors
should respect limitations from the standard on the value of a
kP scale factor with respect to the digit count (d), at least for
values of k other than zero.

[vdonaldson]

https://reviews.llvm.org/D124120

flang/include/flang/Common/format.h

private:
   CHAR NextChar();
   CHAR LookAheadChar();
   void Advance(TokenKind);
   void NextToken();
 
   void check_r(bool allowed = true);
   bool check_w();
   void check_m();
-  bool check_d();
+  bool check_d(bool checkScaleFactor = false);
+  void check_k();
   void check_e();
 
   const CHAR *const format_; // format text
   const CHAR *const end_; // one-past-last of format_ text
   Reporter reporter_;
   IoStmtKind stmt_;
 
   const CHAR *cursor_{}; // current location in format_
   const CHAR *laCursor_{}; // lookahead cursor
-  Token token_{}; // current token
   TokenKind previousTokenKind_{TokenKind::None};
-  int64_t integerValue_{-1}; // value of UnsignedInteger token
+  Token token_{}; // current token
   Token knrToken_{}; // k, n, or r UnsignedInteger token
+  Token scaleFactorToken_{}; // most recent scale factor token P
+  int64_t integerValue_{-1}; // value of UnsignedInteger token
   int64_t knrValue_{-1}; // -1 ==> not present
+  int64_t scaleFactorValue_{}; // signed k in kP
   int64_t wValue_{-1};
   char argString_[3]{}; // 1-2 character msg arg; usually edit descriptor name
   bool formatHasErrors_{false};
   bool unterminatedFormatError_{false};
   bool suppressMessageCascade_{false};
   bool reporterExit_{false};
   int maxNesting_{0}; // max level of nested parentheses
 };
template <typename CHAR> void FormatValidator<CHAR>::check_m() {
   if ((stmt_ == IoStmtKind::Print || stmt_ == IoStmtKind::Write) &&
       wValue_ > 0 && integerValue_ > wValue_) { // 13.7.2.2p5, 13.7.2.4p6
     ReportError("'%s' edit descriptor 'm' value is greater than 'w' value");
   }
   NextToken();
 }
 
 // Return the predicate "d value is present" to control further processing.
-template <typename CHAR> bool FormatValidator<CHAR>::check_d() {
+template <typename CHAR>
+bool FormatValidator<CHAR>::check_d(bool checkScaleFactor) {
   if (token_.kind() != TokenKind::Point) {
     ReportError("Expected '%s' edit descriptor '.d' value");
     return false;
   }
   NextToken();
   if (token_.kind() != TokenKind::UnsignedInteger) {
     ReportError("Expected '%s' edit descriptor 'd' value after '.'");
     return false;
   }
+  if (checkScaleFactor) {
+    check_k();
+  }
   NextToken();
   return true;
 }
 
+// Check the value of scale factor k against a field width d.
+template <typename CHAR> void FormatValidator<CHAR>::check_k() {
+  // Limit the check to D and E edit descriptors in output statements that
+  // explicitly set the scale factor.
+  if (stmt_ != IoStmtKind::Print && stmt_ != IoStmtKind::Write) {
+    return;
+  }
+  if (!scaleFactorToken_.IsSet()) {
+    return;
+  }
+  // 13.7.2.3.3p5 - The values of d and k must satisfy:
+  //   −d < k <= 0; or
+  //    0 < k < d+2
+  const int64_t d{integerValue_};
+  const int64_t k{scaleFactorValue_};
+  // Exception:  d = k = 0 is nonstandard, but has a reasonable interpretation.
+  if (d == 0 && k == 0) {
+    return;
+  }
+  if (k <= 0 && !(-d < k)) {
+    ReportError("Negative scale factor k (from kP) and width d in a '%s' "
+                "edit descriptor must satisfy '-d < k'");
+  } else if (k > 0 && !(k < d + 2)) {
+    ReportError("Positive scale factor k (from kP) and width d in a '%s' "
+                "edit descriptor must satisfy 'k < d+2'");
+  }
+}
+
 template <typename CHAR> void FormatValidator<CHAR>::check_e() {
   if (token_.kind() != TokenKind::E) {
     return;
   }
   NextToken();
   if (token_.kind() != TokenKind::UnsignedInteger) {
     ReportError("Expected '%s' edit descriptor 'e' value after 'E'");
     return;
case TokenKind::Z:
       hasDataEditDesc = true;
       check_r();
       NextToken();
       if (check_w()) {
         check_m();
       }
       break;
     case TokenKind::D:
-    case TokenKind::F:
+    case TokenKind::F: {
       // R1307 data-edit-desc -> D w . d | F w . d
+      bool isD{token_.kind() == TokenKind::D};
       hasDataEditDesc = true;
       check_r();
       NextToken();
       if (check_w()) {
-        check_d();
+        check_d(/*checkScaleFactor=*/isD);
       }
       break;
+    }
     case TokenKind::E:
     case TokenKind::EN:
     case TokenKind::ES:
-    case TokenKind::EX:
+    case TokenKind::EX: {
       // R1307 data-edit-desc ->
       //   E w . d [E e] | EN w . d [E e] | ES w . d [E e] | EX w . d [E e]
+      bool isE{token_.kind() == TokenKind::E};
       hasDataEditDesc = true;
       check_r();
       NextToken();
-      if (check_w() && check_d()) {
+      if (check_w() && check_d(/*checkScaleFactor=*/isE)) {
         check_e();
       }
       break;
+    }
     case TokenKind::G:
       // R1307 data-edit-desc -> G w [. d [E e]]
       hasDataEditDesc = true;
       check_r();
       NextToken();
       if (check_w()) {
         if (wValue_ > 0) {
           if (check_d()) { // C1307
case TokenKind::SS:
       // R1320 decimal-edit-desc -> DC | DP
       check_r(false);
       NextToken();
       break;
     case TokenKind::P: {
       // R1313 control-edit-desc -> k P
       if (knrValue_ < 0) {
         ReportError("'P' edit descriptor must have a scale factor");
+      } else {
+        scaleFactorToken_ = knrToken_;
+        if (signToken.IsSet() && format_[signToken.offset()] == '-') {
+          scaleFactorValue_ = -knrValue_;
+        } else {
+          scaleFactorValue_ = knrValue_;
+        }
       }
       // Diagnosing C1302 may require multiple token lookahead.
       // Save current cursor position to enable backup.
       const CHAR *saveCursor{cursor_};
       NextToken();
       if (token_.kind() == TokenKind::UnsignedInteger) {
         NextToken();
       }

flang/test/Semantics/io08.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
+  character(20), parameter :: kp_ok = "(4P,E20.5,E15.5)"
+  character(20), parameter :: kp_xx = "(4P,E20.5,E15.2)"
+
   write(*,*)
   write(*,'()')
   write(*,'(A)')
   write(*,'(2X:2X)')
   write(*,'(2X/2X)')
   write(*,'(3/2X)')
   write(*,'(3PF5.2)')
   write(*,'(+3PF5.2)')
! RUN: %python %S/test_errors.py %s %flang_fc1
   write(*,'(3Habc, 2X, 3X)')
   write(*,'(987654321098765432X)')
   write(*,'($)')
   write(*,'(\)')
   write(*,'(RZ,RU,RP,RN,RD,RC,SS,SP,S,3G15.3e2)')
   write(*, '(' // achar( 9) // ')') ! horizontal tab
   write(*, '(' // achar(11) // ')') ! vertical tab
   write(*, '(' // achar(32) // ')') ! space
+  write(*, kp_ok)
+  write(*, '(-4P,E20.5,E15.5)')
+  write(*, '(D20.0)')
 
   ! C1302 warnings; no errors
   write(*,'(3P7I2)')
   write(*,'(5X i3)')
   write(*,'(XEN)')
 
   !ERROR: Empty format expression
   write(*,"")
! RUN: %python %S/test_errors.py %s %flang_fc1
   !ERROR: Integer overflow in format expression
   write(*,'(45I20.98765432109876543210, 45I20)')
 
   !ERROR: Integer overflow in format expression
   write(*,'(45' // '  I20.9876543' // '2109876543210, 45I20)')
 
   !ERROR: Repeat specifier before '$' edit descriptor
   write(*,'(7$)')
+
+  !ERROR: Positive scale factor k (from kP) and width d in a 'E' edit descriptor must satisfy 'k < d+2'
+  write(*, kp_xx)
+
+  !ERROR: Negative scale factor k (from kP) and width d in a 'E' edit descriptor must satisfy '-d < k'
+  write(*, '(-4P,E20.5,E15.2)')
 end