[flang][openacc] Make OpenACC block construct parse errors less verbose.

flang/lib/Parser/message.cpp

@@ -16,6 +16,7 @@
 #include <cstdio>
 #include <cstring>
 #include <string>
+#include <tuple>
 #include <vector>
 
 namespace Fortran::parser {
@@ -272,19 +273,52 @@ static llvm::raw_ostream::Colors PrefixColor(Severity severity) {
   return llvm::raw_ostream::SAVEDCOLOR;
 }
 
+static constexpr int MAX_CONTEXTS_EMITTED{2};
+static constexpr bool OMIT_SHARED_CONTEXTS{true};
+
 void Message::Emit(llvm::raw_ostream &o, const AllCookedSources &allCooked,
     bool echoSourceLine) const {
   std::optional<ProvenanceRange> provenanceRange{GetProvenanceRange(allCooked)};
   const AllSources &sources{allCooked.allSources()};
   sources.EmitMessage(o, provenanceRange, ToString(), Prefix(severity()),
       PrefixColor(severity()), echoSourceLine);
+  // Refers to whether the attachment in the loop below is a context, but can't
+  // be declared inside the loop because the previous iteration's
+  // attachment->attachmentIsContext_ indicates this.
   bool isContext{attachmentIsContext_};
+  int contextsEmitted{0};
+  // Emit attachments.
   for (const Message *attachment{attachment_.get()}; attachment;
-       attachment = attachment->attachment_.get()) {
+      isContext = attachment->attachmentIsContext_,
+      attachment = attachment->attachment_.get()) {
     Severity severity = isContext ? Severity::Context : attachment->severity();
-    sources.EmitMessage(o, attachment->GetProvenanceRange(allCooked),
-        attachment->ToString(), Prefix(severity), PrefixColor(severity),
-        echoSourceLine);
+    auto emitAttachment = [&]() {
+      sources.EmitMessage(o, attachment->GetProvenanceRange(allCooked),
+          attachment->ToString(), Prefix(severity), PrefixColor(severity),
+          echoSourceLine);
+    };
+
+    if (isContext) {
+      // Truncate the number of contexts emitted.
+      if (contextsEmitted < MAX_CONTEXTS_EMITTED) {
+        emitAttachment();
+        ++contextsEmitted;
+      }
+      if constexpr (OMIT_SHARED_CONTEXTS) {
+        // Skip less specific contexts at the same location.
+        for (const Message *next_attachment{attachment->attachment_.get()};
+            next_attachment && next_attachment->attachmentIsContext_ &&
+            next_attachment->AtSameLocation(*attachment);
+            next_attachment = next_attachment->attachment_.get()) {
+          attachment = next_attachment;
+        }
+        // NB, this loop increments `attachment` one more time after the
+        // previous loop is done advancing it to the last context at the same
+        // location.
+      }
+    } else {
+      emitAttachment();
+    }
   }
 }
 
@@ -298,7 +332,7 @@ bool Message::operator==(const Message &that) const {
   }
   const Message *thatAttachment{that.attachment_.get()};
   for (const Message *attachment{attachment_.get()}; attachment;
-       attachment = attachment->attachment_.get()) {
+      attachment = attachment->attachment_.get()) {
     if (!thatAttachment || !attachment->AtSameLocation(*thatAttachment) ||
         attachment->ToString() != thatAttachment->ToString() ||
         attachment->severity() != thatAttachment->severity()) {

flang/lib/Parser/openacc-parsers.cpp

@@ -19,9 +19,16 @@
 // OpenACC Directives and Clauses
 namespace Fortran::parser {
 
+// Only need to handle ! line comments because prescanning normalizes the
+// other types of line comments from fixed form.
 constexpr auto startAccLine{skipStuffBeforeStatement >>
-    ("!$ACC "_sptok || "C$ACC "_sptok || "*$ACC "_sptok)};
-constexpr auto endAccLine{space >> endOfLine};
+    withMessage(
+        "expected OpenACC directive sentinel: !$ACC, C$ACC, or *$ACC"_err_en_US,
+        "!$ACC "_sptok)};
+constexpr auto endAccLine{space >>
+    recovery(
+        withMessage("expected end of OpenACC directive"_err_en_US, endOfLine),
+        SkipTo<'\n'>{} || ok)};
 
 // Autogenerated clauses parser. Information is taken from ACC.td and the
 // parser is generated by tablegen.
@@ -221,11 +228,18 @@ TYPE_PARSER(sourced(construct<AccBeginBlockDirective>(
     sourced(Parser<AccBlockDirective>{}), Parser<AccClauseList>{})))
 
 TYPE_PARSER(startAccLine >> sourced(construct<AccEndBlockDirective>("END"_tok >>
-                                sourced(Parser<AccBlockDirective>{}))))
+                                recovery(sourced(Parser<AccBlockDirective>{}),
+                                    construct<AccBlockDirective>(pure(
+                                        llvm::acc::Directive::ACCD_data))))))
 
 TYPE_PARSER(construct<OpenACCBlockConstruct>(
     Parser<AccBeginBlockDirective>{} / endAccLine, block,
-    Parser<AccEndBlockDirective>{} / endAccLine))
+    // NB, This allows mismatched directives, but semantics checks that they
+    // match.
+    recovery(withMessage("expected OpenACC end block directive"_err_en_US,
+                 attempt(Parser<AccEndBlockDirective>{} / endAccLine)),
+        construct<AccEndBlockDirective>(construct<AccBlockDirective>(
+            pure(llvm::acc::Directive::ACCD_data))))))
 
 // Standalone constructs
 TYPE_PARSER(construct<OpenACCStandaloneConstruct>(
@@ -249,8 +263,11 @@ TYPE_PARSER(sourced(construct<OpenACCEndConstruct>(
 TYPE_CONTEXT_PARSER("OpenACC construct"_en_US,
     startAccLine >>
         withMessage("expected OpenACC directive"_err_en_US,
-            first(construct<OpenACCConstruct>(Parser<OpenACCBlockConstruct>{}),
+            // Combined constructs before block constructs so we try to match
+            // the longest possible match first.
+            first(
                 construct<OpenACCConstruct>(Parser<OpenACCCombinedConstruct>{}),
+                construct<OpenACCConstruct>(Parser<OpenACCBlockConstruct>{}),
                 construct<OpenACCConstruct>(Parser<OpenACCLoopConstruct>{}),
                 construct<OpenACCConstruct>(
                     Parser<OpenACCStandaloneConstruct>{}),

flang/test/Driver/debug-parsing-log.f90

@@ -2,24 +2,14 @@
 
 ! Below are just few lines extracted from the dump. The actual output is much _much_ bigger.
 
-! CHECK: {{.*[/\\]}}debug-parsing-log.f90:25:1: IMPLICIT statement
+! CHECK: {{.*[/\\]}}debug-parsing-log.f90:15:1: IMPLICIT statement
 ! CHECK-NEXT:  END PROGRAM
 ! CHECK-NEXT:  ^
 ! CHECK-NEXT:  fail 3
-! CHECK-NEXT: {{.*[/\\]}}debug-parsing-log.f90:25:1: error: expected 'IMPLICIT NONE'
+! CHECK-NEXT: {{.*[/\\]}}debug-parsing-log.f90:15:1: error: expected 'IMPLICIT NONE'
 ! CHECK-NEXT:   END PROGRAM
 ! CHECK-NEXT:   ^
-! CHECK-NEXT: {{.*[/\\]}}debug-parsing-log.f90:25:1: in the context: IMPLICIT statement
+! CHECK-NEXT: {{.*[/\\]}}debug-parsing-log.f90:15:1: in the context: IMPLICIT statement
 ! CHECK-NEXT:   END PROGRAM
 ! CHECK-NEXT:   ^
-! CHECK-NEXT: {{.*[/\\]}}debug-parsing-log.f90:25:1: in the context: implicit part
-! CHECK-NEXT:   END PROGRAM
-! CHECK-NEXT:   ^
-! CHECK-NEXT: {{.*[/\\]}}debug-parsing-log.f90:25:1: in the context: specification part
-! CHECK-NEXT:   END PROGRAM
-! CHECK-NEXT:   ^
-! CHECK-NEXT: {{.*[/\\]}}debug-parsing-log.f90:25:1: in the context: main program
-! CHECK-NEXT:   END PROGRAM
-! CHECK-NEXT:   ^
-
 END PROGRAM

flang/test/Parser/acc-data-statement.f90

@@ -0,0 +1,199 @@
+! RUN: not %flang_fc1 -fsyntax-only -fopenacc %s 2>&1 | FileCheck %s
+program acc_data_test
+    implicit none
+    integer :: a(100), b(100), c(100), d(100)
+    integer :: i, s ! FIXME: if s is named sum you get semantic errors.
+
+    ! Positive tests
+
+    ! Basic data construct in program body
+    !$acc data copy(a, b) create(c)
+    a = 1
+    b = 2
+    c = a + b
+    !$acc end data
+    print *, "After first data region"
+
+    ! Data construct within IF block
+    if (.true.) then
+        !$acc data copyout(a)
+        a = a + 1
+        !$acc end data
+        print *, "Inside if block"
+    end if
+
+    ! Data construct within DO loop
+    do i = 1, 10
+        !$acc data present(a)
+        a(i) = a(i) * 2
+        !$acc end data
+        print *, "Loop iteration", i
+    end do
+
+    ! Nested data constructs
+    !$acc data copyin(a)
+    s = 0
+    !$acc data copy(s)
+    s = s + 1
+    !$acc end data
+    print *, "After nested data"
+    !$acc end data
+
+    ! Negative tests  
+    ! Basic data construct in program body
+    !$acc data copy(a, b) create(d) bogus()
+    !CHECK: acc-data-statement.f90:
+    !CHECK-SAME: error: expected end of OpenACC directive
+    !CHECK-NEXT: !$acc data copy(a, b) create(d) bogus()
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: OpenACC construct
+    !CHECK-NEXT: !$acc data copy(a, b) create(d) bogus()
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: execution part
+    !CHECK-NEXT: !$acc data copy(a, b) create(c)
+    !CHECK-NEXT: ^
+    a = 1
+    b = 2
+    d = a + b
+!   !$acc end data
+    print *, "After first data region"
+
+    ! Data construct within IF block
+    if (.true.) then
+        !$acc data copyout(a)
+        a = a + 1
+!       !$acc end data
+        print *, "Inside if block"
+        !CHECK: acc-data-statement.f90:
+        !CHECK-SAME: error: expected OpenACC end block directive
+        !CHECK-NEXT: end if
+        !CHECK-NEXT: ^ 
+        !CHECK-NEXT: in the context: OpenACC construct
+        !CHECK-NEXT: !$acc data copyout(a)
+        !CHECK-NEXT: ^
+        !CHECK-NEXT: in the context: IF construct
+        !CHECK-NEXT: if (.true.) then
+        !CHECK-NEXT: ^
+    end if
+
+    ! Data construct within DO loop
+    do i = 1, 10
+        !$acc data present(a)
+        a(i) = a(i) * 2
+!       !$acc end data
+        print *, "Loop iteration", i
+        !CHECK: acc-data-statement.f90:
+        !CHECK-SAME: error: expected OpenACC end block directive
+        !CHECK-NEXT: end do
+        !CHECK-NEXT: ^ 
+        !CHECK-NEXT: in the context: OpenACC construct
+        !CHECK-NEXT: !$acc data present(a)
+        !CHECK-NEXT: ^
+        !CHECK-NEXT: in the context: DO construct
+        !CHECK-NEXT: do i = 1, 10
+        !CHECK-NEXT: ^
+    end do
+
+    ! Nested data constructs
+    !$acc data copyin(a)
+    s = 0
+    !$acc data copy(s)
+    s = s + 1
+!   !$acc end data
+    print *, "After nested data"
+    !$acc end data  I forgot to comment this out.
+    !CHECK: acc-data-statement.f90:
+    !CHECK-SAME: error: expected end of OpenACC directive
+    !CHECK-NEXT: !$acc end data  I forgot to comment this out.
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: OpenACC construct
+    !CHECK-NEXT: !$acc data copy(s)
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: OpenACC construct
+    !CHECK-NEXT: !$acc data copyin(a)
+    !CHECK-NEXT: ^
+    print *, "Program finished"
+
+    !CHECK: acc-data-statement.f90:
+    !CHECK-SAME: error: expected OpenACC end block directive
+    !CHECK-NEXT: contains
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: OpenACC construct
+    !CHECK-NEXT: !$acc data copyin(a)
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: OpenACC construct
+    !CHECK-NEXT: !$acc data copy(a, b) create(d) bogus()
+    !CHECK-NEXT: ^
+    !CHECK: acc-data-statement.f90:
+    !CHECK-SAME: error: expected OpenACC end block directive
+    !CHECK-NEXT: contains
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: OpenACC construct
+    !CHECK-NEXT: $acc data copy(a, b) create(d) bogus()
+    !CHECK-NEXT: ^
+    !CHECK-NEXT: in the context: execution part
+    !CHECK-NEXT: !$acc data copy(a, b) create(c)
+    !CHECK-NEXT: ^
+contains
+    subroutine positive_process_array(x)
+        integer, intent(inout) :: x(:)
+
+        ! Data construct in subroutine
+        !$acc data copy(x)
+        x = x + 1
+        !$acc end data
+        print *, "Subroutine finished"
+    end subroutine
+
+    function positive_compute_sum(x) result(total)
+        integer, intent(in) :: x(:)
+        integer :: total
+
+        ! Data construct in function
+        !$acc data copyin(x) copy(total)
+        total = sum(x)
+        !$acc end data
+        print *, "Function finished"
+    end function
+
+    subroutine negative_process_array(x)
+        integer, intent(inout) :: x(:)
+
+        ! Data construct in subroutine
+        !$acc data copy(x)
+        x = x + 1
+!       !$acc end data
+        print *, "Subroutine finished"
+        !CHECK: acc-data-statement.f90:
+        !CHECK-SAME: error: expected OpenACC end block directive
+        !CHECK-NEXT: end subroutine
+        !CHECK-NEXT: ^
+        !CHECK-NEXT: in the context: OpenACC construct
+        !CHECK-NEXT: !$acc data copy(x)
+        !CHECK-NEXT: ^
+        !CHECK-NEXT: in the context: SUBROUTINE subprogram
+        !CHECK-NEXT: subroutine negative_process_array(x)
+        !CHECK-NEXT: ^
+    end subroutine
+
+    function negative_compute_sum(x) result(total)
+        integer, intent(in) :: x(:)
+        integer :: total
+        total = sum(x)
+        ! Data construct in function
+        !$acc data copyin(x) copy(total)
+        total = total + x
+!       !$acc end data
+        print *, "Function finished"
+        !CHECK: acc-data-statement.f90:
+        !CHECK-SAME: error: expected OpenACC end block directive
+        !CHECK-NEXT: end function
+        !CHECK-NEXT: ^ 
+        !CHECK-NEXT: in the context: OpenACC construct
+        !CHECK-NEXT: !$acc data copyin(x) copy(total)
+        !CHECK-NEXT: ^
+        !CHECK-NEXT: in the context: execution part
+        !CHECK-NEXT: total = sum(x)
+        !CHECK-NEXT: ^
+    end function
+end program acc_data_test