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