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