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

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