[flang-commits] [flang] [flang] Support "PRINT namelistname" (PR #112024)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/112024

Nearly every Fortran compiler supports "PRINT namelistname" as a synonym for "WRITE (*, NML=namelistname)".  Implement this extension via parse tree rewriting.

>From f85c3c1fe1f26dc90f570e05cf9d9f99c06d9e67 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 11 Oct 2024 10:15:59 -0700
Subject: [PATCH] [flang] Support "PRINT namelistname"

Nearly every Fortran compiler supports "PRINT namelistname"
as a synonym for "WRITE (*, NML=namelistname)".  Implement this
extension via parse tree rewriting.
---
 flang/docs/Extensions.md                      |  2 ++
 flang/include/flang/Common/Fortran-features.h |  2 +-
 flang/lib/Semantics/rewrite-parse-tree.cpp    | 27 ++++++++++++++++++-
 flang/test/Semantics/rewrite02.f90            |  8 ++++++
 4 files changed, 37 insertions(+), 2 deletions(-)
 create mode 100644 flang/test/Semantics/rewrite02.f90

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 3ffd2949e45bf4..f85a3eb39ed191 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -389,6 +389,8 @@ end
 * A local data object may appear in a specification expression, even
   when it is not a dummy argument or in COMMON, so long as it is
   has the SAVE attribute and was initialized.
+* `PRINT namelistname` is accepted and interpreted as
+  `WRITE(*,NML=namelistname)`, a near-universal extension.
 
 ### Extensions supported when enabled by options
 
diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index 3942a792628645..648f5b0798fa48 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -53,7 +53,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     NonBindCInteroperability, CudaManaged, CudaUnified,
     PolymorphicActualAllocatableOrPointerToMonomorphicDummy, RelaxedPureDummy,
     UndefinableAsynchronousOrVolatileActual, AutomaticInMainProgram, PrintCptr,
-    SavedLocalInSpecExpr)
+    SavedLocalInSpecExpr, PrintNamelist)
 
 // Portability and suspicious usage warnings
 ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
diff --git a/flang/lib/Semantics/rewrite-parse-tree.cpp b/flang/lib/Semantics/rewrite-parse-tree.cpp
index b4fb72ce213017..c90ae66342840e 100644
--- a/flang/lib/Semantics/rewrite-parse-tree.cpp
+++ b/flang/lib/Semantics/rewrite-parse-tree.cpp
@@ -32,7 +32,7 @@ using namespace parser::literals;
 class RewriteMutator {
 public:
   RewriteMutator(SemanticsContext &context)
-      : errorOnUnresolvedName_{!context.AnyFatalError()},
+      : context_{context}, errorOnUnresolvedName_{!context.AnyFatalError()},
         messages_{context.messages()} {}
 
   // Default action for a parse tree node is to visit children.
@@ -42,6 +42,7 @@ class RewriteMutator {
   void Post(parser::Name &);
   void Post(parser::SpecificationPart &);
   bool Pre(parser::ExecutionPart &);
+  bool Pre(parser::ActionStmt &);
   void Post(parser::ReadStmt &);
   void Post(parser::WriteStmt &);
 
@@ -66,6 +67,7 @@ class RewriteMutator {
 private:
   using stmtFuncType =
       parser::Statement<common::Indirection<parser::StmtFunctionStmt>>;
+  SemanticsContext &context_;
   bool errorOnUnresolvedName_{true};
   parser::Messages &messages_;
   std::list<stmtFuncType> stmtFuncsToConvert_;
@@ -130,6 +132,29 @@ bool RewriteMutator::Pre(parser::ExecutionPart &x) {
   return true;
 }
 
+// Rewrite PRINT NML -> WRITE(*,NML=NML)
+bool RewriteMutator::Pre(parser::ActionStmt &x) {
+  if (auto *print{std::get_if<common::Indirection<parser::PrintStmt>>(&x.u)};
+      print &&
+      std::get<std::list<parser::OutputItem>>(print->value().t).empty()) {
+    auto &format{std::get<parser::Format>(print->value().t)};
+    if (std::holds_alternative<parser::Expr>(format.u)) {
+      if (auto *name{parser::Unwrap<parser::Name>(format)}; name &&
+          name->symbol && name->symbol->GetUltimate().has<NamelistDetails>() &&
+          context_.IsEnabled(common::LanguageFeature::PrintNamelist)) {
+        context_.Warn(common::LanguageFeature::PrintNamelist, name->source,
+            "nonstandard: namelist in PRINT statement"_port_en_US);
+        std::list<parser::IoControlSpec> controls;
+        controls.emplace_back(std::move(*name));
+        x.u = common::Indirection<parser::WriteStmt>::Make(
+            parser::IoUnit{parser::Star{}}, std::optional<parser::Format>{},
+            std::move(controls), std::list<parser::OutputItem>{});
+      }
+    }
+  }
+  return true;
+}
+
 // When a namelist group name appears (without NML=) in a READ or WRITE
 // statement in such a way that it can be misparsed as a format expression,
 // rewrite the I/O statement's parse tree node as if the namelist group
diff --git a/flang/test/Semantics/rewrite02.f90 b/flang/test/Semantics/rewrite02.f90
new file mode 100644
index 00000000000000..2393498e65d291
--- /dev/null
+++ b/flang/test/Semantics/rewrite02.f90
@@ -0,0 +1,8 @@
+!RUN: %flang_fc1 -fdebug-unparse -pedantic %s  2>&1 | FileCheck %s
+!Test rewrite of "PRINT namelistname" into "WRITE(*,NML=namelistname)"
+!CHECK: nonstandard: namelist in PRINT statement
+namelist /nml/x
+x = 123.
+!CHECK: WRITE (*, NML=nml)
+print nml
+end