1 //===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 //
9 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
10 //
11 //===----------------------------------------------------------------------===//
12 
13 #include "flang/Lower/Bridge.h"
14 #include "flang/Evaluate/tools.h"
15 #include "flang/Lower/Allocatable.h"
16 #include "flang/Lower/CallInterface.h"
17 #include "flang/Lower/ConvertExpr.h"
18 #include "flang/Lower/ConvertType.h"
19 #include "flang/Lower/ConvertVariable.h"
20 #include "flang/Lower/IO.h"
21 #include "flang/Lower/IterationSpace.h"
22 #include "flang/Lower/Mangler.h"
23 #include "flang/Lower/PFTBuilder.h"
24 #include "flang/Lower/Runtime.h"
25 #include "flang/Lower/StatementContext.h"
26 #include "flang/Lower/SymbolMap.h"
27 #include "flang/Lower/Todo.h"
28 #include "flang/Optimizer/Builder/BoxValue.h"
29 #include "flang/Optimizer/Builder/Character.h"
30 #include "flang/Optimizer/Builder/MutableBox.h"
31 #include "flang/Optimizer/Dialect/FIRAttr.h"
32 #include "flang/Optimizer/Support/FIRContext.h"
33 #include "flang/Optimizer/Support/InternalNames.h"
34 #include "flang/Runtime/iostat.h"
35 #include "flang/Semantics/tools.h"
36 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
37 #include "mlir/IR/PatternMatch.h"
38 #include "mlir/Transforms/RegionUtils.h"
39 #include "llvm/Support/CommandLine.h"
40 #include "llvm/Support/Debug.h"
41 
42 #define DEBUG_TYPE "flang-lower-bridge"
43 
44 static llvm::cl::opt<bool> dumpBeforeFir(
45     "fdebug-dump-pre-fir", llvm::cl::init(false),
46     llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation"));
47 
48 //===----------------------------------------------------------------------===//
49 // FirConverter
50 //===----------------------------------------------------------------------===//
51 
52 namespace {
53 
54 /// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR.
55 class FirConverter : public Fortran::lower::AbstractConverter {
56 public:
57   explicit FirConverter(Fortran::lower::LoweringBridge &bridge)
58       : bridge{bridge}, foldingContext{bridge.createFoldingContext()} {}
59   virtual ~FirConverter() = default;
60 
61   /// Convert the PFT to FIR.
62   void run(Fortran::lower::pft::Program &pft) {
63     // Primary translation pass.
64     //  - Declare all functions that have definitions so that definition
65     //    signatures prevail over call site signatures.
66     //  - Define module variables and OpenMP/OpenACC declarative construct so
67     //    that they are available before lowering any function that may use
68     //    them.
69     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
70       std::visit(Fortran::common::visitors{
71                      [&](Fortran::lower::pft::FunctionLikeUnit &f) {
72                        declareFunction(f);
73                      },
74                      [&](Fortran::lower::pft::ModuleLikeUnit &m) {
75                        lowerModuleDeclScope(m);
76                        for (Fortran::lower::pft::FunctionLikeUnit &f :
77                             m.nestedFunctions)
78                          declareFunction(f);
79                      },
80                      [&](Fortran::lower::pft::BlockDataUnit &b) {},
81                      [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {
82                        setCurrentPosition(
83                            d.get<Fortran::parser::CompilerDirective>().source);
84                        mlir::emitWarning(toLocation(),
85                                          "ignoring all compiler directives");
86                      },
87                  },
88                  u);
89     }
90 
91     // Primary translation pass.
92     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
93       std::visit(
94           Fortran::common::visitors{
95               [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); },
96               [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); },
97               [&](Fortran::lower::pft::BlockDataUnit &b) {},
98               [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
99           },
100           u);
101     }
102   }
103 
104   /// Declare a function.
105   void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
106     setCurrentPosition(funit.getStartingSourceLoc());
107     for (int entryIndex = 0, last = funit.entryPointList.size();
108          entryIndex < last; ++entryIndex) {
109       funit.setActiveEntry(entryIndex);
110       // Calling CalleeInterface ctor will build a declaration mlir::FuncOp with
111       // no other side effects.
112       // TODO: when doing some compiler profiling on real apps, it may be worth
113       // to check it's better to save the CalleeInterface instead of recomputing
114       // it later when lowering the body. CalleeInterface ctor should be linear
115       // with the number of arguments, so it is not awful to do it that way for
116       // now, but the linear coefficient might be non negligible. Until
117       // measured, stick to the solution that impacts the code less.
118       Fortran::lower::CalleeInterface{funit, *this};
119     }
120     funit.setActiveEntry(0);
121 
122     // Compute the set of host associated entities from the nested functions.
123     llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost;
124     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
125       collectHostAssociatedVariables(f, escapeHost);
126     funit.setHostAssociatedSymbols(escapeHost);
127 
128     // Declare internal procedures
129     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
130       declareFunction(f);
131   }
132 
133   /// Collects the canonical list of all host associated symbols. These bindings
134   /// must be aggregated into a tuple which can then be added to each of the
135   /// internal procedure declarations and passed at each call site.
136   void collectHostAssociatedVariables(
137       Fortran::lower::pft::FunctionLikeUnit &funit,
138       llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) {
139     const Fortran::semantics::Scope *internalScope =
140         funit.getSubprogramSymbol().scope();
141     assert(internalScope && "internal procedures symbol must create a scope");
142     auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) {
143       const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
144       const auto *namelistDetails =
145           ultimate.detailsIf<Fortran::semantics::NamelistDetails>();
146       if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() ||
147           Fortran::semantics::IsProcedurePointer(ultimate) ||
148           Fortran::semantics::IsDummy(sym) || namelistDetails) {
149         const Fortran::semantics::Scope &ultimateScope = ultimate.owner();
150         if (ultimateScope.kind() ==
151                 Fortran::semantics::Scope::Kind::MainProgram ||
152             ultimateScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
153           if (ultimateScope != *internalScope &&
154               ultimateScope.Contains(*internalScope)) {
155             if (namelistDetails) {
156               // So far, namelist symbols are processed on the fly in IO and
157               // the related namelist data structure is not added to the symbol
158               // map, so it cannot be passed to the internal procedures.
159               // Instead, all the symbols of the host namelist used in the
160               // internal procedure must be considered as host associated so
161               // that IO lowering can find them when needed.
162               for (const auto &namelistObject : namelistDetails->objects())
163                 escapees.insert(&*namelistObject);
164             } else {
165               escapees.insert(&ultimate);
166             }
167           }
168       }
169     };
170     Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee);
171   }
172 
173   //===--------------------------------------------------------------------===//
174   // AbstractConverter overrides
175   //===--------------------------------------------------------------------===//
176 
177   mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {
178     return lookupSymbol(sym).getAddr();
179   }
180 
181   mlir::Value impliedDoBinding(llvm::StringRef name) override final {
182     mlir::Value val = localSymbols.lookupImpliedDo(name);
183     if (!val)
184       fir::emitFatalError(toLocation(), "ac-do-variable has no binding");
185     return val;
186   }
187 
188   bool lookupLabelSet(Fortran::lower::SymbolRef sym,
189                       Fortran::lower::pft::LabelSet &labelSet) override final {
190     Fortran::lower::pft::FunctionLikeUnit &owningProc =
191         *getEval().getOwningProcedure();
192     auto iter = owningProc.assignSymbolLabelMap.find(sym);
193     if (iter == owningProc.assignSymbolLabelMap.end())
194       return false;
195     labelSet = iter->second;
196     return true;
197   }
198 
199   Fortran::lower::pft::Evaluation *
200   lookupLabel(Fortran::lower::pft::Label label) override final {
201     Fortran::lower::pft::FunctionLikeUnit &owningProc =
202         *getEval().getOwningProcedure();
203     auto iter = owningProc.labelEvaluationMap.find(label);
204     if (iter == owningProc.labelEvaluationMap.end())
205       return nullptr;
206     return iter->second;
207   }
208 
209   fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr,
210                                  Fortran::lower::StatementContext &context,
211                                  mlir::Location *loc = nullptr) override final {
212     return createSomeExtendedAddress(loc ? *loc : toLocation(), *this, expr,
213                                      localSymbols, context);
214   }
215   fir::ExtendedValue
216   genExprValue(const Fortran::lower::SomeExpr &expr,
217                Fortran::lower::StatementContext &context,
218                mlir::Location *loc = nullptr) override final {
219     return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr,
220                                         localSymbols, context);
221   }
222   fir::MutableBoxValue
223   genExprMutableBox(mlir::Location loc,
224                     const Fortran::lower::SomeExpr &expr) override final {
225     return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
226   }
227   fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr,
228                                 Fortran::lower::StatementContext &context,
229                                 mlir::Location loc) override final {
230     if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
231         !Fortran::evaluate::HasVectorSubscript(expr))
232       return Fortran::lower::createSomeArrayBox(*this, expr, localSymbols,
233                                                 context);
234     return fir::BoxValue(
235         builder->createBox(loc, genExprAddr(expr, context, &loc)));
236   }
237 
238   Fortran::evaluate::FoldingContext &getFoldingContext() override final {
239     return foldingContext;
240   }
241 
242   mlir::Type genType(const Fortran::evaluate::DataRef &) override final {
243     TODO_NOLOC("Not implemented genType DataRef. Needed for more complex "
244                "expression lowering");
245   }
246   mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final {
247     return Fortran::lower::translateSomeExprToFIRType(*this, expr);
248   }
249   mlir::Type genType(Fortran::lower::SymbolRef sym) override final {
250     return Fortran::lower::translateSymbolToFIRType(*this, sym);
251   }
252   mlir::Type genType(Fortran::common::TypeCategory tc) override final {
253     TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex "
254                "expression lowering");
255   }
256   mlir::Type
257   genType(Fortran::common::TypeCategory tc, int kind,
258           llvm::ArrayRef<std::int64_t> lenParameters) override final {
259     return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,
260                                       lenParameters);
261   }
262   mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
263     return Fortran::lower::translateVariableToFIRType(*this, var);
264   }
265 
266   void setCurrentPosition(const Fortran::parser::CharBlock &position) {
267     if (position != Fortran::parser::CharBlock{})
268       currentPosition = position;
269   }
270 
271   //===--------------------------------------------------------------------===//
272   // Utility methods
273   //===--------------------------------------------------------------------===//
274 
275   /// Convert a parser CharBlock to a Location
276   mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {
277     return genLocation(cb);
278   }
279 
280   mlir::Location toLocation() { return toLocation(currentPosition); }
281   void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {
282     evalPtr = &eval;
283   }
284   Fortran::lower::pft::Evaluation &getEval() {
285     assert(evalPtr && "current evaluation not set");
286     return *evalPtr;
287   }
288 
289   mlir::Location getCurrentLocation() override final { return toLocation(); }
290 
291   /// Generate a dummy location.
292   mlir::Location genUnknownLocation() override final {
293     // Note: builder may not be instantiated yet
294     return mlir::UnknownLoc::get(&getMLIRContext());
295   }
296 
297   /// Generate a `Location` from the `CharBlock`.
298   mlir::Location
299   genLocation(const Fortran::parser::CharBlock &block) override final {
300     if (const Fortran::parser::AllCookedSources *cooked =
301             bridge.getCookedSource()) {
302       if (std::optional<std::pair<Fortran::parser::SourcePosition,
303                                   Fortran::parser::SourcePosition>>
304               loc = cooked->GetSourcePositionRange(block)) {
305         // loc is a pair (begin, end); use the beginning position
306         Fortran::parser::SourcePosition &filePos = loc->first;
307         return mlir::FileLineColLoc::get(&getMLIRContext(), filePos.file.path(),
308                                          filePos.line, filePos.column);
309       }
310     }
311     return genUnknownLocation();
312   }
313 
314   fir::FirOpBuilder &getFirOpBuilder() override final { return *builder; }
315 
316   mlir::ModuleOp &getModuleOp() override final { return bridge.getModule(); }
317 
318   mlir::MLIRContext &getMLIRContext() override final {
319     return bridge.getMLIRContext();
320   }
321   std::string
322   mangleName(const Fortran::semantics::Symbol &symbol) override final {
323     return Fortran::lower::mangle::mangleName(symbol);
324   }
325 
326   const fir::KindMapping &getKindMap() override final {
327     return bridge.getKindMap();
328   }
329 
330   /// Return the predicate: "current block does not have a terminator branch".
331   bool blockIsUnterminated() {
332     mlir::Block *currentBlock = builder->getBlock();
333     return currentBlock->empty() ||
334            !currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();
335   }
336 
337   /// Unconditionally switch code insertion to a new block.
338   void startBlock(mlir::Block *newBlock) {
339     assert(newBlock && "missing block");
340     // Default termination for the current block is a fallthrough branch to
341     // the new block.
342     if (blockIsUnterminated())
343       genFIRBranch(newBlock);
344     // Some blocks may be re/started more than once, and might not be empty.
345     // If the new block already has (only) a terminator, set the insertion
346     // point to the start of the block.  Otherwise set it to the end.
347     // Note that setting the insertion point causes the subsequent function
348     // call to check the existence of terminator in the newBlock.
349     builder->setInsertionPointToStart(newBlock);
350     if (blockIsUnterminated())
351       builder->setInsertionPointToEnd(newBlock);
352   }
353 
354   /// Conditionally switch code insertion to a new block.
355   void maybeStartBlock(mlir::Block *newBlock) {
356     if (newBlock)
357       startBlock(newBlock);
358   }
359 
360   /// Emit return and cleanup after the function has been translated.
361   void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
362     setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
363     if (funit.isMainProgram())
364       genExitRoutine();
365     else
366       genFIRProcedureExit(funit, funit.getSubprogramSymbol());
367     funit.finalBlock = nullptr;
368     LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n"
369                             << *builder->getFunction() << '\n');
370     // FIXME: Simplification should happen in a normal pass, not here.
371     mlir::IRRewriter rewriter(*builder);
372     (void)mlir::simplifyRegions(rewriter,
373                                 {builder->getRegion()}); // remove dead code
374     delete builder;
375     builder = nullptr;
376     hostAssocTuple = mlir::Value{};
377     localSymbols.clear();
378   }
379 
380   /// Map mlir function block arguments to the corresponding Fortran dummy
381   /// variables. When the result is passed as a hidden argument, the Fortran
382   /// result is also mapped. The symbol map is used to hold this mapping.
383   void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
384                             const Fortran::lower::CalleeInterface &callee) {
385     assert(builder && "require a builder object at this point");
386     using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
387     auto mapPassedEntity = [&](const auto arg) -> void {
388       if (arg.passBy == PassBy::AddressAndLength) {
389         // TODO: now that fir call has some attributes regarding character
390         // return, PassBy::AddressAndLength should be retired.
391         mlir::Location loc = toLocation();
392         fir::factory::CharacterExprHelper charHelp{*builder, loc};
393         mlir::Value box =
394             charHelp.createEmboxChar(arg.firArgument, arg.firLength);
395         addSymbol(arg.entity->get(), box);
396       } else {
397         if (arg.entity.has_value()) {
398           addSymbol(arg.entity->get(), arg.firArgument);
399         } else {
400           assert(funit.parentHasHostAssoc());
401           funit.parentHostAssoc().internalProcedureBindings(*this,
402                                                             localSymbols);
403         }
404       }
405     };
406     for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
407          callee.getPassedArguments())
408       mapPassedEntity(arg);
409 
410     // Allocate local skeleton instances of dummies from other entry points.
411     // Most of these locals will not survive into final generated code, but
412     // some will.  It is illegal to reference them at run time if they do.
413     for (const Fortran::semantics::Symbol *arg :
414          funit.nonUniversalDummyArguments) {
415       if (lookupSymbol(*arg))
416         continue;
417       mlir::Type type = genType(*arg);
418       // TODO: Account for VALUE arguments (and possibly other variants).
419       type = builder->getRefType(type);
420       addSymbol(*arg, builder->create<fir::UndefOp>(toLocation(), type));
421     }
422     if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
423             passedResult = callee.getPassedResult()) {
424       mapPassedEntity(*passedResult);
425       // FIXME: need to make sure things are OK here. addSymbol may not be OK
426       if (funit.primaryResult &&
427           passedResult->entity->get() != *funit.primaryResult)
428         addSymbol(*funit.primaryResult,
429                   getSymbolAddress(passedResult->entity->get()));
430     }
431   }
432 
433   /// Instantiate variable \p var and add it to the symbol map.
434   /// See ConvertVariable.cpp.
435   void instantiateVar(const Fortran::lower::pft::Variable &var,
436                       Fortran::lower::AggregateStoreMap &storeMap) {
437     Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
438   }
439 
440   /// Prepare to translate a new function
441   void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
442     assert(!builder && "expected nullptr");
443     Fortran::lower::CalleeInterface callee(funit, *this);
444     mlir::FuncOp func = callee.addEntryBlockAndMapArguments();
445     func.setVisibility(mlir::SymbolTable::Visibility::Public);
446     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
447     assert(builder && "FirOpBuilder did not instantiate");
448     builder->setInsertionPointToStart(&func.front());
449 
450     mapDummiesAndResults(funit, callee);
451 
452     // Note: not storing Variable references because getOrderedSymbolTable
453     // below returns a temporary.
454     llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
455 
456     // Backup actual argument for entry character results
457     // with different lengths. It needs to be added to the non
458     // primary results symbol before mapSymbolAttributes is called.
459     Fortran::lower::SymbolBox resultArg;
460     if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
461             passedResult = callee.getPassedResult())
462       resultArg = lookupSymbol(passedResult->entity->get());
463 
464     Fortran::lower::AggregateStoreMap storeMap;
465     // The front-end is currently not adding module variables referenced
466     // in a module procedure as host associated. As a result we need to
467     // instantiate all module variables here if this is a module procedure.
468     // It is likely that the front-end behavior should change here.
469     // This also applies to internal procedures inside module procedures.
470     if (auto *module = Fortran::lower::pft::getAncestor<
471             Fortran::lower::pft::ModuleLikeUnit>(funit))
472       for (const Fortran::lower::pft::Variable &var :
473            module->getOrderedSymbolTable())
474         instantiateVar(var, storeMap);
475 
476     mlir::Value primaryFuncResultStorage;
477     for (const Fortran::lower::pft::Variable &var :
478          funit.getOrderedSymbolTable()) {
479       // Always instantiate aggregate storage blocks.
480       if (var.isAggregateStore()) {
481         instantiateVar(var, storeMap);
482         continue;
483       }
484       const Fortran::semantics::Symbol &sym = var.getSymbol();
485       if (funit.parentHasHostAssoc()) {
486         // Never instantitate host associated variables, as they are already
487         // instantiated from an argument tuple. Instead, just bind the symbol to
488         // the reference to the host variable, which must be in the map.
489         const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
490         if (funit.parentHostAssoc().isAssociated(ultimate)) {
491           Fortran::lower::SymbolBox hostBox =
492               localSymbols.lookupSymbol(ultimate);
493           assert(hostBox && "host association is not in map");
494           localSymbols.addSymbol(sym, hostBox.toExtendedValue());
495           continue;
496         }
497       }
498       if (!sym.IsFuncResult() || !funit.primaryResult) {
499         instantiateVar(var, storeMap);
500       } else if (&sym == funit.primaryResult) {
501         instantiateVar(var, storeMap);
502         primaryFuncResultStorage = getSymbolAddress(sym);
503       } else {
504         deferredFuncResultList.push_back(var);
505       }
506     }
507 
508     // If this is a host procedure with host associations, then create the tuple
509     // of pointers for passing to the internal procedures.
510     if (!funit.getHostAssoc().empty())
511       funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
512 
513     /// TODO: should use same mechanism as equivalence?
514     /// One blocking point is character entry returns that need special handling
515     /// since they are not locally allocated but come as argument. CHARACTER(*)
516     /// is not something that fit wells with equivalence lowering.
517     for (const Fortran::lower::pft::Variable &altResult :
518          deferredFuncResultList) {
519       if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
520               passedResult = callee.getPassedResult())
521         addSymbol(altResult.getSymbol(), resultArg.getAddr());
522       Fortran::lower::StatementContext stmtCtx;
523       Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
524                                           stmtCtx, primaryFuncResultStorage);
525     }
526 
527     // Create most function blocks in advance.
528     createEmptyGlobalBlocks(funit.evaluationList);
529 
530     // Reinstate entry block as the current insertion point.
531     builder->setInsertionPointToEnd(&func.front());
532 
533     if (callee.hasAlternateReturns()) {
534       // Create a local temp to hold the alternate return index.
535       // Give it an integer index type and the subroutine name (for dumps).
536       // Attach it to the subroutine symbol in the localSymbols map.
537       // Initialize it to zero, the "fallthrough" alternate return value.
538       const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
539       mlir::Location loc = toLocation();
540       mlir::Type idxTy = builder->getIndexType();
541       mlir::Value altResult =
542           builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
543       addSymbol(symbol, altResult);
544       mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
545       builder->create<fir::StoreOp>(loc, zero, altResult);
546     }
547 
548     if (Fortran::lower::pft::Evaluation *alternateEntryEval =
549             funit.getEntryEval())
550       genFIRBranch(alternateEntryEval->lexicalSuccessor->block);
551   }
552 
553   /// Create global blocks for the current function.  This eliminates the
554   /// distinction between forward and backward targets when generating
555   /// branches.  A block is "global" if it can be the target of a GOTO or
556   /// other source code branch.  A block that can only be targeted by a
557   /// compiler generated branch is "local".  For example, a DO loop preheader
558   /// block containing loop initialization code is global.  A loop header
559   /// block, which is the target of the loop back edge, is local.  Blocks
560   /// belong to a region.  Any block within a nested region must be replaced
561   /// with a block belonging to that region.  Branches may not cross region
562   /// boundaries.
563   void createEmptyGlobalBlocks(
564       std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
565     mlir::Region *region = &builder->getRegion();
566     for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
567       if (eval.isNewBlock)
568         eval.block = builder->createBlock(region);
569       if (eval.isConstruct() || eval.isDirective()) {
570         if (eval.lowerAsUnstructured()) {
571           createEmptyGlobalBlocks(eval.getNestedEvaluations());
572         } else if (eval.hasNestedEvaluations()) {
573           // A structured construct that is a target starts a new block.
574           Fortran::lower::pft::Evaluation &constructStmt =
575               eval.getFirstNestedEvaluation();
576           if (constructStmt.isNewBlock)
577             constructStmt.block = builder->createBlock(region);
578         }
579       }
580     }
581   }
582 
583   /// Lower a procedure (nest).
584   void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
585     if (!funit.isMainProgram()) {
586       const Fortran::semantics::Symbol &procSymbol =
587           funit.getSubprogramSymbol();
588       if (procSymbol.owner().IsSubmodule()) {
589         TODO(toLocation(), "support submodules");
590         return;
591       }
592     }
593     setCurrentPosition(funit.getStartingSourceLoc());
594     for (int entryIndex = 0, last = funit.entryPointList.size();
595          entryIndex < last; ++entryIndex) {
596       funit.setActiveEntry(entryIndex);
597       startNewFunction(funit); // the entry point for lowering this procedure
598       for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
599         genFIR(eval);
600       endNewFunction(funit);
601     }
602     funit.setActiveEntry(0);
603     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
604       lowerFunc(f); // internal procedure
605   }
606 
607   /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
608   /// declarative construct.
609   void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
610     // FIXME: get rid of the bogus function context and instantiate the
611     // globals directly into the module.
612     MLIRContext *context = &getMLIRContext();
613     setCurrentPosition(mod.getStartingSourceLoc());
614     mlir::FuncOp func = fir::FirOpBuilder::createFunction(
615         mlir::UnknownLoc::get(context), getModuleOp(),
616         fir::NameUniquer::doGenerated("ModuleSham"),
617         mlir::FunctionType::get(context, llvm::None, llvm::None));
618     func.addEntryBlock();
619     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
620     for (const Fortran::lower::pft::Variable &var :
621          mod.getOrderedSymbolTable()) {
622       // Only define the variables owned by this module.
623       const Fortran::semantics::Scope *owningScope = var.getOwningScope();
624       if (!owningScope || mod.getScope() == *owningScope)
625         Fortran::lower::defineModuleVariable(*this, var);
626     }
627     for (auto &eval : mod.evaluationList)
628       genFIR(eval);
629     if (mlir::Region *region = func.getCallableRegion())
630       region->dropAllReferences();
631     func.erase();
632     delete builder;
633     builder = nullptr;
634   }
635 
636   /// Lower functions contained in a module.
637   void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
638     for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions)
639       lowerFunc(f);
640   }
641 
642   mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
643 
644   /// Record a binding for the ssa-value of the tuple for this function.
645   void bindHostAssocTuple(mlir::Value val) override final {
646     assert(!hostAssocTuple && val);
647     hostAssocTuple = val;
648   }
649 
650 private:
651   FirConverter() = delete;
652   FirConverter(const FirConverter &) = delete;
653   FirConverter &operator=(const FirConverter &) = delete;
654 
655   //===--------------------------------------------------------------------===//
656   // Helper member functions
657   //===--------------------------------------------------------------------===//
658 
659   mlir::Value createFIRExpr(mlir::Location loc,
660                             const Fortran::lower::SomeExpr *expr,
661                             Fortran::lower::StatementContext &stmtCtx) {
662     return fir::getBase(genExprValue(*expr, stmtCtx, &loc));
663   }
664 
665   /// Find the symbol in the local map or return null.
666   Fortran::lower::SymbolBox
667   lookupSymbol(const Fortran::semantics::Symbol &sym) {
668     if (Fortran::lower::SymbolBox v = localSymbols.lookupSymbol(sym))
669       return v;
670     return {};
671   }
672 
673   /// Add the symbol to the local map and return `true`. If the symbol is
674   /// already in the map and \p forced is `false`, the map is not updated.
675   /// Instead the value `false` is returned.
676   bool addSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val,
677                  bool forced = false) {
678     if (!forced && lookupSymbol(sym))
679       return false;
680     localSymbols.addSymbol(sym, val, forced);
681     return true;
682   }
683 
684   bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {
685     return cat == Fortran::common::TypeCategory::Integer ||
686            cat == Fortran::common::TypeCategory::Real ||
687            cat == Fortran::common::TypeCategory::Complex ||
688            cat == Fortran::common::TypeCategory::Logical;
689   }
690   bool isCharacterCategory(Fortran::common::TypeCategory cat) {
691     return cat == Fortran::common::TypeCategory::Character;
692   }
693   bool isDerivedCategory(Fortran::common::TypeCategory cat) {
694     return cat == Fortran::common::TypeCategory::Derived;
695   }
696 
697   mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval,
698                             Fortran::parser::Label label) {
699     const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
700         eval.getOwningProcedure()->labelEvaluationMap;
701     const auto iter = labelEvaluationMap.find(label);
702     assert(iter != labelEvaluationMap.end() && "label missing from map");
703     mlir::Block *block = iter->second->block;
704     assert(block && "missing labeled evaluation block");
705     return block;
706   }
707 
708   void genFIRBranch(mlir::Block *targetBlock) {
709     assert(targetBlock && "missing unconditional target block");
710     builder->create<cf::BranchOp>(toLocation(), targetBlock);
711   }
712 
713   void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,
714                                mlir::Block *falseTarget) {
715     assert(trueTarget && "missing conditional branch true block");
716     assert(falseTarget && "missing conditional branch false block");
717     mlir::Location loc = toLocation();
718     mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);
719     builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, llvm::None,
720                                             falseTarget, llvm::None);
721   }
722   void genFIRConditionalBranch(mlir::Value cond,
723                                Fortran::lower::pft::Evaluation *trueTarget,
724                                Fortran::lower::pft::Evaluation *falseTarget) {
725     genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
726   }
727   void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
728                                mlir::Block *trueTarget,
729                                mlir::Block *falseTarget) {
730     Fortran::lower::StatementContext stmtCtx;
731     mlir::Value cond =
732         createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
733     stmtCtx.finalize();
734     genFIRConditionalBranch(cond, trueTarget, falseTarget);
735   }
736   void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
737                                Fortran::lower::pft::Evaluation *trueTarget,
738                                Fortran::lower::pft::Evaluation *falseTarget) {
739     Fortran::lower::StatementContext stmtCtx;
740     mlir::Value cond =
741         createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
742     stmtCtx.finalize();
743     genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
744   }
745 
746   //===--------------------------------------------------------------------===//
747   // Termination of symbolically referenced execution units
748   //===--------------------------------------------------------------------===//
749 
750   /// END of program
751   ///
752   /// Generate the cleanup block before the program exits
753   void genExitRoutine() {
754     if (blockIsUnterminated())
755       builder->create<mlir::func::ReturnOp>(toLocation());
756   }
757   void genFIR(const Fortran::parser::EndProgramStmt &) { genExitRoutine(); }
758 
759   /// END of procedure-like constructs
760   ///
761   /// Generate the cleanup block before the procedure exits
762   void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) {
763     const Fortran::semantics::Symbol &resultSym =
764         functionSymbol.get<Fortran::semantics::SubprogramDetails>().result();
765     Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym);
766     mlir::Location loc = toLocation();
767     if (!resultSymBox) {
768       mlir::emitError(loc, "failed lowering function return");
769       return;
770     }
771     mlir::Value resultVal = resultSymBox.match(
772         [&](const fir::CharBoxValue &x) -> mlir::Value {
773           return fir::factory::CharacterExprHelper{*builder, loc}
774               .createEmboxChar(x.getBuffer(), x.getLen());
775         },
776         [&](const auto &) -> mlir::Value {
777           mlir::Value resultRef = resultSymBox.getAddr();
778           mlir::Type resultType = genType(resultSym);
779           mlir::Type resultRefType = builder->getRefType(resultType);
780           // A function with multiple entry points returning different types
781           // tags all result variables with one of the largest types to allow
782           // them to share the same storage.  Convert this to the actual type.
783           if (resultRef.getType() != resultRefType)
784             TODO(loc, "Convert to actual type");
785           return builder->create<fir::LoadOp>(loc, resultRef);
786         });
787     builder->create<mlir::func::ReturnOp>(loc, resultVal);
788   }
789 
790   void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit,
791                            const Fortran::semantics::Symbol &symbol) {
792     if (mlir::Block *finalBlock = funit.finalBlock) {
793       // The current block must end with a terminator.
794       if (blockIsUnterminated())
795         builder->create<mlir::cf::BranchOp>(toLocation(), finalBlock);
796       // Set insertion point to final block.
797       builder->setInsertionPoint(finalBlock, finalBlock->end());
798     }
799     if (Fortran::semantics::IsFunction(symbol)) {
800       genReturnSymbol(symbol);
801     } else {
802       genExitRoutine();
803     }
804   }
805 
806   //
807   // Statements that have control-flow semantics
808   //
809 
810   /// Generate an If[Then]Stmt condition or its negation.
811   template <typename A>
812   mlir::Value genIfCondition(const A *stmt, bool negate = false) {
813     mlir::Location loc = toLocation();
814     Fortran::lower::StatementContext stmtCtx;
815     mlir::Value condExpr = createFIRExpr(
816         loc,
817         Fortran::semantics::GetExpr(
818             std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),
819         stmtCtx);
820     stmtCtx.finalize();
821     mlir::Value cond =
822         builder->createConvert(loc, builder->getI1Type(), condExpr);
823     if (negate)
824       cond = builder->create<mlir::arith::XOrIOp>(
825           loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1));
826     return cond;
827   }
828 
829   static bool
830   isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) {
831     return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
832            !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
833            !Fortran::evaluate::HasVectorSubscript(expr);
834   }
835 
836   [[maybe_unused]] static bool
837   isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
838     const Fortran::semantics::Symbol *sym =
839         Fortran::evaluate::GetFirstSymbol(expr);
840     return sym && sym->IsFuncResult();
841   }
842 
843   static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
844     const Fortran::semantics::Symbol *sym =
845         Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr);
846     return sym && Fortran::semantics::IsAllocatable(*sym);
847   }
848 
849   void genAssignment(const Fortran::evaluate::Assignment &assign) {
850     Fortran::lower::StatementContext stmtCtx;
851     mlir::Location loc = toLocation();
852     std::visit(
853         Fortran::common::visitors{
854             // [1] Plain old assignment.
855             [&](const Fortran::evaluate::Assignment::Intrinsic &) {
856               const Fortran::semantics::Symbol *sym =
857                   Fortran::evaluate::GetLastSymbol(assign.lhs);
858 
859               if (!sym)
860                 TODO(loc, "assignment to pointer result of function reference");
861 
862               std::optional<Fortran::evaluate::DynamicType> lhsType =
863                   assign.lhs.GetType();
864               assert(lhsType && "lhs cannot be typeless");
865               // Assignment to polymorphic allocatables may require changing the
866               // variable dynamic type (See Fortran 2018 10.2.1.3 p3).
867               if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs))
868                 TODO(loc, "assignment to polymorphic allocatable");
869 
870               // Note: No ad-hoc handling for pointers is required here. The
871               // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
872               // on a pointer returns the target address and not the address of
873               // the pointer variable.
874 
875               if (assign.lhs.Rank() > 0) {
876                 // Array assignment
877                 // See Fortran 2018 10.2.1.3 p5, p6, and p7
878                 genArrayAssignment(assign, stmtCtx);
879                 return;
880               }
881 
882               // Scalar assignment
883               const bool isNumericScalar =
884                   isNumericScalarCategory(lhsType->category());
885               fir::ExtendedValue rhs = isNumericScalar
886                                            ? genExprValue(assign.rhs, stmtCtx)
887                                            : genExprAddr(assign.rhs, stmtCtx);
888               bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs);
889               llvm::Optional<fir::factory::MutableBoxReallocation> lhsRealloc;
890               llvm::Optional<fir::MutableBoxValue> lhsMutableBox;
891               auto lhs = [&]() -> fir::ExtendedValue {
892                 if (lhsIsWholeAllocatable) {
893                   lhsMutableBox = genExprMutableBox(loc, assign.lhs);
894                   llvm::SmallVector<mlir::Value> lengthParams;
895                   if (const fir::CharBoxValue *charBox = rhs.getCharBox())
896                     lengthParams.push_back(charBox->getLen());
897                   else if (fir::isDerivedWithLengthParameters(rhs))
898                     TODO(loc, "assignment to derived type allocatable with "
899                               "length parameters");
900                   lhsRealloc = fir::factory::genReallocIfNeeded(
901                       *builder, loc, *lhsMutableBox,
902                       /*shape=*/llvm::None, lengthParams);
903                   return lhsRealloc->newValue;
904                 }
905                 return genExprAddr(assign.lhs, stmtCtx);
906               }();
907 
908               if (isNumericScalar) {
909                 // Fortran 2018 10.2.1.3 p8 and p9
910                 // Conversions should have been inserted by semantic analysis,
911                 // but they can be incorrect between the rhs and lhs. Correct
912                 // that here.
913                 mlir::Value addr = fir::getBase(lhs);
914                 mlir::Value val = fir::getBase(rhs);
915                 // A function with multiple entry points returning different
916                 // types tags all result variables with one of the largest
917                 // types to allow them to share the same storage.  Assignment
918                 // to a result variable of one of the other types requires
919                 // conversion to the actual type.
920                 mlir::Type toTy = genType(assign.lhs);
921                 mlir::Value cast =
922                     builder->convertWithSemantics(loc, toTy, val);
923                 if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) {
924                   assert(isFuncResultDesignator(assign.lhs) && "type mismatch");
925                   addr = builder->createConvert(
926                       toLocation(), builder->getRefType(toTy), addr);
927                 }
928                 builder->create<fir::StoreOp>(loc, cast, addr);
929               } else if (isCharacterCategory(lhsType->category())) {
930                 // Fortran 2018 10.2.1.3 p10 and p11
931                 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
932                     lhs, rhs);
933               } else if (isDerivedCategory(lhsType->category())) {
934                 TODO(toLocation(), "Derived type assignment");
935               } else {
936                 llvm_unreachable("unknown category");
937               }
938               if (lhsIsWholeAllocatable)
939                 fir::factory::finalizeRealloc(
940                     *builder, loc, lhsMutableBox.getValue(),
941                     /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false,
942                     lhsRealloc.getValue());
943             },
944 
945             // [2] User defined assignment. If the context is a scalar
946             // expression then call the procedure.
947             [&](const Fortran::evaluate::ProcedureRef &procRef) {
948               TODO(toLocation(), "User defined assignment");
949             },
950 
951             // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
952             // bounds-spec is a lower bound value.
953             [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
954               TODO(toLocation(),
955                    "Pointer assignment with possibly empty bounds-spec");
956             },
957 
958             // [4] Pointer assignment with bounds-remapping. R1036: a
959             // bounds-remapping is a pair, lower bound and upper bound.
960             [&](const Fortran::evaluate::Assignment::BoundsRemapping
961                     &boundExprs) {
962               TODO(toLocation(), "Pointer assignment with bounds-remapping");
963             },
964         },
965         assign.u);
966   }
967 
968   /// Lowering of CALL statement
969   void genFIR(const Fortran::parser::CallStmt &stmt) {
970     Fortran::lower::StatementContext stmtCtx;
971     setCurrentPosition(stmt.v.source);
972     assert(stmt.typedCall && "Call was not analyzed");
973     // Call statement lowering shares code with function call lowering.
974     mlir::Value res = Fortran::lower::createSubroutineCall(
975         *this, *stmt.typedCall, localSymbols, stmtCtx);
976     if (!res)
977       return; // "Normal" subroutine call.
978   }
979 
980   void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
981     Fortran::lower::StatementContext stmtCtx;
982     Fortran::lower::pft::Evaluation &eval = getEval();
983     mlir::Value selectExpr =
984         createFIRExpr(toLocation(),
985                       Fortran::semantics::GetExpr(
986                           std::get<Fortran::parser::ScalarIntExpr>(stmt.t)),
987                       stmtCtx);
988     stmtCtx.finalize();
989     llvm::SmallVector<int64_t> indexList;
990     llvm::SmallVector<mlir::Block *> blockList;
991     int64_t index = 0;
992     for (Fortran::parser::Label label :
993          std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
994       indexList.push_back(++index);
995       blockList.push_back(blockOfLabel(eval, label));
996     }
997     blockList.push_back(eval.nonNopSuccessor().block); // default
998     builder->create<fir::SelectOp>(toLocation(), selectExpr, indexList,
999                                    blockList);
1000   }
1001 
1002   void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
1003     Fortran::lower::StatementContext stmtCtx;
1004     Fortran::lower::pft::Evaluation &eval = getEval();
1005     mlir::Value expr = createFIRExpr(
1006         toLocation(),
1007         Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)),
1008         stmtCtx);
1009     stmtCtx.finalize();
1010     mlir::Type exprType = expr.getType();
1011     mlir::Location loc = toLocation();
1012     if (exprType.isSignlessInteger()) {
1013       // Arithmetic expression has Integer type.  Generate a SelectCaseOp
1014       // with ranges {(-inf:-1], 0=default, [1:inf)}.
1015       MLIRContext *context = builder->getContext();
1016       llvm::SmallVector<mlir::Attribute> attrList;
1017       llvm::SmallVector<mlir::Value> valueList;
1018       llvm::SmallVector<mlir::Block *> blockList;
1019       attrList.push_back(fir::UpperBoundAttr::get(context));
1020       valueList.push_back(builder->createIntegerConstant(loc, exprType, -1));
1021       blockList.push_back(blockOfLabel(eval, std::get<1>(stmt.t)));
1022       attrList.push_back(fir::LowerBoundAttr::get(context));
1023       valueList.push_back(builder->createIntegerConstant(loc, exprType, 1));
1024       blockList.push_back(blockOfLabel(eval, std::get<3>(stmt.t)));
1025       attrList.push_back(mlir::UnitAttr::get(context)); // 0 is the "default"
1026       blockList.push_back(blockOfLabel(eval, std::get<2>(stmt.t)));
1027       builder->create<fir::SelectCaseOp>(loc, expr, attrList, valueList,
1028                                          blockList);
1029       return;
1030     }
1031     // Arithmetic expression has Real type.  Generate
1032     //   sum = expr + expr  [ raise an exception if expr is a NaN ]
1033     //   if (sum < 0.0) goto L1 else if (sum > 0.0) goto L3 else goto L2
1034     auto sum = builder->create<mlir::arith::AddFOp>(loc, expr, expr);
1035     auto zero = builder->create<mlir::arith::ConstantOp>(
1036         loc, exprType, builder->getFloatAttr(exprType, 0.0));
1037     auto cond1 = builder->create<mlir::arith::CmpFOp>(
1038         loc, mlir::arith::CmpFPredicate::OLT, sum, zero);
1039     mlir::Block *elseIfBlock =
1040         builder->getBlock()->splitBlock(builder->getInsertionPoint());
1041     genFIRConditionalBranch(cond1, blockOfLabel(eval, std::get<1>(stmt.t)),
1042                             elseIfBlock);
1043     startBlock(elseIfBlock);
1044     auto cond2 = builder->create<mlir::arith::CmpFOp>(
1045         loc, mlir::arith::CmpFPredicate::OGT, sum, zero);
1046     genFIRConditionalBranch(cond2, blockOfLabel(eval, std::get<3>(stmt.t)),
1047                             blockOfLabel(eval, std::get<2>(stmt.t)));
1048   }
1049 
1050   void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
1051     // Program requirement 1990 8.2.4 -
1052     //
1053     //   At the time of execution of an assigned GOTO statement, the integer
1054     //   variable must be defined with the value of a statement label of a
1055     //   branch target statement that appears in the same scoping unit.
1056     //   Note that the variable may be defined with a statement label value
1057     //   only by an ASSIGN statement in the same scoping unit as the assigned
1058     //   GOTO statement.
1059 
1060     mlir::Location loc = toLocation();
1061     Fortran::lower::pft::Evaluation &eval = getEval();
1062     const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap =
1063         eval.getOwningProcedure()->assignSymbolLabelMap;
1064     const Fortran::semantics::Symbol &symbol =
1065         *std::get<Fortran::parser::Name>(stmt.t).symbol;
1066     auto selectExpr =
1067         builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol));
1068     auto iter = symbolLabelMap.find(symbol);
1069     if (iter == symbolLabelMap.end()) {
1070       // Fail for a nonconforming program unit that does not have any ASSIGN
1071       // statements.  The front end should check for this.
1072       mlir::emitError(loc, "(semantics issue) no assigned goto targets");
1073       exit(1);
1074     }
1075     auto labelSet = iter->second;
1076     llvm::SmallVector<int64_t> indexList;
1077     llvm::SmallVector<mlir::Block *> blockList;
1078     auto addLabel = [&](Fortran::parser::Label label) {
1079       indexList.push_back(label);
1080       blockList.push_back(blockOfLabel(eval, label));
1081     };
1082     // Add labels from an explicit list.  The list may have duplicates.
1083     for (Fortran::parser::Label label :
1084          std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
1085       if (labelSet.count(label) &&
1086           std::find(indexList.begin(), indexList.end(), label) ==
1087               indexList.end()) { // ignore duplicates
1088         addLabel(label);
1089       }
1090     }
1091     // Absent an explicit list, add all possible label targets.
1092     if (indexList.empty())
1093       for (auto &label : labelSet)
1094         addLabel(label);
1095     // Add a nop/fallthrough branch to the switch for a nonconforming program
1096     // unit that violates the program requirement above.
1097     blockList.push_back(eval.nonNopSuccessor().block); // default
1098     builder->create<fir::SelectOp>(loc, selectExpr, indexList, blockList);
1099   }
1100 
1101   void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
1102     TODO(toLocation(), "DoConstruct lowering");
1103   }
1104 
1105   void genFIR(const Fortran::parser::IfConstruct &) {
1106     mlir::Location loc = toLocation();
1107     Fortran::lower::pft::Evaluation &eval = getEval();
1108     if (eval.lowerAsStructured()) {
1109       // Structured fir.if nest.
1110       fir::IfOp topIfOp, currentIfOp;
1111       for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
1112         auto genIfOp = [&](mlir::Value cond) {
1113           auto ifOp = builder->create<fir::IfOp>(loc, cond, /*withElse=*/true);
1114           builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
1115           return ifOp;
1116         };
1117         if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
1118           topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
1119         } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
1120           topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
1121         } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
1122           builder->setInsertionPointToStart(
1123               &currentIfOp.getElseRegion().front());
1124           currentIfOp = genIfOp(genIfCondition(s));
1125         } else if (e.isA<Fortran::parser::ElseStmt>()) {
1126           builder->setInsertionPointToStart(
1127               &currentIfOp.getElseRegion().front());
1128         } else if (e.isA<Fortran::parser::EndIfStmt>()) {
1129           builder->setInsertionPointAfter(topIfOp);
1130         } else {
1131           genFIR(e, /*unstructuredContext=*/false);
1132         }
1133       }
1134       return;
1135     }
1136 
1137     // Unstructured branch sequence.
1138     for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
1139       auto genIfBranch = [&](mlir::Value cond) {
1140         if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit
1141           genFIRConditionalBranch(cond, e.parentConstruct->constructExit,
1142                                   e.controlSuccessor);
1143         else // non-empty block
1144           genFIRConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor);
1145       };
1146       if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
1147         maybeStartBlock(e.block);
1148         genIfBranch(genIfCondition(s, e.negateCondition));
1149       } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
1150         maybeStartBlock(e.block);
1151         genIfBranch(genIfCondition(s, e.negateCondition));
1152       } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
1153         startBlock(e.block);
1154         genIfBranch(genIfCondition(s));
1155       } else {
1156         genFIR(e);
1157       }
1158     }
1159   }
1160 
1161   void genFIR(const Fortran::parser::CaseConstruct &) {
1162     TODO(toLocation(), "CaseConstruct lowering");
1163   }
1164 
1165   void genFIR(const Fortran::parser::ConcurrentHeader &header) {
1166     TODO(toLocation(), "ConcurrentHeader lowering");
1167   }
1168 
1169   void genFIR(const Fortran::parser::ForallAssignmentStmt &stmt) {
1170     TODO(toLocation(), "ForallAssignmentStmt lowering");
1171   }
1172 
1173   void genFIR(const Fortran::parser::EndForallStmt &) {
1174     TODO(toLocation(), "EndForallStmt lowering");
1175   }
1176 
1177   void genFIR(const Fortran::parser::ForallStmt &) {
1178     TODO(toLocation(), "ForallStmt lowering");
1179   }
1180 
1181   void genFIR(const Fortran::parser::ForallConstruct &) {
1182     TODO(toLocation(), "ForallConstruct lowering");
1183   }
1184 
1185   void genFIR(const Fortran::parser::ForallConstructStmt &) {
1186     TODO(toLocation(), "ForallConstructStmt lowering");
1187   }
1188 
1189   void genFIR(const Fortran::parser::CompilerDirective &) {
1190     TODO(toLocation(), "CompilerDirective lowering");
1191   }
1192 
1193   void genFIR(const Fortran::parser::OpenACCConstruct &) {
1194     TODO(toLocation(), "OpenACCConstruct lowering");
1195   }
1196 
1197   void genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &) {
1198     TODO(toLocation(), "OpenACCDeclarativeConstruct lowering");
1199   }
1200 
1201   void genFIR(const Fortran::parser::OpenMPConstruct &) {
1202     TODO(toLocation(), "OpenMPConstruct lowering");
1203   }
1204 
1205   void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &) {
1206     TODO(toLocation(), "OpenMPDeclarativeConstruct lowering");
1207   }
1208 
1209   void genFIR(const Fortran::parser::SelectCaseStmt &) {
1210     TODO(toLocation(), "SelectCaseStmt lowering");
1211   }
1212 
1213   fir::ExtendedValue
1214   genAssociateSelector(const Fortran::lower::SomeExpr &selector,
1215                        Fortran::lower::StatementContext &stmtCtx) {
1216     return isArraySectionWithoutVectorSubscript(selector)
1217                ? Fortran::lower::createSomeArrayBox(*this, selector,
1218                                                     localSymbols, stmtCtx)
1219                : genExprAddr(selector, stmtCtx);
1220   }
1221 
1222   void genFIR(const Fortran::parser::AssociateConstruct &) {
1223     TODO(toLocation(), "AssociateConstruct lowering");
1224   }
1225 
1226   void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) {
1227     TODO(toLocation(), "BlockConstruct lowering");
1228   }
1229 
1230   void genFIR(const Fortran::parser::BlockStmt &) {
1231     TODO(toLocation(), "BlockStmt lowering");
1232   }
1233 
1234   void genFIR(const Fortran::parser::EndBlockStmt &) {
1235     TODO(toLocation(), "EndBlockStmt lowering");
1236   }
1237 
1238   void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {
1239     TODO(toLocation(), "ChangeTeamConstruct lowering");
1240   }
1241 
1242   void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) {
1243     TODO(toLocation(), "ChangeTeamStmt lowering");
1244   }
1245 
1246   void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) {
1247     TODO(toLocation(), "EndChangeTeamStmt lowering");
1248   }
1249 
1250   void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) {
1251     TODO(toLocation(), "CriticalConstruct lowering");
1252   }
1253 
1254   void genFIR(const Fortran::parser::CriticalStmt &) {
1255     TODO(toLocation(), "CriticalStmt lowering");
1256   }
1257 
1258   void genFIR(const Fortran::parser::EndCriticalStmt &) {
1259     TODO(toLocation(), "EndCriticalStmt lowering");
1260   }
1261 
1262   void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) {
1263     TODO(toLocation(), "SelectRankConstruct lowering");
1264   }
1265 
1266   void genFIR(const Fortran::parser::SelectRankStmt &) {
1267     TODO(toLocation(), "SelectRankStmt lowering");
1268   }
1269 
1270   void genFIR(const Fortran::parser::SelectRankCaseStmt &) {
1271     TODO(toLocation(), "SelectRankCaseStmt lowering");
1272   }
1273 
1274   void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {
1275     TODO(toLocation(), "SelectTypeConstruct lowering");
1276   }
1277 
1278   void genFIR(const Fortran::parser::SelectTypeStmt &) {
1279     TODO(toLocation(), "SelectTypeStmt lowering");
1280   }
1281 
1282   void genFIR(const Fortran::parser::TypeGuardStmt &) {
1283     TODO(toLocation(), "TypeGuardStmt lowering");
1284   }
1285 
1286   //===--------------------------------------------------------------------===//
1287   // IO statements (see io.h)
1288   //===--------------------------------------------------------------------===//
1289 
1290   void genFIR(const Fortran::parser::BackspaceStmt &stmt) {
1291     mlir::Value iostat = genBackspaceStatement(*this, stmt);
1292     genIoConditionBranches(getEval(), stmt.v, iostat);
1293   }
1294 
1295   void genFIR(const Fortran::parser::CloseStmt &stmt) {
1296     mlir::Value iostat = genCloseStatement(*this, stmt);
1297     genIoConditionBranches(getEval(), stmt.v, iostat);
1298   }
1299 
1300   void genFIR(const Fortran::parser::EndfileStmt &stmt) {
1301     mlir::Value iostat = genEndfileStatement(*this, stmt);
1302     genIoConditionBranches(getEval(), stmt.v, iostat);
1303   }
1304 
1305   void genFIR(const Fortran::parser::FlushStmt &stmt) {
1306     mlir::Value iostat = genFlushStatement(*this, stmt);
1307     genIoConditionBranches(getEval(), stmt.v, iostat);
1308   }
1309 
1310   void genFIR(const Fortran::parser::InquireStmt &stmt) {
1311     mlir::Value iostat = genInquireStatement(*this, stmt);
1312     if (const auto *specs =
1313             std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u))
1314       genIoConditionBranches(getEval(), *specs, iostat);
1315   }
1316 
1317   void genFIR(const Fortran::parser::OpenStmt &stmt) {
1318     mlir::Value iostat = genOpenStatement(*this, stmt);
1319     genIoConditionBranches(getEval(), stmt.v, iostat);
1320   }
1321 
1322   void genFIR(const Fortran::parser::PrintStmt &stmt) {
1323     genPrintStatement(*this, stmt);
1324   }
1325 
1326   void genFIR(const Fortran::parser::ReadStmt &stmt) {
1327     mlir::Value iostat = genReadStatement(*this, stmt);
1328     genIoConditionBranches(getEval(), stmt.controls, iostat);
1329   }
1330 
1331   void genFIR(const Fortran::parser::RewindStmt &stmt) {
1332     mlir::Value iostat = genRewindStatement(*this, stmt);
1333     genIoConditionBranches(getEval(), stmt.v, iostat);
1334   }
1335 
1336   void genFIR(const Fortran::parser::WaitStmt &stmt) {
1337     mlir::Value iostat = genWaitStatement(*this, stmt);
1338     genIoConditionBranches(getEval(), stmt.v, iostat);
1339   }
1340 
1341   void genFIR(const Fortran::parser::WriteStmt &stmt) {
1342     mlir::Value iostat = genWriteStatement(*this, stmt);
1343     genIoConditionBranches(getEval(), stmt.controls, iostat);
1344   }
1345 
1346   template <typename A>
1347   void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
1348                               const A &specList, mlir::Value iostat) {
1349     if (!iostat)
1350       return;
1351 
1352     mlir::Block *endBlock = nullptr;
1353     mlir::Block *eorBlock = nullptr;
1354     mlir::Block *errBlock = nullptr;
1355     for (const auto &spec : specList) {
1356       std::visit(Fortran::common::visitors{
1357                      [&](const Fortran::parser::EndLabel &label) {
1358                        endBlock = blockOfLabel(eval, label.v);
1359                      },
1360                      [&](const Fortran::parser::EorLabel &label) {
1361                        eorBlock = blockOfLabel(eval, label.v);
1362                      },
1363                      [&](const Fortran::parser::ErrLabel &label) {
1364                        errBlock = blockOfLabel(eval, label.v);
1365                      },
1366                      [](const auto &) {}},
1367                  spec.u);
1368     }
1369     if (!endBlock && !eorBlock && !errBlock)
1370       return;
1371 
1372     mlir::Location loc = toLocation();
1373     mlir::Type indexType = builder->getIndexType();
1374     mlir::Value selector = builder->createConvert(loc, indexType, iostat);
1375     llvm::SmallVector<int64_t> indexList;
1376     llvm::SmallVector<mlir::Block *> blockList;
1377     if (eorBlock) {
1378       indexList.push_back(Fortran::runtime::io::IostatEor);
1379       blockList.push_back(eorBlock);
1380     }
1381     if (endBlock) {
1382       indexList.push_back(Fortran::runtime::io::IostatEnd);
1383       blockList.push_back(endBlock);
1384     }
1385     if (errBlock) {
1386       indexList.push_back(0);
1387       blockList.push_back(eval.nonNopSuccessor().block);
1388       // ERR label statement is the default successor.
1389       blockList.push_back(errBlock);
1390     } else {
1391       // Fallthrough successor statement is the default successor.
1392       blockList.push_back(eval.nonNopSuccessor().block);
1393     }
1394     builder->create<fir::SelectOp>(loc, selector, indexList, blockList);
1395   }
1396 
1397   //===--------------------------------------------------------------------===//
1398   // Memory allocation and deallocation
1399   //===--------------------------------------------------------------------===//
1400 
1401   void genFIR(const Fortran::parser::AllocateStmt &stmt) {
1402     Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
1403   }
1404 
1405   void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
1406     Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
1407   }
1408 
1409   void genFIR(const Fortran::parser::NullifyStmt &stmt) {
1410     TODO(toLocation(), "NullifyStmt lowering");
1411   }
1412 
1413   //===--------------------------------------------------------------------===//
1414 
1415   void genFIR(const Fortran::parser::EventPostStmt &stmt) {
1416     TODO(toLocation(), "EventPostStmt lowering");
1417   }
1418 
1419   void genFIR(const Fortran::parser::EventWaitStmt &stmt) {
1420     TODO(toLocation(), "EventWaitStmt lowering");
1421   }
1422 
1423   void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
1424     TODO(toLocation(), "FormTeamStmt lowering");
1425   }
1426 
1427   void genFIR(const Fortran::parser::LockStmt &stmt) {
1428     TODO(toLocation(), "LockStmt lowering");
1429   }
1430 
1431   /// Generate an array assignment.
1432   /// This is an assignment expression with rank > 0. The assignment may or may
1433   /// not be in a WHERE and/or FORALL context.
1434   void genArrayAssignment(const Fortran::evaluate::Assignment &assign,
1435                           Fortran::lower::StatementContext &stmtCtx) {
1436     if (isWholeAllocatable(assign.lhs)) {
1437       // Assignment to allocatables may require the lhs to be
1438       // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3
1439       Fortran::lower::createAllocatableArrayAssignment(
1440           *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
1441           localSymbols, stmtCtx);
1442       return;
1443     }
1444 
1445     // No masks and the iteration space is implied by the array, so create a
1446     // simple array assignment.
1447     Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs,
1448                                               localSymbols, stmtCtx);
1449   }
1450 
1451   void genFIR(const Fortran::parser::WhereConstruct &c) {
1452     TODO(toLocation(), "WhereConstruct lowering");
1453   }
1454 
1455   void genFIR(const Fortran::parser::WhereBodyConstruct &body) {
1456     TODO(toLocation(), "WhereBodyConstruct lowering");
1457   }
1458 
1459   void genFIR(const Fortran::parser::WhereConstructStmt &stmt) {
1460     TODO(toLocation(), "WhereConstructStmt lowering");
1461   }
1462 
1463   void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {
1464     TODO(toLocation(), "MaskedElsewhere lowering");
1465   }
1466 
1467   void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) {
1468     TODO(toLocation(), "MaskedElsewhereStmt lowering");
1469   }
1470 
1471   void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) {
1472     TODO(toLocation(), "Elsewhere lowering");
1473   }
1474 
1475   void genFIR(const Fortran::parser::ElsewhereStmt &stmt) {
1476     TODO(toLocation(), "ElsewhereStmt lowering");
1477   }
1478 
1479   void genFIR(const Fortran::parser::EndWhereStmt &) {
1480     TODO(toLocation(), "EndWhereStmt lowering");
1481   }
1482 
1483   void genFIR(const Fortran::parser::WhereStmt &stmt) {
1484     TODO(toLocation(), "WhereStmt lowering");
1485   }
1486 
1487   void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) {
1488     TODO(toLocation(), "PointerAssignmentStmt lowering");
1489   }
1490 
1491   void genFIR(const Fortran::parser::AssignmentStmt &stmt) {
1492     genAssignment(*stmt.typedAssignment->v);
1493   }
1494 
1495   void genFIR(const Fortran::parser::SyncAllStmt &stmt) {
1496     TODO(toLocation(), "SyncAllStmt lowering");
1497   }
1498 
1499   void genFIR(const Fortran::parser::SyncImagesStmt &stmt) {
1500     TODO(toLocation(), "SyncImagesStmt lowering");
1501   }
1502 
1503   void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) {
1504     TODO(toLocation(), "SyncMemoryStmt lowering");
1505   }
1506 
1507   void genFIR(const Fortran::parser::SyncTeamStmt &stmt) {
1508     TODO(toLocation(), "SyncTeamStmt lowering");
1509   }
1510 
1511   void genFIR(const Fortran::parser::UnlockStmt &stmt) {
1512     TODO(toLocation(), "UnlockStmt lowering");
1513   }
1514 
1515   void genFIR(const Fortran::parser::AssignStmt &stmt) {
1516     const Fortran::semantics::Symbol &symbol =
1517         *std::get<Fortran::parser::Name>(stmt.t).symbol;
1518     mlir::Location loc = toLocation();
1519     mlir::Value labelValue = builder->createIntegerConstant(
1520         loc, genType(symbol), std::get<Fortran::parser::Label>(stmt.t));
1521     builder->create<fir::StoreOp>(loc, labelValue, getSymbolAddress(symbol));
1522   }
1523 
1524   void genFIR(const Fortran::parser::FormatStmt &) {
1525     TODO(toLocation(), "FormatStmt lowering");
1526   }
1527 
1528   void genFIR(const Fortran::parser::PauseStmt &stmt) {
1529     genPauseStatement(*this, stmt);
1530   }
1531 
1532   void genFIR(const Fortran::parser::FailImageStmt &stmt) {
1533     TODO(toLocation(), "FailImageStmt lowering");
1534   }
1535 
1536   // call STOP, ERROR STOP in runtime
1537   void genFIR(const Fortran::parser::StopStmt &stmt) {
1538     genStopStatement(*this, stmt);
1539   }
1540 
1541   void genFIR(const Fortran::parser::ReturnStmt &stmt) {
1542     Fortran::lower::pft::FunctionLikeUnit *funit =
1543         getEval().getOwningProcedure();
1544     assert(funit && "not inside main program, function or subroutine");
1545     if (funit->isMainProgram()) {
1546       genExitRoutine();
1547       return;
1548     }
1549     mlir::Location loc = toLocation();
1550     if (stmt.v) {
1551       TODO(loc, "Alternate return statement");
1552     }
1553     // Branch to the last block of the SUBROUTINE, which has the actual return.
1554     if (!funit->finalBlock) {
1555       mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
1556       funit->finalBlock = builder->createBlock(&builder->getRegion());
1557       builder->restoreInsertionPoint(insPt);
1558     }
1559     builder->create<mlir::cf::BranchOp>(loc, funit->finalBlock);
1560   }
1561 
1562   void genFIR(const Fortran::parser::CycleStmt &) {
1563     TODO(toLocation(), "CycleStmt lowering");
1564   }
1565 
1566   void genFIR(const Fortran::parser::ExitStmt &) {
1567     TODO(toLocation(), "ExitStmt lowering");
1568   }
1569 
1570   void genFIR(const Fortran::parser::GotoStmt &) {
1571     genFIRBranch(getEval().controlSuccessor->block);
1572   }
1573 
1574   void genFIR(const Fortran::parser::AssociateStmt &) {
1575     TODO(toLocation(), "AssociateStmt lowering");
1576   }
1577 
1578   void genFIR(const Fortran::parser::CaseStmt &) {
1579     TODO(toLocation(), "CaseStmt lowering");
1580   }
1581 
1582   void genFIR(const Fortran::parser::ElseIfStmt &) {
1583     TODO(toLocation(), "ElseIfStmt lowering");
1584   }
1585 
1586   void genFIR(const Fortran::parser::ElseStmt &) {
1587     TODO(toLocation(), "ElseStmt lowering");
1588   }
1589 
1590   void genFIR(const Fortran::parser::EndAssociateStmt &) {
1591     TODO(toLocation(), "EndAssociateStmt lowering");
1592   }
1593 
1594   void genFIR(const Fortran::parser::EndDoStmt &) {
1595     TODO(toLocation(), "EndDoStmt lowering");
1596   }
1597 
1598   void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {
1599     TODO(toLocation(), "EndMpSubprogramStmt lowering");
1600   }
1601 
1602   void genFIR(const Fortran::parser::EndSelectStmt &) {
1603     TODO(toLocation(), "EndSelectStmt lowering");
1604   }
1605 
1606   // Nop statements - No code, or code is generated at the construct level.
1607   void genFIR(const Fortran::parser::ContinueStmt &) {}      // nop
1608   void genFIR(const Fortran::parser::EndFunctionStmt &) {}   // nop
1609   void genFIR(const Fortran::parser::EndIfStmt &) {}         // nop
1610   void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
1611 
1612   void genFIR(const Fortran::parser::EntryStmt &) {
1613     TODO(toLocation(), "EntryStmt lowering");
1614   }
1615 
1616   void genFIR(const Fortran::parser::IfStmt &) {
1617     TODO(toLocation(), "IfStmt lowering");
1618   }
1619 
1620   void genFIR(const Fortran::parser::IfThenStmt &) {
1621     TODO(toLocation(), "IfThenStmt lowering");
1622   }
1623 
1624   void genFIR(const Fortran::parser::NonLabelDoStmt &) {
1625     TODO(toLocation(), "NonLabelDoStmt lowering");
1626   }
1627 
1628   void genFIR(const Fortran::parser::OmpEndLoopDirective &) {
1629     TODO(toLocation(), "OmpEndLoopDirective lowering");
1630   }
1631 
1632   void genFIR(const Fortran::parser::NamelistStmt &) {
1633     TODO(toLocation(), "NamelistStmt lowering");
1634   }
1635 
1636   void genFIR(Fortran::lower::pft::Evaluation &eval,
1637               bool unstructuredContext = true) {
1638     if (unstructuredContext) {
1639       // When transitioning from unstructured to structured code,
1640       // the structured code could be a target that starts a new block.
1641       maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured()
1642                           ? eval.getFirstNestedEvaluation().block
1643                           : eval.block);
1644     }
1645 
1646     setCurrentEval(eval);
1647     setCurrentPosition(eval.position);
1648     eval.visit([&](const auto &stmt) { genFIR(stmt); });
1649   }
1650 
1651   //===--------------------------------------------------------------------===//
1652 
1653   Fortran::lower::LoweringBridge &bridge;
1654   Fortran::evaluate::FoldingContext foldingContext;
1655   fir::FirOpBuilder *builder = nullptr;
1656   Fortran::lower::pft::Evaluation *evalPtr = nullptr;
1657   Fortran::lower::SymMap localSymbols;
1658   Fortran::parser::CharBlock currentPosition;
1659 
1660   /// Tuple of host assoicated variables.
1661   mlir::Value hostAssocTuple;
1662   Fortran::lower::ImplicitIterSpace implicitIterSpace;
1663   Fortran::lower::ExplicitIterSpace explicitIterSpace;
1664 };
1665 
1666 } // namespace
1667 
1668 Fortran::evaluate::FoldingContext
1669 Fortran::lower::LoweringBridge::createFoldingContext() const {
1670   return {getDefaultKinds(), getIntrinsicTable()};
1671 }
1672 
1673 void Fortran::lower::LoweringBridge::lower(
1674     const Fortran::parser::Program &prg,
1675     const Fortran::semantics::SemanticsContext &semanticsContext) {
1676   std::unique_ptr<Fortran::lower::pft::Program> pft =
1677       Fortran::lower::createPFT(prg, semanticsContext);
1678   if (dumpBeforeFir)
1679     Fortran::lower::dumpPFT(llvm::errs(), *pft);
1680   FirConverter converter{*this};
1681   converter.run(*pft);
1682 }
1683 
1684 Fortran::lower::LoweringBridge::LoweringBridge(
1685     mlir::MLIRContext &context,
1686     const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds,
1687     const Fortran::evaluate::IntrinsicProcTable &intrinsics,
1688     const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
1689     fir::KindMapping &kindMap)
1690     : defaultKinds{defaultKinds}, intrinsics{intrinsics}, cooked{&cooked},
1691       context{context}, kindMap{kindMap} {
1692   // Register the diagnostic handler.
1693   context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
1694     llvm::raw_ostream &os = llvm::errs();
1695     switch (diag.getSeverity()) {
1696     case mlir::DiagnosticSeverity::Error:
1697       os << "error: ";
1698       break;
1699     case mlir::DiagnosticSeverity::Remark:
1700       os << "info: ";
1701       break;
1702     case mlir::DiagnosticSeverity::Warning:
1703       os << "warning: ";
1704       break;
1705     default:
1706       break;
1707     }
1708     if (!diag.getLocation().isa<UnknownLoc>())
1709       os << diag.getLocation() << ": ";
1710     os << diag << '\n';
1711     os.flush();
1712     return mlir::success();
1713   });
1714 
1715   // Create the module and attach the attributes.
1716   module = std::make_unique<mlir::ModuleOp>(
1717       mlir::ModuleOp::create(mlir::UnknownLoc::get(&context)));
1718   assert(module.get() && "module was not created");
1719   fir::setTargetTriple(*module.get(), triple);
1720   fir::setKindMapping(*module.get(), kindMap);
1721 }
1722