xref: /llvm-project/flang/lib/Lower/IO.cpp (revision 3e13acfbf4c93067d5ee5dc1f6e0c6e0fef9297f)
1 //===-- IO.cpp -- IO statement lowering -----------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 //
9 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
10 //
11 //===----------------------------------------------------------------------===//
12 
13 #include "flang/Lower/IO.h"
14 #include "flang/Common/uint128.h"
15 #include "flang/Evaluate/tools.h"
16 #include "flang/Lower/Allocatable.h"
17 #include "flang/Lower/Bridge.h"
18 #include "flang/Lower/CallInterface.h"
19 #include "flang/Lower/ConvertExpr.h"
20 #include "flang/Lower/ConvertVariable.h"
21 #include "flang/Lower/Mangler.h"
22 #include "flang/Lower/PFTBuilder.h"
23 #include "flang/Lower/Runtime.h"
24 #include "flang/Lower/StatementContext.h"
25 #include "flang/Lower/Support/Utils.h"
26 #include "flang/Lower/VectorSubscripts.h"
27 #include "flang/Optimizer/Builder/Character.h"
28 #include "flang/Optimizer/Builder/Complex.h"
29 #include "flang/Optimizer/Builder/FIRBuilder.h"
30 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
31 #include "flang/Optimizer/Builder/Runtime/Stop.h"
32 #include "flang/Optimizer/Builder/Todo.h"
33 #include "flang/Optimizer/Dialect/FIRDialect.h"
34 #include "flang/Optimizer/Dialect/Support/FIRContext.h"
35 #include "flang/Optimizer/Support/InternalNames.h"
36 #include "flang/Parser/parse-tree.h"
37 #include "flang/Runtime/io-api-consts.h"
38 #include "flang/Semantics/runtime-type-info.h"
39 #include "flang/Semantics/tools.h"
40 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
41 #include "llvm/Support/Debug.h"
42 #include <optional>
43 
44 #define DEBUG_TYPE "flang-lower-io"
45 
46 // Define additional runtime type models specific to IO.
47 namespace fir::runtime {
48 template <>
49 constexpr TypeBuilderFunc getModel<Fortran::runtime::io::IoStatementState *>() {
50   return getModel<char *>();
51 }
52 template <>
53 constexpr TypeBuilderFunc getModel<Fortran::runtime::io::Iostat>() {
54   return [](mlir::MLIRContext *context) -> mlir::Type {
55     return mlir::IntegerType::get(context,
56                                   8 * sizeof(Fortran::runtime::io::Iostat));
57   };
58 }
59 template <>
60 constexpr TypeBuilderFunc
61 getModel<const Fortran::runtime::io::NamelistGroup &>() {
62   return [](mlir::MLIRContext *context) -> mlir::Type {
63     return fir::ReferenceType::get(mlir::TupleType::get(context));
64   };
65 }
66 template <>
67 constexpr TypeBuilderFunc
68 getModel<const Fortran::runtime::io::NonTbpDefinedIoTable *>() {
69   return [](mlir::MLIRContext *context) -> mlir::Type {
70     return fir::ReferenceType::get(mlir::TupleType::get(context));
71   };
72 }
73 } // namespace fir::runtime
74 
75 using namespace Fortran::runtime::io;
76 
77 #define mkIOKey(X) FirmkKey(IONAME(X))
78 
79 namespace Fortran::lower {
80 /// Static table of IO runtime calls
81 ///
82 /// This logical map contains the name and type builder function for each IO
83 /// runtime function listed in the tuple. This table is fully constructed at
84 /// compile-time. Use the `mkIOKey` macro to access the table.
85 static constexpr std::tuple<
86     mkIOKey(BeginBackspace), mkIOKey(BeginClose), mkIOKey(BeginEndfile),
87     mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginExternalFormattedOutput),
88     mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalListOutput),
89     mkIOKey(BeginFlush), mkIOKey(BeginInquireFile),
90     mkIOKey(BeginInquireIoLength), mkIOKey(BeginInquireUnit),
91     mkIOKey(BeginInternalArrayFormattedInput),
92     mkIOKey(BeginInternalArrayFormattedOutput),
93     mkIOKey(BeginInternalArrayListInput), mkIOKey(BeginInternalArrayListOutput),
94     mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginInternalFormattedOutput),
95     mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalListOutput),
96     mkIOKey(BeginOpenNewUnit), mkIOKey(BeginOpenUnit), mkIOKey(BeginRewind),
97     mkIOKey(BeginUnformattedInput), mkIOKey(BeginUnformattedOutput),
98     mkIOKey(BeginWait), mkIOKey(BeginWaitAll),
99     mkIOKey(CheckUnitNumberInRange64), mkIOKey(CheckUnitNumberInRange128),
100     mkIOKey(EnableHandlers), mkIOKey(EndIoStatement),
101     mkIOKey(GetAsynchronousId), mkIOKey(GetIoLength), mkIOKey(GetIoMsg),
102     mkIOKey(GetNewUnit), mkIOKey(GetSize), mkIOKey(InputAscii),
103     mkIOKey(InputComplex32), mkIOKey(InputComplex64), mkIOKey(InputDerivedType),
104     mkIOKey(InputDescriptor), mkIOKey(InputInteger), mkIOKey(InputLogical),
105     mkIOKey(InputNamelist), mkIOKey(InputReal32), mkIOKey(InputReal64),
106     mkIOKey(InquireCharacter), mkIOKey(InquireInteger64),
107     mkIOKey(InquireLogical), mkIOKey(InquirePendingId), mkIOKey(OutputAscii),
108     mkIOKey(OutputComplex32), mkIOKey(OutputComplex64),
109     mkIOKey(OutputDerivedType), mkIOKey(OutputDescriptor),
110     mkIOKey(OutputInteger8), mkIOKey(OutputInteger16), mkIOKey(OutputInteger32),
111     mkIOKey(OutputInteger64), mkIOKey(OutputInteger128), mkIOKey(OutputLogical),
112     mkIOKey(OutputNamelist), mkIOKey(OutputReal32), mkIOKey(OutputReal64),
113     mkIOKey(SetAccess), mkIOKey(SetAction), mkIOKey(SetAdvance),
114     mkIOKey(SetAsynchronous), mkIOKey(SetBlank), mkIOKey(SetCarriagecontrol),
115     mkIOKey(SetConvert), mkIOKey(SetDecimal), mkIOKey(SetDelim),
116     mkIOKey(SetEncoding), mkIOKey(SetFile), mkIOKey(SetForm), mkIOKey(SetPad),
117     mkIOKey(SetPos), mkIOKey(SetPosition), mkIOKey(SetRec), mkIOKey(SetRecl),
118     mkIOKey(SetRound), mkIOKey(SetSign), mkIOKey(SetStatus)>
119     newIOTable;
120 } // namespace Fortran::lower
121 
122 namespace {
123 /// IO statements may require exceptional condition handling. A statement that
124 /// encounters an exceptional condition may branch to a label given on an ERR
125 /// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT
126 /// specifier variable may be set to a value that indicates some condition,
127 /// and an IOMSG specifier variable may be set to a description of a condition.
128 struct ConditionSpecInfo {
129   const Fortran::lower::SomeExpr *ioStatExpr{};
130   std::optional<fir::ExtendedValue> ioMsg;
131   bool hasErr{};
132   bool hasEnd{};
133   bool hasEor{};
134   fir::IfOp bigUnitIfOp;
135 
136   /// Check for any condition specifier that applies to specifier processing.
137   bool hasErrorConditionSpec() const { return ioStatExpr != nullptr || hasErr; }
138 
139   /// Check for any condition specifier that applies to data transfer items
140   /// in a PRINT, READ, WRITE, or WAIT statement. (WAIT may be irrelevant.)
141   bool hasTransferConditionSpec() const {
142     return hasErrorConditionSpec() || hasEnd || hasEor;
143   }
144 
145   /// Check for any condition specifier, including IOMSG.
146   bool hasAnyConditionSpec() const {
147     return hasTransferConditionSpec() || ioMsg;
148   }
149 };
150 } // namespace
151 
152 template <typename D>
153 static void genIoLoop(Fortran::lower::AbstractConverter &converter,
154                       mlir::Value cookie, const D &ioImpliedDo,
155                       bool isFormatted, bool checkResult, mlir::Value &ok,
156                       bool inLoop);
157 
158 /// Helper function to retrieve the name of the IO function given the key `A`
159 template <typename A>
160 static constexpr const char *getName() {
161   return std::get<A>(Fortran::lower::newIOTable).name;
162 }
163 
164 /// Helper function to retrieve the type model signature builder of the IO
165 /// function as defined by the key `A`
166 template <typename A>
167 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() {
168   return std::get<A>(Fortran::lower::newIOTable).getTypeModel();
169 }
170 
171 inline int64_t getLength(mlir::Type argTy) {
172   return mlir::cast<fir::SequenceType>(argTy).getShape()[0];
173 }
174 
175 /// Get (or generate) the MLIR FuncOp for a given IO runtime function.
176 template <typename E>
177 static mlir::func::FuncOp getIORuntimeFunc(mlir::Location loc,
178                                            fir::FirOpBuilder &builder) {
179   llvm::StringRef name = getName<E>();
180   mlir::func::FuncOp func = builder.getNamedFunction(name);
181   if (func)
182     return func;
183   auto funTy = getTypeModel<E>()(builder.getContext());
184   func = builder.createFunction(loc, name, funTy);
185   func->setAttr(fir::FIROpsDialect::getFirRuntimeAttrName(),
186                 builder.getUnitAttr());
187   func->setAttr("fir.io", builder.getUnitAttr());
188   return func;
189 }
190 
191 /// Generate calls to end an IO statement. Return the IOSTAT value, if any.
192 /// It is the caller's responsibility to generate branches on that value.
193 static mlir::Value genEndIO(Fortran::lower::AbstractConverter &converter,
194                             mlir::Location loc, mlir::Value cookie,
195                             ConditionSpecInfo &csi,
196                             Fortran::lower::StatementContext &stmtCtx) {
197   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
198   if (csi.ioMsg) {
199     mlir::func::FuncOp getIoMsg =
200         getIORuntimeFunc<mkIOKey(GetIoMsg)>(loc, builder);
201     builder.create<fir::CallOp>(
202         loc, getIoMsg,
203         mlir::ValueRange{
204             cookie,
205             builder.createConvert(loc, getIoMsg.getFunctionType().getInput(1),
206                                   fir::getBase(*csi.ioMsg)),
207             builder.createConvert(loc, getIoMsg.getFunctionType().getInput(2),
208                                   fir::getLen(*csi.ioMsg))});
209   }
210   mlir::func::FuncOp endIoStatement =
211       getIORuntimeFunc<mkIOKey(EndIoStatement)>(loc, builder);
212   auto call = builder.create<fir::CallOp>(loc, endIoStatement,
213                                           mlir::ValueRange{cookie});
214   mlir::Value iostat = call.getResult(0);
215   if (csi.bigUnitIfOp) {
216     stmtCtx.finalizeAndPop();
217     builder.create<fir::ResultOp>(loc, iostat);
218     builder.setInsertionPointAfter(csi.bigUnitIfOp);
219     iostat = csi.bigUnitIfOp.getResult(0);
220   }
221   if (csi.ioStatExpr) {
222     mlir::Value ioStatVar =
223         fir::getBase(converter.genExprAddr(loc, csi.ioStatExpr, stmtCtx));
224     mlir::Value ioStatResult =
225         builder.createConvert(loc, converter.genType(*csi.ioStatExpr), iostat);
226     builder.create<fir::StoreOp>(loc, ioStatResult, ioStatVar);
227   }
228   return csi.hasTransferConditionSpec() ? iostat : mlir::Value{};
229 }
230 
231 /// Make the next call in the IO statement conditional on runtime result `ok`.
232 /// If a call returns `ok==false`, further suboperation calls for an IO
233 /// statement will be skipped. This may generate branch heavy, deeply nested
234 /// conditionals for IO statements with a large number of suboperations.
235 static void makeNextConditionalOn(fir::FirOpBuilder &builder,
236                                   mlir::Location loc, bool checkResult,
237                                   mlir::Value ok, bool inLoop = false) {
238   if (!checkResult || !ok)
239     // Either no IO calls need to be checked, or this will be the first call.
240     return;
241 
242   // A previous IO call for a statement returned the bool `ok`. If this call
243   // is in a fir.iterate_while loop, the result must be propagated up to the
244   // loop scope as an extra ifOp result. (The propagation is done in genIoLoop.)
245   mlir::TypeRange resTy;
246   // TypeRange does not own its contents, so make sure the the type object
247   // is live until the end of the function.
248   mlir::IntegerType boolTy = builder.getI1Type();
249   if (inLoop)
250     resTy = boolTy;
251   auto ifOp = builder.create<fir::IfOp>(loc, resTy, ok,
252                                         /*withElseRegion=*/inLoop);
253   builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
254 }
255 
256 // Derived type symbols may each be mapped to up to 4 defined IO procedures.
257 using DefinedIoProcMap = std::multimap<const Fortran::semantics::Symbol *,
258                                        Fortran::semantics::NonTbpDefinedIo>;
259 
260 /// Get the current scope's non-type-bound defined IO procedures.
261 static DefinedIoProcMap
262 getDefinedIoProcMap(Fortran::lower::AbstractConverter &converter) {
263   const Fortran::semantics::Scope *scope = &converter.getCurrentScope();
264   for (; !scope->IsGlobal(); scope = &scope->parent())
265     if (scope->kind() == Fortran::semantics::Scope::Kind::MainProgram ||
266         scope->kind() == Fortran::semantics::Scope::Kind::Subprogram ||
267         scope->kind() == Fortran::semantics::Scope::Kind::BlockConstruct)
268       break;
269   return Fortran::semantics::CollectNonTbpDefinedIoGenericInterfaces(*scope,
270                                                                      false);
271 }
272 
273 /// Check a set of defined IO procedures for any procedure pointer or dummy
274 /// procedures.
275 static bool hasLocalDefinedIoProc(DefinedIoProcMap &definedIoProcMap) {
276   for (auto &iface : definedIoProcMap) {
277     const Fortran::semantics::Symbol *procSym = iface.second.subroutine;
278     if (!procSym)
279       continue;
280     procSym = &procSym->GetUltimate();
281     if (Fortran::semantics::IsProcedurePointer(*procSym) ||
282         Fortran::semantics::IsDummy(*procSym))
283       return true;
284   }
285   return false;
286 }
287 
288 /// Retrieve or generate a runtime description of the non-type-bound defined
289 /// IO procedures in the current scope. If any procedure is a dummy or a
290 /// procedure pointer, the result is local. Otherwise the result is static.
291 /// If there are no procedures, return a scope-independent default table with
292 /// an empty procedure list, but with the `ignoreNonTbpEntries` flag set. The
293 /// form of the description is defined in runtime header file non-tbp-dio.h.
294 static mlir::Value
295 getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter,
296                             DefinedIoProcMap &definedIoProcMap) {
297   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
298   mlir::MLIRContext *context = builder.getContext();
299   mlir::Location loc = converter.getCurrentLocation();
300   mlir::Type refTy = fir::ReferenceType::get(mlir::NoneType::get(context));
301   std::string suffix = ".nonTbpDefinedIoTable";
302   std::string tableMangleName =
303       definedIoProcMap.empty()
304           ? fir::NameUniquer::doGenerated("default" + suffix)
305           : converter.mangleName(suffix);
306   if (auto table = builder.getNamedGlobal(tableMangleName))
307     return builder.createConvert(
308         loc, refTy,
309         builder.create<fir::AddrOfOp>(loc, table.resultType(),
310                                       table.getSymbol()));
311 
312   mlir::StringAttr linkOnce = builder.createLinkOnceLinkage();
313   mlir::Type idxTy = builder.getIndexType();
314   mlir::Type sizeTy =
315       fir::runtime::getModel<std::size_t>()(builder.getContext());
316   mlir::Type intTy = fir::runtime::getModel<int>()(builder.getContext());
317   mlir::Type boolTy = fir::runtime::getModel<bool>()(builder.getContext());
318   mlir::Type listTy = fir::SequenceType::get(
319       definedIoProcMap.size(),
320       mlir::TupleType::get(context, {refTy, refTy, intTy, boolTy}));
321   mlir::Type tableTy = mlir::TupleType::get(
322       context, {sizeTy, fir::ReferenceType::get(listTy), boolTy});
323 
324   // Define the list of NonTbpDefinedIo procedures.
325   bool tableIsLocal =
326       !definedIoProcMap.empty() && hasLocalDefinedIoProc(definedIoProcMap);
327   mlir::Value listAddr =
328       tableIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{};
329   std::string listMangleName = tableMangleName + ".list";
330   auto listFunc = [&](fir::FirOpBuilder &builder) {
331     mlir::Value list = builder.create<fir::UndefOp>(loc, listTy);
332     mlir::IntegerAttr intAttr[4];
333     for (int i = 0; i < 4; ++i)
334       intAttr[i] = builder.getIntegerAttr(idxTy, i);
335     llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{},
336                                                  mlir::Attribute{}};
337     int n0 = 0, n1;
338     auto insert = [&](mlir::Value val) {
339       idx[1] = intAttr[n1++];
340       list = builder.create<fir::InsertValueOp>(loc, listTy, list, val,
341                                                 builder.getArrayAttr(idx));
342     };
343     for (auto &iface : definedIoProcMap) {
344       idx[0] = builder.getIntegerAttr(idxTy, n0++);
345       n1 = 0;
346       // derived type description [const typeInfo::DerivedType &derivedType]
347       const Fortran::semantics::Symbol &dtSym = iface.first->GetUltimate();
348       std::string dtName = converter.mangleName(dtSym);
349       insert(builder.createConvert(
350           loc, refTy,
351           builder.create<fir::AddrOfOp>(
352               loc, fir::ReferenceType::get(converter.genType(dtSym)),
353               builder.getSymbolRefAttr(dtName))));
354       // defined IO procedure [void (*subroutine)()], may be null
355       const Fortran::semantics::Symbol *procSym = iface.second.subroutine;
356       if (procSym) {
357         procSym = &procSym->GetUltimate();
358         if (Fortran::semantics::IsProcedurePointer(*procSym)) {
359           TODO(loc, "defined IO procedure pointers");
360         } else if (Fortran::semantics::IsDummy(*procSym)) {
361           Fortran::lower::StatementContext stmtCtx;
362           insert(builder.create<fir::BoxAddrOp>(
363               loc, refTy,
364               fir::getBase(converter.genExprAddr(
365                   loc,
366                   Fortran::lower::SomeExpr{
367                       Fortran::evaluate::ProcedureDesignator{*procSym}},
368                   stmtCtx))));
369         } else {
370           mlir::func::FuncOp procDef = Fortran::lower::getOrDeclareFunction(
371               Fortran::evaluate::ProcedureDesignator{*procSym}, converter);
372           mlir::SymbolRefAttr nameAttr =
373               builder.getSymbolRefAttr(procDef.getSymName());
374           insert(builder.createConvert(
375               loc, refTy,
376               builder.create<fir::AddrOfOp>(loc, procDef.getFunctionType(),
377                                             nameAttr)));
378         }
379       } else {
380         insert(builder.createNullConstant(loc, refTy));
381       }
382       // defined IO variant, one of (read/write, formatted/unformatted)
383       // [common::DefinedIo definedIo]
384       insert(builder.createIntegerConstant(
385           loc, intTy, static_cast<int>(iface.second.definedIo)));
386       // polymorphic flag is set if first defined IO dummy arg is CLASS(T)
387       // [bool isDtvArgPolymorphic]
388       insert(builder.createIntegerConstant(loc, boolTy,
389                                            iface.second.isDtvArgPolymorphic));
390     }
391     if (tableIsLocal)
392       builder.create<fir::StoreOp>(loc, list, listAddr);
393     else
394       builder.create<fir::HasValueOp>(loc, list);
395   };
396   if (!definedIoProcMap.empty()) {
397     if (tableIsLocal)
398       listFunc(builder);
399     else
400       builder.createGlobalConstant(loc, listTy, listMangleName, listFunc,
401                                    linkOnce);
402   }
403 
404   // Define the NonTbpDefinedIoTable.
405   mlir::Value tableAddr = tableIsLocal
406                               ? builder.create<fir::AllocaOp>(loc, tableTy)
407                               : mlir::Value{};
408   auto tableFunc = [&](fir::FirOpBuilder &builder) {
409     mlir::Value table = builder.create<fir::UndefOp>(loc, tableTy);
410     // list item count [std::size_t items]
411     table = builder.create<fir::InsertValueOp>(
412         loc, tableTy, table,
413         builder.createIntegerConstant(loc, sizeTy, definedIoProcMap.size()),
414         builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0)));
415     // item list [const NonTbpDefinedIo *item]
416     if (definedIoProcMap.empty())
417       listAddr = builder.createNullConstant(loc, builder.getRefType(listTy));
418     else if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName))
419       listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(),
420                                                list.getSymbol());
421     assert(listAddr && "missing namelist object list");
422     table = builder.create<fir::InsertValueOp>(
423         loc, tableTy, table, listAddr,
424         builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1)));
425     // [bool ignoreNonTbpEntries] conservatively set to true
426     table = builder.create<fir::InsertValueOp>(
427         loc, tableTy, table, builder.createIntegerConstant(loc, boolTy, true),
428         builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2)));
429     if (tableIsLocal)
430       builder.create<fir::StoreOp>(loc, table, tableAddr);
431     else
432       builder.create<fir::HasValueOp>(loc, table);
433   };
434   if (tableIsLocal) {
435     tableFunc(builder);
436   } else {
437     fir::GlobalOp table = builder.createGlobal(
438         loc, tableTy, tableMangleName,
439         /*isConst=*/true, /*isTarget=*/false, tableFunc, linkOnce);
440     tableAddr = builder.create<fir::AddrOfOp>(
441         loc, fir::ReferenceType::get(tableTy), table.getSymbol());
442   }
443   assert(tableAddr && "missing NonTbpDefinedIo table result");
444   return builder.createConvert(loc, refTy, tableAddr);
445 }
446 
447 static mlir::Value
448 getNonTbpDefinedIoTableAddr(Fortran::lower::AbstractConverter &converter) {
449   DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter);
450   return getNonTbpDefinedIoTableAddr(converter, definedIoProcMap);
451 }
452 
453 /// Retrieve or generate a runtime description of NAMELIST group \p symbol.
454 /// The form of the description is defined in runtime header file namelist.h.
455 /// Static descriptors are generated for global objects; local descriptors for
456 /// local objects. If all descriptors and defined IO procedures are static,
457 /// the NamelistGroup is static.
458 static mlir::Value
459 getNamelistGroup(Fortran::lower::AbstractConverter &converter,
460                  const Fortran::semantics::Symbol &symbol,
461                  Fortran::lower::StatementContext &stmtCtx) {
462   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
463   mlir::Location loc = converter.getCurrentLocation();
464   std::string groupMangleName = converter.mangleName(symbol);
465   if (auto group = builder.getNamedGlobal(groupMangleName))
466     return builder.create<fir::AddrOfOp>(loc, group.resultType(),
467                                          group.getSymbol());
468 
469   const auto &details =
470       symbol.GetUltimate().get<Fortran::semantics::NamelistDetails>();
471   mlir::MLIRContext *context = builder.getContext();
472   mlir::StringAttr linkOnce = builder.createLinkOnceLinkage();
473   mlir::Type idxTy = builder.getIndexType();
474   mlir::Type sizeTy =
475       fir::runtime::getModel<std::size_t>()(builder.getContext());
476   mlir::Type charRefTy = fir::ReferenceType::get(builder.getIntegerType(8));
477   mlir::Type descRefTy =
478       fir::ReferenceType::get(fir::BoxType::get(mlir::NoneType::get(context)));
479   mlir::Type listTy = fir::SequenceType::get(
480       details.objects().size(),
481       mlir::TupleType::get(context, {charRefTy, descRefTy}));
482   mlir::Type groupTy = mlir::TupleType::get(
483       context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy),
484                 fir::ReferenceType::get(mlir::NoneType::get(context))});
485   auto stringAddress = [&](const Fortran::semantics::Symbol &symbol) {
486     return fir::factory::createStringLiteral(builder, loc,
487                                              symbol.name().ToString() + '\0');
488   };
489 
490   // Define variable names, and static descriptors for global variables.
491   DefinedIoProcMap definedIoProcMap = getDefinedIoProcMap(converter);
492   bool groupIsLocal = hasLocalDefinedIoProc(definedIoProcMap);
493   stringAddress(symbol);
494   for (const Fortran::semantics::Symbol &s : details.objects()) {
495     stringAddress(s);
496     if (!Fortran::lower::symbolIsGlobal(s)) {
497       groupIsLocal = true;
498       continue;
499     }
500     // A global pointer or allocatable variable has a descriptor for typical
501     // accesses. Variables in multiple namelist groups may already have one.
502     // Create descriptors for other cases.
503     if (!IsAllocatableOrObjectPointer(&s)) {
504       std::string mangleName =
505           Fortran::lower::mangle::globalNamelistDescriptorName(s);
506       if (builder.getNamedGlobal(mangleName))
507         continue;
508       const auto expr = Fortran::evaluate::AsGenericExpr(s);
509       fir::BoxType boxTy =
510           fir::BoxType::get(fir::PointerType::get(converter.genType(s)));
511       auto descFunc = [&](fir::FirOpBuilder &b) {
512         auto box = Fortran::lower::genInitialDataTarget(
513             converter, loc, boxTy, *expr, /*couldBeInEquivalence=*/true);
514         b.create<fir::HasValueOp>(loc, box);
515       };
516       builder.createGlobalConstant(loc, boxTy, mangleName, descFunc, linkOnce);
517     }
518   }
519 
520   // Define the list of Items.
521   mlir::Value listAddr =
522       groupIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{};
523   std::string listMangleName = groupMangleName + ".list";
524   auto listFunc = [&](fir::FirOpBuilder &builder) {
525     mlir::Value list = builder.create<fir::UndefOp>(loc, listTy);
526     mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0);
527     mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1);
528     llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{},
529                                                  mlir::Attribute{}};
530     int n = 0;
531     for (const Fortran::semantics::Symbol &s : details.objects()) {
532       idx[0] = builder.getIntegerAttr(idxTy, n++);
533       idx[1] = zero;
534       mlir::Value nameAddr =
535           builder.createConvert(loc, charRefTy, fir::getBase(stringAddress(s)));
536       list = builder.create<fir::InsertValueOp>(loc, listTy, list, nameAddr,
537                                                 builder.getArrayAttr(idx));
538       idx[1] = one;
539       mlir::Value descAddr;
540       if (auto desc = builder.getNamedGlobal(
541               Fortran::lower::mangle::globalNamelistDescriptorName(s))) {
542         descAddr = builder.create<fir::AddrOfOp>(loc, desc.resultType(),
543                                                  desc.getSymbol());
544       } else if (Fortran::semantics::FindCommonBlockContaining(s) &&
545                  IsAllocatableOrPointer(s)) {
546         mlir::Type symType = converter.genType(s);
547         const Fortran::semantics::Symbol *commonBlockSym =
548             Fortran::semantics::FindCommonBlockContaining(s);
549         std::string commonBlockName = converter.mangleName(*commonBlockSym);
550         fir::GlobalOp commonGlobal = builder.getNamedGlobal(commonBlockName);
551         mlir::Value commonBlockAddr = builder.create<fir::AddrOfOp>(
552             loc, commonGlobal.resultType(), commonGlobal.getSymbol());
553         mlir::IntegerType i8Ty = builder.getIntegerType(8);
554         mlir::Type i8Ptr = builder.getRefType(i8Ty);
555         mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(i8Ty));
556         mlir::Value base = builder.createConvert(loc, seqTy, commonBlockAddr);
557         std::size_t byteOffset = s.GetUltimate().offset();
558         mlir::Value offs = builder.createIntegerConstant(
559             loc, builder.getIndexType(), byteOffset);
560         mlir::Value varAddr = builder.create<fir::CoordinateOp>(
561             loc, i8Ptr, base, mlir::ValueRange{offs});
562         descAddr =
563             builder.createConvert(loc, builder.getRefType(symType), varAddr);
564       } else {
565         const auto expr = Fortran::evaluate::AsGenericExpr(s);
566         fir::ExtendedValue exv = converter.genExprAddr(*expr, stmtCtx);
567         mlir::Type type = fir::getBase(exv).getType();
568         if (mlir::Type baseTy = fir::dyn_cast_ptrOrBoxEleTy(type))
569           type = baseTy;
570         fir::BoxType boxType = fir::BoxType::get(fir::PointerType::get(type));
571         descAddr = builder.createTemporary(loc, boxType);
572         fir::MutableBoxValue box = fir::MutableBoxValue(descAddr, {}, {});
573         fir::factory::associateMutableBox(builder, loc, box, exv,
574                                           /*lbounds=*/std::nullopt);
575       }
576       descAddr = builder.createConvert(loc, descRefTy, descAddr);
577       list = builder.create<fir::InsertValueOp>(loc, listTy, list, descAddr,
578                                                 builder.getArrayAttr(idx));
579     }
580     if (groupIsLocal)
581       builder.create<fir::StoreOp>(loc, list, listAddr);
582     else
583       builder.create<fir::HasValueOp>(loc, list);
584   };
585   if (groupIsLocal)
586     listFunc(builder);
587   else
588     builder.createGlobalConstant(loc, listTy, listMangleName, listFunc,
589                                  linkOnce);
590 
591   // Define the group.
592   mlir::Value groupAddr = groupIsLocal
593                               ? builder.create<fir::AllocaOp>(loc, groupTy)
594                               : mlir::Value{};
595   auto groupFunc = [&](fir::FirOpBuilder &builder) {
596     mlir::Value group = builder.create<fir::UndefOp>(loc, groupTy);
597     // group name [const char *groupName]
598     group = builder.create<fir::InsertValueOp>(
599         loc, groupTy, group,
600         builder.createConvert(loc, charRefTy,
601                               fir::getBase(stringAddress(symbol))),
602         builder.getArrayAttr(builder.getIntegerAttr(idxTy, 0)));
603     // list item count [std::size_t items]
604     group = builder.create<fir::InsertValueOp>(
605         loc, groupTy, group,
606         builder.createIntegerConstant(loc, sizeTy, details.objects().size()),
607         builder.getArrayAttr(builder.getIntegerAttr(idxTy, 1)));
608     // item list [const Item *item]
609     if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName))
610       listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(),
611                                                list.getSymbol());
612     assert(listAddr && "missing namelist object list");
613     group = builder.create<fir::InsertValueOp>(
614         loc, groupTy, group, listAddr,
615         builder.getArrayAttr(builder.getIntegerAttr(idxTy, 2)));
616     // non-type-bound defined IO procedures
617     // [const NonTbpDefinedIoTable *nonTbpDefinedIo]
618     group = builder.create<fir::InsertValueOp>(
619         loc, groupTy, group,
620         getNonTbpDefinedIoTableAddr(converter, definedIoProcMap),
621         builder.getArrayAttr(builder.getIntegerAttr(idxTy, 3)));
622     if (groupIsLocal)
623       builder.create<fir::StoreOp>(loc, group, groupAddr);
624     else
625       builder.create<fir::HasValueOp>(loc, group);
626   };
627   if (groupIsLocal) {
628     groupFunc(builder);
629   } else {
630     fir::GlobalOp group = builder.createGlobal(
631         loc, groupTy, groupMangleName,
632         /*isConst=*/true, /*isTarget=*/false, groupFunc, linkOnce);
633     groupAddr = builder.create<fir::AddrOfOp>(loc, group.resultType(),
634                                               group.getSymbol());
635   }
636   assert(groupAddr && "missing namelist group result");
637   return groupAddr;
638 }
639 
640 /// Generate a namelist IO call.
641 static void genNamelistIO(Fortran::lower::AbstractConverter &converter,
642                           mlir::Value cookie, mlir::func::FuncOp funcOp,
643                           Fortran::semantics::Symbol &symbol, bool checkResult,
644                           mlir::Value &ok,
645                           Fortran::lower::StatementContext &stmtCtx) {
646   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
647   mlir::Location loc = converter.getCurrentLocation();
648   makeNextConditionalOn(builder, loc, checkResult, ok);
649   mlir::Type argType = funcOp.getFunctionType().getInput(1);
650   mlir::Value groupAddr =
651       getNamelistGroup(converter, symbol.GetUltimate(), stmtCtx);
652   groupAddr = builder.createConvert(loc, argType, groupAddr);
653   llvm::SmallVector<mlir::Value> args = {cookie, groupAddr};
654   ok = builder.create<fir::CallOp>(loc, funcOp, args).getResult(0);
655 }
656 
657 /// Get the output function to call for a value of the given type.
658 static mlir::func::FuncOp getOutputFunc(mlir::Location loc,
659                                         fir::FirOpBuilder &builder,
660                                         mlir::Type type, bool isFormatted) {
661   if (mlir::isa<fir::RecordType>(fir::unwrapPassByRefType(type)))
662     return getIORuntimeFunc<mkIOKey(OutputDerivedType)>(loc, builder);
663   if (!isFormatted)
664     return getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc, builder);
665   if (auto ty = mlir::dyn_cast<mlir::IntegerType>(type)) {
666     if (!ty.isUnsigned()) {
667       switch (ty.getWidth()) {
668       case 1:
669         return getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder);
670       case 8:
671         return getIORuntimeFunc<mkIOKey(OutputInteger8)>(loc, builder);
672       case 16:
673         return getIORuntimeFunc<mkIOKey(OutputInteger16)>(loc, builder);
674       case 32:
675         return getIORuntimeFunc<mkIOKey(OutputInteger32)>(loc, builder);
676       case 64:
677         return getIORuntimeFunc<mkIOKey(OutputInteger64)>(loc, builder);
678       case 128:
679         return getIORuntimeFunc<mkIOKey(OutputInteger128)>(loc, builder);
680       }
681       llvm_unreachable("unknown OutputInteger kind");
682     }
683   }
684   if (auto ty = mlir::dyn_cast<mlir::FloatType>(type)) {
685     if (auto width = ty.getWidth(); width == 32)
686       return getIORuntimeFunc<mkIOKey(OutputReal32)>(loc, builder);
687     else if (width == 64)
688       return getIORuntimeFunc<mkIOKey(OutputReal64)>(loc, builder);
689   }
690   auto kindMap = fir::getKindMapping(builder.getModule());
691   if (auto ty = mlir::dyn_cast<mlir::ComplexType>(type)) {
692     // COMPLEX(KIND=k) corresponds to a pair of REAL(KIND=k).
693     auto width = mlir::cast<mlir::FloatType>(ty.getElementType()).getWidth();
694     if (width == 32)
695       return getIORuntimeFunc<mkIOKey(OutputComplex32)>(loc, builder);
696     else if (width == 64)
697       return getIORuntimeFunc<mkIOKey(OutputComplex64)>(loc, builder);
698   }
699   if (mlir::isa<fir::LogicalType>(type))
700     return getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder);
701   if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) {
702     // TODO: What would it mean if the default CHARACTER KIND is set to a wide
703     // character encoding scheme? How do we handle UTF-8? Is it a distinct KIND
704     // value? For now, assume that if the default CHARACTER KIND is 8 bit,
705     // then it is an ASCII string and UTF-8 is unsupported.
706     auto asciiKind = kindMap.defaultCharacterKind();
707     if (kindMap.getCharacterBitsize(asciiKind) == 8 &&
708         fir::factory::CharacterExprHelper::getCharacterKind(type) == asciiKind)
709       return getIORuntimeFunc<mkIOKey(OutputAscii)>(loc, builder);
710   }
711   return getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc, builder);
712 }
713 
714 /// Generate a sequence of output data transfer calls.
715 static void genOutputItemList(
716     Fortran::lower::AbstractConverter &converter, mlir::Value cookie,
717     const std::list<Fortran::parser::OutputItem> &items, bool isFormatted,
718     bool checkResult, mlir::Value &ok, bool inLoop) {
719   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
720   for (const Fortran::parser::OutputItem &item : items) {
721     if (const auto &impliedDo = std::get_if<1>(&item.u)) {
722       genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult,
723                 ok, inLoop);
724       continue;
725     }
726     auto &pExpr = std::get<Fortran::parser::Expr>(item.u);
727     mlir::Location loc = converter.genLocation(pExpr.source);
728     makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
729     Fortran::lower::StatementContext stmtCtx;
730 
731     const auto *expr = Fortran::semantics::GetExpr(pExpr);
732     if (!expr)
733       fir::emitFatalError(loc, "internal error: could not get evaluate::Expr");
734     mlir::Type itemTy = converter.genType(*expr);
735     mlir::func::FuncOp outputFunc =
736         getOutputFunc(loc, builder, itemTy, isFormatted);
737     mlir::Type argType = outputFunc.getFunctionType().getInput(1);
738     assert((isFormatted || mlir::isa<fir::BoxType>(argType)) &&
739            "expect descriptor for unformatted IO runtime");
740     llvm::SmallVector<mlir::Value> outputFuncArgs = {cookie};
741     fir::factory::CharacterExprHelper helper{builder, loc};
742     if (mlir::isa<fir::BoxType>(argType)) {
743       mlir::Value box = fir::getBase(converter.genExprBox(loc, *expr, stmtCtx));
744       outputFuncArgs.push_back(builder.createConvert(loc, argType, box));
745       if (mlir::isa<fir::RecordType>(fir::unwrapPassByRefType(itemTy)))
746         outputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter));
747     } else if (helper.isCharacterScalar(itemTy)) {
748       fir::ExtendedValue exv = converter.genExprAddr(loc, expr, stmtCtx);
749       // scalar allocatable/pointer may also get here, not clear if
750       // genExprAddr will lower them as CharBoxValue or BoxValue.
751       if (!exv.getCharBox())
752         llvm::report_fatal_error(
753             "internal error: scalar character not in CharBox");
754       outputFuncArgs.push_back(builder.createConvert(
755           loc, outputFunc.getFunctionType().getInput(1), fir::getBase(exv)));
756       outputFuncArgs.push_back(builder.createConvert(
757           loc, outputFunc.getFunctionType().getInput(2), fir::getLen(exv)));
758     } else {
759       fir::ExtendedValue itemBox = converter.genExprValue(loc, expr, stmtCtx);
760       mlir::Value itemValue = fir::getBase(itemBox);
761       if (fir::isa_complex(itemTy)) {
762         auto parts =
763             fir::factory::Complex{builder, loc}.extractParts(itemValue);
764         outputFuncArgs.push_back(parts.first);
765         outputFuncArgs.push_back(parts.second);
766       } else {
767         itemValue = builder.createConvert(loc, argType, itemValue);
768         outputFuncArgs.push_back(itemValue);
769       }
770     }
771     ok = builder.create<fir::CallOp>(loc, outputFunc, outputFuncArgs)
772              .getResult(0);
773   }
774 }
775 
776 /// Get the input function to call for a value of the given type.
777 static mlir::func::FuncOp getInputFunc(mlir::Location loc,
778                                        fir::FirOpBuilder &builder,
779                                        mlir::Type type, bool isFormatted) {
780   if (mlir::isa<fir::RecordType>(fir::unwrapPassByRefType(type)))
781     return getIORuntimeFunc<mkIOKey(InputDerivedType)>(loc, builder);
782   if (!isFormatted)
783     return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder);
784   if (auto ty = mlir::dyn_cast<mlir::IntegerType>(type)) {
785     if (type.isUnsignedInteger())
786       return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder);
787     return ty.getWidth() == 1
788                ? getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder)
789                : getIORuntimeFunc<mkIOKey(InputInteger)>(loc, builder);
790   }
791   if (auto ty = mlir::dyn_cast<mlir::FloatType>(type)) {
792     if (auto width = ty.getWidth(); width == 32)
793       return getIORuntimeFunc<mkIOKey(InputReal32)>(loc, builder);
794     else if (width == 64)
795       return getIORuntimeFunc<mkIOKey(InputReal64)>(loc, builder);
796   }
797   auto kindMap = fir::getKindMapping(builder.getModule());
798   if (auto ty = mlir::dyn_cast<mlir::ComplexType>(type)) {
799     auto width = mlir::cast<mlir::FloatType>(ty.getElementType()).getWidth();
800     if (width == 32)
801       return getIORuntimeFunc<mkIOKey(InputComplex32)>(loc, builder);
802     else if (width == 64)
803       return getIORuntimeFunc<mkIOKey(InputComplex64)>(loc, builder);
804   }
805   if (mlir::isa<fir::LogicalType>(type))
806     return getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder);
807   if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) {
808     auto asciiKind = kindMap.defaultCharacterKind();
809     if (kindMap.getCharacterBitsize(asciiKind) == 8 &&
810         fir::factory::CharacterExprHelper::getCharacterKind(type) == asciiKind)
811       return getIORuntimeFunc<mkIOKey(InputAscii)>(loc, builder);
812   }
813   return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder);
814 }
815 
816 /// Interpret the lowest byte of a LOGICAL and store that value into the full
817 /// storage of the LOGICAL. The load, convert, and store effectively (sign or
818 /// zero) extends the lowest byte into the full LOGICAL value storage, as the
819 /// runtime is unaware of the LOGICAL value's actual bit width (it was passed
820 /// as a `bool&` to the runtime in order to be set).
821 static void boolRefToLogical(mlir::Location loc, fir::FirOpBuilder &builder,
822                              mlir::Value addr) {
823   auto boolType = builder.getRefType(builder.getI1Type());
824   auto boolAddr = builder.createConvert(loc, boolType, addr);
825   auto boolValue = builder.create<fir::LoadOp>(loc, boolAddr);
826   auto logicalType = fir::unwrapPassByRefType(addr.getType());
827   // The convert avoid making any assumptions about how LOGICALs are actually
828   // represented (it might end-up being either a signed or zero extension).
829   auto logicalValue = builder.createConvert(loc, logicalType, boolValue);
830   builder.create<fir::StoreOp>(loc, logicalValue, addr);
831 }
832 
833 static mlir::Value
834 createIoRuntimeCallForItem(Fortran::lower::AbstractConverter &converter,
835                            mlir::Location loc, mlir::func::FuncOp inputFunc,
836                            mlir::Value cookie, const fir::ExtendedValue &item) {
837   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
838   mlir::Type argType = inputFunc.getFunctionType().getInput(1);
839   llvm::SmallVector<mlir::Value> inputFuncArgs = {cookie};
840   if (mlir::isa<fir::BaseBoxType>(argType)) {
841     mlir::Value box = fir::getBase(item);
842     auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(box.getType());
843     assert(boxTy && "must be previously emboxed");
844     inputFuncArgs.push_back(builder.createConvert(loc, argType, box));
845     if (mlir::isa<fir::RecordType>(fir::unwrapPassByRefType(boxTy)))
846       inputFuncArgs.push_back(getNonTbpDefinedIoTableAddr(converter));
847   } else {
848     mlir::Value itemAddr = fir::getBase(item);
849     mlir::Type itemTy = fir::unwrapPassByRefType(itemAddr.getType());
850     inputFuncArgs.push_back(builder.createConvert(loc, argType, itemAddr));
851     fir::factory::CharacterExprHelper charHelper{builder, loc};
852     if (charHelper.isCharacterScalar(itemTy)) {
853       mlir::Value len = fir::getLen(item);
854       inputFuncArgs.push_back(builder.createConvert(
855           loc, inputFunc.getFunctionType().getInput(2), len));
856     } else if (mlir::isa<mlir::IntegerType>(itemTy)) {
857       inputFuncArgs.push_back(builder.create<mlir::arith::ConstantOp>(
858           loc, builder.getI32IntegerAttr(
859                    mlir::cast<mlir::IntegerType>(itemTy).getWidth() / 8)));
860     }
861   }
862   auto call = builder.create<fir::CallOp>(loc, inputFunc, inputFuncArgs);
863   auto itemAddr = fir::getBase(item);
864   auto itemTy = fir::unwrapRefType(itemAddr.getType());
865   if (mlir::isa<fir::LogicalType>(itemTy))
866     boolRefToLogical(loc, builder, itemAddr);
867   return call.getResult(0);
868 }
869 
870 /// Generate a sequence of input data transfer calls.
871 static void genInputItemList(Fortran::lower::AbstractConverter &converter,
872                              mlir::Value cookie,
873                              const std::list<Fortran::parser::InputItem> &items,
874                              bool isFormatted, bool checkResult,
875                              mlir::Value &ok, bool inLoop) {
876   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
877   for (const Fortran::parser::InputItem &item : items) {
878     if (const auto &impliedDo = std::get_if<1>(&item.u)) {
879       genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult,
880                 ok, inLoop);
881       continue;
882     }
883     auto &pVar = std::get<Fortran::parser::Variable>(item.u);
884     mlir::Location loc = converter.genLocation(pVar.GetSource());
885     makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
886     Fortran::lower::StatementContext stmtCtx;
887     const auto *expr = Fortran::semantics::GetExpr(pVar);
888     if (!expr)
889       fir::emitFatalError(loc, "internal error: could not get evaluate::Expr");
890     if (Fortran::evaluate::HasVectorSubscript(*expr)) {
891       auto vectorSubscriptBox =
892           Fortran::lower::genVectorSubscriptBox(loc, converter, stmtCtx, *expr);
893       mlir::func::FuncOp inputFunc = getInputFunc(
894           loc, builder, vectorSubscriptBox.getElementType(), isFormatted);
895       const bool mustBox =
896           mlir::isa<fir::BoxType>(inputFunc.getFunctionType().getInput(1));
897       if (!checkResult) {
898         auto elementalGenerator = [&](const fir::ExtendedValue &element) {
899           createIoRuntimeCallForItem(converter, loc, inputFunc, cookie,
900                                      mustBox ? builder.createBox(loc, element)
901                                              : element);
902         };
903         vectorSubscriptBox.loopOverElements(builder, loc, elementalGenerator);
904       } else {
905         auto elementalGenerator =
906             [&](const fir::ExtendedValue &element) -> mlir::Value {
907           return createIoRuntimeCallForItem(
908               converter, loc, inputFunc, cookie,
909               mustBox ? builder.createBox(loc, element) : element);
910         };
911         if (!ok)
912           ok = builder.createBool(loc, true);
913         ok = vectorSubscriptBox.loopOverElementsWhile(builder, loc,
914                                                       elementalGenerator, ok);
915       }
916       continue;
917     }
918     mlir::Type itemTy = converter.genType(*expr);
919     mlir::func::FuncOp inputFunc =
920         getInputFunc(loc, builder, itemTy, isFormatted);
921     auto itemExv =
922         mlir::isa<fir::BoxType>(inputFunc.getFunctionType().getInput(1))
923             ? converter.genExprBox(loc, *expr, stmtCtx)
924             : converter.genExprAddr(loc, expr, stmtCtx);
925     ok = createIoRuntimeCallForItem(converter, loc, inputFunc, cookie, itemExv);
926   }
927 }
928 
929 /// Generate an io-implied-do loop.
930 template <typename D>
931 static void genIoLoop(Fortran::lower::AbstractConverter &converter,
932                       mlir::Value cookie, const D &ioImpliedDo,
933                       bool isFormatted, bool checkResult, mlir::Value &ok,
934                       bool inLoop) {
935   Fortran::lower::StatementContext stmtCtx;
936   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
937   mlir::Location loc = converter.getCurrentLocation();
938   mlir::arith::IntegerOverflowFlags flags{};
939   if (!converter.getLoweringOptions().getIntegerWrapAround())
940     flags = bitEnumSet(flags, mlir::arith::IntegerOverflowFlags::nsw);
941   auto iofAttr =
942       mlir::arith::IntegerOverflowFlagsAttr::get(builder.getContext(), flags);
943   makeNextConditionalOn(builder, loc, checkResult, ok, inLoop);
944   const auto &itemList = std::get<0>(ioImpliedDo.t);
945   const auto &control = std::get<1>(ioImpliedDo.t);
946   const auto &loopSym = *control.name.thing.thing.symbol;
947   mlir::Value loopVar = fir::getBase(converter.genExprAddr(
948       Fortran::evaluate::AsGenericExpr(loopSym).value(), stmtCtx));
949   auto genControlValue = [&](const Fortran::parser::ScalarIntExpr &expr) {
950     mlir::Value v = fir::getBase(
951         converter.genExprValue(*Fortran::semantics::GetExpr(expr), stmtCtx));
952     return builder.createConvert(loc, builder.getIndexType(), v);
953   };
954   mlir::Value lowerValue = genControlValue(control.lower);
955   mlir::Value upperValue = genControlValue(control.upper);
956   mlir::Value stepValue =
957       control.step.has_value()
958           ? genControlValue(*control.step)
959           : builder.create<mlir::arith::ConstantIndexOp>(loc, 1);
960   auto genItemList = [&](const D &ioImpliedDo) {
961     if constexpr (std::is_same_v<D, Fortran::parser::InputImpliedDo>)
962       genInputItemList(converter, cookie, itemList, isFormatted, checkResult,
963                        ok, /*inLoop=*/true);
964     else
965       genOutputItemList(converter, cookie, itemList, isFormatted, checkResult,
966                         ok, /*inLoop=*/true);
967   };
968   if (!checkResult) {
969     // No IO call result checks - the loop is a fir.do_loop op.
970     auto doLoopOp = builder.create<fir::DoLoopOp>(
971         loc, lowerValue, upperValue, stepValue, /*unordered=*/false,
972         /*finalCountValue=*/true);
973     builder.setInsertionPointToStart(doLoopOp.getBody());
974     mlir::Value lcv = builder.createConvert(
975         loc, fir::unwrapRefType(loopVar.getType()), doLoopOp.getInductionVar());
976     builder.create<fir::StoreOp>(loc, lcv, loopVar);
977     genItemList(ioImpliedDo);
978     builder.setInsertionPointToEnd(doLoopOp.getBody());
979     mlir::Value result = builder.create<mlir::arith::AddIOp>(
980         loc, doLoopOp.getInductionVar(), doLoopOp.getStep(), iofAttr);
981     builder.create<fir::ResultOp>(loc, result);
982     builder.setInsertionPointAfter(doLoopOp);
983     // The loop control variable may be used after the loop.
984     lcv = builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()),
985                                 doLoopOp.getResult(0));
986     builder.create<fir::StoreOp>(loc, lcv, loopVar);
987     return;
988   }
989   // Check IO call results - the loop is a fir.iterate_while op.
990   if (!ok)
991     ok = builder.createBool(loc, true);
992   auto iterWhileOp = builder.create<fir::IterWhileOp>(
993       loc, lowerValue, upperValue, stepValue, ok, /*finalCountValue*/ true);
994   builder.setInsertionPointToStart(iterWhileOp.getBody());
995   mlir::Value lcv =
996       builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()),
997                             iterWhileOp.getInductionVar());
998   builder.create<fir::StoreOp>(loc, lcv, loopVar);
999   ok = iterWhileOp.getIterateVar();
1000   mlir::Value falseValue =
1001       builder.createIntegerConstant(loc, builder.getI1Type(), 0);
1002   genItemList(ioImpliedDo);
1003   // Unwind nested IO call scopes, filling in true and false ResultOp's.
1004   for (mlir::Operation *op = builder.getBlock()->getParentOp();
1005        mlir::isa<fir::IfOp>(op); op = op->getBlock()->getParentOp()) {
1006     auto ifOp = mlir::dyn_cast<fir::IfOp>(op);
1007     mlir::Operation *lastOp = &ifOp.getThenRegion().front().back();
1008     builder.setInsertionPointAfter(lastOp);
1009     // The primary ifOp result is the result of an IO call or loop.
1010     if (mlir::isa<fir::CallOp, fir::IfOp>(*lastOp))
1011       builder.create<fir::ResultOp>(loc, lastOp->getResult(0));
1012     else
1013       builder.create<fir::ResultOp>(loc, ok); // loop result
1014     // The else branch propagates an early exit false result.
1015     builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
1016     builder.create<fir::ResultOp>(loc, falseValue);
1017   }
1018   builder.setInsertionPointToEnd(iterWhileOp.getBody());
1019   mlir::OpResult iterateResult = builder.getBlock()->back().getResult(0);
1020   mlir::Value inductionResult0 = iterWhileOp.getInductionVar();
1021   auto inductionResult1 = builder.create<mlir::arith::AddIOp>(
1022       loc, inductionResult0, iterWhileOp.getStep(), iofAttr);
1023   auto inductionResult = builder.create<mlir::arith::SelectOp>(
1024       loc, iterateResult, inductionResult1, inductionResult0);
1025   llvm::SmallVector<mlir::Value> results = {inductionResult, iterateResult};
1026   builder.create<fir::ResultOp>(loc, results);
1027   ok = iterWhileOp.getResult(1);
1028   builder.setInsertionPointAfter(iterWhileOp);
1029   // The loop control variable may be used after the loop.
1030   lcv = builder.createConvert(loc, fir::unwrapRefType(loopVar.getType()),
1031                               iterWhileOp.getResult(0));
1032   builder.create<fir::StoreOp>(loc, lcv, loopVar);
1033 }
1034 
1035 //===----------------------------------------------------------------------===//
1036 // Default argument generation.
1037 //===----------------------------------------------------------------------===//
1038 
1039 static mlir::Value locToFilename(Fortran::lower::AbstractConverter &converter,
1040                                  mlir::Location loc, mlir::Type toType) {
1041   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1042   return builder.createConvert(loc, toType,
1043                                fir::factory::locationToFilename(builder, loc));
1044 }
1045 
1046 static mlir::Value locToLineNo(Fortran::lower::AbstractConverter &converter,
1047                                mlir::Location loc, mlir::Type toType) {
1048   return fir::factory::locationToLineNo(converter.getFirOpBuilder(), loc,
1049                                         toType);
1050 }
1051 
1052 static mlir::Value getDefaultScratch(fir::FirOpBuilder &builder,
1053                                      mlir::Location loc, mlir::Type toType) {
1054   mlir::Value null = builder.create<mlir::arith::ConstantOp>(
1055       loc, builder.getI64IntegerAttr(0));
1056   return builder.createConvert(loc, toType, null);
1057 }
1058 
1059 static mlir::Value getDefaultScratchLen(fir::FirOpBuilder &builder,
1060                                         mlir::Location loc, mlir::Type toType) {
1061   return builder.create<mlir::arith::ConstantOp>(
1062       loc, builder.getIntegerAttr(toType, 0));
1063 }
1064 
1065 /// Generate a reference to a buffer and the length of buffer given
1066 /// a character expression. An array expression will be cast to scalar
1067 /// character as long as they are contiguous.
1068 static std::tuple<mlir::Value, mlir::Value>
1069 genBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1070           const Fortran::lower::SomeExpr &expr, mlir::Type strTy,
1071           mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) {
1072   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1073   fir::ExtendedValue exprAddr = converter.genExprAddr(expr, stmtCtx);
1074   fir::factory::CharacterExprHelper helper(builder, loc);
1075   using ValuePair = std::pair<mlir::Value, mlir::Value>;
1076   auto [buff, len] = exprAddr.match(
1077       [&](const fir::CharBoxValue &x) -> ValuePair {
1078         return {x.getBuffer(), x.getLen()};
1079       },
1080       [&](const fir::CharArrayBoxValue &x) -> ValuePair {
1081         fir::CharBoxValue scalar = helper.toScalarCharacter(x);
1082         return {scalar.getBuffer(), scalar.getLen()};
1083       },
1084       [&](const fir::BoxValue &) -> ValuePair {
1085         // May need to copy before after IO to handle contiguous
1086         // aspect. Not sure descriptor can get here though.
1087         TODO(loc, "character descriptor to contiguous buffer");
1088       },
1089       [&](const auto &) -> ValuePair {
1090         llvm::report_fatal_error(
1091             "internal error: IO buffer is not a character");
1092       });
1093   buff = builder.createConvert(loc, strTy, buff);
1094   len = builder.createConvert(loc, lenTy, len);
1095   return {buff, len};
1096 }
1097 
1098 /// Lower a string literal. Many arguments to the runtime are conveyed as
1099 /// Fortran CHARACTER literals.
1100 template <typename A>
1101 static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1102 lowerStringLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1103                Fortran::lower::StatementContext &stmtCtx, const A &syntax,
1104                mlir::Type strTy, mlir::Type lenTy, mlir::Type ty2 = {}) {
1105   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1106   auto *expr = Fortran::semantics::GetExpr(syntax);
1107   if (!expr)
1108     fir::emitFatalError(loc, "internal error: null semantic expr in IO");
1109   auto [buff, len] = genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx);
1110   mlir::Value kind;
1111   if (ty2) {
1112     auto kindVal = expr->GetType().value().kind();
1113     kind = builder.create<mlir::arith::ConstantOp>(
1114         loc, builder.getIntegerAttr(ty2, kindVal));
1115   }
1116   return {buff, len, kind};
1117 }
1118 
1119 /// Pass the body of the FORMAT statement in as if it were a CHARACTER literal
1120 /// constant. NB: This is the prescribed manner in which the front-end passes
1121 /// this information to lowering.
1122 static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1123 lowerSourceTextAsStringLit(Fortran::lower::AbstractConverter &converter,
1124                            mlir::Location loc, llvm::StringRef text,
1125                            mlir::Type strTy, mlir::Type lenTy) {
1126   text = text.drop_front(text.find('('));
1127   text = text.take_front(text.rfind(')') + 1);
1128   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1129   mlir::Value addrGlobalStringLit =
1130       fir::getBase(fir::factory::createStringLiteral(builder, loc, text));
1131   mlir::Value buff = builder.createConvert(loc, strTy, addrGlobalStringLit);
1132   mlir::Value len = builder.createIntegerConstant(loc, lenTy, text.size());
1133   return {buff, len, mlir::Value{}};
1134 }
1135 
1136 //===----------------------------------------------------------------------===//
1137 // Handle IO statement specifiers.
1138 // These are threaded together for a single statement via the passed cookie.
1139 //===----------------------------------------------------------------------===//
1140 
1141 /// Generic to build an integral argument to the runtime.
1142 template <typename A, typename B>
1143 mlir::Value genIntIOOption(Fortran::lower::AbstractConverter &converter,
1144                            mlir::Location loc, mlir::Value cookie,
1145                            const B &spec) {
1146   Fortran::lower::StatementContext localStatementCtx;
1147   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1148   mlir::func::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder);
1149   mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1150   mlir::Value expr = fir::getBase(converter.genExprValue(
1151       loc, Fortran::semantics::GetExpr(spec.v), localStatementCtx));
1152   mlir::Value val = builder.createConvert(loc, ioFuncTy.getInput(1), expr);
1153   llvm::SmallVector<mlir::Value> ioArgs = {cookie, val};
1154   return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1155 }
1156 
1157 /// Generic to build a string argument to the runtime. This passes a CHARACTER
1158 /// as a pointer to the buffer and a LEN parameter.
1159 template <typename A, typename B>
1160 mlir::Value genCharIOOption(Fortran::lower::AbstractConverter &converter,
1161                             mlir::Location loc, mlir::Value cookie,
1162                             const B &spec) {
1163   Fortran::lower::StatementContext localStatementCtx;
1164   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1165   mlir::func::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder);
1166   mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1167   std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1168       lowerStringLit(converter, loc, localStatementCtx, spec,
1169                      ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1170   llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
1171                                            std::get<1>(tup)};
1172   return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1173 }
1174 
1175 template <typename A>
1176 mlir::Value genIOOption(Fortran::lower::AbstractConverter &converter,
1177                         mlir::Location loc, mlir::Value cookie, const A &spec) {
1178   // These specifiers are processed in advance elsewhere - skip them here.
1179   using PreprocessedSpecs =
1180       std::tuple<Fortran::parser::EndLabel, Fortran::parser::EorLabel,
1181                  Fortran::parser::ErrLabel, Fortran::parser::FileUnitNumber,
1182                  Fortran::parser::Format, Fortran::parser::IoUnit,
1183                  Fortran::parser::MsgVariable, Fortran::parser::Name,
1184                  Fortran::parser::StatVariable>;
1185   static_assert(Fortran::common::HasMember<A, PreprocessedSpecs>,
1186                 "missing genIOOPtion specialization");
1187   return {};
1188 }
1189 
1190 template <>
1191 mlir::Value genIOOption<Fortran::parser::FileNameExpr>(
1192     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1193     mlir::Value cookie, const Fortran::parser::FileNameExpr &spec) {
1194   Fortran::lower::StatementContext localStatementCtx;
1195   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1196   // has an extra KIND argument
1197   mlir::func::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(SetFile)>(loc, builder);
1198   mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1199   std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1200       lowerStringLit(converter, loc, localStatementCtx, spec,
1201                      ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1202   llvm::SmallVector<mlir::Value> ioArgs{cookie, std::get<0>(tup),
1203                                         std::get<1>(tup)};
1204   return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1205 }
1206 
1207 template <>
1208 mlir::Value genIOOption<Fortran::parser::ConnectSpec::CharExpr>(
1209     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1210     mlir::Value cookie, const Fortran::parser::ConnectSpec::CharExpr &spec) {
1211   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1212   mlir::func::FuncOp ioFunc;
1213   switch (std::get<Fortran::parser::ConnectSpec::CharExpr::Kind>(spec.t)) {
1214   case Fortran::parser::ConnectSpec::CharExpr::Kind::Access:
1215     ioFunc = getIORuntimeFunc<mkIOKey(SetAccess)>(loc, builder);
1216     break;
1217   case Fortran::parser::ConnectSpec::CharExpr::Kind::Action:
1218     ioFunc = getIORuntimeFunc<mkIOKey(SetAction)>(loc, builder);
1219     break;
1220   case Fortran::parser::ConnectSpec::CharExpr::Kind::Asynchronous:
1221     ioFunc = getIORuntimeFunc<mkIOKey(SetAsynchronous)>(loc, builder);
1222     break;
1223   case Fortran::parser::ConnectSpec::CharExpr::Kind::Blank:
1224     ioFunc = getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder);
1225     break;
1226   case Fortran::parser::ConnectSpec::CharExpr::Kind::Decimal:
1227     ioFunc = getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder);
1228     break;
1229   case Fortran::parser::ConnectSpec::CharExpr::Kind::Delim:
1230     ioFunc = getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder);
1231     break;
1232   case Fortran::parser::ConnectSpec::CharExpr::Kind::Encoding:
1233     ioFunc = getIORuntimeFunc<mkIOKey(SetEncoding)>(loc, builder);
1234     break;
1235   case Fortran::parser::ConnectSpec::CharExpr::Kind::Form:
1236     ioFunc = getIORuntimeFunc<mkIOKey(SetForm)>(loc, builder);
1237     break;
1238   case Fortran::parser::ConnectSpec::CharExpr::Kind::Pad:
1239     ioFunc = getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder);
1240     break;
1241   case Fortran::parser::ConnectSpec::CharExpr::Kind::Position:
1242     ioFunc = getIORuntimeFunc<mkIOKey(SetPosition)>(loc, builder);
1243     break;
1244   case Fortran::parser::ConnectSpec::CharExpr::Kind::Round:
1245     ioFunc = getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder);
1246     break;
1247   case Fortran::parser::ConnectSpec::CharExpr::Kind::Sign:
1248     ioFunc = getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder);
1249     break;
1250   case Fortran::parser::ConnectSpec::CharExpr::Kind::Carriagecontrol:
1251     ioFunc = getIORuntimeFunc<mkIOKey(SetCarriagecontrol)>(loc, builder);
1252     break;
1253   case Fortran::parser::ConnectSpec::CharExpr::Kind::Convert:
1254     ioFunc = getIORuntimeFunc<mkIOKey(SetConvert)>(loc, builder);
1255     break;
1256   case Fortran::parser::ConnectSpec::CharExpr::Kind::Dispose:
1257     TODO(loc, "DISPOSE not part of the runtime::io interface");
1258   }
1259   Fortran::lower::StatementContext localStatementCtx;
1260   mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1261   std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1262       lowerStringLit(converter, loc, localStatementCtx,
1263                      std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t),
1264                      ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1265   llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
1266                                            std::get<1>(tup)};
1267   return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1268 }
1269 
1270 template <>
1271 mlir::Value genIOOption<Fortran::parser::ConnectSpec::Recl>(
1272     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1273     mlir::Value cookie, const Fortran::parser::ConnectSpec::Recl &spec) {
1274   return genIntIOOption<mkIOKey(SetRecl)>(converter, loc, cookie, spec);
1275 }
1276 
1277 template <>
1278 mlir::Value genIOOption<Fortran::parser::StatusExpr>(
1279     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1280     mlir::Value cookie, const Fortran::parser::StatusExpr &spec) {
1281   return genCharIOOption<mkIOKey(SetStatus)>(converter, loc, cookie, spec.v);
1282 }
1283 
1284 template <>
1285 mlir::Value genIOOption<Fortran::parser::IoControlSpec::CharExpr>(
1286     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1287     mlir::Value cookie, const Fortran::parser::IoControlSpec::CharExpr &spec) {
1288   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1289   mlir::func::FuncOp ioFunc;
1290   switch (std::get<Fortran::parser::IoControlSpec::CharExpr::Kind>(spec.t)) {
1291   case Fortran::parser::IoControlSpec::CharExpr::Kind::Advance:
1292     ioFunc = getIORuntimeFunc<mkIOKey(SetAdvance)>(loc, builder);
1293     break;
1294   case Fortran::parser::IoControlSpec::CharExpr::Kind::Blank:
1295     ioFunc = getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder);
1296     break;
1297   case Fortran::parser::IoControlSpec::CharExpr::Kind::Decimal:
1298     ioFunc = getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder);
1299     break;
1300   case Fortran::parser::IoControlSpec::CharExpr::Kind::Delim:
1301     ioFunc = getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder);
1302     break;
1303   case Fortran::parser::IoControlSpec::CharExpr::Kind::Pad:
1304     ioFunc = getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder);
1305     break;
1306   case Fortran::parser::IoControlSpec::CharExpr::Kind::Round:
1307     ioFunc = getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder);
1308     break;
1309   case Fortran::parser::IoControlSpec::CharExpr::Kind::Sign:
1310     ioFunc = getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder);
1311     break;
1312   }
1313   Fortran::lower::StatementContext localStatementCtx;
1314   mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1315   std::tuple<mlir::Value, mlir::Value, mlir::Value> tup =
1316       lowerStringLit(converter, loc, localStatementCtx,
1317                      std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t),
1318                      ioFuncTy.getInput(1), ioFuncTy.getInput(2));
1319   llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup),
1320                                            std::get<1>(tup)};
1321   return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1322 }
1323 
1324 template <>
1325 mlir::Value genIOOption<Fortran::parser::IoControlSpec::Asynchronous>(
1326     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1327     mlir::Value cookie,
1328     const Fortran::parser::IoControlSpec::Asynchronous &spec) {
1329   return genCharIOOption<mkIOKey(SetAsynchronous)>(converter, loc, cookie,
1330                                                    spec.v);
1331 }
1332 
1333 template <>
1334 mlir::Value genIOOption<Fortran::parser::IoControlSpec::Pos>(
1335     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1336     mlir::Value cookie, const Fortran::parser::IoControlSpec::Pos &spec) {
1337   return genIntIOOption<mkIOKey(SetPos)>(converter, loc, cookie, spec);
1338 }
1339 
1340 template <>
1341 mlir::Value genIOOption<Fortran::parser::IoControlSpec::Rec>(
1342     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1343     mlir::Value cookie, const Fortran::parser::IoControlSpec::Rec &spec) {
1344   return genIntIOOption<mkIOKey(SetRec)>(converter, loc, cookie, spec);
1345 }
1346 
1347 /// Generate runtime call to set some control variable.
1348 /// Generates "VAR = IoRuntimeKey(cookie)".
1349 template <typename IoRuntimeKey, typename VAR>
1350 static void genIOGetVar(Fortran::lower::AbstractConverter &converter,
1351                         mlir::Location loc, mlir::Value cookie,
1352                         const VAR &parserVar) {
1353   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1354   mlir::func::FuncOp ioFunc = getIORuntimeFunc<IoRuntimeKey>(loc, builder);
1355   mlir::Value value =
1356       builder.create<fir::CallOp>(loc, ioFunc, mlir::ValueRange{cookie})
1357           .getResult(0);
1358   Fortran::lower::StatementContext localStatementCtx;
1359   fir::ExtendedValue var = converter.genExprAddr(
1360       loc, Fortran::semantics::GetExpr(parserVar.v), localStatementCtx);
1361   builder.createStoreWithConvert(loc, value, fir::getBase(var));
1362 }
1363 
1364 //===----------------------------------------------------------------------===//
1365 // Gather IO statement condition specifier information (if any).
1366 //===----------------------------------------------------------------------===//
1367 
1368 template <typename SEEK, typename A>
1369 static bool hasX(const A &list) {
1370   for (const auto &spec : list)
1371     if (std::holds_alternative<SEEK>(spec.u))
1372       return true;
1373   return false;
1374 }
1375 
1376 template <typename SEEK, typename A>
1377 static bool hasSpec(const A &stmt) {
1378   return hasX<SEEK>(stmt.v);
1379 }
1380 
1381 /// Get the sought expression from the specifier list.
1382 template <typename SEEK, typename A>
1383 static const Fortran::lower::SomeExpr *getExpr(const A &stmt) {
1384   for (const auto &spec : stmt.v)
1385     if (auto *f = std::get_if<SEEK>(&spec.u))
1386       return Fortran::semantics::GetExpr(f->v);
1387   llvm::report_fatal_error("must have a file unit");
1388 }
1389 
1390 /// For each specifier, build the appropriate call, threading the cookie.
1391 template <typename A>
1392 static void threadSpecs(Fortran::lower::AbstractConverter &converter,
1393                         mlir::Location loc, mlir::Value cookie,
1394                         const A &specList, bool checkResult, mlir::Value &ok) {
1395   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1396   for (const auto &spec : specList) {
1397     makeNextConditionalOn(builder, loc, checkResult, ok);
1398     ok = Fortran::common::visit(
1399         Fortran::common::visitors{
1400             [&](const Fortran::parser::IoControlSpec::Size &x) -> mlir::Value {
1401               // Size must be queried after the related READ runtime calls, not
1402               // before.
1403               return ok;
1404             },
1405             [&](const Fortran::parser::ConnectSpec::Newunit &x) -> mlir::Value {
1406               // Newunit must be queried after OPEN specifier runtime calls
1407               // that may fail to avoid modifying the newunit variable if
1408               // there is an error.
1409               return ok;
1410             },
1411             [&](const Fortran::parser::IdVariable &) -> mlir::Value {
1412               // ID is queried after the transfer so that ASYNCHROUNOUS= has
1413               // been processed and also to set it to zero if the transfer is
1414               // already finished.
1415               return ok;
1416             },
1417             [&](const auto &x) {
1418               return genIOOption(converter, loc, cookie, x);
1419             }},
1420         spec.u);
1421   }
1422 }
1423 
1424 /// Most IO statements allow one or more of five optional exception condition
1425 /// handling specifiers: ERR, EOR, END, IOSTAT, and IOMSG. The first three
1426 /// cause control flow to transfer to another statement. The final two return
1427 /// information from the runtime, via a variable, about the nature of the
1428 /// condition that occurred. These condition specifiers are handled here.
1429 template <typename A>
1430 ConditionSpecInfo lowerErrorSpec(Fortran::lower::AbstractConverter &converter,
1431                                  mlir::Location loc, const A &specList) {
1432   ConditionSpecInfo csi;
1433   const Fortran::lower::SomeExpr *ioMsgExpr = nullptr;
1434   for (const auto &spec : specList) {
1435     Fortran::common::visit(
1436         Fortran::common::visitors{
1437             [&](const Fortran::parser::StatVariable &var) {
1438               csi.ioStatExpr = Fortran::semantics::GetExpr(var);
1439             },
1440             [&](const Fortran::parser::InquireSpec::IntVar &var) {
1441               if (std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t) ==
1442                   Fortran::parser::InquireSpec::IntVar::Kind::Iostat)
1443                 csi.ioStatExpr = Fortran::semantics::GetExpr(
1444                     std::get<Fortran::parser::ScalarIntVariable>(var.t));
1445             },
1446             [&](const Fortran::parser::MsgVariable &var) {
1447               ioMsgExpr = Fortran::semantics::GetExpr(var);
1448             },
1449             [&](const Fortran::parser::InquireSpec::CharVar &var) {
1450               if (std::get<Fortran::parser::InquireSpec::CharVar::Kind>(
1451                       var.t) ==
1452                   Fortran::parser::InquireSpec::CharVar::Kind::Iomsg)
1453                 ioMsgExpr = Fortran::semantics::GetExpr(
1454                     std::get<Fortran::parser::ScalarDefaultCharVariable>(
1455                         var.t));
1456             },
1457             [&](const Fortran::parser::EndLabel &) { csi.hasEnd = true; },
1458             [&](const Fortran::parser::EorLabel &) { csi.hasEor = true; },
1459             [&](const Fortran::parser::ErrLabel &) { csi.hasErr = true; },
1460             [](const auto &) {}},
1461         spec.u);
1462   }
1463   if (ioMsgExpr) {
1464     // iomsg is a variable, its evaluation may require temps, but it cannot
1465     // itself be a temp, and it is ok to us a local statement context here.
1466     Fortran::lower::StatementContext stmtCtx;
1467     csi.ioMsg = converter.genExprAddr(loc, ioMsgExpr, stmtCtx);
1468   }
1469 
1470   return csi;
1471 }
1472 template <typename A>
1473 static void
1474 genConditionHandlerCall(Fortran::lower::AbstractConverter &converter,
1475                         mlir::Location loc, mlir::Value cookie,
1476                         const A &specList, ConditionSpecInfo &csi) {
1477   if (!csi.hasAnyConditionSpec())
1478     return;
1479   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1480   mlir::func::FuncOp enableHandlers =
1481       getIORuntimeFunc<mkIOKey(EnableHandlers)>(loc, builder);
1482   mlir::Type boolType = enableHandlers.getFunctionType().getInput(1);
1483   auto boolValue = [&](bool specifierIsPresent) {
1484     return builder.create<mlir::arith::ConstantOp>(
1485         loc, builder.getIntegerAttr(boolType, specifierIsPresent));
1486   };
1487   llvm::SmallVector<mlir::Value> ioArgs = {cookie,
1488                                            boolValue(csi.ioStatExpr != nullptr),
1489                                            boolValue(csi.hasErr),
1490                                            boolValue(csi.hasEnd),
1491                                            boolValue(csi.hasEor),
1492                                            boolValue(csi.ioMsg.has_value())};
1493   builder.create<fir::CallOp>(loc, enableHandlers, ioArgs);
1494 }
1495 
1496 //===----------------------------------------------------------------------===//
1497 // Data transfer helpers
1498 //===----------------------------------------------------------------------===//
1499 
1500 template <typename SEEK, typename A>
1501 static bool hasIOControl(const A &stmt) {
1502   return hasX<SEEK>(stmt.controls);
1503 }
1504 
1505 template <typename SEEK, typename A>
1506 static const auto *getIOControl(const A &stmt) {
1507   for (const auto &spec : stmt.controls)
1508     if (const auto *result = std::get_if<SEEK>(&spec.u))
1509       return result;
1510   return static_cast<const SEEK *>(nullptr);
1511 }
1512 
1513 /// Returns true iff the expression in the parse tree is not really a format but
1514 /// rather a namelist group.
1515 template <typename A>
1516 static bool formatIsActuallyNamelist(const A &format) {
1517   if (auto *e = std::get_if<Fortran::parser::Expr>(&format.u)) {
1518     auto *expr = Fortran::semantics::GetExpr(*e);
1519     if (const Fortran::semantics::Symbol *y =
1520             Fortran::evaluate::UnwrapWholeSymbolDataRef(*expr))
1521       return y->has<Fortran::semantics::NamelistDetails>();
1522   }
1523   return false;
1524 }
1525 
1526 template <typename A>
1527 static bool isDataTransferFormatted(const A &stmt) {
1528   if (stmt.format)
1529     return !formatIsActuallyNamelist(*stmt.format);
1530   return hasIOControl<Fortran::parser::Format>(stmt);
1531 }
1532 template <>
1533 constexpr bool isDataTransferFormatted<Fortran::parser::PrintStmt>(
1534     const Fortran::parser::PrintStmt &) {
1535   return true; // PRINT is always formatted
1536 }
1537 
1538 template <typename A>
1539 static bool isDataTransferList(const A &stmt) {
1540   if (stmt.format)
1541     return std::holds_alternative<Fortran::parser::Star>(stmt.format->u);
1542   if (auto *mem = getIOControl<Fortran::parser::Format>(stmt))
1543     return std::holds_alternative<Fortran::parser::Star>(mem->u);
1544   return false;
1545 }
1546 template <>
1547 bool isDataTransferList<Fortran::parser::PrintStmt>(
1548     const Fortran::parser::PrintStmt &stmt) {
1549   return std::holds_alternative<Fortran::parser::Star>(
1550       std::get<Fortran::parser::Format>(stmt.t).u);
1551 }
1552 
1553 template <typename A>
1554 static bool isDataTransferInternal(const A &stmt) {
1555   if (stmt.iounit.has_value())
1556     return std::holds_alternative<Fortran::parser::Variable>(stmt.iounit->u);
1557   if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt))
1558     return std::holds_alternative<Fortran::parser::Variable>(unit->u);
1559   return false;
1560 }
1561 template <>
1562 constexpr bool isDataTransferInternal<Fortran::parser::PrintStmt>(
1563     const Fortran::parser::PrintStmt &) {
1564   return false;
1565 }
1566 
1567 /// If the variable `var` is an array or of a KIND other than the default
1568 /// (normally 1), then a descriptor is required by the runtime IO API. This
1569 /// condition holds even in F77 sources.
1570 static std::optional<fir::ExtendedValue> getVariableBufferRequiredDescriptor(
1571     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1572     const Fortran::parser::Variable &var,
1573     Fortran::lower::StatementContext &stmtCtx) {
1574   fir::ExtendedValue varBox =
1575       converter.genExprBox(loc, var.typedExpr->v.value(), stmtCtx);
1576   fir::KindTy defCharKind = converter.getKindMap().defaultCharacterKind();
1577   mlir::Value varAddr = fir::getBase(varBox);
1578   if (fir::factory::CharacterExprHelper::getCharacterOrSequenceKind(
1579           varAddr.getType()) != defCharKind)
1580     return varBox;
1581   if (fir::factory::CharacterExprHelper::isArray(varAddr.getType()))
1582     return varBox;
1583   return std::nullopt;
1584 }
1585 
1586 template <typename A>
1587 static std::optional<fir::ExtendedValue>
1588 maybeGetInternalIODescriptor(Fortran::lower::AbstractConverter &converter,
1589                              mlir::Location loc, const A &stmt,
1590                              Fortran::lower::StatementContext &stmtCtx) {
1591   if (stmt.iounit.has_value())
1592     if (auto *var = std::get_if<Fortran::parser::Variable>(&stmt.iounit->u))
1593       return getVariableBufferRequiredDescriptor(converter, loc, *var, stmtCtx);
1594   if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt))
1595     if (auto *var = std::get_if<Fortran::parser::Variable>(&unit->u))
1596       return getVariableBufferRequiredDescriptor(converter, loc, *var, stmtCtx);
1597   return std::nullopt;
1598 }
1599 template <>
1600 inline std::optional<fir::ExtendedValue>
1601 maybeGetInternalIODescriptor<Fortran::parser::PrintStmt>(
1602     Fortran::lower::AbstractConverter &, mlir::Location loc,
1603     const Fortran::parser::PrintStmt &, Fortran::lower::StatementContext &) {
1604   return std::nullopt;
1605 }
1606 
1607 template <typename A>
1608 static bool isDataTransferNamelist(const A &stmt) {
1609   if (stmt.format)
1610     return formatIsActuallyNamelist(*stmt.format);
1611   return hasIOControl<Fortran::parser::Name>(stmt);
1612 }
1613 template <>
1614 constexpr bool isDataTransferNamelist<Fortran::parser::PrintStmt>(
1615     const Fortran::parser::PrintStmt &) {
1616   return false;
1617 }
1618 
1619 /// Lowers a format statment that uses an assigned variable label reference as
1620 /// a select operation to allow for run-time selection of the format statement.
1621 static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1622 lowerReferenceAsStringSelect(Fortran::lower::AbstractConverter &converter,
1623                              mlir::Location loc,
1624                              const Fortran::lower::SomeExpr &expr,
1625                              mlir::Type strTy, mlir::Type lenTy,
1626                              Fortran::lower::StatementContext &stmtCtx) {
1627   // Create the requisite blocks to inline a selectOp.
1628   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1629   mlir::Block *startBlock = builder.getBlock();
1630   mlir::Block *endBlock = startBlock->splitBlock(builder.getInsertionPoint());
1631   mlir::Block *block = startBlock->splitBlock(builder.getInsertionPoint());
1632   builder.setInsertionPointToEnd(block);
1633 
1634   llvm::SmallVector<int64_t> indexList;
1635   llvm::SmallVector<mlir::Block *> blockList;
1636 
1637   auto symbol = GetLastSymbol(&expr);
1638   Fortran::lower::pft::LabelSet labels;
1639   converter.lookupLabelSet(*symbol, labels);
1640 
1641   for (auto label : labels) {
1642     indexList.push_back(label);
1643     auto *eval = converter.lookupLabel(label);
1644     assert(eval && "Label is missing from the table");
1645 
1646     llvm::StringRef text = toStringRef(eval->position);
1647     mlir::Value stringRef;
1648     mlir::Value stringLen;
1649     if (eval->isA<Fortran::parser::FormatStmt>()) {
1650       assert(text.contains('(') && "FORMAT is unexpectedly ill-formed");
1651       // This is a format statement, so extract the spec from the text.
1652       std::tuple<mlir::Value, mlir::Value, mlir::Value> stringLit =
1653           lowerSourceTextAsStringLit(converter, loc, text, strTy, lenTy);
1654       stringRef = std::get<0>(stringLit);
1655       stringLen = std::get<1>(stringLit);
1656     } else {
1657       // This is not a format statement, so use null.
1658       stringRef = builder.createConvert(
1659           loc, strTy,
1660           builder.createIntegerConstant(loc, builder.getIndexType(), 0));
1661       stringLen = builder.createIntegerConstant(loc, lenTy, 0);
1662     }
1663 
1664     // Pass the format string reference and the string length out of the select
1665     // statement.
1666     llvm::SmallVector<mlir::Value> args = {stringRef, stringLen};
1667     builder.create<mlir::cf::BranchOp>(loc, endBlock, args);
1668 
1669     // Add block to the list of cases and make a new one.
1670     blockList.push_back(block);
1671     block = block->splitBlock(builder.getInsertionPoint());
1672     builder.setInsertionPointToEnd(block);
1673   }
1674 
1675   // Create the unit case which should result in an error.
1676   auto *unitBlock = block->splitBlock(builder.getInsertionPoint());
1677   builder.setInsertionPointToEnd(unitBlock);
1678   fir::runtime::genReportFatalUserError(
1679       builder, loc,
1680       "Assigned format variable '" + symbol->name().ToString() +
1681           "' has not been assigned a valid format label");
1682   builder.create<fir::UnreachableOp>(loc);
1683   blockList.push_back(unitBlock);
1684 
1685   // Lower the selectOp.
1686   builder.setInsertionPointToEnd(startBlock);
1687   auto label = fir::getBase(converter.genExprValue(loc, &expr, stmtCtx));
1688   builder.create<fir::SelectOp>(loc, label, indexList, blockList);
1689 
1690   builder.setInsertionPointToEnd(endBlock);
1691   endBlock->addArgument(strTy, loc);
1692   endBlock->addArgument(lenTy, loc);
1693 
1694   // Handle and return the string reference and length selected by the selectOp.
1695   auto buff = endBlock->getArgument(0);
1696   auto len = endBlock->getArgument(1);
1697 
1698   return {buff, len, mlir::Value{}};
1699 }
1700 
1701 /// Generate a reference to a format string. There are four cases - a format
1702 /// statement label, a character format expression, an integer that holds the
1703 /// label of a format statement, and the * case. The first three are done here.
1704 /// The * case is done elsewhere.
1705 static std::tuple<mlir::Value, mlir::Value, mlir::Value>
1706 genFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1707           const Fortran::parser::Format &format, mlir::Type strTy,
1708           mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) {
1709   if (const auto *label = std::get_if<Fortran::parser::Label>(&format.u)) {
1710     // format statement label
1711     auto eval = converter.lookupLabel(*label);
1712     assert(eval && "FORMAT not found in PROCEDURE");
1713     return lowerSourceTextAsStringLit(
1714         converter, loc, toStringRef(eval->position), strTy, lenTy);
1715   }
1716   const auto *pExpr = std::get_if<Fortran::parser::Expr>(&format.u);
1717   assert(pExpr && "missing format expression");
1718   auto e = Fortran::semantics::GetExpr(*pExpr);
1719   if (Fortran::semantics::ExprHasTypeCategory(
1720           *e, Fortran::common::TypeCategory::Character)) {
1721     // character expression
1722     if (e->Rank())
1723       // Array: return address(descriptor) and no length (and no kind value).
1724       return {fir::getBase(converter.genExprBox(loc, *e, stmtCtx)),
1725               mlir::Value{}, mlir::Value{}};
1726     // Scalar: return address(format) and format length (and no kind value).
1727     return lowerStringLit(converter, loc, stmtCtx, *pExpr, strTy, lenTy);
1728   }
1729 
1730   if (Fortran::semantics::ExprHasTypeCategory(
1731           *e, Fortran::common::TypeCategory::Integer) &&
1732       e->Rank() == 0 && Fortran::evaluate::UnwrapWholeSymbolDataRef(*e)) {
1733     // Treat as a scalar integer variable containing an ASSIGN label.
1734     return lowerReferenceAsStringSelect(converter, loc, *e, strTy, lenTy,
1735                                         stmtCtx);
1736   }
1737 
1738   // Legacy extension: it is possible that `*e` is not a scalar INTEGER
1739   // variable containing a label value. The output appears to be the source text
1740   // that initialized the variable? Needs more investigatation.
1741   TODO(loc, "io-control-spec contains a reference to a non-integer, "
1742             "non-scalar, or non-variable");
1743 }
1744 
1745 template <typename A>
1746 std::tuple<mlir::Value, mlir::Value, mlir::Value>
1747 getFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1748           const A &stmt, mlir::Type strTy, mlir::Type lenTy,
1749           Fortran ::lower::StatementContext &stmtCtx) {
1750   if (stmt.format && !formatIsActuallyNamelist(*stmt.format))
1751     return genFormat(converter, loc, *stmt.format, strTy, lenTy, stmtCtx);
1752   return genFormat(converter, loc, *getIOControl<Fortran::parser::Format>(stmt),
1753                    strTy, lenTy, stmtCtx);
1754 }
1755 template <>
1756 std::tuple<mlir::Value, mlir::Value, mlir::Value>
1757 getFormat<Fortran::parser::PrintStmt>(
1758     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1759     const Fortran::parser::PrintStmt &stmt, mlir::Type strTy, mlir::Type lenTy,
1760     Fortran::lower::StatementContext &stmtCtx) {
1761   return genFormat(converter, loc, std::get<Fortran::parser::Format>(stmt.t),
1762                    strTy, lenTy, stmtCtx);
1763 }
1764 
1765 /// Get a buffer for an internal file data transfer.
1766 template <typename A>
1767 std::tuple<mlir::Value, mlir::Value>
1768 getBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1769           const A &stmt, mlir::Type strTy, mlir::Type lenTy,
1770           Fortran::lower::StatementContext &stmtCtx) {
1771   const Fortran::parser::IoUnit *iounit =
1772       stmt.iounit ? &*stmt.iounit : getIOControl<Fortran::parser::IoUnit>(stmt);
1773   if (iounit)
1774     if (auto *var = std::get_if<Fortran::parser::Variable>(&iounit->u))
1775       if (auto *expr = Fortran::semantics::GetExpr(*var))
1776         return genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx);
1777   llvm::report_fatal_error("failed to get IoUnit expr");
1778 }
1779 
1780 static mlir::Value genIOUnitNumber(Fortran::lower::AbstractConverter &converter,
1781                                    mlir::Location loc,
1782                                    const Fortran::lower::SomeExpr *iounit,
1783                                    mlir::Type ty, ConditionSpecInfo &csi,
1784                                    Fortran::lower::StatementContext &stmtCtx) {
1785   auto &builder = converter.getFirOpBuilder();
1786   auto rawUnit = fir::getBase(converter.genExprValue(loc, iounit, stmtCtx));
1787   unsigned rawUnitWidth =
1788       mlir::cast<mlir::IntegerType>(rawUnit.getType()).getWidth();
1789   unsigned runtimeArgWidth = mlir::cast<mlir::IntegerType>(ty).getWidth();
1790   // The IO runtime supports `int` unit numbers, if the unit number may
1791   // overflow when passed to the IO runtime, check that the unit number is
1792   // in range before calling the BeginXXX.
1793   if (rawUnitWidth > runtimeArgWidth) {
1794     mlir::func::FuncOp check =
1795         rawUnitWidth <= 64
1796             ? getIORuntimeFunc<mkIOKey(CheckUnitNumberInRange64)>(loc, builder)
1797             : getIORuntimeFunc<mkIOKey(CheckUnitNumberInRange128)>(loc,
1798                                                                    builder);
1799     mlir::FunctionType funcTy = check.getFunctionType();
1800     llvm::SmallVector<mlir::Value> args;
1801     args.push_back(builder.createConvert(loc, funcTy.getInput(0), rawUnit));
1802     args.push_back(builder.createBool(loc, csi.hasErrorConditionSpec()));
1803     if (csi.ioMsg) {
1804       args.push_back(builder.createConvert(loc, funcTy.getInput(2),
1805                                            fir::getBase(*csi.ioMsg)));
1806       args.push_back(builder.createConvert(loc, funcTy.getInput(3),
1807                                            fir::getLen(*csi.ioMsg)));
1808     } else {
1809       args.push_back(builder.createNullConstant(loc, funcTy.getInput(2)));
1810       args.push_back(
1811           fir::factory::createZeroValue(builder, loc, funcTy.getInput(3)));
1812     }
1813     mlir::Value file = locToFilename(converter, loc, funcTy.getInput(4));
1814     mlir::Value line = locToLineNo(converter, loc, funcTy.getInput(5));
1815     args.push_back(file);
1816     args.push_back(line);
1817     auto checkCall = builder.create<fir::CallOp>(loc, check, args);
1818     if (csi.hasErrorConditionSpec()) {
1819       mlir::Value iostat = checkCall.getResult(0);
1820       mlir::Type iostatTy = iostat.getType();
1821       mlir::Value zero = fir::factory::createZeroValue(builder, loc, iostatTy);
1822       mlir::Value unitIsOK = builder.create<mlir::arith::CmpIOp>(
1823           loc, mlir::arith::CmpIPredicate::eq, iostat, zero);
1824       auto ifOp = builder.create<fir::IfOp>(loc, iostatTy, unitIsOK,
1825                                             /*withElseRegion=*/true);
1826       builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
1827       builder.create<fir::ResultOp>(loc, iostat);
1828       builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
1829       stmtCtx.pushScope();
1830       csi.bigUnitIfOp = ifOp;
1831     }
1832   }
1833   return builder.createConvert(loc, ty, rawUnit);
1834 }
1835 
1836 static mlir::Value genIOUnit(Fortran::lower::AbstractConverter &converter,
1837                              mlir::Location loc,
1838                              const Fortran::parser::IoUnit *iounit,
1839                              mlir::Type ty, ConditionSpecInfo &csi,
1840                              Fortran::lower::StatementContext &stmtCtx,
1841                              int defaultUnitNumber) {
1842   auto &builder = converter.getFirOpBuilder();
1843   if (iounit)
1844     if (auto *e = std::get_if<Fortran::parser::FileUnitNumber>(&iounit->u))
1845       return genIOUnitNumber(converter, loc, Fortran::semantics::GetExpr(*e),
1846                              ty, csi, stmtCtx);
1847   return builder.create<mlir::arith::ConstantOp>(
1848       loc, builder.getIntegerAttr(ty, defaultUnitNumber));
1849 }
1850 
1851 template <typename A>
1852 static mlir::Value
1853 getIOUnit(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1854           const A &stmt, mlir::Type ty, ConditionSpecInfo &csi,
1855           Fortran::lower::StatementContext &stmtCtx, int defaultUnitNumber) {
1856   const Fortran::parser::IoUnit *iounit =
1857       stmt.iounit ? &*stmt.iounit : getIOControl<Fortran::parser::IoUnit>(stmt);
1858   return genIOUnit(converter, loc, iounit, ty, csi, stmtCtx, defaultUnitNumber);
1859 }
1860 //===----------------------------------------------------------------------===//
1861 // Generators for each IO statement type.
1862 //===----------------------------------------------------------------------===//
1863 
1864 template <typename K, typename S>
1865 static mlir::Value genBasicIOStmt(Fortran::lower::AbstractConverter &converter,
1866                                   const S &stmt) {
1867   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1868   Fortran::lower::StatementContext stmtCtx;
1869   mlir::Location loc = converter.getCurrentLocation();
1870   ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
1871   mlir::func::FuncOp beginFunc = getIORuntimeFunc<K>(loc, builder);
1872   mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
1873   mlir::Value unit = genIOUnitNumber(
1874       converter, loc, getExpr<Fortran::parser::FileUnitNumber>(stmt),
1875       beginFuncTy.getInput(0), csi, stmtCtx);
1876   mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit);
1877   mlir::Value file = locToFilename(converter, loc, beginFuncTy.getInput(1));
1878   mlir::Value line = locToLineNo(converter, loc, beginFuncTy.getInput(2));
1879   auto call = builder.create<fir::CallOp>(loc, beginFunc,
1880                                           mlir::ValueRange{un, file, line});
1881   mlir::Value cookie = call.getResult(0);
1882   genConditionHandlerCall(converter, loc, cookie, stmt.v, csi);
1883   mlir::Value ok;
1884   auto insertPt = builder.saveInsertionPoint();
1885   threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok);
1886   builder.restoreInsertionPoint(insertPt);
1887   return genEndIO(converter, converter.getCurrentLocation(), cookie, csi,
1888                   stmtCtx);
1889 }
1890 
1891 mlir::Value Fortran::lower::genBackspaceStatement(
1892     Fortran::lower::AbstractConverter &converter,
1893     const Fortran::parser::BackspaceStmt &stmt) {
1894   return genBasicIOStmt<mkIOKey(BeginBackspace)>(converter, stmt);
1895 }
1896 
1897 mlir::Value Fortran::lower::genEndfileStatement(
1898     Fortran::lower::AbstractConverter &converter,
1899     const Fortran::parser::EndfileStmt &stmt) {
1900   return genBasicIOStmt<mkIOKey(BeginEndfile)>(converter, stmt);
1901 }
1902 
1903 mlir::Value
1904 Fortran::lower::genFlushStatement(Fortran::lower::AbstractConverter &converter,
1905                                   const Fortran::parser::FlushStmt &stmt) {
1906   return genBasicIOStmt<mkIOKey(BeginFlush)>(converter, stmt);
1907 }
1908 
1909 mlir::Value
1910 Fortran::lower::genRewindStatement(Fortran::lower::AbstractConverter &converter,
1911                                    const Fortran::parser::RewindStmt &stmt) {
1912   return genBasicIOStmt<mkIOKey(BeginRewind)>(converter, stmt);
1913 }
1914 
1915 static mlir::Value
1916 genNewunitSpec(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1917                mlir::Value cookie,
1918                const std::list<Fortran::parser::ConnectSpec> &specList) {
1919   for (const auto &spec : specList)
1920     if (auto *newunit =
1921             std::get_if<Fortran::parser::ConnectSpec::Newunit>(&spec.u)) {
1922       Fortran::lower::StatementContext stmtCtx;
1923       fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1924       mlir::func::FuncOp ioFunc =
1925           getIORuntimeFunc<mkIOKey(GetNewUnit)>(loc, builder);
1926       mlir::FunctionType ioFuncTy = ioFunc.getFunctionType();
1927       const auto *var = Fortran::semantics::GetExpr(newunit->v);
1928       mlir::Value addr = builder.createConvert(
1929           loc, ioFuncTy.getInput(1),
1930           fir::getBase(converter.genExprAddr(loc, var, stmtCtx)));
1931       auto kind = builder.createIntegerConstant(loc, ioFuncTy.getInput(2),
1932                                                 var->GetType().value().kind());
1933       llvm::SmallVector<mlir::Value> ioArgs = {cookie, addr, kind};
1934       return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
1935     }
1936   llvm_unreachable("missing Newunit spec");
1937 }
1938 
1939 mlir::Value
1940 Fortran::lower::genOpenStatement(Fortran::lower::AbstractConverter &converter,
1941                                  const Fortran::parser::OpenStmt &stmt) {
1942   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1943   Fortran::lower::StatementContext stmtCtx;
1944   mlir::func::FuncOp beginFunc;
1945   llvm::SmallVector<mlir::Value> beginArgs;
1946   mlir::Location loc = converter.getCurrentLocation();
1947   ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
1948   bool hasNewunitSpec = false;
1949   if (hasSpec<Fortran::parser::FileUnitNumber>(stmt)) {
1950     beginFunc = getIORuntimeFunc<mkIOKey(BeginOpenUnit)>(loc, builder);
1951     mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
1952     mlir::Value unit = genIOUnitNumber(
1953         converter, loc, getExpr<Fortran::parser::FileUnitNumber>(stmt),
1954         beginFuncTy.getInput(0), csi, stmtCtx);
1955     beginArgs.push_back(unit);
1956     beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(1)));
1957     beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(2)));
1958   } else {
1959     hasNewunitSpec = hasSpec<Fortran::parser::ConnectSpec::Newunit>(stmt);
1960     assert(hasNewunitSpec && "missing unit specifier");
1961     beginFunc = getIORuntimeFunc<mkIOKey(BeginOpenNewUnit)>(loc, builder);
1962     mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
1963     beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(0)));
1964     beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(1)));
1965   }
1966   auto cookie =
1967       builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0);
1968   genConditionHandlerCall(converter, loc, cookie, stmt.v, csi);
1969   mlir::Value ok;
1970   auto insertPt = builder.saveInsertionPoint();
1971   threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok);
1972   if (hasNewunitSpec)
1973     genNewunitSpec(converter, loc, cookie, stmt.v);
1974   builder.restoreInsertionPoint(insertPt);
1975   return genEndIO(converter, loc, cookie, csi, stmtCtx);
1976 }
1977 
1978 mlir::Value
1979 Fortran::lower::genCloseStatement(Fortran::lower::AbstractConverter &converter,
1980                                   const Fortran::parser::CloseStmt &stmt) {
1981   return genBasicIOStmt<mkIOKey(BeginClose)>(converter, stmt);
1982 }
1983 
1984 mlir::Value
1985 Fortran::lower::genWaitStatement(Fortran::lower::AbstractConverter &converter,
1986                                  const Fortran::parser::WaitStmt &stmt) {
1987   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1988   Fortran::lower::StatementContext stmtCtx;
1989   mlir::Location loc = converter.getCurrentLocation();
1990   ConditionSpecInfo csi = lowerErrorSpec(converter, loc, stmt.v);
1991   bool hasId = hasSpec<Fortran::parser::IdExpr>(stmt);
1992   mlir::func::FuncOp beginFunc =
1993       hasId ? getIORuntimeFunc<mkIOKey(BeginWait)>(loc, builder)
1994             : getIORuntimeFunc<mkIOKey(BeginWaitAll)>(loc, builder);
1995   mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
1996   mlir::Value unit = genIOUnitNumber(
1997       converter, loc, getExpr<Fortran::parser::FileUnitNumber>(stmt),
1998       beginFuncTy.getInput(0), csi, stmtCtx);
1999   llvm::SmallVector<mlir::Value> args{unit};
2000   if (hasId) {
2001     mlir::Value id = fir::getBase(converter.genExprValue(
2002         loc, getExpr<Fortran::parser::IdExpr>(stmt), stmtCtx));
2003     args.push_back(builder.createConvert(loc, beginFuncTy.getInput(1), id));
2004     args.push_back(locToFilename(converter, loc, beginFuncTy.getInput(2)));
2005     args.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(3)));
2006   } else {
2007     args.push_back(locToFilename(converter, loc, beginFuncTy.getInput(1)));
2008     args.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(2)));
2009   }
2010   auto cookie = builder.create<fir::CallOp>(loc, beginFunc, args).getResult(0);
2011   genConditionHandlerCall(converter, loc, cookie, stmt.v, csi);
2012   return genEndIO(converter, converter.getCurrentLocation(), cookie, csi,
2013                   stmtCtx);
2014 }
2015 
2016 //===----------------------------------------------------------------------===//
2017 // Data transfer statements.
2018 //
2019 // There are several dimensions to the API with regard to data transfer
2020 // statements that need to be considered.
2021 //
2022 //   - input (READ) vs. output (WRITE, PRINT)
2023 //   - unformatted vs. formatted vs. list vs. namelist
2024 //   - synchronous vs. asynchronous
2025 //   - external vs. internal
2026 //===----------------------------------------------------------------------===//
2027 
2028 // Get the begin data transfer IO function to call for the given values.
2029 template <bool isInput>
2030 mlir::func::FuncOp
2031 getBeginDataTransferFunc(mlir::Location loc, fir::FirOpBuilder &builder,
2032                          bool isFormatted, bool isListOrNml, bool isInternal,
2033                          bool isInternalWithDesc) {
2034   if constexpr (isInput) {
2035     if (isFormatted || isListOrNml) {
2036       if (isInternal) {
2037         if (isInternalWithDesc) {
2038           if (isListOrNml)
2039             return getIORuntimeFunc<mkIOKey(BeginInternalArrayListInput)>(
2040                 loc, builder);
2041           return getIORuntimeFunc<mkIOKey(BeginInternalArrayFormattedInput)>(
2042               loc, builder);
2043         }
2044         if (isListOrNml)
2045           return getIORuntimeFunc<mkIOKey(BeginInternalListInput)>(loc,
2046                                                                    builder);
2047         return getIORuntimeFunc<mkIOKey(BeginInternalFormattedInput)>(loc,
2048                                                                       builder);
2049       }
2050       if (isListOrNml)
2051         return getIORuntimeFunc<mkIOKey(BeginExternalListInput)>(loc, builder);
2052       return getIORuntimeFunc<mkIOKey(BeginExternalFormattedInput)>(loc,
2053                                                                     builder);
2054     }
2055     return getIORuntimeFunc<mkIOKey(BeginUnformattedInput)>(loc, builder);
2056   } else {
2057     if (isFormatted || isListOrNml) {
2058       if (isInternal) {
2059         if (isInternalWithDesc) {
2060           if (isListOrNml)
2061             return getIORuntimeFunc<mkIOKey(BeginInternalArrayListOutput)>(
2062                 loc, builder);
2063           return getIORuntimeFunc<mkIOKey(BeginInternalArrayFormattedOutput)>(
2064               loc, builder);
2065         }
2066         if (isListOrNml)
2067           return getIORuntimeFunc<mkIOKey(BeginInternalListOutput)>(loc,
2068                                                                     builder);
2069         return getIORuntimeFunc<mkIOKey(BeginInternalFormattedOutput)>(loc,
2070                                                                        builder);
2071       }
2072       if (isListOrNml)
2073         return getIORuntimeFunc<mkIOKey(BeginExternalListOutput)>(loc, builder);
2074       return getIORuntimeFunc<mkIOKey(BeginExternalFormattedOutput)>(loc,
2075                                                                      builder);
2076     }
2077     return getIORuntimeFunc<mkIOKey(BeginUnformattedOutput)>(loc, builder);
2078   }
2079 }
2080 
2081 /// Generate the arguments of a begin data transfer statement call.
2082 template <bool hasIOCtrl, int defaultUnitNumber, typename A>
2083 void genBeginDataTransferCallArgs(
2084     llvm::SmallVectorImpl<mlir::Value> &ioArgs,
2085     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2086     const A &stmt, mlir::FunctionType ioFuncTy, bool isFormatted,
2087     bool isListOrNml, [[maybe_unused]] bool isInternal,
2088     const std::optional<fir::ExtendedValue> &descRef, ConditionSpecInfo &csi,
2089     Fortran::lower::StatementContext &stmtCtx) {
2090   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2091   auto maybeGetFormatArgs = [&]() {
2092     if (!isFormatted || isListOrNml)
2093       return;
2094     std::tuple triple =
2095         getFormat(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()),
2096                   ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx);
2097     mlir::Value address = std::get<0>(triple);
2098     mlir::Value length = std::get<1>(triple);
2099     if (length) {
2100       // Scalar format: string arg + length arg; no format descriptor arg
2101       ioArgs.push_back(address); // format string
2102       ioArgs.push_back(length);  // format length
2103       ioArgs.push_back(
2104           builder.createNullConstant(loc, ioFuncTy.getInput(ioArgs.size())));
2105       return;
2106     }
2107     // Array format: no string arg, no length arg; format descriptor arg
2108     ioArgs.push_back(
2109         builder.createNullConstant(loc, ioFuncTy.getInput(ioArgs.size())));
2110     ioArgs.push_back(
2111         builder.createNullConstant(loc, ioFuncTy.getInput(ioArgs.size())));
2112     ioArgs.push_back( // format descriptor
2113         builder.createConvert(loc, ioFuncTy.getInput(ioArgs.size()), address));
2114   };
2115   if constexpr (hasIOCtrl) { // READ or WRITE
2116     if (isInternal) {
2117       // descriptor or scalar variable; maybe explicit format; scratch area
2118       if (descRef) {
2119         mlir::Value desc = builder.createBox(loc, *descRef);
2120         ioArgs.push_back(
2121             builder.createConvert(loc, ioFuncTy.getInput(ioArgs.size()), desc));
2122       } else {
2123         std::tuple<mlir::Value, mlir::Value> pair =
2124             getBuffer(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()),
2125                       ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx);
2126         ioArgs.push_back(std::get<0>(pair)); // scalar character variable
2127         ioArgs.push_back(std::get<1>(pair)); // character length
2128       }
2129       maybeGetFormatArgs();
2130       ioArgs.push_back( // internal scratch area buffer
2131           getDefaultScratch(builder, loc, ioFuncTy.getInput(ioArgs.size())));
2132       ioArgs.push_back( // buffer length
2133           getDefaultScratchLen(builder, loc, ioFuncTy.getInput(ioArgs.size())));
2134     } else { // external IO - maybe explicit format; unit
2135       maybeGetFormatArgs();
2136       ioArgs.push_back(getIOUnit(converter, loc, stmt,
2137                                  ioFuncTy.getInput(ioArgs.size()), csi, stmtCtx,
2138                                  defaultUnitNumber));
2139     }
2140   } else { // PRINT - maybe explicit format; default unit
2141     maybeGetFormatArgs();
2142     ioArgs.push_back(builder.create<mlir::arith::ConstantOp>(
2143         loc, builder.getIntegerAttr(ioFuncTy.getInput(ioArgs.size()),
2144                                     defaultUnitNumber)));
2145   }
2146   // File name and line number are always the last two arguments.
2147   ioArgs.push_back(
2148       locToFilename(converter, loc, ioFuncTy.getInput(ioArgs.size())));
2149   ioArgs.push_back(
2150       locToLineNo(converter, loc, ioFuncTy.getInput(ioArgs.size())));
2151 }
2152 
2153 template <bool isInput, bool hasIOCtrl = true, typename A>
2154 static mlir::Value
2155 genDataTransferStmt(Fortran::lower::AbstractConverter &converter,
2156                     const A &stmt) {
2157   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2158   Fortran::lower::StatementContext stmtCtx;
2159   mlir::Location loc = converter.getCurrentLocation();
2160   const bool isFormatted = isDataTransferFormatted(stmt);
2161   const bool isList = isFormatted ? isDataTransferList(stmt) : false;
2162   const bool isInternal = isDataTransferInternal(stmt);
2163   std::optional<fir::ExtendedValue> descRef =
2164       isInternal ? maybeGetInternalIODescriptor(converter, loc, stmt, stmtCtx)
2165                  : std::nullopt;
2166   const bool isInternalWithDesc = descRef.has_value();
2167   const bool isNml = isDataTransferNamelist(stmt);
2168   // Flang runtime currently implement asynchronous IO synchronously, so
2169   // asynchronous IO statements are lowered as regular IO statements
2170   // (except that GetAsynchronousId may be called to set the ID variable
2171   // and SetAsynchronous will be call to tell the runtime that this is supposed
2172   // to be (or not) an asynchronous IO statements).
2173 
2174   // Generate an EnableHandlers call and remaining specifier calls.
2175   ConditionSpecInfo csi;
2176   if constexpr (hasIOCtrl) {
2177     csi = lowerErrorSpec(converter, loc, stmt.controls);
2178   }
2179 
2180   // Generate the begin data transfer function call.
2181   mlir::func::FuncOp ioFunc = getBeginDataTransferFunc<isInput>(
2182       loc, builder, isFormatted, isList || isNml, isInternal,
2183       isInternalWithDesc);
2184   llvm::SmallVector<mlir::Value> ioArgs;
2185   genBeginDataTransferCallArgs<
2186       hasIOCtrl, isInput ? Fortran::runtime::io::DefaultInputUnit
2187                          : Fortran::runtime::io::DefaultOutputUnit>(
2188       ioArgs, converter, loc, stmt, ioFunc.getFunctionType(), isFormatted,
2189       isList || isNml, isInternal, descRef, csi, stmtCtx);
2190   mlir::Value cookie =
2191       builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0);
2192 
2193   auto insertPt = builder.saveInsertionPoint();
2194   mlir::Value ok;
2195   if constexpr (hasIOCtrl) {
2196     genConditionHandlerCall(converter, loc, cookie, stmt.controls, csi);
2197     threadSpecs(converter, loc, cookie, stmt.controls,
2198                 csi.hasErrorConditionSpec(), ok);
2199   }
2200 
2201   // Generate data transfer list calls.
2202   if constexpr (isInput) { // READ
2203     if (isNml)
2204       genNamelistIO(converter, cookie,
2205                     getIORuntimeFunc<mkIOKey(InputNamelist)>(loc, builder),
2206                     *getIOControl<Fortran::parser::Name>(stmt)->symbol,
2207                     csi.hasTransferConditionSpec(), ok, stmtCtx);
2208     else
2209       genInputItemList(converter, cookie, stmt.items, isFormatted,
2210                        csi.hasTransferConditionSpec(), ok, /*inLoop=*/false);
2211   } else if constexpr (std::is_same_v<A, Fortran::parser::WriteStmt>) {
2212     if (isNml)
2213       genNamelistIO(converter, cookie,
2214                     getIORuntimeFunc<mkIOKey(OutputNamelist)>(loc, builder),
2215                     *getIOControl<Fortran::parser::Name>(stmt)->symbol,
2216                     csi.hasTransferConditionSpec(), ok, stmtCtx);
2217     else
2218       genOutputItemList(converter, cookie, stmt.items, isFormatted,
2219                         csi.hasTransferConditionSpec(), ok,
2220                         /*inLoop=*/false);
2221   } else { // PRINT
2222     genOutputItemList(converter, cookie, std::get<1>(stmt.t), isFormatted,
2223                       csi.hasTransferConditionSpec(), ok,
2224                       /*inLoop=*/false);
2225   }
2226 
2227   builder.restoreInsertionPoint(insertPt);
2228   if constexpr (hasIOCtrl) {
2229     for (const auto &spec : stmt.controls)
2230       if (const auto *size =
2231               std::get_if<Fortran::parser::IoControlSpec::Size>(&spec.u)) {
2232         // This call is not conditional on the current IO status (ok) because
2233         // the size needs to be filled even if some error condition
2234         // (end-of-file...) was met during the input statement (in which case
2235         // the runtime may return zero for the size read).
2236         genIOGetVar<mkIOKey(GetSize)>(converter, loc, cookie, *size);
2237       } else if (const auto *idVar =
2238                      std::get_if<Fortran::parser::IdVariable>(&spec.u)) {
2239         genIOGetVar<mkIOKey(GetAsynchronousId)>(converter, loc, cookie, *idVar);
2240       }
2241   }
2242   // Generate end statement call/s.
2243   mlir::Value result = genEndIO(converter, loc, cookie, csi, stmtCtx);
2244   stmtCtx.finalizeAndReset();
2245   return result;
2246 }
2247 
2248 void Fortran::lower::genPrintStatement(
2249     Fortran::lower::AbstractConverter &converter,
2250     const Fortran::parser::PrintStmt &stmt) {
2251   // PRINT does not take an io-control-spec. It only has a format specifier, so
2252   // it is a simplified case of WRITE.
2253   genDataTransferStmt</*isInput=*/false, /*ioCtrl=*/false>(converter, stmt);
2254 }
2255 
2256 mlir::Value
2257 Fortran::lower::genWriteStatement(Fortran::lower::AbstractConverter &converter,
2258                                   const Fortran::parser::WriteStmt &stmt) {
2259   return genDataTransferStmt</*isInput=*/false>(converter, stmt);
2260 }
2261 
2262 mlir::Value
2263 Fortran::lower::genReadStatement(Fortran::lower::AbstractConverter &converter,
2264                                  const Fortran::parser::ReadStmt &stmt) {
2265   return genDataTransferStmt</*isInput=*/true>(converter, stmt);
2266 }
2267 
2268 /// Get the file expression from the inquire spec list. Also return if the
2269 /// expression is a file name.
2270 static std::pair<const Fortran::lower::SomeExpr *, bool>
2271 getInquireFileExpr(const std::list<Fortran::parser::InquireSpec> *stmt) {
2272   if (!stmt)
2273     return {nullptr, /*filename?=*/false};
2274   for (const Fortran::parser::InquireSpec &spec : *stmt) {
2275     if (auto *f = std::get_if<Fortran::parser::FileUnitNumber>(&spec.u))
2276       return {Fortran::semantics::GetExpr(*f), /*filename?=*/false};
2277     if (auto *f = std::get_if<Fortran::parser::FileNameExpr>(&spec.u))
2278       return {Fortran::semantics::GetExpr(*f), /*filename?=*/true};
2279   }
2280   // semantics should have already caught this condition
2281   llvm::report_fatal_error("inquire spec must have a file");
2282 }
2283 
2284 /// Generate calls to the four distinct INQUIRE subhandlers. An INQUIRE may
2285 /// return values of type CHARACTER, INTEGER, or LOGICAL. There is one
2286 /// additional special case for INQUIRE with both PENDING and ID specifiers.
2287 template <typename A>
2288 static mlir::Value genInquireSpec(Fortran::lower::AbstractConverter &converter,
2289                                   mlir::Location loc, mlir::Value cookie,
2290                                   mlir::Value idExpr, const A &var,
2291                                   Fortran::lower::StatementContext &stmtCtx) {
2292   // default case: do nothing
2293   return {};
2294 }
2295 /// Specialization for CHARACTER.
2296 template <>
2297 mlir::Value genInquireSpec<Fortran::parser::InquireSpec::CharVar>(
2298     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2299     mlir::Value cookie, mlir::Value idExpr,
2300     const Fortran::parser::InquireSpec::CharVar &var,
2301     Fortran::lower::StatementContext &stmtCtx) {
2302   // IOMSG is handled with exception conditions
2303   if (std::get<Fortran::parser::InquireSpec::CharVar::Kind>(var.t) ==
2304       Fortran::parser::InquireSpec::CharVar::Kind::Iomsg)
2305     return {};
2306   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2307   mlir::func::FuncOp specFunc =
2308       getIORuntimeFunc<mkIOKey(InquireCharacter)>(loc, builder);
2309   mlir::FunctionType specFuncTy = specFunc.getFunctionType();
2310   const auto *varExpr = Fortran::semantics::GetExpr(
2311       std::get<Fortran::parser::ScalarDefaultCharVariable>(var.t));
2312   fir::ExtendedValue str = converter.genExprAddr(loc, varExpr, stmtCtx);
2313   llvm::SmallVector<mlir::Value> args = {
2314       builder.createConvert(loc, specFuncTy.getInput(0), cookie),
2315       builder.createIntegerConstant(
2316           loc, specFuncTy.getInput(1),
2317           Fortran::runtime::io::HashInquiryKeyword(std::string{
2318               Fortran::parser::InquireSpec::CharVar::EnumToString(
2319                   std::get<Fortran::parser::InquireSpec::CharVar::Kind>(var.t))}
2320                                                        .c_str())),
2321       builder.createConvert(loc, specFuncTy.getInput(2), fir::getBase(str)),
2322       builder.createConvert(loc, specFuncTy.getInput(3), fir::getLen(str))};
2323   return builder.create<fir::CallOp>(loc, specFunc, args).getResult(0);
2324 }
2325 /// Specialization for INTEGER.
2326 template <>
2327 mlir::Value genInquireSpec<Fortran::parser::InquireSpec::IntVar>(
2328     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2329     mlir::Value cookie, mlir::Value idExpr,
2330     const Fortran::parser::InquireSpec::IntVar &var,
2331     Fortran::lower::StatementContext &stmtCtx) {
2332   // IOSTAT is handled with exception conditions
2333   if (std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t) ==
2334       Fortran::parser::InquireSpec::IntVar::Kind::Iostat)
2335     return {};
2336   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2337   mlir::func::FuncOp specFunc =
2338       getIORuntimeFunc<mkIOKey(InquireInteger64)>(loc, builder);
2339   mlir::FunctionType specFuncTy = specFunc.getFunctionType();
2340   const auto *varExpr = Fortran::semantics::GetExpr(
2341       std::get<Fortran::parser::ScalarIntVariable>(var.t));
2342   mlir::Value addr = fir::getBase(converter.genExprAddr(loc, varExpr, stmtCtx));
2343   mlir::Type eleTy = fir::dyn_cast_ptrEleTy(addr.getType());
2344   if (!eleTy)
2345     fir::emitFatalError(loc,
2346                         "internal error: expected a memory reference type");
2347   auto width = mlir::cast<mlir::IntegerType>(eleTy).getWidth();
2348   mlir::IndexType idxTy = builder.getIndexType();
2349   mlir::Value kind = builder.createIntegerConstant(loc, idxTy, width / 8);
2350   llvm::SmallVector<mlir::Value> args = {
2351       builder.createConvert(loc, specFuncTy.getInput(0), cookie),
2352       builder.createIntegerConstant(
2353           loc, specFuncTy.getInput(1),
2354           Fortran::runtime::io::HashInquiryKeyword(std::string{
2355               Fortran::parser::InquireSpec::IntVar::EnumToString(
2356                   std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t))}
2357                                                        .c_str())),
2358       builder.createConvert(loc, specFuncTy.getInput(2), addr),
2359       builder.createConvert(loc, specFuncTy.getInput(3), kind)};
2360   return builder.create<fir::CallOp>(loc, specFunc, args).getResult(0);
2361 }
2362 /// Specialization for LOGICAL and (PENDING + ID).
2363 template <>
2364 mlir::Value genInquireSpec<Fortran::parser::InquireSpec::LogVar>(
2365     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2366     mlir::Value cookie, mlir::Value idExpr,
2367     const Fortran::parser::InquireSpec::LogVar &var,
2368     Fortran::lower::StatementContext &stmtCtx) {
2369   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2370   auto logVarKind = std::get<Fortran::parser::InquireSpec::LogVar::Kind>(var.t);
2371   bool pendId =
2372       idExpr &&
2373       logVarKind == Fortran::parser::InquireSpec::LogVar::Kind::Pending;
2374   mlir::func::FuncOp specFunc =
2375       pendId ? getIORuntimeFunc<mkIOKey(InquirePendingId)>(loc, builder)
2376              : getIORuntimeFunc<mkIOKey(InquireLogical)>(loc, builder);
2377   mlir::FunctionType specFuncTy = specFunc.getFunctionType();
2378   mlir::Value addr = fir::getBase(converter.genExprAddr(
2379       loc,
2380       Fortran::semantics::GetExpr(
2381           std::get<Fortran::parser::Scalar<
2382               Fortran::parser::Logical<Fortran::parser::Variable>>>(var.t)),
2383       stmtCtx));
2384   llvm::SmallVector<mlir::Value> args = {
2385       builder.createConvert(loc, specFuncTy.getInput(0), cookie)};
2386   if (pendId)
2387     args.push_back(builder.createConvert(loc, specFuncTy.getInput(1), idExpr));
2388   else
2389     args.push_back(builder.createIntegerConstant(
2390         loc, specFuncTy.getInput(1),
2391         Fortran::runtime::io::HashInquiryKeyword(std::string{
2392             Fortran::parser::InquireSpec::LogVar::EnumToString(logVarKind)}
2393                                                      .c_str())));
2394   args.push_back(builder.createConvert(loc, specFuncTy.getInput(2), addr));
2395   auto call = builder.create<fir::CallOp>(loc, specFunc, args);
2396   boolRefToLogical(loc, builder, addr);
2397   return call.getResult(0);
2398 }
2399 
2400 /// If there is an IdExpr in the list of inquire-specs, then lower it and return
2401 /// the resulting Value. Otherwise, return null.
2402 static mlir::Value
2403 lowerIdExpr(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2404             const std::list<Fortran::parser::InquireSpec> &ispecs,
2405             Fortran::lower::StatementContext &stmtCtx) {
2406   for (const Fortran::parser::InquireSpec &spec : ispecs)
2407     if (mlir::Value v = Fortran::common::visit(
2408             Fortran::common::visitors{
2409                 [&](const Fortran::parser::IdExpr &idExpr) {
2410                   return fir::getBase(converter.genExprValue(
2411                       loc, Fortran::semantics::GetExpr(idExpr), stmtCtx));
2412                 },
2413                 [](const auto &) { return mlir::Value{}; }},
2414             spec.u))
2415       return v;
2416   return {};
2417 }
2418 
2419 /// For each inquire-spec, build the appropriate call, threading the cookie.
2420 static void threadInquire(Fortran::lower::AbstractConverter &converter,
2421                           mlir::Location loc, mlir::Value cookie,
2422                           const std::list<Fortran::parser::InquireSpec> &ispecs,
2423                           bool checkResult, mlir::Value &ok,
2424                           Fortran::lower::StatementContext &stmtCtx) {
2425   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2426   mlir::Value idExpr = lowerIdExpr(converter, loc, ispecs, stmtCtx);
2427   for (const Fortran::parser::InquireSpec &spec : ispecs) {
2428     makeNextConditionalOn(builder, loc, checkResult, ok);
2429     ok = Fortran::common::visit(Fortran::common::visitors{[&](const auto &x) {
2430                                   return genInquireSpec(converter, loc, cookie,
2431                                                         idExpr, x, stmtCtx);
2432                                 }},
2433                                 spec.u);
2434   }
2435 }
2436 
2437 mlir::Value Fortran::lower::genInquireStatement(
2438     Fortran::lower::AbstractConverter &converter,
2439     const Fortran::parser::InquireStmt &stmt) {
2440   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2441   Fortran::lower::StatementContext stmtCtx;
2442   mlir::Location loc = converter.getCurrentLocation();
2443   mlir::func::FuncOp beginFunc;
2444   llvm::SmallVector<mlir::Value> beginArgs;
2445   const auto *list =
2446       std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u);
2447   auto exprPair = getInquireFileExpr(list);
2448   auto inquireFileUnit = [&]() -> bool {
2449     return exprPair.first && !exprPair.second;
2450   };
2451   auto inquireFileName = [&]() -> bool {
2452     return exprPair.first && exprPair.second;
2453   };
2454 
2455   ConditionSpecInfo csi =
2456       list ? lowerErrorSpec(converter, loc, *list) : ConditionSpecInfo{};
2457 
2458   // Make one of three BeginInquire calls.
2459   if (inquireFileUnit()) {
2460     // Inquire by unit -- [UNIT=]file-unit-number.
2461     beginFunc = getIORuntimeFunc<mkIOKey(BeginInquireUnit)>(loc, builder);
2462     mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
2463     mlir::Value unit = genIOUnitNumber(converter, loc, exprPair.first,
2464                                        beginFuncTy.getInput(0), csi, stmtCtx);
2465     beginArgs = {unit, locToFilename(converter, loc, beginFuncTy.getInput(1)),
2466                  locToLineNo(converter, loc, beginFuncTy.getInput(2))};
2467   } else if (inquireFileName()) {
2468     // Inquire by file -- FILE=file-name-expr.
2469     beginFunc = getIORuntimeFunc<mkIOKey(BeginInquireFile)>(loc, builder);
2470     mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
2471     fir::ExtendedValue file =
2472         converter.genExprAddr(loc, exprPair.first, stmtCtx);
2473     beginArgs = {
2474         builder.createConvert(loc, beginFuncTy.getInput(0), fir::getBase(file)),
2475         builder.createConvert(loc, beginFuncTy.getInput(1), fir::getLen(file)),
2476         locToFilename(converter, loc, beginFuncTy.getInput(2)),
2477         locToLineNo(converter, loc, beginFuncTy.getInput(3))};
2478   } else {
2479     // Inquire by output list -- IOLENGTH=scalar-int-variable.
2480     const auto *ioLength =
2481         std::get_if<Fortran::parser::InquireStmt::Iolength>(&stmt.u);
2482     assert(ioLength && "must have an IOLENGTH specifier");
2483     beginFunc = getIORuntimeFunc<mkIOKey(BeginInquireIoLength)>(loc, builder);
2484     mlir::FunctionType beginFuncTy = beginFunc.getFunctionType();
2485     beginArgs = {locToFilename(converter, loc, beginFuncTy.getInput(0)),
2486                  locToLineNo(converter, loc, beginFuncTy.getInput(1))};
2487     auto cookie =
2488         builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0);
2489     mlir::Value ok;
2490     genOutputItemList(
2491         converter, cookie,
2492         std::get<std::list<Fortran::parser::OutputItem>>(ioLength->t),
2493         /*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false);
2494     auto *ioLengthVar = Fortran::semantics::GetExpr(
2495         std::get<Fortran::parser::ScalarIntVariable>(ioLength->t));
2496     mlir::Value ioLengthVarAddr =
2497         fir::getBase(converter.genExprAddr(loc, ioLengthVar, stmtCtx));
2498     llvm::SmallVector<mlir::Value> args = {cookie};
2499     mlir::Value length =
2500         builder
2501             .create<fir::CallOp>(
2502                 loc, getIORuntimeFunc<mkIOKey(GetIoLength)>(loc, builder), args)
2503             .getResult(0);
2504     mlir::Value length1 =
2505         builder.createConvert(loc, converter.genType(*ioLengthVar), length);
2506     builder.create<fir::StoreOp>(loc, length1, ioLengthVarAddr);
2507     return genEndIO(converter, loc, cookie, csi, stmtCtx);
2508   }
2509 
2510   // Common handling for inquire by unit or file.
2511   assert(list && "inquire-spec list must be present");
2512   auto cookie =
2513       builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0);
2514   genConditionHandlerCall(converter, loc, cookie, *list, csi);
2515   // Handle remaining arguments in specifier list.
2516   mlir::Value ok;
2517   auto insertPt = builder.saveInsertionPoint();
2518   threadInquire(converter, loc, cookie, *list, csi.hasErrorConditionSpec(), ok,
2519                 stmtCtx);
2520   builder.restoreInsertionPoint(insertPt);
2521   // Generate end statement call.
2522   return genEndIO(converter, loc, cookie, csi, stmtCtx);
2523 }
2524