[flang-commits] [flang] 8c22cb8 - [flang] Lower basic IO statement
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Tue Mar 1 12:48:49 PST 2022
Author: Valentin Clement
Date: 2022-03-01T21:48:41+01:00
New Revision: 8c22cb846f31c42ce1d19370025ad05c4db56256
URL: https://github.com/llvm/llvm-project/commit/8c22cb846f31c42ce1d19370025ad05c4db56256
DIFF: https://github.com/llvm/llvm-project/commit/8c22cb846f31c42ce1d19370025ad05c4db56256.diff
LOG: [flang] Lower basic IO statement
This patch enables the lowering of the print, read and write
IO statements.
This patch is part of the upstreaming effort from fir-dev branch.
Reviewed By: PeteSteinfeld, schweitz
Differential Revision: https://reviews.llvm.org/D120743
Co-authored-by: Eric Schweitz <eschweitz at nvidia.com>
Co-authored-by: Jean Perier <jperier at nvidia.com>
Co-authored-by: V Donaldson <vdonaldson at nvidia.com>
Co-authored-by: Kiran Chandramohan <kiran.chandramohan at arm.com>
Added:
flang/include/flang/Lower/IO.h
flang/lib/Lower/IO.cpp
flang/test/Lower/io-statement-1.f90
flang/test/Lower/io-statement-2.f90
Modified:
flang/include/flang/Lower/AbstractConverter.h
flang/include/flang/Lower/ConvertExpr.h
flang/include/flang/Lower/ConvertType.h
flang/include/flang/Lower/ConvertVariable.h
flang/include/flang/Lower/StatementContext.h
flang/include/flang/Optimizer/Dialect/FIROps.td
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/CMakeLists.txt
flang/lib/Lower/ConvertExpr.cpp
flang/lib/Lower/ConvertType.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Optimizer/Dialect/FIROps.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h
index 1b38bfb973d7c..657c584d8d0a5 100644
--- a/flang/include/flang/Lower/AbstractConverter.h
+++ b/flang/include/flang/Lower/AbstractConverter.h
@@ -14,6 +14,7 @@
#define FORTRAN_LOWER_ABSTRACTCONVERTER_H
#include "flang/Common/Fortran.h"
+#include "flang/Lower/PFTDefs.h"
#include "flang/Optimizer/Builder/BoxValue.h"
#include "mlir/IR/BuiltinOps.h"
#include "llvm/ADT/ArrayRef.h"
@@ -75,6 +76,12 @@ class AbstractConverter {
/// Get the mlir instance of a symbol.
virtual mlir::Value getSymbolAddress(SymbolRef sym) = 0;
+ /// Get the label set associated with a symbol.
+ virtual bool lookupLabelSet(SymbolRef sym, pft::LabelSet &labelSet) = 0;
+
+ /// Get the code defined by a label
+ virtual pft::Evaluation *lookupLabel(pft::Label label) = 0;
+
//===--------------------------------------------------------------------===//
// Expressions
//===--------------------------------------------------------------------===//
@@ -99,6 +106,12 @@ class AbstractConverter {
return genExprValue(*someExpr, stmtCtx, &loc);
}
+ /// Generate or get a fir.box describing the expression. If SomeExpr is
+ /// a Designator, the fir.box describes an entity over the Designator base
+ /// storage without making a temporary.
+ virtual fir::ExtendedValue genExprBox(const SomeExpr &, StatementContext &,
+ mlir::Location) = 0;
+
/// Generate the address of the box describing the variable designated
/// by the expression. The expression must be an allocatable or pointer
/// designator.
@@ -125,8 +138,10 @@ class AbstractConverter {
virtual mlir::Type genType(SymbolRef) = 0;
/// Generate the type from a category
virtual mlir::Type genType(Fortran::common::TypeCategory tc) = 0;
- /// Generate the type from a category and kind
- virtual mlir::Type genType(Fortran::common::TypeCategory tc, int kind) = 0;
+ /// Generate the type from a category and kind and length parameters.
+ virtual mlir::Type
+ genType(Fortran::common::TypeCategory tc, int kind,
+ llvm::ArrayRef<std::int64_t> lenParameters = llvm::None) = 0;
/// Generate the type from a Variable
virtual mlir::Type genType(const pft::Variable &) = 0;
diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h
index 47d4fd2e136a7..cb4a86945c726 100644
--- a/flang/include/flang/Lower/ConvertExpr.h
+++ b/flang/include/flang/Lower/ConvertExpr.h
@@ -49,6 +49,22 @@ fir::ExtendedValue createSomeExtendedExpression(mlir::Location loc,
SymMap &symMap,
StatementContext &stmtCtx);
+/// Create a global array symbol with the Dense attribute
+fir::GlobalOp createDenseGlobal(mlir::Location loc, mlir::Type symTy,
+ llvm::StringRef globalName,
+ mlir::StringAttr linkage, bool isConst,
+ const SomeExpr &expr,
+ Fortran::lower::AbstractConverter &converter);
+
+/// Create the IR for the expression \p expr in an initialization context.
+/// Expressions that appear in initializers may not allocate temporaries, do not
+/// have a stack, etc.
+fir::ExtendedValue createSomeInitializerExpression(mlir::Location loc,
+ AbstractConverter &converter,
+ const SomeExpr &expr,
+ SymMap &symMap,
+ StatementContext &stmtCtx);
+
/// Create an extended expression address.
fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc,
AbstractConverter &converter,
@@ -56,12 +72,27 @@ fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc,
SymMap &symMap,
StatementContext &stmtCtx);
+/// Create an address in an initializer context. Must be a constant or a symbol
+/// to be resolved at link-time. Expressions that appear in initializers may not
+/// allocate temporaries, do not have a stack, etc.
+fir::ExtendedValue createInitializerAddress(mlir::Location loc,
+ AbstractConverter &converter,
+ const SomeExpr &expr,
+ SymMap &symMap,
+ StatementContext &stmtCtx);
+
/// Create the address of the box.
/// \p expr must be the designator of an allocatable/pointer entity.
fir::MutableBoxValue createMutableBox(mlir::Location loc,
AbstractConverter &converter,
const SomeExpr &expr, SymMap &symMap);
+/// Lower an array expression to a value of type box. The expression must be a
+/// variable.
+fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter,
+ const SomeExpr &expr, SymMap &symMap,
+ StatementContext &stmtCtx);
+
/// Lower a subroutine call. This handles both elemental and non elemental
/// subroutines. \p isUserDefAssignment must be set if this is called in the
/// context of a user defined assignment. For subroutines with alternate
diff --git a/flang/include/flang/Lower/ConvertType.h b/flang/include/flang/Lower/ConvertType.h
index fccddc7dbf0ff..430f5f1bd36f6 100644
--- a/flang/include/flang/Lower/ConvertType.h
+++ b/flang/include/flang/Lower/ConvertType.h
@@ -60,7 +60,7 @@ using LenParameterTy = std::int64_t;
/// Get a FIR type based on a category and kind.
mlir::Type getFIRType(mlir::MLIRContext *ctxt, common::TypeCategory tc,
- int kind);
+ int kind, llvm::ArrayRef<LenParameterTy>);
/// Translate a SomeExpr to an mlir::Type.
mlir::Type translateSomeExprToFIRType(Fortran::lower::AbstractConverter &,
diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h
index a4222f2478aa7..f01b52a1873d0 100644
--- a/flang/include/flang/Lower/ConvertVariable.h
+++ b/flang/include/flang/Lower/ConvertVariable.h
@@ -17,7 +17,9 @@
#ifndef FORTRAN_LOWER_CONVERT_VARIABLE_H
#define FORTRAN_LOWER_CONVERT_VARIABLE_H
+#include "flang/Lower/Support/Utils.h"
#include "mlir/IR/Value.h"
+#include "llvm/ADT/DenseMap.h"
namespace Fortran ::lower {
class AbstractConverter;
@@ -28,12 +30,19 @@ namespace pft {
struct Variable;
}
+/// AggregateStoreMap is used to keep track of instantiated aggregate stores
+/// when lowering a scope containing equivalences (aliases). It must only be
+/// owned by the code lowering a scope and provided to instantiateVariable.
+using AggregateStoreKey =
+ std::tuple<const Fortran::semantics::Scope *, std::size_t>;
+using AggregateStoreMap = llvm::DenseMap<AggregateStoreKey, mlir::Value>;
+
/// Instantiate variable \p var and add it to \p symMap.
/// The AbstractConverter builder must be set.
/// The AbstractConverter own symbol mapping is not used during the
/// instantiation and can be
diff erent form \p symMap.
void instantiateVariable(AbstractConverter &, const pft::Variable &var,
- SymMap &symMap);
+ SymMap &symMap, AggregateStoreMap &storeMap);
/// Lower a symbol attributes given an optional storage \p and add it to the
/// provided symbol map. If \preAlloc is not provided, a temporary storage will
@@ -49,5 +58,11 @@ void mapCallInterfaceSymbols(AbstractConverter &,
const Fortran::lower::CallerInterface &caller,
SymMap &symMap);
+/// Create initial-data-target fir.box in a global initializer region.
+/// This handles the local instantiation of the target variable.
+mlir::Value genInitialDataTarget(Fortran::lower::AbstractConverter &,
+ mlir::Location, mlir::Type boxType,
+ const SomeExpr &initialTarget);
+
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_CONVERT_VARIABLE_H
diff --git a/flang/include/flang/Lower/IO.h b/flang/include/flang/Lower/IO.h
new file mode 100644
index 0000000000000..9d5c007cbc35e
--- /dev/null
+++ b/flang/include/flang/Lower/IO.h
@@ -0,0 +1,46 @@
+//===-- Lower/IO.h -- lower IO statements -----------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_IO_H
+#define FORTRAN_LOWER_IO_H
+
+namespace mlir {
+class Value;
+} // namespace mlir
+
+namespace Fortran {
+namespace parser {
+struct ReadStmt;
+struct PrintStmt;
+struct WriteStmt;
+} // namespace parser
+
+namespace lower {
+
+class AbstractConverter;
+
+/// Generate IO call(s) for READ; return the IOSTAT code
+mlir::Value genReadStatement(AbstractConverter &converter,
+ const parser::ReadStmt &stmt);
+
+/// Generate IO call(s) for PRINT
+void genPrintStatement(AbstractConverter &converter,
+ const parser::PrintStmt &stmt);
+
+/// Generate IO call(s) for WRITE; return the IOSTAT code
+mlir::Value genWriteStatement(AbstractConverter &converter,
+ const parser::WriteStmt &stmt);
+
+} // namespace lower
+} // namespace Fortran
+
+#endif // FORTRAN_LOWER_IO_H
diff --git a/flang/include/flang/Lower/StatementContext.h b/flang/include/flang/Lower/StatementContext.h
index b4df75026e1d4..58cb9e9271596 100644
--- a/flang/include/flang/Lower/StatementContext.h
+++ b/flang/include/flang/Lower/StatementContext.h
@@ -13,6 +13,8 @@
#ifndef FORTRAN_LOWER_STATEMENTCONTEXT_H
#define FORTRAN_LOWER_STATEMENTCONTEXT_H
+#include "llvm/ADT/Optional.h"
+#include "llvm/ADT/SmallVector.h"
#include <functional>
namespace Fortran::lower {
diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td
index dd285032df095..8f2d6d48230a3 100644
--- a/flang/include/flang/Optimizer/Dialect/FIROps.td
+++ b/flang/include/flang/Optimizer/Dialect/FIROps.td
@@ -1805,6 +1805,7 @@ def fir_FieldIndexOp : fir_OneResultOp<"field_index", [NoSideEffect]> {
static constexpr llvm::StringRef fieldAttrName() { return "field_id"; }
static constexpr llvm::StringRef typeAttrName() { return "on_type"; }
llvm::StringRef getFieldName() { return getFieldId(); }
+ llvm::SmallVector<mlir::Attribute> getAttributes();
}];
}
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 6e50e1c35e058..f7e142ef451e6 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -16,6 +16,7 @@
#include "flang/Lower/ConvertExpr.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
+#include "flang/Lower/IO.h"
#include "flang/Lower/IterationSpace.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/PFTBuilder.h"
@@ -27,6 +28,7 @@
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Support/FIRContext.h"
+#include "flang/Runtime/iostat.h"
#include "flang/Semantics/tools.h"
#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
#include "mlir/IR/PatternMatch.h"
@@ -81,6 +83,27 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return lookupSymbol(sym).getAddr();
}
+ bool lookupLabelSet(Fortran::lower::SymbolRef sym,
+ Fortran::lower::pft::LabelSet &labelSet) override final {
+ Fortran::lower::pft::FunctionLikeUnit &owningProc =
+ *getEval().getOwningProcedure();
+ auto iter = owningProc.assignSymbolLabelMap.find(sym);
+ if (iter == owningProc.assignSymbolLabelMap.end())
+ return false;
+ labelSet = iter->second;
+ return true;
+ }
+
+ Fortran::lower::pft::Evaluation *
+ lookupLabel(Fortran::lower::pft::Label label) override final {
+ Fortran::lower::pft::FunctionLikeUnit &owningProc =
+ *getEval().getOwningProcedure();
+ auto iter = owningProc.labelEvaluationMap.find(label);
+ if (iter == owningProc.labelEvaluationMap.end())
+ return nullptr;
+ return iter->second;
+ }
+
fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr,
Fortran::lower::StatementContext &context,
mlir::Location *loc = nullptr) override final {
@@ -99,6 +122,16 @@ class FirConverter : public Fortran::lower::AbstractConverter {
const Fortran::lower::SomeExpr &expr) override final {
return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
}
+ fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr,
+ Fortran::lower::StatementContext &context,
+ mlir::Location loc) override final {
+ if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
+ !Fortran::evaluate::HasVectorSubscript(expr))
+ return Fortran::lower::createSomeArrayBox(*this, expr, localSymbols,
+ context);
+ return fir::BoxValue(
+ builder->createBox(loc, genExprAddr(expr, context, &loc)));
+ }
Fortran::evaluate::FoldingContext &getFoldingContext() override final {
return foldingContext;
@@ -118,9 +151,11 @@ class FirConverter : public Fortran::lower::AbstractConverter {
TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex "
"expression lowering");
}
- mlir::Type genType(Fortran::common::TypeCategory tc,
- int kind) override final {
- return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind);
+ mlir::Type
+ genType(Fortran::common::TypeCategory tc, int kind,
+ llvm::ArrayRef<std::int64_t> lenParameters) override final {
+ return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,
+ lenParameters);
}
mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
return Fortran::lower::translateVariableToFIRType(*this, var);
@@ -295,8 +330,9 @@ class FirConverter : public Fortran::lower::AbstractConverter {
/// Instantiate variable \p var and add it to the symbol map.
/// See ConvertVariable.cpp.
- void instantiateVar(const Fortran::lower::pft::Variable &var) {
- Fortran::lower::instantiateVariable(*this, var, localSymbols);
+ void instantiateVar(const Fortran::lower::pft::Variable &var,
+ Fortran::lower::AggregateStoreMap &storeMap) {
+ Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
}
/// Prepare to translate a new function
@@ -311,13 +347,14 @@ class FirConverter : public Fortran::lower::AbstractConverter {
mapDummiesAndResults(funit, callee);
+ Fortran::lower::AggregateStoreMap storeMap;
for (const Fortran::lower::pft::Variable &var :
funit.getOrderedSymbolTable()) {
const Fortran::semantics::Symbol &sym = var.getSymbol();
if (!sym.IsFuncResult() || !funit.primaryResult) {
- instantiateVar(var);
+ instantiateVar(var, storeMap);
} else if (&sym == funit.primaryResult) {
- instantiateVar(var);
+ instantiateVar(var, storeMap);
}
}
@@ -413,6 +450,17 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return cat == Fortran::common::TypeCategory::Derived;
}
+ mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval,
+ Fortran::parser::Label label) {
+ const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
+ eval.getOwningProcedure()->labelEvaluationMap;
+ const auto iter = labelEvaluationMap.find(label);
+ assert(iter != labelEvaluationMap.end() && "label missing from map");
+ mlir::Block *block = iter->second->block;
+ assert(block && "missing labeled evaluation block");
+ return block;
+ }
+
void genFIRBranch(mlir::Block *targetBlock) {
assert(targetBlock && "missing unconditional target block");
builder->create<cf::BranchOp>(toLocation(), targetBlock);
@@ -572,7 +620,9 @@ class FirConverter : public Fortran::lower::AbstractConverter {
}
builder->create<fir::StoreOp>(loc, cast, addr);
} else if (isCharacterCategory(lhsType->category())) {
- TODO(toLocation(), "Character assignment");
+ // Fortran 2018 10.2.1.3 p10 and p11
+ fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
+ lhs, rhs);
} else if (isDerivedCategory(lhsType->category())) {
TODO(toLocation(), "Derived type assignment");
} else {
@@ -785,11 +835,12 @@ class FirConverter : public Fortran::lower::AbstractConverter {
}
void genFIR(const Fortran::parser::PrintStmt &stmt) {
- TODO(toLocation(), "PrintStmt lowering");
+ genPrintStatement(*this, stmt);
}
void genFIR(const Fortran::parser::ReadStmt &stmt) {
- TODO(toLocation(), "ReadStmt lowering");
+ mlir::Value iostat = genReadStatement(*this, stmt);
+ genIoConditionBranches(getEval(), stmt.controls, iostat);
}
void genFIR(const Fortran::parser::RewindStmt &stmt) {
@@ -801,7 +852,59 @@ class FirConverter : public Fortran::lower::AbstractConverter {
}
void genFIR(const Fortran::parser::WriteStmt &stmt) {
- TODO(toLocation(), "WriteStmt lowering");
+ mlir::Value iostat = genWriteStatement(*this, stmt);
+ genIoConditionBranches(getEval(), stmt.controls, iostat);
+ }
+
+ template <typename A>
+ void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
+ const A &specList, mlir::Value iostat) {
+ if (!iostat)
+ return;
+
+ mlir::Block *endBlock = nullptr;
+ mlir::Block *eorBlock = nullptr;
+ mlir::Block *errBlock = nullptr;
+ for (const auto &spec : specList) {
+ std::visit(Fortran::common::visitors{
+ [&](const Fortran::parser::EndLabel &label) {
+ endBlock = blockOfLabel(eval, label.v);
+ },
+ [&](const Fortran::parser::EorLabel &label) {
+ eorBlock = blockOfLabel(eval, label.v);
+ },
+ [&](const Fortran::parser::ErrLabel &label) {
+ errBlock = blockOfLabel(eval, label.v);
+ },
+ [](const auto &) {}},
+ spec.u);
+ }
+ if (!endBlock && !eorBlock && !errBlock)
+ return;
+
+ mlir::Location loc = toLocation();
+ mlir::Type indexType = builder->getIndexType();
+ mlir::Value selector = builder->createConvert(loc, indexType, iostat);
+ llvm::SmallVector<int64_t> indexList;
+ llvm::SmallVector<mlir::Block *> blockList;
+ if (eorBlock) {
+ indexList.push_back(Fortran::runtime::io::IostatEor);
+ blockList.push_back(eorBlock);
+ }
+ if (endBlock) {
+ indexList.push_back(Fortran::runtime::io::IostatEnd);
+ blockList.push_back(endBlock);
+ }
+ if (errBlock) {
+ indexList.push_back(0);
+ blockList.push_back(eval.nonNopSuccessor().block);
+ // ERR label statement is the default successor.
+ blockList.push_back(errBlock);
+ } else {
+ // Fallthrough successor statement is the default successor.
+ blockList.push_back(eval.nonNopSuccessor().block);
+ }
+ builder->create<fir::SelectOp>(loc, selector, indexList, blockList);
}
//===--------------------------------------------------------------------===//
diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt
index e60087e3fc17c..297cc9b1b247f 100644
--- a/flang/lib/Lower/CMakeLists.txt
+++ b/flang/lib/Lower/CMakeLists.txt
@@ -9,6 +9,7 @@ add_flang_library(FortranLower
ConvertType.cpp
ConvertVariable.cpp
IntrinsicCall.cpp
+ IO.cpp
ComponentPath.cpp
DumpEvaluateExpr.cpp
IterationSpace.cpp
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index dd8c6ced3cbc5..85ea688ca4365 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -250,6 +250,16 @@ bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) {
return false;
}
+/// Some auxiliary data for processing initialization in ScalarExprLowering
+/// below. This is currently used for generating dense attributed global
+/// arrays.
+struct InitializerData {
+ explicit InitializerData(bool getRawVals = false) : genRawVals{getRawVals} {}
+ llvm::SmallVector<mlir::Attribute> rawVals; // initialization raw values
+ mlir::Type rawType; // Type of elements processed for rawVals vector.
+ bool genRawVals; // generate the rawVals vector if set.
+};
+
/// If \p arg is the address of a function with a denoted host-association tuple
/// argument, then return the host-associations tuple value of the current
/// procedure. Otherwise, return nullptr.
@@ -275,7 +285,8 @@ class ScalarExprLowering {
explicit ScalarExprLowering(mlir::Location loc,
Fortran::lower::AbstractConverter &converter,
Fortran::lower::SymMap &symMap,
- Fortran::lower::StatementContext &stmtCtx)
+ Fortran::lower::StatementContext &stmtCtx,
+ InitializerData *initializer = nullptr)
: location{loc}, converter{converter},
builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap} {
}
@@ -1762,6 +1773,30 @@ class ArrayExprLowering {
takeLboundsIfRealloc, realloc);
}
+ /// Entry point for when an array expression appears in a context where the
+ /// result must be boxed. (BoxValue semantics.)
+ static ExtValue
+ lowerBoxedArrayExpression(Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx,
+ const Fortran::lower::SomeExpr &expr) {
+ ArrayExprLowering ael{converter, stmtCtx, symMap,
+ ConstituentSemantics::BoxValue};
+ return ael.lowerBoxedArrayExpr(expr);
+ }
+
+ ExtValue lowerBoxedArrayExpr(const Fortran::lower::SomeExpr &exp) {
+ return std::visit(
+ [&](const auto &e) {
+ auto f = genarr(e);
+ ExtValue exv = f(IterationSpace{});
+ if (fir::getBase(exv).getType().template isa<fir::BoxType>())
+ return exv;
+ fir::emitFatalError(getLoc(), "array must be emboxed");
+ },
+ exp.u);
+ }
+
/// Entry point into lowering an expression with rank. This entry point is for
/// lowering a rhs expression, for example. (RefTransparent semantics.)
static ExtValue
@@ -2659,6 +2694,43 @@ fir::ExtendedValue Fortran::lower::createSomeExtendedExpression(
return ScalarExprLowering{loc, converter, symMap, stmtCtx}.genval(expr);
}
+fir::GlobalOp Fortran::lower::createDenseGlobal(
+ mlir::Location loc, mlir::Type symTy, llvm::StringRef globalName,
+ mlir::StringAttr linkage, bool isConst,
+ const Fortran::lower::SomeExpr &expr,
+ Fortran::lower::AbstractConverter &converter) {
+
+ Fortran::lower::StatementContext stmtCtx(/*prohibited=*/true);
+ Fortran::lower::SymMap emptyMap;
+ InitializerData initData(/*genRawVals=*/true);
+ ScalarExprLowering sel(loc, converter, emptyMap, stmtCtx,
+ /*initializer=*/&initData);
+ sel.genval(expr);
+
+ size_t sz = initData.rawVals.size();
+ llvm::ArrayRef<mlir::Attribute> ar = {initData.rawVals.data(), sz};
+
+ mlir::RankedTensorType tensorTy;
+ auto &builder = converter.getFirOpBuilder();
+ mlir::Type iTy = initData.rawType;
+ if (!iTy)
+ return 0; // array extent is probably 0 in this case, so just return 0.
+ tensorTy = mlir::RankedTensorType::get(sz, iTy);
+ auto init = mlir::DenseElementsAttr::get(tensorTy, ar);
+ return builder.createGlobal(loc, symTy, globalName, linkage, init, isConst);
+}
+
+fir::ExtendedValue Fortran::lower::createSomeInitializerExpression(
+ mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx) {
+ LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n');
+ InitializerData initData; // needed for initializations
+ return ScalarExprLowering{loc, converter, symMap, stmtCtx,
+ /*initializer=*/&initData}
+ .genval(expr);
+}
+
fir::ExtendedValue Fortran::lower::createSomeExtendedAddress(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
@@ -2667,6 +2739,25 @@ fir::ExtendedValue Fortran::lower::createSomeExtendedAddress(
return ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(expr);
}
+fir::ExtendedValue Fortran::lower::createInitializerAddress(
+ mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx) {
+ LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n');
+ InitializerData init;
+ return ScalarExprLowering(loc, converter, symMap, stmtCtx, &init).gen(expr);
+}
+
+fir::ExtendedValue
+Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::SomeExpr &expr,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx) {
+ LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n');
+ return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap,
+ stmtCtx, expr);
+}
+
fir::MutableBoxValue Fortran::lower::createMutableBox(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index 19556fc3afb27..f028df58e0e8a 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -75,6 +75,15 @@ static mlir::Type genLogicalType(mlir::MLIRContext *context, int KIND) {
return {};
}
+static mlir::Type genCharacterType(
+ mlir::MLIRContext *context, int KIND,
+ Fortran::lower::LenParameterTy len = fir::CharacterType::unknownLen()) {
+ if (Fortran::evaluate::IsValidKindOfIntrinsicType(
+ Fortran::common::TypeCategory::Character, KIND))
+ return fir::CharacterType::get(context, KIND, len);
+ return {};
+}
+
static mlir::Type genComplexType(mlir::MLIRContext *context, int KIND) {
if (Fortran::evaluate::IsValidKindOfIntrinsicType(
Fortran::common::TypeCategory::Complex, KIND))
@@ -82,8 +91,10 @@ static mlir::Type genComplexType(mlir::MLIRContext *context, int KIND) {
return {};
}
-static mlir::Type genFIRType(mlir::MLIRContext *context,
- Fortran::common::TypeCategory tc, int kind) {
+static mlir::Type
+genFIRType(mlir::MLIRContext *context, Fortran::common::TypeCategory tc,
+ int kind,
+ llvm::ArrayRef<Fortran::lower::LenParameterTy> lenParameters) {
switch (tc) {
case Fortran::common::TypeCategory::Real:
return genRealType(context, kind);
@@ -94,7 +105,9 @@ static mlir::Type genFIRType(mlir::MLIRContext *context,
case Fortran::common::TypeCategory::Logical:
return genLogicalType(context, kind);
case Fortran::common::TypeCategory::Character:
- TODO_NOLOC("genFIRType Character");
+ if (!lenParameters.empty())
+ return genCharacterType(context, kind, lenParameters[0]);
+ return genCharacterType(context, kind);
default:
break;
}
@@ -129,7 +142,9 @@ class TypeBuilder {
TODO(converter.getCurrentLocation(), "genExprType derived");
} else {
// LOGICAL, INTEGER, REAL, COMPLEX, CHARACTER
- baseType = genFIRType(context, category, dynamicType->kind());
+ llvm::SmallVector<Fortran::lower::LenParameterTy> params;
+ translateLenParameters(params, category, expr);
+ baseType = genFIRType(context, category, dynamicType->kind(), params);
}
std::optional<Fortran::evaluate::Shape> shapeExpr =
Fortran::evaluate::GetShape(converter.getFoldingContext(), expr);
@@ -211,7 +226,9 @@ class TypeBuilder {
if (const Fortran::semantics::IntrinsicTypeSpec *tySpec =
type->AsIntrinsic()) {
int kind = toInt64(Fortran::common::Clone(tySpec->kind())).value();
- ty = genFIRType(context, tySpec->category(), kind);
+ llvm::SmallVector<Fortran::lower::LenParameterTy> params;
+ translateLenParameters(params, tySpec->category(), ultimate);
+ ty = genFIRType(context, tySpec->category(), kind, params);
} else if (type->IsPolymorphic()) {
TODO(loc, "genSymbolType polymorphic types");
} else if (type->AsDerived()) {
@@ -246,6 +263,65 @@ class TypeBuilder {
return ty;
}
+ // To get the character length from a symbol, make an fold a designator for
+ // the symbol to cover the case where the symbol is an assumed length named
+ // constant and its length comes from its init expression length.
+ template <int Kind>
+ fir::SequenceType::Extent
+ getCharacterLengthHelper(const Fortran::semantics::Symbol &symbol) {
+ using TC =
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, Kind>;
+ auto designator = Fortran::evaluate::Fold(
+ converter.getFoldingContext(),
+ Fortran::evaluate::Expr<TC>{Fortran::evaluate::Designator<TC>{symbol}});
+ if (auto len = toInt64(std::move(designator.LEN())))
+ return *len;
+ return fir::SequenceType::getUnknownExtent();
+ }
+
+ template <typename T>
+ void translateLenParameters(
+ llvm::SmallVectorImpl<Fortran::lower::LenParameterTy> ¶ms,
+ Fortran::common::TypeCategory category, const T &exprOrSym) {
+ if (category == Fortran::common::TypeCategory::Character)
+ params.push_back(getCharacterLength(exprOrSym));
+ else if (category == Fortran::common::TypeCategory::Derived)
+ TODO(converter.getCurrentLocation(),
+ "lowering derived type length parameters");
+ return;
+ }
+ Fortran::lower::LenParameterTy
+ getCharacterLength(const Fortran::semantics::Symbol &symbol) {
+ const Fortran::semantics::DeclTypeSpec *type = symbol.GetType();
+ if (!type ||
+ type->category() != Fortran::semantics::DeclTypeSpec::Character ||
+ !type->AsIntrinsic())
+ llvm::report_fatal_error("not a character symbol");
+ int kind =
+ toInt64(Fortran::common::Clone(type->AsIntrinsic()->kind())).value();
+ switch (kind) {
+ case 1:
+ return getCharacterLengthHelper<1>(symbol);
+ case 2:
+ return getCharacterLengthHelper<2>(symbol);
+ case 4:
+ return getCharacterLengthHelper<4>(symbol);
+ }
+ llvm_unreachable("unknown character kind");
+ }
+ Fortran::lower::LenParameterTy
+ getCharacterLength(const Fortran::lower::SomeExpr &expr) {
+ // Do not use dynamic type length here. We would miss constant
+ // lengths opportunities because dynamic type only has the length
+ // if it comes from a declaration.
+ auto charExpr =
+ std::get<Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter>>(
+ expr.u);
+ if (auto constantLen = toInt64(charExpr.LEN()))
+ return *constantLen;
+ return fir::SequenceType::getUnknownExtent();
+ }
+
mlir::Type genVariableType(const Fortran::lower::pft::Variable &var) {
return genSymbolType(var.getSymbol(), var.isHeapAlloc(), var.isPointer());
}
@@ -259,8 +335,9 @@ class TypeBuilder {
mlir::Type Fortran::lower::getFIRType(mlir::MLIRContext *context,
Fortran::common::TypeCategory tc,
- int kind) {
- return genFIRType(context, tc, kind);
+ int kind,
+ llvm::ArrayRef<LenParameterTy> params) {
+ return genFIRType(context, tc, kind, params);
}
mlir::Type Fortran::lower::translateSomeExprToFIRType(
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index f11e031bee3d6..593e9c7e6e3e8 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -35,6 +35,45 @@
#define DEBUG_TYPE "flang-lower-variable"
+/// Helper to retrieve a copy of a character literal string from a SomeExpr.
+/// Required to build character global initializers.
+template <int KIND>
+static llvm::Optional<std::tuple<std::string, std::size_t>>
+getCharacterLiteralCopy(
+ const Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, KIND>>
+ &x) {
+ if (const auto *con =
+ Fortran::evaluate::UnwrapConstantValue<Fortran::evaluate::Type<
+ Fortran::common::TypeCategory::Character, KIND>>(x))
+ if (auto val = con->GetScalarValue())
+ return std::tuple<std::string, std::size_t>{
+ std::string{(const char *)val->c_str(),
+ KIND * (std::size_t)con->LEN()},
+ (std::size_t)con->LEN()};
+ return llvm::None;
+}
+static llvm::Optional<std::tuple<std::string, std::size_t>>
+getCharacterLiteralCopy(
+ const Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter> &x) {
+ return std::visit([](const auto &e) { return getCharacterLiteralCopy(e); },
+ x.u);
+}
+static llvm::Optional<std::tuple<std::string, std::size_t>>
+getCharacterLiteralCopy(const Fortran::lower::SomeExpr &x) {
+ if (const auto *e = Fortran::evaluate::UnwrapExpr<
+ Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter>>(x))
+ return getCharacterLiteralCopy(*e);
+ return llvm::None;
+}
+template <typename A>
+static llvm::Optional<std::tuple<std::string, std::size_t>>
+getCharacterLiteralCopy(const std::optional<A> &x) {
+ if (x)
+ return getCharacterLiteralCopy(*x);
+ return llvm::None;
+}
+
/// Helper to lower a scalar expression using a specific symbol mapping.
static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter,
mlir::Location loc,
@@ -47,6 +86,430 @@ static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter,
loc, converter, expr, symMap, context));
}
+/// Does this variable have a default initialization?
+static bool hasDefaultInitialization(const Fortran::semantics::Symbol &sym) {
+ if (sym.has<Fortran::semantics::ObjectEntityDetails>() && sym.size())
+ if (!Fortran::semantics::IsAllocatableOrPointer(sym))
+ if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType())
+ if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
+ declTypeSpec->AsDerived())
+ return derivedTypeSpec->HasDefaultInitialization();
+ return false;
+}
+
+//===----------------------------------------------------------------===//
+// Global variables instantiation (not for alias and common)
+//===----------------------------------------------------------------===//
+
+/// Helper to generate expression value inside global initializer.
+static fir::ExtendedValue
+genInitializerExprValue(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::lower::SomeExpr &expr,
+ Fortran::lower::StatementContext &stmtCtx) {
+ // Data initializer are constant value and should not depend on other symbols
+ // given the front-end fold parameter references. In any case, the "current"
+ // map of the converter should not be used since it holds mapping to
+ // mlir::Value from another mlir region. If these value are used by accident
+ // in the initializer, this will lead to segfaults in mlir code.
+ Fortran::lower::SymMap emptyMap;
+ return Fortran::lower::createSomeInitializerExpression(loc, converter, expr,
+ emptyMap, stmtCtx);
+}
+
+/// Can this symbol constant be placed in read-only memory?
+static bool isConstant(const Fortran::semantics::Symbol &sym) {
+ return sym.attrs().test(Fortran::semantics::Attr::PARAMETER) ||
+ sym.test(Fortran::semantics::Symbol::Flag::ReadOnly);
+}
+
+/// Create the global op declaration without any initializer
+static fir::GlobalOp declareGlobal(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable &var,
+ llvm::StringRef globalName,
+ mlir::StringAttr linkage) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ if (fir::GlobalOp global = builder.getNamedGlobal(globalName))
+ return global;
+ const Fortran::semantics::Symbol &sym = var.getSymbol();
+ mlir::Location loc = converter.genLocation(sym.name());
+ // Resolve potential host and module association before checking that this
+ // symbol is an object of a function pointer.
+ const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
+ if (!ultimate.has<Fortran::semantics::ObjectEntityDetails>() &&
+ !ultimate.has<Fortran::semantics::ProcEntityDetails>())
+ mlir::emitError(loc, "lowering global declaration: symbol '")
+ << toStringRef(sym.name()) << "' has unexpected details\n";
+ return builder.createGlobal(loc, converter.genType(var), globalName, linkage,
+ mlir::Attribute{}, isConstant(ultimate));
+}
+
+/// Temporary helper to catch todos in initial data target lowering.
+static bool
+hasDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) {
+ if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
+ if (const Fortran::semantics::DerivedTypeSpec *derived =
+ declTy->AsDerived())
+ return Fortran::semantics::CountLenParameters(*derived) > 0;
+ return false;
+}
+
+static mlir::Type unwrapElementType(mlir::Type type) {
+ if (mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(type))
+ type = ty;
+ if (auto seqType = type.dyn_cast<fir::SequenceType>())
+ type = seqType.getEleTy();
+ return type;
+}
+
+/// create initial-data-target fir.box in a global initializer region.
+mlir::Value Fortran::lower::genInitialDataTarget(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Type boxType, const Fortran::lower::SomeExpr &initialTarget) {
+ Fortran::lower::SymMap globalOpSymMap;
+ Fortran::lower::AggregateStoreMap storeMap;
+ Fortran::lower::StatementContext stmtCtx;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+ initialTarget))
+ return fir::factory::createUnallocatedBox(builder, loc, boxType,
+ /*nonDeferredParams=*/llvm::None);
+ // Pointer initial data target, and NULL(mold).
+ if (const Fortran::semantics::Symbol *sym =
+ Fortran::evaluate::GetFirstSymbol(initialTarget)) {
+ // Length parameters processing will need care in global initializer
+ // context.
+ if (hasDerivedTypeWithLengthParameters(*sym))
+ TODO(loc, "initial-data-target with derived type length parameters");
+
+ auto var = Fortran::lower::pft::Variable(*sym, /*global=*/true);
+ Fortran::lower::instantiateVariable(converter, var, globalOpSymMap,
+ storeMap);
+ }
+ mlir::Value box;
+ if (initialTarget.Rank() > 0) {
+ box = fir::getBase(Fortran::lower::createSomeArrayBox(
+ converter, initialTarget, globalOpSymMap, stmtCtx));
+ } else {
+ fir::ExtendedValue addr = Fortran::lower::createInitializerAddress(
+ loc, converter, initialTarget, globalOpSymMap, stmtCtx);
+ box = builder.createBox(loc, addr);
+ }
+ // box is a fir.box<T>, not a fir.box<fir.ptr<T>> as it should to be used
+ // for pointers. A fir.convert should not be used here, because it would
+ // not actually set the pointer attribute in the descriptor.
+ // In a normal context, fir.rebox would be used to set the pointer attribute
+ // while copying the projection from another fir.box. But fir.rebox cannot be
+ // used in initializer because its current codegen expects that the input
+ // fir.box is in memory, which is not the case in initializers.
+ // So, just replace the fir.embox that created addr with one with
+ // fir.box<fir.ptr<T>> result type.
+ // Note that the descriptor cannot have been created with fir.rebox because
+ // the initial-data-target cannot be a fir.box itself (it cannot be
+ // assumed-shape, deferred-shape, or polymorphic as per C765). However the
+ // case where the initial data target is a derived type with length parameters
+ // will most likely be a bit trickier, hence the TODO above.
+
+ mlir::Operation *op = box.getDefiningOp();
+ if (!op || !mlir::isa<fir::EmboxOp>(*op))
+ fir::emitFatalError(
+ loc, "fir.box must be created with embox in global initializers");
+ mlir::Type targetEleTy = unwrapElementType(box.getType());
+ if (!fir::isa_char(targetEleTy))
+ return builder.create<fir::EmboxOp>(loc, boxType, op->getOperands(),
+ op->getAttrs());
+
+ // Handle the character case length particularities: embox takes a length
+ // value argument when the result type has unknown length, but not when the
+ // result type has constant length. The type of the initial target must be
+ // constant length, but the one of the pointer may not be. In this case, a
+ // length operand must be added.
+ auto targetLen = targetEleTy.cast<fir::CharacterType>().getLen();
+ auto ptrLen = unwrapElementType(boxType).cast<fir::CharacterType>().getLen();
+ if (ptrLen == targetLen)
+ // Nothing to do
+ return builder.create<fir::EmboxOp>(loc, boxType, op->getOperands(),
+ op->getAttrs());
+ auto embox = mlir::cast<fir::EmboxOp>(*op);
+ auto ptrType = boxType.cast<fir::BoxType>().getEleTy();
+ mlir::Value memref = builder.createConvert(loc, ptrType, embox.getMemref());
+ if (targetLen == fir::CharacterType::unknownLen())
+ // Drop the length argument.
+ return builder.create<fir::EmboxOp>(loc, boxType, memref, embox.getShape(),
+ embox.getSlice());
+ // targetLen is constant and ptrLen is unknown. Add a length argument.
+ mlir::Value targetLenValue =
+ builder.createIntegerConstant(loc, builder.getIndexType(), targetLen);
+ return builder.create<fir::EmboxOp>(loc, boxType, memref, embox.getShape(),
+ embox.getSlice(),
+ mlir::ValueRange{targetLenValue});
+}
+
+static mlir::Value genDefaultInitializerValue(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::semantics::Symbol &sym, mlir::Type symTy,
+ Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Type scalarType = symTy;
+ fir::SequenceType sequenceType;
+ if (auto ty = symTy.dyn_cast<fir::SequenceType>()) {
+ sequenceType = ty;
+ scalarType = ty.getEleTy();
+ }
+ // Build a scalar default value of the symbol type, looping through the
+ // components to build each component initial value.
+ auto recTy = scalarType.cast<fir::RecordType>();
+ auto fieldTy = fir::FieldType::get(scalarType.getContext());
+ mlir::Value initialValue = builder.create<fir::UndefOp>(loc, scalarType);
+ const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType();
+ assert(declTy && "var with default initialization must have a type");
+ Fortran::semantics::OrderedComponentIterator components(
+ declTy->derivedTypeSpec());
+ for (const auto &component : components) {
+ // Skip parent components, the sub-components of parent types are part of
+ // components and will be looped through right after.
+ if (component.test(Fortran::semantics::Symbol::Flag::ParentComp))
+ continue;
+ mlir::Value componentValue;
+ llvm::StringRef name = toStringRef(component.name());
+ mlir::Type componentTy = recTy.getType(name);
+ assert(componentTy && "component not found in type");
+ if (const auto *object{
+ component.detailsIf<Fortran::semantics::ObjectEntityDetails>()}) {
+ if (const auto &init = object->init()) {
+ // Component has explicit initialization.
+ if (Fortran::semantics::IsPointer(component))
+ // Initial data target.
+ componentValue =
+ genInitialDataTarget(converter, loc, componentTy, *init);
+ else
+ // Initial value.
+ componentValue = fir::getBase(
+ genInitializerExprValue(converter, loc, *init, stmtCtx));
+ } else if (Fortran::semantics::IsAllocatableOrPointer(component)) {
+ // Pointer or allocatable without initialization.
+ // Create deallocated/disassociated value.
+ // From a standard point of view, pointer without initialization do not
+ // need to be disassociated, but for sanity and simplicity, do it in
+ // global constructor since this has no runtime cost.
+ componentValue = fir::factory::createUnallocatedBox(
+ builder, loc, componentTy, llvm::None);
+ } else if (hasDefaultInitialization(component)) {
+ // Component type has default initialization.
+ componentValue = genDefaultInitializerValue(converter, loc, component,
+ componentTy, stmtCtx);
+ } else {
+ // Component has no initial value.
+ componentValue = builder.create<fir::UndefOp>(loc, componentTy);
+ }
+ } else if (const auto *proc{
+ component
+ .detailsIf<Fortran::semantics::ProcEntityDetails>()}) {
+ if (proc->init().has_value())
+ TODO(loc, "procedure pointer component default initialization");
+ else
+ componentValue = builder.create<fir::UndefOp>(loc, componentTy);
+ }
+ assert(componentValue && "must have been computed");
+ componentValue = builder.createConvert(loc, componentTy, componentValue);
+ // FIXME: type parameters must come from the derived-type-spec
+ auto field = builder.create<fir::FieldIndexOp>(
+ loc, fieldTy, name, scalarType,
+ /*typeParams=*/mlir::ValueRange{} /*TODO*/);
+ initialValue = builder.create<fir::InsertValueOp>(
+ loc, recTy, initialValue, componentValue,
+ builder.getArrayAttr(field.getAttributes()));
+ }
+
+ if (sequenceType) {
+ // For arrays, duplicate the scalar value to all elements with an
+ // fir.insert_range covering the whole array.
+ auto arrayInitialValue = builder.create<fir::UndefOp>(loc, sequenceType);
+ llvm::SmallVector<int64_t> rangeBounds;
+ for (int64_t extent : sequenceType.getShape()) {
+ if (extent == fir::SequenceType::getUnknownExtent())
+ TODO(loc,
+ "default initial value of array component with length parameters");
+ rangeBounds.push_back(0);
+ rangeBounds.push_back(extent - 1);
+ }
+ return builder.create<fir::InsertOnRangeOp>(
+ loc, sequenceType, arrayInitialValue, initialValue,
+ builder.getIndexVectorAttr(rangeBounds));
+ }
+ return initialValue;
+}
+
+/// Does this global already have an initializer ?
+static bool globalIsInitialized(fir::GlobalOp global) {
+ return !global.getRegion().empty() || global.getInitVal();
+}
+
+/// Call \p genInit to generate code inside \p global initializer region.
+static void
+createGlobalInitialization(fir::FirOpBuilder &builder, fir::GlobalOp global,
+ std::function<void(fir::FirOpBuilder &)> genInit) {
+ mlir::Region ®ion = global.getRegion();
+ region.push_back(new mlir::Block);
+ mlir::Block &block = region.back();
+ auto insertPt = builder.saveInsertionPoint();
+ builder.setInsertionPointToStart(&block);
+ genInit(builder);
+ builder.restoreInsertionPoint(insertPt);
+}
+
+/// Create the global op and its init if it has one
+static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable &var,
+ llvm::StringRef globalName,
+ mlir::StringAttr linkage) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ const Fortran::semantics::Symbol &sym = var.getSymbol();
+ mlir::Location loc = converter.genLocation(sym.name());
+ bool isConst = isConstant(sym);
+ fir::GlobalOp global = builder.getNamedGlobal(globalName);
+ mlir::Type symTy = converter.genType(var);
+
+ if (global && globalIsInitialized(global))
+ return global;
+ // If this is an array, check to see if we can use a dense attribute
+ // with a tensor mlir type. This optimization currently only supports
+ // rank-1 Fortran arrays of integer, real, or logical. The tensor
+ // type does not support nested structures which are needed for
+ // complex numbers.
+ // To get multidimensional arrays to work, we will have to use column major
+ // array ordering with the tensor type (so it matches column major ordering
+ // with the Fortran fir.array). By default, tensor types assume row major
+ // ordering. How to create this tensor type is to be determined.
+ if (symTy.isa<fir::SequenceType>() && sym.Rank() == 1 &&
+ !Fortran::semantics::IsAllocatableOrPointer(sym)) {
+ mlir::Type eleTy = symTy.cast<fir::SequenceType>().getEleTy();
+ if (eleTy.isa<mlir::IntegerType, mlir::FloatType, fir::LogicalType>()) {
+ const auto *details =
+ sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
+ if (details->init()) {
+ global = Fortran::lower::createDenseGlobal(
+ loc, symTy, globalName, linkage, isConst, details->init().value(),
+ converter);
+ if (global) {
+ global.setVisibility(mlir::SymbolTable::Visibility::Public);
+ return global;
+ }
+ }
+ }
+ }
+ if (!global)
+ global = builder.createGlobal(loc, symTy, globalName, linkage,
+ mlir::Attribute{}, isConst);
+ if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
+ const auto *details =
+ sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
+ if (details && details->init()) {
+ auto expr = *details->init();
+ createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) {
+ mlir::Value box =
+ Fortran::lower::genInitialDataTarget(converter, loc, symTy, expr);
+ b.create<fir::HasValueOp>(loc, box);
+ });
+ } else {
+ // Create unallocated/disassociated descriptor if no explicit init
+ createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) {
+ mlir::Value box =
+ fir::factory::createUnallocatedBox(b, loc, symTy, llvm::None);
+ b.create<fir::HasValueOp>(loc, box);
+ });
+ }
+
+ } else if (const auto *details =
+ sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
+ if (details->init()) {
+ if (fir::isa_char(symTy)) {
+ // CHARACTER literal
+ if (auto chLit = getCharacterLiteralCopy(details->init().value())) {
+ mlir::StringAttr init =
+ builder.getStringAttr(std::get<std::string>(*chLit));
+ global->setAttr(global.getInitValAttrName(), init);
+ } else {
+ fir::emitFatalError(loc, "CHARACTER has unexpected initial value");
+ }
+ } else {
+ createGlobalInitialization(
+ builder, global, [&](fir::FirOpBuilder &builder) {
+ Fortran::lower::StatementContext stmtCtx(
+ /*cleanupProhibited=*/true);
+ fir::ExtendedValue initVal = genInitializerExprValue(
+ converter, loc, details->init().value(), stmtCtx);
+ mlir::Value castTo =
+ builder.createConvert(loc, symTy, fir::getBase(initVal));
+ builder.create<fir::HasValueOp>(loc, castTo);
+ });
+ }
+ } else if (hasDefaultInitialization(sym)) {
+ createGlobalInitialization(
+ builder, global, [&](fir::FirOpBuilder &builder) {
+ Fortran::lower::StatementContext stmtCtx(
+ /*cleanupProhibited=*/true);
+ mlir::Value initVal =
+ genDefaultInitializerValue(converter, loc, sym, symTy, stmtCtx);
+ mlir::Value castTo = builder.createConvert(loc, symTy, initVal);
+ builder.create<fir::HasValueOp>(loc, castTo);
+ });
+ }
+ } else if (sym.has<Fortran::semantics::CommonBlockDetails>()) {
+ mlir::emitError(loc, "COMMON symbol processed elsewhere");
+ } else {
+ TODO(loc, "global"); // Procedure pointer or something else
+ }
+ // Creates undefined initializer for globals without initializers
+ if (!globalIsInitialized(global))
+ createGlobalInitialization(
+ builder, global, [&](fir::FirOpBuilder &builder) {
+ builder.create<fir::HasValueOp>(
+ loc, builder.create<fir::UndefOp>(loc, symTy));
+ });
+ // Set public visibility to prevent global definition to be optimized out
+ // even if they have no initializer and are unused in this compilation unit.
+ global.setVisibility(mlir::SymbolTable::Visibility::Public);
+ return global;
+}
+
+/// Return linkage attribute for \p var.
+static mlir::StringAttr
+getLinkageAttribute(fir::FirOpBuilder &builder,
+ const Fortran::lower::pft::Variable &var) {
+ if (var.isModuleVariable())
+ return {}; // external linkage
+ // Otherwise, the variable is owned by a procedure and must not be visible in
+ // other compilation units.
+ return builder.createInternalLinkage();
+}
+
+/// Instantiate a global variable. If it hasn't already been processed, add
+/// the global to the ModuleOp as a new uniqued symbol and initialize it with
+/// the correct value. It will be referenced on demand using `fir.addr_of`.
+static void instantiateGlobal(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable &var,
+ Fortran::lower::SymMap &symMap) {
+ const Fortran::semantics::Symbol &sym = var.getSymbol();
+ assert(!var.isAlias() && "must be handled in instantiateAlias");
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ std::string globalName = Fortran::lower::mangle::mangleName(sym);
+ mlir::Location loc = converter.genLocation(sym.name());
+ fir::GlobalOp global = builder.getNamedGlobal(globalName);
+ mlir::StringAttr linkage = getLinkageAttribute(builder, var);
+ if (var.isModuleVariable()) {
+ // A module global was or will be defined when lowering the module. Emit
+ // only a declaration if the global does not exist at that point.
+ global = declareGlobal(converter, var, globalName, linkage);
+ } else {
+ global = defineGlobal(converter, var, globalName, linkage);
+ }
+ auto addrOf = builder.create<fir::AddrOfOp>(loc, global.resultType(),
+ global.getSymbol());
+ Fortran::lower::StatementContext stmtCtx;
+ mapSymbolAttributes(converter, var, symMap, stmtCtx, addrOf);
+}
+
//===----------------------------------------------------------------===//
// Local variables instantiation (not for alias)
//===----------------------------------------------------------------===//
@@ -401,7 +864,8 @@ void Fortran::lower::mapSymbolAttributes(
void Fortran::lower::instantiateVariable(AbstractConverter &converter,
const pft::Variable &var,
- SymMap &symMap) {
+ SymMap &symMap,
+ AggregateStoreMap &storeMap) {
const Fortran::semantics::Symbol &sym = var.getSymbol();
const mlir::Location loc = converter.genLocation(sym.name());
if (var.isAggregateStore()) {
@@ -412,7 +876,7 @@ void Fortran::lower::instantiateVariable(AbstractConverter &converter,
} else if (var.isAlias()) {
TODO(loc, "instantiateVariable Alias");
} else if (var.isGlobal()) {
- TODO(loc, "instantiateVariable Global");
+ instantiateGlobal(converter, var, symMap);
} else {
instantiateLocal(converter, var, symMap);
}
@@ -421,11 +885,12 @@ void Fortran::lower::instantiateVariable(AbstractConverter &converter,
void Fortran::lower::mapCallInterfaceSymbols(
AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
SymMap &symMap) {
+ Fortran::lower::AggregateStoreMap storeMap;
const Fortran::semantics::Symbol &result = caller.getResultSymbol();
for (Fortran::lower::pft::Variable var :
Fortran::lower::pft::buildFuncResultDependencyList(result)) {
if (var.isAggregateStore()) {
- instantiateVariable(converter, var, symMap);
+ instantiateVariable(converter, var, symMap, storeMap);
} else {
const Fortran::semantics::Symbol &sym = var.getSymbol();
const auto *hostDetails =
@@ -460,7 +925,7 @@ void Fortran::lower::mapCallInterfaceSymbols(
// module or common block variable to satisfy specification expression
// requirements in 10.1.11, instantiateVariable will get its address and
// properties.
- instantiateVariable(converter, var, symMap);
+ instantiateVariable(converter, var, symMap, storeMap);
}
}
}
diff --git a/flang/lib/Lower/IO.cpp b/flang/lib/Lower/IO.cpp
new file mode 100644
index 0000000000000..7b396e6e305b0
--- /dev/null
+++ b/flang/lib/Lower/IO.cpp
@@ -0,0 +1,1695 @@
+//===-- IO.cpp -- IO statement lowering -----------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Lower/IO.h"
+#include "flang/Common/uint128.h"
+#include "flang/Lower/Bridge.h"
+#include "flang/Lower/ConvertVariable.h"
+#include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/StatementContext.h"
+#include "flang/Lower/Support/Utils.h"
+#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/Character.h"
+#include "flang/Optimizer/Builder/Complex.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
+#include "flang/Parser/parse-tree.h"
+#include "flang/Runtime/io-api.h"
+#include "flang/Semantics/tools.h"
+#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
+
+#define DEBUG_TYPE "flang-lower-io"
+
+// Define additional runtime type models specific to IO.
+namespace fir::runtime {
+template <>
+constexpr TypeBuilderFunc getModel<Fortran::runtime::io::IoStatementState *>() {
+ return getModel<char *>();
+}
+template <>
+constexpr TypeBuilderFunc
+getModel<const Fortran::runtime::io::NamelistGroup &>() {
+ return [](mlir::MLIRContext *context) -> mlir::Type {
+ return fir::ReferenceType::get(mlir::TupleType::get(context));
+ };
+}
+template <>
+constexpr TypeBuilderFunc getModel<Fortran::runtime::io::Iostat>() {
+ return [](mlir::MLIRContext *context) -> mlir::Type {
+ return mlir::IntegerType::get(context,
+ 8 * sizeof(Fortran::runtime::io::Iostat));
+ };
+}
+} // namespace fir::runtime
+
+using namespace Fortran::runtime::io;
+
+#define mkIOKey(X) FirmkKey(IONAME(X))
+
+namespace Fortran::lower {
+/// Static table of IO runtime calls
+///
+/// This logical map contains the name and type builder function for each IO
+/// runtime function listed in the tuple. This table is fully constructed at
+/// compile-time. Use the `mkIOKey` macro to access the table.
+static constexpr std::tuple<
+ mkIOKey(BeginInternalArrayListOutput), mkIOKey(BeginInternalArrayListInput),
+ mkIOKey(BeginInternalArrayFormattedOutput),
+ mkIOKey(BeginInternalArrayFormattedInput), mkIOKey(BeginInternalListOutput),
+ mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalFormattedOutput),
+ mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginExternalListOutput),
+ mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalFormattedOutput),
+ mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginUnformattedOutput),
+ mkIOKey(BeginUnformattedInput), mkIOKey(BeginAsynchronousOutput),
+ mkIOKey(BeginAsynchronousInput), mkIOKey(BeginWait), mkIOKey(BeginWaitAll),
+ mkIOKey(BeginClose), mkIOKey(BeginFlush), mkIOKey(BeginBackspace),
+ mkIOKey(BeginEndfile), mkIOKey(BeginRewind), mkIOKey(BeginOpenUnit),
+ mkIOKey(BeginOpenNewUnit), mkIOKey(BeginInquireUnit),
+ mkIOKey(BeginInquireFile), mkIOKey(BeginInquireIoLength),
+ mkIOKey(EnableHandlers), mkIOKey(SetAdvance), mkIOKey(SetBlank),
+ mkIOKey(SetDecimal), mkIOKey(SetDelim), mkIOKey(SetPad), mkIOKey(SetPos),
+ mkIOKey(SetRec), mkIOKey(SetRound), mkIOKey(SetSign),
+ mkIOKey(OutputNamelist), mkIOKey(InputNamelist), mkIOKey(OutputDescriptor),
+ mkIOKey(InputDescriptor), mkIOKey(OutputUnformattedBlock),
+ mkIOKey(InputUnformattedBlock), mkIOKey(OutputInteger8),
+ mkIOKey(OutputInteger16), mkIOKey(OutputInteger32),
+ mkIOKey(OutputInteger64),
+#ifdef __SIZEOF_INT128__
+ mkIOKey(OutputInteger128),
+#endif
+ mkIOKey(InputInteger), mkIOKey(OutputReal32), mkIOKey(InputReal32),
+ mkIOKey(OutputReal64), mkIOKey(InputReal64), mkIOKey(OutputComplex32),
+ mkIOKey(InputComplex32), mkIOKey(OutputComplex64), mkIOKey(InputComplex64),
+ mkIOKey(OutputAscii), mkIOKey(InputAscii), mkIOKey(OutputLogical),
+ mkIOKey(InputLogical), mkIOKey(SetAccess), mkIOKey(SetAction),
+ mkIOKey(SetAsynchronous), mkIOKey(SetCarriagecontrol), mkIOKey(SetEncoding),
+ mkIOKey(SetForm), mkIOKey(SetPosition), mkIOKey(SetRecl),
+ mkIOKey(SetStatus), mkIOKey(SetFile), mkIOKey(GetNewUnit), mkIOKey(GetSize),
+ mkIOKey(GetIoLength), mkIOKey(GetIoMsg), mkIOKey(InquireCharacter),
+ mkIOKey(InquireLogical), mkIOKey(InquirePendingId),
+ mkIOKey(InquireInteger64), mkIOKey(EndIoStatement)>
+ newIOTable;
+} // namespace Fortran::lower
+
+namespace {
+/// IO statements may require exceptional condition handling. A statement that
+/// encounters an exceptional condition may branch to a label given on an ERR
+/// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT
+/// specifier variable may be set to a value that indicates some condition,
+/// and an IOMSG specifier variable may be set to a description of a condition.
+struct ConditionSpecInfo {
+ const Fortran::lower::SomeExpr *ioStatExpr{};
+ const Fortran::lower::SomeExpr *ioMsgExpr{};
+ bool hasErr{};
+ bool hasEnd{};
+ bool hasEor{};
+
+ /// Check for any condition specifier that applies to specifier processing.
+ bool hasErrorConditionSpec() const { return ioStatExpr != nullptr || hasErr; }
+
+ /// Check for any condition specifier that applies to data transfer items
+ /// in a PRINT, READ, WRITE, or WAIT statement. (WAIT may be irrelevant.)
+ bool hasTransferConditionSpec() const {
+ return hasErrorConditionSpec() || hasEnd || hasEor;
+ }
+
+ /// Check for any condition specifier, including IOMSG.
+ bool hasAnyConditionSpec() const {
+ return hasTransferConditionSpec() || ioMsgExpr != nullptr;
+ }
+};
+} // namespace
+
+template <typename D>
+static void genIoLoop(Fortran::lower::AbstractConverter &converter,
+ mlir::Value cookie, const D &ioImpliedDo,
+ bool isFormatted, bool checkResult, mlir::Value &ok,
+ bool inLoop, Fortran::lower::StatementContext &stmtCtx);
+
+/// Helper function to retrieve the name of the IO function given the key `A`
+template <typename A>
+static constexpr const char *getName() {
+ return std::get<A>(Fortran::lower::newIOTable).name;
+}
+
+/// Helper function to retrieve the type model signature builder of the IO
+/// function as defined by the key `A`
+template <typename A>
+static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
+ return std::get<A>(Fortran::lower::newIOTable).getTypeModel();
+}
+
+/// Get (or generate) the MLIR FuncOp for a given IO runtime function.
+template <typename E>
+static mlir::FuncOp getIORuntimeFunc(mlir::Location loc,
+ fir::FirOpBuilder &builder) {
+ llvm::StringRef name = getName<E>();
+ mlir::FuncOp func = builder.getNamedFunction(name);
+ if (func)
+ return func;
+ auto funTy = getTypeModel<E>()(builder.getContext());
+ func = builder.createFunction(loc, name, funTy);
+ func->setAttr("fir.runtime", builder.getUnitAttr());
+ func->setAttr("fir.io", builder.getUnitAttr());
+ return func;
+}
+
+/// Generate calls to end an IO statement. Return the IOSTAT value, if any.
+/// It is the caller's responsibility to generate branches on that value.
+static mlir::Value genEndIO(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Value cookie,
+ const ConditionSpecInfo &csi,
+ Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ if (csi.ioMsgExpr) {
+ mlir::FuncOp getIoMsg = getIORuntimeFunc<mkIOKey(GetIoMsg)>(loc, builder);
+ fir::ExtendedValue ioMsgVar =
+ converter.genExprAddr(csi.ioMsgExpr, stmtCtx, loc);
+ builder.create<fir::CallOp>(
+ loc, getIoMsg,
+ mlir::ValueRange{
+ cookie,
+ builder.createConvert(loc, getIoMsg.getType().getInput(1),
+ fir::getBase(ioMsgVar)),
+ builder.createConvert(loc, getIoMsg.getType().getInput(2),
+ fir::getLen(ioMsgVar))});
+ }
+ mlir::FuncOp endIoStatement =
+ getIORuntimeFunc<mkIOKey(EndIoStatement)>(loc, builder);
+ auto call = builder.create<fir::CallOp>(loc, endIoStatement,
+ mlir::ValueRange{cookie});
+ if (csi.ioStatExpr) {
+ mlir::Value ioStatVar =
+ fir::getBase(converter.genExprAddr(csi.ioStatExpr, stmtCtx, loc));
+ mlir::Value ioStatResult = builder.createConvert(
+ loc, converter.genType(*csi.ioStatExpr), call.getResult(0));
+ builder.create<fir::StoreOp>(loc, ioStatResult, ioStatVar);
+ }
+ return csi.hasTransferConditionSpec() ? call.getResult(0) : mlir::Value{};
+}
+
+/// Make the next call in the IO statement conditional on runtime result `ok`.
+/// If a call returns `ok==false`, further suboperation calls for an IO
+/// statement will be skipped. This may generate branch heavy, deeply nested
+/// conditionals for IO statements with a large number of suboperations.
+static void makeNextConditionalOn(fir::FirOpBuilder &builder,
+ mlir::Location loc, bool checkResult,
+ mlir::Value ok, bool inLoop = false) {
+ if (!checkResult || !ok)
+ // Either no IO calls need to be checked, or this will be the first call.
+ return;
+
+ // A previous IO call for a statement returned the bool `ok`. If this call
+ // is in a fir.iterate_while loop, the result must be propagated up to the
+ // loop scope as an extra ifOp result. (The propagation is done in genIoLoop.)
+ mlir::TypeRange resTy;
+ if (inLoop)
+ resTy = builder.getI1Type();
+ auto ifOp = builder.create<fir::IfOp>(loc, resTy, ok,
+ /*withElseRegion=*/inLoop);
+ builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
+}
+
+/// Retrieve or generate a runtime description of NAMELIST group `symbol`.
+/// The form of the description is defined in runtime header file namelist.h.
+/// Static descriptors are generated for global objects; local descriptors for
+/// local objects. If all descriptors are static, the NamelistGroup is static.
+static mlir::Value
+getNamelistGroup(Fortran::lower::AbstractConverter &converter,
+ const Fortran::semantics::Symbol &symbol,
+ Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Location loc = converter.getCurrentLocation();
+ std::string groupMangleName = converter.mangleName(symbol);
+ if (auto group = builder.getNamedGlobal(groupMangleName))
+ return builder.create<fir::AddrOfOp>(loc, group.resultType(),
+ group.getSymbol());
+
+ const auto &details =
+ symbol.GetUltimate().get<Fortran::semantics::NamelistDetails>();
+ mlir::MLIRContext *context = builder.getContext();
+ mlir::StringAttr linkOnce = builder.createLinkOnceLinkage();
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::IntegerType sizeTy = builder.getIntegerType(8 * sizeof(std::size_t));
+ fir::ReferenceType charRefTy =
+ fir::ReferenceType::get(builder.getIntegerType(8));
+ fir::ReferenceType descRefTy =
+ fir::ReferenceType::get(fir::BoxType::get(mlir::NoneType::get(context)));
+ fir::SequenceType listTy = fir::SequenceType::get(
+ details.objects().size(),
+ mlir::TupleType::get(context, {charRefTy, descRefTy}));
+ mlir::TupleType groupTy = mlir::TupleType::get(
+ context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy)});
+ auto stringAddress = [&](const Fortran::semantics::Symbol &symbol) {
+ return fir::factory::createStringLiteral(builder, loc,
+ symbol.name().ToString() + '\0');
+ };
+
+ // Define object names, and static descriptors for global objects.
+ bool groupIsLocal = false;
+ stringAddress(symbol);
+ for (const Fortran::semantics::Symbol &s : details.objects()) {
+ stringAddress(s);
+ if (!Fortran::lower::symbolIsGlobal(s)) {
+ groupIsLocal = true;
+ continue;
+ }
+ std::string mangleName = converter.mangleName(s) + ".desc";
+ if (builder.getNamedGlobal(mangleName))
+ continue;
+ const auto expr = Fortran::evaluate::AsGenericExpr(s);
+ fir::BoxType boxTy =
+ fir::BoxType::get(fir::PointerType::get(converter.genType(s)));
+ auto descFunc = [&](fir::FirOpBuilder &b) {
+ auto box =
+ Fortran::lower::genInitialDataTarget(converter, loc, boxTy, *expr);
+ b.create<fir::HasValueOp>(loc, box);
+ };
+ builder.createGlobalConstant(loc, boxTy, mangleName, descFunc, linkOnce);
+ }
+
+ // Define the list of Items.
+ mlir::Value listAddr =
+ groupIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{};
+ std::string listMangleName = groupMangleName + ".list";
+ auto listFunc = [&](fir::FirOpBuilder &builder) {
+ mlir::Value list = builder.create<fir::UndefOp>(loc, listTy);
+ mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0);
+ mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1);
+ llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{},
+ mlir::Attribute{}};
+ size_t n = 0;
+ for (const Fortran::semantics::Symbol &s : details.objects()) {
+ idx[0] = builder.getIntegerAttr(idxTy, n);
+ idx[1] = zero;
+ mlir::Value nameAddr =
+ builder.createConvert(loc, charRefTy, fir::getBase(stringAddress(s)));
+ list = builder.create<fir::InsertValueOp>(loc, listTy, list, nameAddr,
+ builder.getArrayAttr(idx));
+ idx[1] = one;
+ mlir::Value descAddr;
+ if (auto desc =
+ builder.getNamedGlobal(converter.mangleName(s) + ".desc")) {
+ descAddr = builder.create<fir::AddrOfOp>(loc, desc.resultType(),
+ desc.getSymbol());
+ } else {
+ const auto expr = Fortran::evaluate::AsGenericExpr(s);
+ fir::ExtendedValue exv = converter.genExprAddr(*expr, stmtCtx);
+ mlir::Type type = fir::getBase(exv).getType();
+ if (mlir::Type baseTy = fir::dyn_cast_ptrOrBoxEleTy(type))
+ type = baseTy;
+ fir::BoxType boxType = fir::BoxType::get(fir::PointerType::get(type));
+ descAddr = builder.createTemporary(loc, boxType);
+ fir::MutableBoxValue box = fir::MutableBoxValue(descAddr, {}, {});
+ fir::factory::associateMutableBox(builder, loc, box, exv,
+ /*lbounds=*/llvm::None);
+ }
+ descAddr = builder.createConvert(loc, descRefTy, descAddr);
+ list = builder.create<fir::InsertValueOp>(loc, listTy, list, descAddr,
+ builder.getArrayAttr(idx));
+ ++n;
+ }
+ if (groupIsLocal)
+ builder.create<fir::StoreOp>(loc, list, listAddr);
+ else
+ builder.create<fir::HasValueOp>(loc, list);
+ };
+ if (groupIsLocal)
+ listFunc(builder);
+ else
+ builder.createGlobalConstant(loc, listTy, listMangleName, listFunc,
+ linkOnce);
+
+ // Define the group.
+ mlir::Value groupAddr = groupIsLocal
+ ? builder.create<fir::AllocaOp>(loc, groupTy)
+ : mlir::Value{};
+ auto groupFunc = [&](fir::FirOpBuilder &builder) {
+ mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0);
+ mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1);
+ mlir::IntegerAttr two = builder.getIntegerAttr(idxTy, 2);
+ mlir::Value group = builder.create<fir::UndefOp>(loc, groupTy);
+ mlir::Value nameAddr = builder.createConvert(
+ loc, charRefTy, fir::getBase(stringAddress(symbol)));
+ group = builder.create<fir::InsertValueOp>(loc, groupTy, group, nameAddr,
+ builder.getArrayAttr(zero));
+ mlir::Value itemCount =
+ builder.createIntegerConstant(loc, sizeTy, details.objects().size());
+ group = builder.create<fir::InsertValueOp>(loc, groupTy, group, itemCount,
+ builder.getArrayAttr(one));
+ if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName))
+ listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(),
+ list.getSymbol());
+ assert(listAddr && "missing namelist object list");
+ group = builder.create<fir::InsertValueOp>(loc, groupTy, group, listAddr,
+ builder.getArrayAttr(two));
+ if (groupIsLocal)
+ builder.create<fir::StoreOp>(loc, group, groupAddr);
+ else
+ builder.create<fir::HasValueOp>(loc, group);
+ };
+ if (groupIsLocal) {
+ groupFunc(builder);
+ } else {
+ fir::GlobalOp group =
+ builder.createGlobal(loc, groupTy, groupMangleName,
+ /*isConst=*/true, groupFunc, linkOnce);
+ groupAddr = builder.create<fir::AddrOfOp>(loc, group.resultType(),
+ group.getSymbol());
+ }
+ assert(groupAddr && "missing namelist group result");
+ return groupAddr;
+}
+
+/// Generate a namelist IO call.
+static void genNamelistIO(Fortran::lower::AbstractConverter &converter,
+ mlir::Value cookie, mlir::FuncOp funcOp,
+ Fortran::semantics::Symbol &symbol, bool checkResult,
+ mlir::Value &ok,
+ Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Location loc = converter.getCurrentLocation();
+ makeNextConditionalOn(builder, loc, checkResult, ok);
+ mlir::Type argType = funcOp.getType().getInput(1);
+ mlir::Value groupAddr = getNamelistGroup(converter, symbol, stmtCtx);
+ groupAddr = builder.createConvert(loc, argType, groupAddr);
+ llvm::SmallVector<mlir::Value> args = {cookie, groupAddr};
+ ok = builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
+}
+
+/// Get the output function to call for a value of the given type.
+static mlir::FuncOp getOutputFunc(mlir::Location loc,
+ fir::FirOpBuilder &builder, mlir::Type type,
+ bool isFormatted) {
+ if (!isFormatted)
+ return getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc, builder);
+ if (auto ty = type.dyn_cast<mlir::IntegerType>()) {
+ switch (ty.getWidth()) {
+ case 1:
+ return getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder);
+ case 8:
+ return getIORuntimeFunc<mkIOKey(OutputInteger8)>(loc, builder);
+ case 16:
+ return getIORuntimeFunc<mkIOKey(OutputInteger16)>(loc, builder);
+ case 32:
+ return getIORuntimeFunc<mkIOKey(OutputInteger32)>(loc, builder);
+ case 64:
+ return getIORuntimeFunc<mkIOKey(OutputInteger64)>(loc, builder);
+#ifdef __SIZEOF_INT128__
+ case 128:
+ return getIORuntimeFunc<mkIOKey(OutputInteger128)>(loc, builder);
+#endif
+ }
+ llvm_unreachable("unknown OutputInteger kind");
+ }
+ if (auto ty = type.dyn_cast<mlir::FloatType>()) {
+ if (auto width = ty.getWidth(); width == 32)
+ return getIORuntimeFunc<mkIOKey(OutputReal32)>(loc, builder);
+ else if (width == 64)
+ return getIORuntimeFunc<mkIOKey(OutputReal64)>(loc, builder);
+ }
+ if (auto ty = type.dyn_cast<fir::ComplexType>()) {
+ if (auto kind = ty.getFKind(); kind == 4)
+ return getIORuntimeFunc<mkIOKey(OutputComplex32)>(loc, builder);
+ else if (kind == 8)
+ return getIORuntimeFunc<mkIOKey(OutputComplex64)>(loc, builder);
+ }
+ if (type.isa<fir::LogicalType>())
+ return getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder);
+ if (fir::factory::CharacterExprHelper::isCharacterScalar(type))
+ return getIORuntimeFunc<mkIOKey(OutputAscii)>(loc, builder);
+ return getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc, builder);
+}
+
+/// Generate a sequence of output data transfer calls.
+static void
+genOutputItemList(Fortran::lower::AbstractConverter &converter,
+ mlir::Value cookie,
+ const std::list<Fortran::parser::OutputItem> &items,
+ bool isFormatted, bool checkResult, mlir::Value &ok,
+ bool inLoop, Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ for (const Fortran::parser::OutputItem &item : items) {
+ if (const auto &impliedDo = std::get_if<1>(&item.u)) {
+ genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult,
+ ok, inLoop, stmtCtx);
+ continue;
+ }
+ auto &pExpr = std::get<Fortran::parser::Expr>(item.u);
+ mlir::Location loc = converter.genLocation(pExpr.source);
+ makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
+
+ const auto *expr = Fortran::semantics::GetExpr(pExpr);
+ if (!expr)
+ fir::emitFatalError(loc, "internal error: could not get evaluate::Expr");
+ mlir::Type itemTy = converter.genType(*expr);
+ mlir::FuncOp outputFunc = getOutputFunc(loc, builder, itemTy, isFormatted);
+ mlir::Type argType = outputFunc.getType().getInput(1);
+ assert((isFormatted || argType.isa<fir::BoxType>()) &&
+ "expect descriptor for unformatted IO runtime");
+ llvm::SmallVector<mlir::Value> outputFuncArgs = {cookie};
+ fir::factory::CharacterExprHelper helper{builder, loc};
+ if (argType.isa<fir::BoxType>()) {
+ mlir::Value box = fir::getBase(converter.genExprBox(*expr, stmtCtx, loc));
+ outputFuncArgs.push_back(builder.createConvert(loc, argType, box));
+ } else if (helper.isCharacterScalar(itemTy)) {
+ fir::ExtendedValue exv = converter.genExprAddr(expr, stmtCtx, loc);
+ // scalar allocatable/pointer may also get here, not clear if
+ // genExprAddr will lower them as CharBoxValue or BoxValue.
+ if (!exv.getCharBox())
+ llvm::report_fatal_error(
+ "internal error: scalar character not in CharBox");
+ outputFuncArgs.push_back(builder.createConvert(
+ loc, outputFunc.getType().getInput(1), fir::getBase(exv)));
+ outputFuncArgs.push_back(builder.createConvert(
+ loc, outputFunc.getType().getInput(2), fir::getLen(exv)));
+ } else {
+ fir::ExtendedValue itemBox = converter.genExprValue(expr, stmtCtx, loc);
+ mlir::Value itemValue = fir::getBase(itemBox);
+ if (fir::isa_complex(itemTy)) {
+ auto parts =
+ fir::factory::Complex{builder, loc}.extractParts(itemValue);
+ outputFuncArgs.push_back(parts.first);
+ outputFuncArgs.push_back(parts.second);
+ } else {
+ itemValue = builder.createConvert(loc, argType, itemValue);
+ outputFuncArgs.push_back(itemValue);
+ }
+ }
+ ok = builder.create<fir::CallOp>(loc, outputFunc, outputFuncArgs)
+ .getResult(0);
+ }
+}
+
+/// Get the input function to call for a value of the given type.
+static mlir::FuncOp getInputFunc(mlir::Location loc, fir::FirOpBuilder &builder,
+ mlir::Type type, bool isFormatted) {
+ if (!isFormatted)
+ return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder);
+ if (auto ty = type.dyn_cast<mlir::IntegerType>())
+ return ty.getWidth() == 1
+ ? getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder)
+ : getIORuntimeFunc<mkIOKey(InputInteger)>(loc, builder);
+ if (auto ty = type.dyn_cast<mlir::FloatType>()) {
+ if (auto width = ty.getWidth(); width <= 32)
+ return getIORuntimeFunc<mkIOKey(InputReal32)>(loc, builder);
+ else if (width <= 64)
+ return getIORuntimeFunc<mkIOKey(InputReal64)>(loc, builder);
+ }
+ if (auto ty = type.dyn_cast<fir::ComplexType>()) {
+ if (auto kind = ty.getFKind(); kind <= 4)
+ return getIORuntimeFunc<mkIOKey(InputComplex32)>(loc, builder);
+ else if (kind <= 8)
+ return getIORuntimeFunc<mkIOKey(InputComplex64)>(loc, builder);
+ }
+ if (type.isa<fir::LogicalType>())
+ return getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder);
+ if (fir::factory::CharacterExprHelper::isCharacterScalar(type))
+ return getIORuntimeFunc<mkIOKey(InputAscii)>(loc, builder);
+ return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder);
+}
+
+static mlir::Value createIoRuntimeCallForItem(mlir::Location loc,
+ fir::FirOpBuilder &builder,
+ mlir::FuncOp inputFunc,
+ mlir::Value cookie,
+ const fir::ExtendedValue &item) {
+ mlir::Type argType = inputFunc.getType().getInput(1);
+ llvm::SmallVector<mlir::Value> inputFuncArgs = {cookie};
+ if (argType.isa<fir::BoxType>()) {
+ mlir::Value box = fir::getBase(item);
+ assert(box.getType().isa<fir::BoxType>() && "must be previously emboxed");
+ inputFuncArgs.push_back(builder.createConvert(loc, argType, box));
+ } else {
+ mlir::Value itemAddr = fir::getBase(item);
+ mlir::Type itemTy = fir::unwrapPassByRefType(itemAddr.getType());
+ inputFuncArgs.push_back(builder.createConvert(loc, argType, itemAddr));
+ fir::factory::CharacterExprHelper charHelper{builder, loc};
+ if (charHelper.isCharacterScalar(itemTy)) {
+ mlir::Value len = fir::getLen(item);
+ inputFuncArgs.push_back(
+ builder.createConvert(loc, inputFunc.getType().getInput(2), len));
+ } else if (itemTy.isa<mlir::IntegerType>()) {
+ inputFuncArgs.push_back(builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getI32IntegerAttr(
+ itemTy.cast<mlir::IntegerType>().getWidth() / 8)));
+ }
+ }
+ return builder.create<fir::CallOp>(loc, inputFunc, inputFuncArgs)
+ .getResult(0);
+}
+
+/// Generate a sequence of input data transfer calls.
+static void genInputItemList(Fortran::lower::AbstractConverter &converter,
+ mlir::Value cookie,
+ const std::list<Fortran::parser::InputItem> &items,
+ bool isFormatted, bool checkResult,
+ mlir::Value &ok, bool inLoop,
+ Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ for (const Fortran::parser::InputItem &item : items) {
+ if (const auto &impliedDo = std::get_if<1>(&item.u)) {
+ genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult,
+ ok, inLoop, stmtCtx);
+ continue;
+ }
+ auto &pVar = std::get<Fortran::parser::Variable>(item.u);
+ mlir::Location loc = converter.genLocation(pVar.GetSource());
+ makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
+ const auto *expr = Fortran::semantics::GetExpr(pVar);
+ if (!expr)
+ fir::emitFatalError(loc, "internal error: could not get evaluate::Expr");
+ if (Fortran::evaluate::HasVectorSubscript(*expr)) {
+ TODO(loc, "genInputItemList with VectorSubscript");
+ }
+ mlir::Type itemTy = converter.genType(*expr);
+ mlir::FuncOp inputFunc = getInputFunc(loc, builder, itemTy, isFormatted);
+ auto itemExv = inputFunc.getType().getInput(1).isa<fir::BoxType>()
+ ? converter.genExprBox(*expr, stmtCtx, loc)
+ : converter.genExprAddr(expr, stmtCtx, loc);
+ ok = createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, itemExv);
+ }
+}
+
+/// Generate an io-implied-do loop.
+template <typename D>
+static void genIoLoop(Fortran::lower::AbstractConverter &converter,
+ mlir::Value cookie, const D &ioImpliedDo,
+ bool isFormatted, bool checkResult, mlir::Value &ok,
+ bool inLoop, Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Location loc = converter.getCurrentLocation();
+ makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
+ const auto &itemList = std::get<0>(ioImpliedDo.t);
+ const auto &control = std::get<1>(ioImpliedDo.t);
+ const auto &loopSym = *control.name.thing.thing.symbol;
+ mlir::Value loopVar = converter.getSymbolAddress(loopSym);
+ auto genControlValue = [&](const Fortran::parser::ScalarIntExpr &expr) {
+ mlir::Value v = fir::getBase(
+ converter.genExprValue(*Fortran::semantics::GetExpr(expr), stmtCtx));
+ return builder.createConvert(loc, builder.getIndexType(), v);
+ };
+ mlir::Value lowerValue = genControlValue(control.lower);
+ mlir::Value upperValue = genControlValue(control.upper);
+ mlir::Value stepValue =
+ control.step.has_value()
+ ? genControlValue(*control.step)
+ : builder.create<mlir::arith::ConstantIndexOp>(loc, 1);
+ auto genItemList = [&](const D &ioImpliedDo) {
+ Fortran::lower::StatementContext loopCtx;
+ if constexpr (std::is_same_v<D, Fortran::parser::InputImpliedDo>)
+ genInputItemList(converter, cookie, itemList, isFormatted, checkResult,
+ ok, /*inLoop=*/true, loopCtx);
+ else
+ genOutputItemList(converter, cookie, itemList, isFormatted, checkResult,
+ ok, /*inLoop=*/true, loopCtx);
+ };
+ if (!checkResult) {
+ // No IO call result checks - the loop is a fir.do_loop op.
+ auto doLoopOp = builder.create<fir::DoLoopOp>(
+ loc, lowerValue, upperValue, stepValue, /*unordered=*/false,
+ /*finalCountValue=*/true);
+ builder.setInsertionPointToStart(doLoopOp.getBody());
+ mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym),
+ doLoopOp.getInductionVar());
+ builder.create<fir::StoreOp>(loc, lcv, loopVar);
+ genItemList(ioImpliedDo);
+ builder.setInsertionPointToEnd(doLoopOp.getBody());
+ mlir::Value result = builder.create<mlir::arith::AddIOp>(
+ loc, doLoopOp.getInductionVar(), doLoopOp.getStep());
+ builder.create<fir::ResultOp>(loc, result);
+ builder.setInsertionPointAfter(doLoopOp);
+ // The loop control variable may be used after the loop.
+ lcv = builder.createConvert(loc, converter.genType(loopSym),
+ doLoopOp.getResult(0));
+ builder.create<fir::StoreOp>(loc, lcv, loopVar);
+ return;
+ }
+ // Check IO call results - the loop is a fir.iterate_while op.
+ if (!ok)
+ ok = builder.createBool(loc, true);
+ auto iterWhileOp = builder.create<fir::IterWhileOp>(
+ loc, lowerValue, upperValue, stepValue, ok, /*finalCountValue*/ true);
+ builder.setInsertionPointToStart(iterWhileOp.getBody());
+ mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym),
+ iterWhileOp.getInductionVar());
+ builder.create<fir::StoreOp>(loc, lcv, loopVar);
+ ok = iterWhileOp.getIterateVar();
+ mlir::Value falseValue =
+ builder.createIntegerConstant(loc, builder.getI1Type(), 0);
+ genItemList(ioImpliedDo);
+ // Unwind nested IO call scopes, filling in true and false ResultOp's.
+ for (mlir::Operation *op = builder.getBlock()->getParentOp();
+ isa<fir::IfOp>(op); op = op->getBlock()->getParentOp()) {
+ auto ifOp = dyn_cast<fir::IfOp>(op);
+ mlir::Operation *lastOp = &ifOp.getThenRegion().front().back();
+ builder.setInsertionPointAfter(lastOp);
+ // The primary ifOp result is the result of an IO call or loop.
+ if (mlir::isa<fir::CallOp, fir::IfOp>(*lastOp))
+ builder.create<fir::ResultOp>(loc, lastOp->getResult(0));
+ else
+ builder.create<fir::ResultOp>(loc, ok); // loop result
+ // The else branch propagates an early exit false result.
+ builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
+ builder.create<fir::ResultOp>(loc, falseValue);
+ }
+ builder.setInsertionPointToEnd(iterWhileOp.getBody());
+ mlir::OpResult iterateResult = builder.getBlock()->back().getResult(0);
+ mlir::Value inductionResult0 = iterWhileOp.getInductionVar();
+ auto inductionResult1 = builder.create<mlir::arith::AddIOp>(
+ loc, inductionResult0, iterWhileOp.getStep());
+ auto inductionResult = builder.create<mlir::arith::SelectOp>(
+ loc, iterateResult, inductionResult1, inductionResult0);
+ llvm::SmallVector<mlir::Value> results = {inductionResult, iterateResult};
+ builder.create<fir::ResultOp>(loc, results);
+ ok = iterWhileOp.getResult(1);
+ builder.setInsertionPointAfter(iterWhileOp);
+ // The loop control variable may be used after the loop.
+ lcv = builder.createConvert(loc, converter.genType(loopSym),
+ iterWhileOp.getResult(0));
+ builder.create<fir::StoreOp>(loc, lcv, loopVar);
+}
+
+//===----------------------------------------------------------------------===//
+// Default argument generation.
+//===----------------------------------------------------------------------===//
+
+static mlir::Value locToFilename(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Type toType) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ return builder.createConvert(loc, toType,
+ fir::factory::locationToFilename(builder, loc));
+}
+
+static mlir::Value locToLineNo(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Type toType) {
+ return fir::factory::locationToLineNo(converter.getFirOpBuilder(), loc,
+ toType);
+}
+
+static mlir::Value getDefaultScratch(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Type toType) {
+ mlir::Value null = builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getI64IntegerAttr(0));
+ return builder.createConvert(loc, toType, null);
+}
+
+static mlir::Value getDefaultScratchLen(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Type toType) {
+ return builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getIntegerAttr(toType, 0));
+}
+
+/// Generate a reference to a buffer and the length of buffer given
+/// a character expression. An array expression will be cast to scalar
+/// character as long as they are contiguous.
+static std::tuple<mlir::Value, mlir::Value>
+genBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::lower::SomeExpr &expr, mlir::Type strTy,
+ mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ fir::ExtendedValue exprAddr = converter.genExprAddr(expr, stmtCtx);
+ fir::factory::CharacterExprHelper helper(builder, loc);
+ using ValuePair = std::pair<mlir::Value, mlir::Value>;
+ auto [buff, len] = exprAddr.match(
+ [&](const fir::CharBoxValue &x) -> ValuePair {
+ return {x.getBuffer(), x.getLen()};
+ },
+ [&](const fir::CharArrayBoxValue &x) -> ValuePair {
+ fir::CharBoxValue scalar = helper.toScalarCharacter(x);
+ return {scalar.getBuffer(), scalar.getLen()};
+ },
+ [&](const fir::BoxValue &) -> ValuePair {
+ // May need to copy before after IO to handle contiguous
+ // aspect. Not sure descriptor can get here though.
+ TODO(loc, "character descriptor to contiguous buffer");
+ },
+ [&](const auto &) -> ValuePair {
+ llvm::report_fatal_error(
+ "internal error: IO buffer is not a character");
+ });
+ buff = builder.createConvert(loc, strTy, buff);
+ len = builder.createConvert(loc, lenTy, len);
+ return {buff, len};
+}
+
+/// Lower a string literal. Many arguments to the runtime are conveyed as
+/// Fortran CHARACTER literals.
+template <typename A>
+static std::tuple<mlir::Value, mlir::Value, mlir::Value>
+lowerStringLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ Fortran::lower::StatementContext &stmtCtx, const A &syntax,
+ mlir::Type strTy, mlir::Type lenTy, mlir::Type ty2 = {}) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ auto *expr = Fortran::semantics::GetExpr(syntax);
+ if (!expr)
+ fir::emitFatalError(loc, "internal error: null semantic expr in IO");
+ auto [buff, len] = genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx);
+ mlir::Value kind;
+ if (ty2) {
+ auto kindVal = expr->GetType().value().kind();
+ kind = builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getIntegerAttr(ty2, kindVal));
+ }
+ return {buff, len, kind};
+}
+
+/// Pass the body of the FORMAT statement in as if it were a CHARACTER literal
+/// constant. NB: This is the prescribed manner in which the front-end passes
+/// this information to lowering.
+static std::tuple<mlir::Value, mlir::Value, mlir::Value>
+lowerSourceTextAsStringLit(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, llvm::StringRef text,
+ mlir::Type strTy, mlir::Type lenTy) {
+ text = text.drop_front(text.find('('));
+ text = text.take_front(text.rfind(')') + 1);
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Value addrGlobalStringLit =
+ fir::getBase(fir::factory::createStringLiteral(builder, loc, text));
+ mlir::Value buff = builder.createConvert(loc, strTy, addrGlobalStringLit);
+ mlir::Value len = builder.createIntegerConstant(loc, lenTy, text.size());
+ return {buff, len, mlir::Value{}};
+}
+
+//===----------------------------------------------------------------------===//
+// Handle IO statement specifiers.
+// These are threaded together for a single statement via the passed cookie.
+//===----------------------------------------------------------------------===//
+
+/// Generic to build an integral argument to the runtime.
+template <typename A, typename B>
+mlir::Value genIntIOOption(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Value cookie,
+ const B &spec) {
+ Fortran::lower::StatementContext localStatementCtx;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder);
+ mlir::FunctionType ioFuncTy = ioFunc.getType();
+ mlir::Value expr = fir::getBase(converter.genExprValue(
+ Fortran::semantics::GetExpr(spec.v), localStatementCtx, loc));
+ mlir::Value val = builder.createConvert(loc, ioFuncTy.getInput(1), expr);
+ llvm::SmallVector<mlir::Value> ioArgs = {cookie, val};
+ return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
+}
+
+/// Generic to build a string argument to the runtime. This passes a CHARACTER
+/// as a pointer to the buffer and a LEN parameter.
+template <typename A, typename B>
+mlir::Value genCharIOOption(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Value cookie,
+ const B &spec) {
+ Fortran::lower::StatementContext localStatementCtx;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder);
+ mlir::FunctionType ioFuncTy = ioFunc.getType();
+ std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
+ lowerStringLit(converter, loc, localStatementCtx, spec,
+ ioFuncTy.getInput(1), ioFuncTy.getInput(2));
+ llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
+ std::get<1>(tup)};
+ return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
+}
+
+template <typename A>
+mlir::Value genIOOption(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Value cookie, const A &spec) {
+ // These specifiers are processed in advance elsewhere - skip them here.
+ using PreprocessedSpecs =
+ std::tuple<Fortran::parser::EndLabel, Fortran::parser::EorLabel,
+ Fortran::parser::ErrLabel, Fortran::parser::FileUnitNumber,
+ Fortran::parser::Format, Fortran::parser::IoUnit,
+ Fortran::parser::MsgVariable, Fortran::parser::Name,
+ Fortran::parser::StatVariable>;
+ static_assert(Fortran::common::HasMember<A, PreprocessedSpecs>,
+ "missing genIOOPtion specialization");
+ return {};
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::FileNameExpr>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::FileNameExpr &spec) {
+ Fortran::lower::StatementContext localStatementCtx;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ // has an extra KIND argument
+ mlir::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(SetFile)>(loc, builder);
+ mlir::FunctionType ioFuncTy = ioFunc.getType();
+ std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
+ lowerStringLit(converter, loc, localStatementCtx, spec,
+ ioFuncTy.getInput(1), ioFuncTy.getInput(2));
+ llvm::SmallVector<mlir::Value> ioArgs{cookie, std::get<0>(tup),
+ std::get<1>(tup)};
+ return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::ConnectSpec::CharExpr>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::ConnectSpec::CharExpr &spec) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::FuncOp ioFunc;
+ switch (std::get<Fortran::parser::ConnectSpec::CharExpr::Kind>(spec.t)) {
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Access:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetAccess)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Action:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetAction)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Asynchronous:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetAsynchronous)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Blank:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Decimal:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Delim:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Encoding:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetEncoding)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Form:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetForm)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Pad:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Position:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetPosition)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Round:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Sign:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Carriagecontrol:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetCarriagecontrol)>(loc, builder);
+ break;
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Convert:
+ TODO(loc, "CONVERT not part of the runtime::io interface");
+ case Fortran::parser::ConnectSpec::CharExpr::Kind::Dispose:
+ TODO(loc, "DISPOSE not part of the runtime::io interface");
+ }
+ Fortran::lower::StatementContext localStatementCtx;
+ mlir::FunctionType ioFuncTy = ioFunc.getType();
+ std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
+ lowerStringLit(converter, loc, localStatementCtx,
+ std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t),
+ ioFuncTy.getInput(1), ioFuncTy.getInput(2));
+ llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
+ std::get<1>(tup)};
+ return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::ConnectSpec::Recl>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::ConnectSpec::Recl &spec) {
+ return genIntIOOption<mkIOKey(SetRecl)>(converter, loc, cookie, spec);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::ConnectSpec::Newunit>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::ConnectSpec::Newunit &spec) {
+ Fortran::lower::StatementContext stmtCtx;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(GetNewUnit)>(loc, builder);
+ mlir::FunctionType ioFuncTy = ioFunc.getType();
+ const auto *var = Fortran::semantics::GetExpr(spec);
+ mlir::Value addr = builder.createConvert(
+ loc, ioFuncTy.getInput(1),
+ fir::getBase(converter.genExprAddr(var, stmtCtx, loc)));
+ auto kind = builder.createIntegerConstant(loc, ioFuncTy.getInput(2),
+ var->GetType().value().kind());
+ llvm::SmallVector<mlir::Value> ioArgs = {cookie, addr, kind};
+ return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::StatusExpr>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::StatusExpr &spec) {
+ return genCharIOOption<mkIOKey(SetStatus)>(converter, loc, cookie, spec.v);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::IoControlSpec::CharExpr>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::IoControlSpec::CharExpr &spec) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::FuncOp ioFunc;
+ switch (std::get<Fortran::parser::IoControlSpec::CharExpr::Kind>(spec.t)) {
+ case Fortran::parser::IoControlSpec::CharExpr::Kind::Advance:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetAdvance)>(loc, builder);
+ break;
+ case Fortran::parser::IoControlSpec::CharExpr::Kind::Blank:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder);
+ break;
+ case Fortran::parser::IoControlSpec::CharExpr::Kind::Decimal:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder);
+ break;
+ case Fortran::parser::IoControlSpec::CharExpr::Kind::Delim:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder);
+ break;
+ case Fortran::parser::IoControlSpec::CharExpr::Kind::Pad:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder);
+ break;
+ case Fortran::parser::IoControlSpec::CharExpr::Kind::Round:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder);
+ break;
+ case Fortran::parser::IoControlSpec::CharExpr::Kind::Sign:
+ ioFunc = getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder);
+ break;
+ }
+ Fortran::lower::StatementContext localStatementCtx;
+ mlir::FunctionType ioFuncTy = ioFunc.getType();
+ std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
+ lowerStringLit(converter, loc, localStatementCtx,
+ std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t),
+ ioFuncTy.getInput(1), ioFuncTy.getInput(2));
+ llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
+ std::get<1>(tup)};
+ return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::IoControlSpec::Asynchronous>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie,
+ const Fortran::parser::IoControlSpec::Asynchronous &spec) {
+ return genCharIOOption<mkIOKey(SetAsynchronous)>(converter, loc, cookie,
+ spec.v);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::IdVariable>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::IdVariable &spec) {
+ TODO(loc, "asynchronous ID not implemented");
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::IoControlSpec::Pos>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::IoControlSpec::Pos &spec) {
+ return genIntIOOption<mkIOKey(SetPos)>(converter, loc, cookie, spec);
+}
+
+template <>
+mlir::Value genIOOption<Fortran::parser::IoControlSpec::Rec>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ mlir::Value cookie, const Fortran::parser::IoControlSpec::Rec &spec) {
+ return genIntIOOption<mkIOKey(SetRec)>(converter, loc, cookie, spec);
+}
+
+/// Generate runtime call to query the read size after an input statement if
+/// the statement has SIZE control-spec.
+template <typename A>
+static void genIOReadSize(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Value cookie,
+ const A &specList, bool checkResult) {
+ // This call is not conditional on the current IO status (ok) because the size
+ // needs to be filled even if some error condition (end-of-file...) was met
+ // during the input statement (in which case the runtime may return zero for
+ // the size read).
+ for (const auto &spec : specList)
+ if (const auto *size =
+ std::get_if<Fortran::parser::IoControlSpec::Size>(&spec.u)) {
+
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(GetSize)>(loc, builder);
+ auto sizeValue =
+ builder.create<fir::CallOp>(loc, ioFunc, mlir::ValueRange{cookie})
+ .getResult(0);
+ Fortran::lower::StatementContext localStatementCtx;
+ fir::ExtendedValue var = converter.genExprAddr(
+ Fortran::semantics::GetExpr(size->v), localStatementCtx, loc);
+ mlir::Value varAddr = fir::getBase(var);
+ mlir::Type varType = fir::unwrapPassByRefType(varAddr.getType());
+ mlir::Value sizeCast = builder.createConvert(loc, varType, sizeValue);
+ builder.create<fir::StoreOp>(loc, sizeCast, varAddr);
+ break;
+ }
+}
+
+//===----------------------------------------------------------------------===//
+// Gather IO statement condition specifier information (if any).
+//===----------------------------------------------------------------------===//
+
+template <typename SEEK, typename A>
+static bool hasX(const A &list) {
+ for (const auto &spec : list)
+ if (std::holds_alternative<SEEK>(spec.u))
+ return true;
+ return false;
+}
+
+/// For each specifier, build the appropriate call, threading the cookie.
+template <typename A>
+static void threadSpecs(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Value cookie,
+ const A &specList, bool checkResult, mlir::Value &ok) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ for (const auto &spec : specList) {
+ makeNextConditionalOn(builder, loc, checkResult, ok);
+ ok = std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::parser::IoControlSpec::Size &x) -> mlir::Value {
+ // Size must be queried after the related READ runtime calls, not
+ // before.
+ return ok;
+ },
+ [&](const auto &x) {
+ return genIOOption(converter, loc, cookie, x);
+ }},
+ spec.u);
+ }
+}
+
+/// Most IO statements allow one or more of five optional exception condition
+/// handling specifiers: ERR, EOR, END, IOSTAT, and IOMSG. The first three
+/// cause control flow to transfer to another statement. The final two return
+/// information from the runtime, via a variable, about the nature of the
+/// condition that occurred. These condition specifiers are handled here.
+template <typename A>
+static void
+genConditionHandlerCall(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, mlir::Value cookie,
+ const A &specList, ConditionSpecInfo &csi) {
+ for (const auto &spec : specList) {
+ std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::parser::StatVariable &var) {
+ csi.ioStatExpr = Fortran::semantics::GetExpr(var);
+ },
+ [&](const Fortran::parser::InquireSpec::IntVar &var) {
+ if (std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t) ==
+ Fortran::parser::InquireSpec::IntVar::Kind::Iostat)
+ csi.ioStatExpr = Fortran::semantics::GetExpr(
+ std::get<Fortran::parser::ScalarIntVariable>(var.t));
+ },
+ [&](const Fortran::parser::MsgVariable &var) {
+ csi.ioMsgExpr = Fortran::semantics::GetExpr(var);
+ },
+ [&](const Fortran::parser::InquireSpec::CharVar &var) {
+ if (std::get<Fortran::parser::InquireSpec::CharVar::Kind>(
+ var.t) ==
+ Fortran::parser::InquireSpec::CharVar::Kind::Iomsg)
+ csi.ioMsgExpr = Fortran::semantics::GetExpr(
+ std::get<Fortran::parser::ScalarDefaultCharVariable>(
+ var.t));
+ },
+ [&](const Fortran::parser::EndLabel &) { csi.hasEnd = true; },
+ [&](const Fortran::parser::EorLabel &) { csi.hasEor = true; },
+ [&](const Fortran::parser::ErrLabel &) { csi.hasErr = true; },
+ [](const auto &) {}},
+ spec.u);
+ }
+ if (!csi.hasAnyConditionSpec())
+ return;
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::FuncOp enableHandlers =
+ getIORuntimeFunc<mkIOKey(EnableHandlers)>(loc, builder);
+ mlir::Type boolType = enableHandlers.getType().getInput(1);
+ auto boolValue = [&](bool specifierIsPresent) {
+ return builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getIntegerAttr(boolType, specifierIsPresent));
+ };
+ llvm::SmallVector<mlir::Value> ioArgs = {cookie,
+ boolValue(csi.ioStatExpr != nullptr),
+ boolValue(csi.hasErr),
+ boolValue(csi.hasEnd),
+ boolValue(csi.hasEor),
+ boolValue(csi.ioMsgExpr != nullptr)};
+ builder.create<fir::CallOp>(loc, enableHandlers, ioArgs);
+}
+
+//===----------------------------------------------------------------------===//
+// Data transfer helpers
+//===----------------------------------------------------------------------===//
+
+template <typename SEEK, typename A>
+static bool hasIOControl(const A &stmt) {
+ return hasX<SEEK>(stmt.controls);
+}
+
+template <typename SEEK, typename A>
+static const auto *getIOControl(const A &stmt) {
+ for (const auto &spec : stmt.controls)
+ if (const auto *result = std::get_if<SEEK>(&spec.u))
+ return result;
+ return static_cast<const SEEK *>(nullptr);
+}
+
+/// Returns true iff the expression in the parse tree is not really a format but
+/// rather a namelist group.
+template <typename A>
+static bool formatIsActuallyNamelist(const A &format) {
+ if (auto *e = std::get_if<Fortran::parser::Expr>(&format.u)) {
+ auto *expr = Fortran::semantics::GetExpr(*e);
+ if (const Fortran::semantics::Symbol *y =
+ Fortran::evaluate::UnwrapWholeSymbolDataRef(*expr))
+ return y->has<Fortran::semantics::NamelistDetails>();
+ }
+ return false;
+}
+
+template <typename A>
+static bool isDataTransferFormatted(const A &stmt) {
+ if (stmt.format)
+ return !formatIsActuallyNamelist(*stmt.format);
+ return hasIOControl<Fortran::parser::Format>(stmt);
+}
+template <>
+constexpr bool isDataTransferFormatted<Fortran::parser::PrintStmt>(
+ const Fortran::parser::PrintStmt &) {
+ return true; // PRINT is always formatted
+}
+
+template <typename A>
+static bool isDataTransferList(const A &stmt) {
+ if (stmt.format)
+ return std::holds_alternative<Fortran::parser::Star>(stmt.format->u);
+ if (auto *mem = getIOControl<Fortran::parser::Format>(stmt))
+ return std::holds_alternative<Fortran::parser::Star>(mem->u);
+ return false;
+}
+template <>
+bool isDataTransferList<Fortran::parser::PrintStmt>(
+ const Fortran::parser::PrintStmt &stmt) {
+ return std::holds_alternative<Fortran::parser::Star>(
+ std::get<Fortran::parser::Format>(stmt.t).u);
+}
+
+template <typename A>
+static bool isDataTransferInternal(const A &stmt) {
+ if (stmt.iounit.has_value())
+ return std::holds_alternative<Fortran::parser::Variable>(stmt.iounit->u);
+ if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt))
+ return std::holds_alternative<Fortran::parser::Variable>(unit->u);
+ return false;
+}
+template <>
+constexpr bool isDataTransferInternal<Fortran::parser::PrintStmt>(
+ const Fortran::parser::PrintStmt &) {
+ return false;
+}
+
+/// If the variable `var` is an array or of a KIND other than the default
+/// (normally 1), then a descriptor is required by the runtime IO API. This
+/// condition holds even in F77 sources.
+static llvm::Optional<fir::ExtendedValue> getVariableBufferRequiredDescriptor(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::parser::Variable &var,
+ Fortran::lower::StatementContext &stmtCtx) {
+ fir::ExtendedValue varBox =
+ converter.genExprAddr(var.typedExpr->v.value(), stmtCtx);
+ fir::KindTy defCharKind = converter.getKindMap().defaultCharacterKind();
+ mlir::Value varAddr = fir::getBase(varBox);
+ if (fir::factory::CharacterExprHelper::getCharacterOrSequenceKind(
+ varAddr.getType()) != defCharKind)
+ return varBox;
+ if (fir::factory::CharacterExprHelper::isArray(varAddr.getType()))
+ return varBox;
+ return llvm::None;
+}
+
+template <typename A>
+static llvm::Optional<fir::ExtendedValue>
+maybeGetInternalIODescriptor(Fortran::lower::AbstractConverter &converter,
+ const A &stmt,
+ Fortran::lower::StatementContext &stmtCtx) {
+ if (stmt.iounit.has_value())
+ if (auto *var = std::get_if<Fortran::parser::Variable>(&stmt.iounit->u))
+ return getVariableBufferRequiredDescriptor(converter, *var, stmtCtx);
+ if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt))
+ if (auto *var = std::get_if<Fortran::parser::Variable>(&unit->u))
+ return getVariableBufferRequiredDescriptor(converter, *var, stmtCtx);
+ return llvm::None;
+}
+template <>
+inline llvm::Optional<fir::ExtendedValue>
+maybeGetInternalIODescriptor<Fortran::parser::PrintStmt>(
+ Fortran::lower::AbstractConverter &, const Fortran::parser::PrintStmt &,
+ Fortran::lower::StatementContext &) {
+ return llvm::None;
+}
+
+template <typename A>
+static bool isDataTransferAsynchronous(mlir::Location loc, const A &stmt) {
+ if (auto *asynch =
+ getIOControl<Fortran::parser::IoControlSpec::Asynchronous>(stmt)) {
+ // FIXME: should contain a string of YES or NO
+ TODO(loc, "asynchronous transfers not implemented in runtime");
+ }
+ return false;
+}
+template <>
+bool isDataTransferAsynchronous<Fortran::parser::PrintStmt>(
+ mlir::Location, const Fortran::parser::PrintStmt &) {
+ return false;
+}
+
+template <typename A>
+static bool isDataTransferNamelist(const A &stmt) {
+ if (stmt.format)
+ return formatIsActuallyNamelist(*stmt.format);
+ return hasIOControl<Fortran::parser::Name>(stmt);
+}
+template <>
+constexpr bool isDataTransferNamelist<Fortran::parser::PrintStmt>(
+ const Fortran::parser::PrintStmt &) {
+ return false;
+}
+
+/// Lowers a format statment that uses an assigned variable label reference as
+/// a select operation to allow for run-time selection of the format statement.
+static std::tuple<mlir::Value, mlir::Value, mlir::Value>
+lowerReferenceAsStringSelect(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::lower::SomeExpr &expr,
+ mlir::Type strTy, mlir::Type lenTy,
+ Fortran::lower::StatementContext &stmtCtx) {
+ // Possible optimization TODO: Instead of inlining a selectOp every time there
+ // is a variable reference to a format statement, a function with the selectOp
+ // could be generated to reduce code size. It is not clear if such an
+ // optimization would be deployed very often or improve the object code
+ // beyond, say, what GVN/GCM might produce.
+
+ // Create the requisite blocks to inline a selectOp.
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Block *startBlock = builder.getBlock();
+ mlir::Block *endBlock = startBlock->splitBlock(builder.getInsertionPoint());
+ mlir::Block *block = startBlock->splitBlock(builder.getInsertionPoint());
+ builder.setInsertionPointToEnd(block);
+
+ llvm::SmallVector<int64_t> indexList;
+ llvm::SmallVector<mlir::Block *> blockList;
+
+ auto symbol = GetLastSymbol(&expr);
+ Fortran::lower::pft::LabelSet labels;
+ [[maybe_unused]] auto foundLabelSet =
+ converter.lookupLabelSet(*symbol, labels);
+ assert(foundLabelSet && "Label not found in map");
+
+ for (auto label : labels) {
+ indexList.push_back(label);
+ auto *eval = converter.lookupLabel(label);
+ assert(eval && "Label is missing from the table");
+
+ llvm::StringRef text = toStringRef(eval->position);
+ mlir::Value stringRef;
+ mlir::Value stringLen;
+ if (eval->isA<Fortran::parser::FormatStmt>()) {
+ assert(text.find('(') != llvm::StringRef::npos &&
+ "FORMAT is unexpectedly ill-formed");
+ // This is a format statement, so extract the spec from the text.
+ std::tuple<mlir::Value, mlir::Value, mlir::Value> stringLit =
+ lowerSourceTextAsStringLit(converter, loc, text, strTy, lenTy);
+ stringRef = std::get<0>(stringLit);
+ stringLen = std::get<1>(stringLit);
+ } else {
+ // This is not a format statement, so use null.
+ stringRef = builder.createConvert(
+ loc, strTy,
+ builder.createIntegerConstant(loc, builder.getIndexType(), 0));
+ stringLen = builder.createIntegerConstant(loc, lenTy, 0);
+ }
+
+ // Pass the format string reference and the string length out of the select
+ // statement.
+ llvm::SmallVector<mlir::Value> args = {stringRef, stringLen};
+ builder.create<mlir::cf::BranchOp>(loc, endBlock, args);
+
+ // Add block to the list of cases and make a new one.
+ blockList.push_back(block);
+ block = block->splitBlock(builder.getInsertionPoint());
+ builder.setInsertionPointToEnd(block);
+ }
+
+ // Create the unit case which should result in an error.
+ auto *unitBlock = block->splitBlock(builder.getInsertionPoint());
+ builder.setInsertionPointToEnd(unitBlock);
+
+ // Crash the program.
+ builder.create<fir::UnreachableOp>(loc);
+
+ // Add unit case to the select statement.
+ blockList.push_back(unitBlock);
+
+ // Lower the selectOp.
+ builder.setInsertionPointToEnd(startBlock);
+ auto label = fir::getBase(converter.genExprValue(&expr, stmtCtx, loc));
+ builder.create<fir::SelectOp>(loc, label, indexList, blockList);
+
+ builder.setInsertionPointToEnd(endBlock);
+ endBlock->addArgument(strTy, loc);
+ endBlock->addArgument(lenTy, loc);
+
+ // Handle and return the string reference and length selected by the selectOp.
+ auto buff = endBlock->getArgument(0);
+ auto len = endBlock->getArgument(1);
+
+ return {buff, len, mlir::Value{}};
+}
+
+/// Generate a reference to a format string. There are four cases - a format
+/// statement label, a character format expression, an integer that holds the
+/// label of a format statement, and the * case. The first three are done here.
+/// The * case is done elsewhere.
+static std::tuple<mlir::Value, mlir::Value, mlir::Value>
+genFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::parser::Format &format, mlir::Type strTy,
+ mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) {
+ if (const auto *label = std::get_if<Fortran::parser::Label>(&format.u)) {
+ // format statement label
+ auto eval = converter.lookupLabel(*label);
+ assert(eval && "FORMAT not found in PROCEDURE");
+ return lowerSourceTextAsStringLit(
+ converter, loc, toStringRef(eval->position), strTy, lenTy);
+ }
+ const auto *pExpr = std::get_if<Fortran::parser::Expr>(&format.u);
+ assert(pExpr && "missing format expression");
+ auto e = Fortran::semantics::GetExpr(*pExpr);
+ if (Fortran::semantics::ExprHasTypeCategory(
+ *e, Fortran::common::TypeCategory::Character))
+ // character expression
+ return lowerStringLit(converter, loc, stmtCtx, *pExpr, strTy, lenTy);
+
+ if (Fortran::semantics::ExprHasTypeCategory(
+ *e, Fortran::common::TypeCategory::Integer) &&
+ e->Rank() == 0 && Fortran::evaluate::UnwrapWholeSymbolDataRef(*e)) {
+ // Treat as a scalar integer variable containing an ASSIGN label.
+ return lowerReferenceAsStringSelect(converter, loc, *e, strTy, lenTy,
+ stmtCtx);
+ }
+
+ // Legacy extension: it is possible that `*e` is not a scalar INTEGER
+ // variable containing a label value. The output appears to be the source text
+ // that initialized the variable? Needs more investigatation.
+ TODO(loc, "io-control-spec contains a reference to a non-integer, "
+ "non-scalar, or non-variable");
+}
+
+template <typename A>
+std::tuple<mlir::Value, mlir::Value, mlir::Value>
+getFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const A &stmt, mlir::Type strTy, mlir::Type lenTy,
+ Fortran ::lower::StatementContext &stmtCtx) {
+ if (stmt.format && !formatIsActuallyNamelist(*stmt.format))
+ return genFormat(converter, loc, *stmt.format, strTy, lenTy, stmtCtx);
+ return genFormat(converter, loc, *getIOControl<Fortran::parser::Format>(stmt),
+ strTy, lenTy, stmtCtx);
+}
+template <>
+std::tuple<mlir::Value, mlir::Value, mlir::Value>
+getFormat<Fortran::parser::PrintStmt>(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::parser::PrintStmt &stmt, mlir::Type strTy, mlir::Type lenTy,
+ Fortran::lower::StatementContext &stmtCtx) {
+ return genFormat(converter, loc, std::get<Fortran::parser::Format>(stmt.t),
+ strTy, lenTy, stmtCtx);
+}
+
+/// Get a buffer for an internal file data transfer.
+template <typename A>
+std::tuple<mlir::Value, mlir::Value>
+getBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const A &stmt, mlir::Type strTy, mlir::Type lenTy,
+ Fortran::lower::StatementContext &stmtCtx) {
+ const Fortran::parser::IoUnit *iounit =
+ stmt.iounit ? &*stmt.iounit : getIOControl<Fortran::parser::IoUnit>(stmt);
+ if (iounit)
+ if (auto *var = std::get_if<Fortran::parser::Variable>(&iounit->u))
+ if (auto *expr = Fortran::semantics::GetExpr(*var))
+ return genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx);
+ llvm::report_fatal_error("failed to get IoUnit expr in lowering");
+}
+
+static mlir::Value genIOUnit(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::parser::IoUnit &iounit,
+ mlir::Type ty,
+ Fortran::lower::StatementContext &stmtCtx) {
+ auto &builder = converter.getFirOpBuilder();
+ if (auto *e = std::get_if<Fortran::parser::FileUnitNumber>(&iounit.u)) {
+ auto ex = fir::getBase(
+ converter.genExprValue(Fortran::semantics::GetExpr(*e), stmtCtx, loc));
+ return builder.createConvert(loc, ty, ex);
+ }
+ return builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit));
+}
+
+template <typename A>
+mlir::Value getIOUnit(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc, const A &stmt, mlir::Type ty,
+ Fortran::lower::StatementContext &stmtCtx) {
+ if (stmt.iounit)
+ return genIOUnit(converter, loc, *stmt.iounit, ty, stmtCtx);
+ if (auto *iounit = getIOControl<Fortran::parser::IoUnit>(stmt))
+ return genIOUnit(converter, loc, *iounit, ty, stmtCtx);
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ return builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit));
+}
+
+//===----------------------------------------------------------------------===//
+// Data transfer statements.
+//
+// There are several dimensions to the API with regard to data transfer
+// statements that need to be considered.
+//
+// - input (READ) vs. output (WRITE, PRINT)
+// - unformatted vs. formatted vs. list vs. namelist
+// - synchronous vs. asynchronous
+// - external vs. internal
+//===----------------------------------------------------------------------===//
+
+// Get the begin data transfer IO function to call for the given values.
+template <bool isInput>
+mlir::FuncOp
+getBeginDataTransferFunc(mlir::Location loc, fir::FirOpBuilder &builder,
+ bool isFormatted, bool isListOrNml, bool isInternal,
+ bool isInternalWithDesc, bool isAsync) {
+ if constexpr (isInput) {
+ if (isAsync)
+ return getIORuntimeFunc<mkIOKey(BeginAsynchronousInput)>(loc, builder);
+ if (isFormatted || isListOrNml) {
+ if (isInternal) {
+ if (isInternalWithDesc) {
+ if (isListOrNml)
+ return getIORuntimeFunc<mkIOKey(BeginInternalArrayListInput)>(
+ loc, builder);
+ return getIORuntimeFunc<mkIOKey(BeginInternalArrayFormattedInput)>(
+ loc, builder);
+ }
+ if (isListOrNml)
+ return getIORuntimeFunc<mkIOKey(BeginInternalListInput)>(loc,
+ builder);
+ return getIORuntimeFunc<mkIOKey(BeginInternalFormattedInput)>(loc,
+ builder);
+ }
+ if (isListOrNml)
+ return getIORuntimeFunc<mkIOKey(BeginExternalListInput)>(loc, builder);
+ return getIORuntimeFunc<mkIOKey(BeginExternalFormattedInput)>(loc,
+ builder);
+ }
+ return getIORuntimeFunc<mkIOKey(BeginUnformattedInput)>(loc, builder);
+ } else {
+ if (isAsync)
+ return getIORuntimeFunc<mkIOKey(BeginAsynchronousOutput)>(loc, builder);
+ if (isFormatted || isListOrNml) {
+ if (isInternal) {
+ if (isInternalWithDesc) {
+ if (isListOrNml)
+ return getIORuntimeFunc<mkIOKey(BeginInternalArrayListOutput)>(
+ loc, builder);
+ return getIORuntimeFunc<mkIOKey(BeginInternalArrayFormattedOutput)>(
+ loc, builder);
+ }
+ if (isListOrNml)
+ return getIORuntimeFunc<mkIOKey(BeginInternalListOutput)>(loc,
+ builder);
+ return getIORuntimeFunc<mkIOKey(BeginInternalFormattedOutput)>(loc,
+ builder);
+ }
+ if (isListOrNml)
+ return getIORuntimeFunc<mkIOKey(BeginExternalListOutput)>(loc, builder);
+ return getIORuntimeFunc<mkIOKey(BeginExternalFormattedOutput)>(loc,
+ builder);
+ }
+ return getIORuntimeFunc<mkIOKey(BeginUnformattedOutput)>(loc, builder);
+ }
+}
+
+/// Generate the arguments of a begin data transfer statement call.
+template <bool hasIOCtrl, typename A>
+void genBeginDataTransferCallArgs(
+ llvm::SmallVectorImpl<mlir::Value> &ioArgs,
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const A &stmt, mlir::FunctionType ioFuncTy, bool isFormatted,
+ bool isListOrNml, [[maybe_unused]] bool isInternal,
+ [[maybe_unused]] bool isAsync,
+ const llvm::Optional<fir::ExtendedValue> &descRef,
+ Fortran::lower::StatementContext &stmtCtx) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ auto maybeGetFormatArgs = [&]() {
+ if (!isFormatted || isListOrNml)
+ return;
+ auto pair =
+ getFormat(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()),
+ ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx);
+ ioArgs.push_back(std::get<0>(pair)); // format character string
+ ioArgs.push_back(std::get<1>(pair)); // format length
+ };
+ if constexpr (hasIOCtrl) { // READ or WRITE
+ if (isInternal) {
+ // descriptor or scalar variable; maybe explicit format; scratch area
+ if (descRef.hasValue()) {
+ mlir::Value desc = builder.createBox(loc, *descRef);
+ ioArgs.push_back(
+ builder.createConvert(loc, ioFuncTy.getInput(ioArgs.size()), desc));
+ } else {
+ std::tuple<mlir::Value, mlir::Value> pair =
+ getBuffer(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()),
+ ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx);
+ ioArgs.push_back(std::get<0>(pair)); // scalar character variable
+ ioArgs.push_back(std::get<1>(pair)); // character length
+ }
+ maybeGetFormatArgs();
+ ioArgs.push_back( // internal scratch area buffer
+ getDefaultScratch(builder, loc, ioFuncTy.getInput(ioArgs.size())));
+ ioArgs.push_back( // buffer length
+ getDefaultScratchLen(builder, loc, ioFuncTy.getInput(ioArgs.size())));
+ } else if (isAsync) { // unit; REC; buffer and length
+ ioArgs.push_back(getIOUnit(converter, loc, stmt,
+ ioFuncTy.getInput(ioArgs.size()), stmtCtx));
+ TODO(loc, "asynchronous");
+ } else { // external IO - maybe explicit format; unit
+ maybeGetFormatArgs();
+ ioArgs.push_back(getIOUnit(converter, loc, stmt,
+ ioFuncTy.getInput(ioArgs.size()), stmtCtx));
+ }
+ } else { // PRINT - maybe explicit format; default unit
+ maybeGetFormatArgs();
+ ioArgs.push_back(builder.create<mlir::arith::ConstantOp>(
+ loc, builder.getIntegerAttr(ioFuncTy.getInput(ioArgs.size()),
+ Fortran::runtime::io::DefaultUnit)));
+ }
+ // File name and line number are always the last two arguments.
+ ioArgs.push_back(
+ locToFilename(converter, loc, ioFuncTy.getInput(ioArgs.size())));
+ ioArgs.push_back(
+ locToLineNo(converter, loc, ioFuncTy.getInput(ioArgs.size())));
+}
+
+template <bool isInput, bool hasIOCtrl = true, typename A>
+static mlir::Value
+genDataTransferStmt(Fortran::lower::AbstractConverter &converter,
+ const A &stmt) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ Fortran::lower::StatementContext stmtCtx;
+ mlir::Location loc = converter.getCurrentLocation();
+ const bool isFormatted = isDataTransferFormatted(stmt);
+ const bool isList = isFormatted ? isDataTransferList(stmt) : false;
+ const bool isInternal = isDataTransferInternal(stmt);
+ llvm::Optional<fir::ExtendedValue> descRef =
+ isInternal ? maybeGetInternalIODescriptor(converter, stmt, stmtCtx)
+ : llvm::None;
+ const bool isInternalWithDesc = descRef.hasValue();
+ const bool isAsync = isDataTransferAsynchronous(loc, stmt);
+ const bool isNml = isDataTransferNamelist(stmt);
+
+ // Generate the begin data transfer function call.
+ mlir::FuncOp ioFunc = getBeginDataTransferFunc<isInput>(
+ loc, builder, isFormatted, isList || isNml, isInternal,
+ isInternalWithDesc, isAsync);
+ llvm::SmallVector<mlir::Value> ioArgs;
+ genBeginDataTransferCallArgs<hasIOCtrl>(
+ ioArgs, converter, loc, stmt, ioFunc.getType(), isFormatted,
+ isList || isNml, isInternal, isAsync, descRef, stmtCtx);
+ mlir::Value cookie =
+ builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
+
+ // Generate an EnableHandlers call and remaining specifier calls.
+ ConditionSpecInfo csi;
+ auto insertPt = builder.saveInsertionPoint();
+ mlir::Value ok;
+ if constexpr (hasIOCtrl) {
+ genConditionHandlerCall(converter, loc, cookie, stmt.controls, csi);
+ threadSpecs(converter, loc, cookie, stmt.controls,
+ csi.hasErrorConditionSpec(), ok);
+ }
+
+ // Generate data transfer list calls.
+ if constexpr (isInput) { // READ
+ if (isNml)
+ genNamelistIO(converter, cookie,
+ getIORuntimeFunc<mkIOKey(InputNamelist)>(loc, builder),
+ *getIOControl<Fortran::parser::Name>(stmt)->symbol,
+ csi.hasTransferConditionSpec(), ok, stmtCtx);
+ else
+ genInputItemList(converter, cookie, stmt.items, isFormatted,
+ csi.hasTransferConditionSpec(), ok, /*inLoop=*/false,
+ stmtCtx);
+ } else if constexpr (std::is_same_v<A, Fortran::parser::WriteStmt>) {
+ if (isNml)
+ genNamelistIO(converter, cookie,
+ getIORuntimeFunc<mkIOKey(OutputNamelist)>(loc, builder),
+ *getIOControl<Fortran::parser::Name>(stmt)->symbol,
+ csi.hasTransferConditionSpec(), ok, stmtCtx);
+ else
+ genOutputItemList(converter, cookie, stmt.items, isFormatted,
+ csi.hasTransferConditionSpec(), ok,
+ /*inLoop=*/false, stmtCtx);
+ } else { // PRINT
+ genOutputItemList(converter, cookie, std::get<1>(stmt.t), isFormatted,
+ csi.hasTransferConditionSpec(), ok,
+ /*inLoop=*/false, stmtCtx);
+ }
+ stmtCtx.finalize();
+
+ builder.restoreInsertionPoint(insertPt);
+ if constexpr (hasIOCtrl) {
+ genIOReadSize(converter, loc, cookie, stmt.controls,
+ csi.hasErrorConditionSpec());
+ }
+ // Generate end statement call/s.
+ return genEndIO(converter, loc, cookie, csi, stmtCtx);
+}
+
+void Fortran::lower::genPrintStatement(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::parser::PrintStmt &stmt) {
+ // PRINT does not take an io-control-spec. It only has a format specifier, so
+ // it is a simplified case of WRITE.
+ genDataTransferStmt</*isInput=*/false, /*ioCtrl=*/false>(converter, stmt);
+}
+
+mlir::Value
+Fortran::lower::genWriteStatement(Fortran::lower::AbstractConverter &converter,
+ const Fortran::parser::WriteStmt &stmt) {
+ return genDataTransferStmt</*isInput=*/false>(converter, stmt);
+}
+
+mlir::Value
+Fortran::lower::genReadStatement(Fortran::lower::AbstractConverter &converter,
+ const Fortran::parser::ReadStmt &stmt) {
+ return genDataTransferStmt</*isInput=*/true>(converter, stmt);
+}
diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp
index 9a9a31e5d53fe..f2b45e6a82f2f 100644
--- a/flang/lib/Optimizer/Dialect/FIROps.cpp
+++ b/flang/lib/Optimizer/Dialect/FIROps.cpp
@@ -1416,6 +1416,13 @@ void fir::FieldIndexOp::build(mlir::OpBuilder &builder,
result.addOperands(operands);
}
+llvm::SmallVector<mlir::Attribute> fir::FieldIndexOp::getAttributes() {
+ llvm::SmallVector<mlir::Attribute> attrs;
+ attrs.push_back(getFieldIdAttr());
+ attrs.push_back(getOnTypeAttr());
+ return attrs;
+}
+
//===----------------------------------------------------------------------===//
// InsertOnRangeOp
//===----------------------------------------------------------------------===//
diff --git a/flang/test/Lower/io-statement-1.f90 b/flang/test/Lower/io-statement-1.f90
new file mode 100644
index 0000000000000..1f9f51a6993e4
--- /dev/null
+++ b/flang/test/Lower/io-statement-1.f90
@@ -0,0 +1,55 @@
+! RUN: bbc %s -o - | FileCheck %s
+! UNSUPPORTED: system-windows
+
+ logical :: existsvar
+ integer :: length
+ real :: a(100)
+
+ ! CHECK-LABEL: _QQmain
+ ! CHECK: call {{.*}}BeginExternalListInput
+ ! CHECK: call {{.*}}InputInteger
+ ! CHECK: call {{.*}}InputReal32
+ ! CHECK: call {{.*}}EndIoStatement
+ read (8,*) i, f
+
+ ! CHECK: call {{.*}}BeginExternalListOutput
+ ! CHECK: call {{.*}}OutputInteger32
+ ! CHECK: call {{.*}}OutputReal32
+ ! CHECK: call {{.*}}EndIoStatement
+ write (8,*) i, f
+
+ ! CHECK: call {{.*}}BeginExternalListOutput
+ ! CHECK: call {{.*}}OutputAscii
+ ! CHECK: call {{.*}}EndIoStatement
+ print *, "A literal string"
+end
+
+! CHECK-LABEL: @_QPboz
+subroutine boz
+ ! CHECK: fir.call @_FortranAioOutputInteger8(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i8) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger16(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i16) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i32) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger128(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i128) -> i1
+ print '(*(Z3))', 96_1, 96_2, 96_4, 96_8, 96_16
+
+ ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i32) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ print '(I3,2Z44)', 40, 2**40_8, 2**40_8+1
+
+ ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i32) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ print '(I3,2I44)', 40, 1099511627776, 1099511627777
+
+ ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i32) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ print '(I3,2O44)', 40, 2**40_8, 2**40_8+1
+
+ ! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i32) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ ! CHECK: fir.call @_FortranAioOutputInteger64(%{{.*}}, %{{.*}}) : (!fir.ref<i8>, i64) -> i1
+ print '(I3,2B44)', 40, 2**40_8, 2**40_8+1
+end
diff --git a/flang/test/Lower/io-statement-2.f90 b/flang/test/Lower/io-statement-2.f90
new file mode 100644
index 0000000000000..b6e3603707089
--- /dev/null
+++ b/flang/test/Lower/io-statement-2.f90
@@ -0,0 +1,35 @@
+! RUN: bbc -emit-fir -o - %s | FileCheck %s
+
+ character*10 :: exx
+ character*30 :: m
+ integer*2 :: s
+ exx = 'AA'
+ m = 'CCCCCC'
+ s = -13
+ ! CHECK: call {{.*}}BeginExternalFormattedInput
+ ! CHECK: call {{.*}}EnableHandlers
+ ! CHECK: call {{.*}}SetAdvance
+ ! CHECK: call {{.*}}InputReal
+ ! CHECK: call {{.*}}GetIoMsg
+ ! CHECK: call {{.*}}EndIoStatement
+ ! CHECK: fir.select %{{.*}} : index [-2, ^bb4, -1, ^bb3, 0, ^bb1, unit, ^bb2]
+ read(*, '(A)', ADVANCE='NO', ERR=10, END=20, EOR=30, IOSTAT=s, IOMSG=m) f
+ ! CHECK-LABEL: ^bb1:
+ exx = 'Zip'; goto 90
+10 exx = 'Err'; goto 90
+20 exx = 'End'; goto 90
+30 exx = 'Eor'; goto 90
+90 print*, exx, c, m, s
+end
+
+! CHECK-LABEL: func @_QPimpliedformat
+subroutine impliedformat
+ ! CHECK: BeginExternalListInput(%c-1
+ ! CHECK: InputReal32
+ ! CHECK: EndIoStatement(%3) : (!fir.ref<i8>) -> i32
+ read*, x
+ ! CHECK: BeginExternalListOutput(%c-1
+ ! CHECK: OutputReal32
+ ! CHECK: EndIoStatement
+ print*, x
+end
More information about the flang-commits
mailing list