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

source code of flang/lib/Lower/IO.cpp