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