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/Builder/Runtime/Ragged.h"
33 #include "flang/Optimizer/Dialect/FIRAttr.h"
34 #include "flang/Optimizer/Support/FIRContext.h"
35 #include "flang/Optimizer/Support/InternalNames.h"
36 #include "flang/Runtime/iostat.h"
37 #include "flang/Semantics/tools.h"
38 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
39 #include "mlir/IR/PatternMatch.h"
40 #include "mlir/Transforms/RegionUtils.h"
41 #include "llvm/Support/CommandLine.h"
42 #include "llvm/Support/Debug.h"
43 
44 #define DEBUG_TYPE "flang-lower-bridge"
45 
46 using namespace mlir;
47 
48 static llvm::cl::opt<bool> dumpBeforeFir(
49     "fdebug-dump-pre-fir", llvm::cl::init(false),
50     llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation"));
51 
52 //===----------------------------------------------------------------------===//
53 // FirConverter
54 //===----------------------------------------------------------------------===//
55 
56 namespace {
57 
58 /// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR.
59 class FirConverter : public Fortran::lower::AbstractConverter {
60 public:
61   explicit FirConverter(Fortran::lower::LoweringBridge &bridge)
62       : bridge{bridge}, foldingContext{bridge.createFoldingContext()} {}
63   virtual ~FirConverter() = default;
64 
65   /// Convert the PFT to FIR.
66   void run(Fortran::lower::pft::Program &pft) {
67     // Preliminary translation pass.
68     //  - Declare all functions that have definitions so that definition
69     //    signatures prevail over call site signatures.
70     //  - Define module variables and OpenMP/OpenACC declarative construct so
71     //    that they are available before lowering any function that may use
72     //    them.
73     //  - Translate block data programs so that common block definitions with
74     //    data initializations take precedence over other definitions.
75     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
76       std::visit(
77           Fortran::common::visitors{
78               [&](Fortran::lower::pft::FunctionLikeUnit &f) {
79                 declareFunction(f);
80               },
81               [&](Fortran::lower::pft::ModuleLikeUnit &m) {
82                 lowerModuleDeclScope(m);
83                 for (Fortran::lower::pft::FunctionLikeUnit &f :
84                      m.nestedFunctions)
85                   declareFunction(f);
86               },
87               [&](Fortran::lower::pft::BlockDataUnit &b) { lowerBlockData(b); },
88               [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
89           },
90           u);
91     }
92 
93     // Primary translation pass.
94     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
95       std::visit(
96           Fortran::common::visitors{
97               [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); },
98               [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); },
99               [&](Fortran::lower::pft::BlockDataUnit &b) {},
100               [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
101           },
102           u);
103     }
104   }
105 
106   /// Declare a function.
107   void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
108     setCurrentPosition(funit.getStartingSourceLoc());
109     for (int entryIndex = 0, last = funit.entryPointList.size();
110          entryIndex < last; ++entryIndex) {
111       funit.setActiveEntry(entryIndex);
112       // Calling CalleeInterface ctor will build a declaration mlir::FuncOp with
113       // no other side effects.
114       // TODO: when doing some compiler profiling on real apps, it may be worth
115       // to check it's better to save the CalleeInterface instead of recomputing
116       // it later when lowering the body. CalleeInterface ctor should be linear
117       // with the number of arguments, so it is not awful to do it that way for
118       // now, but the linear coefficient might be non negligible. Until
119       // measured, stick to the solution that impacts the code less.
120       Fortran::lower::CalleeInterface{funit, *this};
121     }
122     funit.setActiveEntry(0);
123 
124     // Compute the set of host associated entities from the nested functions.
125     llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost;
126     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
127       collectHostAssociatedVariables(f, escapeHost);
128     funit.setHostAssociatedSymbols(escapeHost);
129 
130     // Declare internal procedures
131     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
132       declareFunction(f);
133   }
134 
135   /// Collects the canonical list of all host associated symbols. These bindings
136   /// must be aggregated into a tuple which can then be added to each of the
137   /// internal procedure declarations and passed at each call site.
138   void collectHostAssociatedVariables(
139       Fortran::lower::pft::FunctionLikeUnit &funit,
140       llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) {
141     const Fortran::semantics::Scope *internalScope =
142         funit.getSubprogramSymbol().scope();
143     assert(internalScope && "internal procedures symbol must create a scope");
144     auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) {
145       const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
146       const auto *namelistDetails =
147           ultimate.detailsIf<Fortran::semantics::NamelistDetails>();
148       if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() ||
149           Fortran::semantics::IsProcedurePointer(ultimate) ||
150           Fortran::semantics::IsDummy(sym) || namelistDetails) {
151         const Fortran::semantics::Scope &ultimateScope = ultimate.owner();
152         if (ultimateScope.kind() ==
153                 Fortran::semantics::Scope::Kind::MainProgram ||
154             ultimateScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
155           if (ultimateScope != *internalScope &&
156               ultimateScope.Contains(*internalScope)) {
157             if (namelistDetails) {
158               // So far, namelist symbols are processed on the fly in IO and
159               // the related namelist data structure is not added to the symbol
160               // map, so it cannot be passed to the internal procedures.
161               // Instead, all the symbols of the host namelist used in the
162               // internal procedure must be considered as host associated so
163               // that IO lowering can find them when needed.
164               for (const auto &namelistObject : namelistDetails->objects())
165                 escapees.insert(&*namelistObject);
166             } else {
167               escapees.insert(&ultimate);
168             }
169           }
170       }
171     };
172     Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee);
173   }
174 
175   //===--------------------------------------------------------------------===//
176   // AbstractConverter overrides
177   //===--------------------------------------------------------------------===//
178 
179   mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {
180     return lookupSymbol(sym).getAddr();
181   }
182 
183   mlir::Value impliedDoBinding(llvm::StringRef name) override final {
184     mlir::Value val = localSymbols.lookupImpliedDo(name);
185     if (!val)
186       fir::emitFatalError(toLocation(), "ac-do-variable has no binding");
187     return val;
188   }
189 
190   void copySymbolBinding(Fortran::lower::SymbolRef src,
191                          Fortran::lower::SymbolRef target) override final {
192     localSymbols.addSymbol(target, lookupSymbol(src).toExtendedValue());
193   }
194 
195   /// Add the symbol binding to the inner-most level of the symbol map and
196   /// return true if it is not already present. Otherwise, return false.
197   bool bindIfNewSymbol(Fortran::lower::SymbolRef sym,
198                        const fir::ExtendedValue &exval) {
199     if (shallowLookupSymbol(sym))
200       return false;
201     bindSymbol(sym, exval);
202     return true;
203   }
204 
205   void bindSymbol(Fortran::lower::SymbolRef sym,
206                   const fir::ExtendedValue &exval) override final {
207     localSymbols.addSymbol(sym, exval, /*forced=*/true);
208   }
209 
210   bool lookupLabelSet(Fortran::lower::SymbolRef sym,
211                       Fortran::lower::pft::LabelSet &labelSet) override final {
212     Fortran::lower::pft::FunctionLikeUnit &owningProc =
213         *getEval().getOwningProcedure();
214     auto iter = owningProc.assignSymbolLabelMap.find(sym);
215     if (iter == owningProc.assignSymbolLabelMap.end())
216       return false;
217     labelSet = iter->second;
218     return true;
219   }
220 
221   Fortran::lower::pft::Evaluation *
222   lookupLabel(Fortran::lower::pft::Label label) override final {
223     Fortran::lower::pft::FunctionLikeUnit &owningProc =
224         *getEval().getOwningProcedure();
225     auto iter = owningProc.labelEvaluationMap.find(label);
226     if (iter == owningProc.labelEvaluationMap.end())
227       return nullptr;
228     return iter->second;
229   }
230 
231   fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr,
232                                  Fortran::lower::StatementContext &context,
233                                  mlir::Location *loc = nullptr) override final {
234     return createSomeExtendedAddress(loc ? *loc : toLocation(), *this, expr,
235                                      localSymbols, context);
236   }
237   fir::ExtendedValue
238   genExprValue(const Fortran::lower::SomeExpr &expr,
239                Fortran::lower::StatementContext &context,
240                mlir::Location *loc = nullptr) override final {
241     return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr,
242                                         localSymbols, context);
243   }
244   fir::MutableBoxValue
245   genExprMutableBox(mlir::Location loc,
246                     const Fortran::lower::SomeExpr &expr) override final {
247     return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
248   }
249   fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr,
250                                 Fortran::lower::StatementContext &context,
251                                 mlir::Location loc) override final {
252     return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols,
253                                           context);
254   }
255 
256   Fortran::evaluate::FoldingContext &getFoldingContext() override final {
257     return foldingContext;
258   }
259 
260   mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final {
261     return Fortran::lower::translateSomeExprToFIRType(*this, expr);
262   }
263   mlir::Type genType(Fortran::lower::SymbolRef sym) override final {
264     return Fortran::lower::translateSymbolToFIRType(*this, sym);
265   }
266   mlir::Type
267   genType(Fortran::common::TypeCategory tc, int kind,
268           llvm::ArrayRef<std::int64_t> lenParameters) override final {
269     return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,
270                                       lenParameters);
271   }
272   mlir::Type
273   genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final {
274     return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec);
275   }
276   mlir::Type genType(Fortran::common::TypeCategory tc) override final {
277     TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex "
278                "expression lowering");
279   }
280   mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
281     return Fortran::lower::translateVariableToFIRType(*this, var);
282   }
283 
284   void setCurrentPosition(const Fortran::parser::CharBlock &position) {
285     if (position != Fortran::parser::CharBlock{})
286       currentPosition = position;
287   }
288 
289   //===--------------------------------------------------------------------===//
290   // Utility methods
291   //===--------------------------------------------------------------------===//
292 
293   /// Convert a parser CharBlock to a Location
294   mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {
295     return genLocation(cb);
296   }
297 
298   mlir::Location toLocation() { return toLocation(currentPosition); }
299   void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {
300     evalPtr = &eval;
301   }
302   Fortran::lower::pft::Evaluation &getEval() {
303     assert(evalPtr && "current evaluation not set");
304     return *evalPtr;
305   }
306 
307   mlir::Location getCurrentLocation() override final { return toLocation(); }
308 
309   /// Generate a dummy location.
310   mlir::Location genUnknownLocation() override final {
311     // Note: builder may not be instantiated yet
312     return mlir::UnknownLoc::get(&getMLIRContext());
313   }
314 
315   /// Generate a `Location` from the `CharBlock`.
316   mlir::Location
317   genLocation(const Fortran::parser::CharBlock &block) override final {
318     if (const Fortran::parser::AllCookedSources *cooked =
319             bridge.getCookedSource()) {
320       if (std::optional<std::pair<Fortran::parser::SourcePosition,
321                                   Fortran::parser::SourcePosition>>
322               loc = cooked->GetSourcePositionRange(block)) {
323         // loc is a pair (begin, end); use the beginning position
324         Fortran::parser::SourcePosition &filePos = loc->first;
325         return mlir::FileLineColLoc::get(&getMLIRContext(), filePos.file.path(),
326                                          filePos.line, filePos.column);
327       }
328     }
329     return genUnknownLocation();
330   }
331 
332   fir::FirOpBuilder &getFirOpBuilder() override final { return *builder; }
333 
334   mlir::ModuleOp &getModuleOp() override final { return bridge.getModule(); }
335 
336   mlir::MLIRContext &getMLIRContext() override final {
337     return bridge.getMLIRContext();
338   }
339   std::string
340   mangleName(const Fortran::semantics::Symbol &symbol) override final {
341     return Fortran::lower::mangle::mangleName(symbol);
342   }
343 
344   const fir::KindMapping &getKindMap() override final {
345     return bridge.getKindMap();
346   }
347 
348   /// Return the predicate: "current block does not have a terminator branch".
349   bool blockIsUnterminated() {
350     mlir::Block *currentBlock = builder->getBlock();
351     return currentBlock->empty() ||
352            !currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();
353   }
354 
355   /// Unconditionally switch code insertion to a new block.
356   void startBlock(mlir::Block *newBlock) {
357     assert(newBlock && "missing block");
358     // Default termination for the current block is a fallthrough branch to
359     // the new block.
360     if (blockIsUnterminated())
361       genFIRBranch(newBlock);
362     // Some blocks may be re/started more than once, and might not be empty.
363     // If the new block already has (only) a terminator, set the insertion
364     // point to the start of the block.  Otherwise set it to the end.
365     // Note that setting the insertion point causes the subsequent function
366     // call to check the existence of terminator in the newBlock.
367     builder->setInsertionPointToStart(newBlock);
368     if (blockIsUnterminated())
369       builder->setInsertionPointToEnd(newBlock);
370   }
371 
372   /// Conditionally switch code insertion to a new block.
373   void maybeStartBlock(mlir::Block *newBlock) {
374     if (newBlock)
375       startBlock(newBlock);
376   }
377 
378   /// Emit return and cleanup after the function has been translated.
379   void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
380     setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
381     if (funit.isMainProgram())
382       genExitRoutine();
383     else
384       genFIRProcedureExit(funit, funit.getSubprogramSymbol());
385     funit.finalBlock = nullptr;
386     LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n"
387                             << *builder->getFunction() << '\n');
388     // FIXME: Simplification should happen in a normal pass, not here.
389     mlir::IRRewriter rewriter(*builder);
390     (void)mlir::simplifyRegions(rewriter,
391                                 {builder->getRegion()}); // remove dead code
392     delete builder;
393     builder = nullptr;
394     hostAssocTuple = mlir::Value{};
395     localSymbols.clear();
396   }
397 
398   /// Helper to generate GlobalOps when the builder is not positioned in any
399   /// region block. This is required because the FirOpBuilder assumes it is
400   /// always positioned inside a region block when creating globals, the easiest
401   /// way comply is to create a dummy function and to throw it afterwards.
402   void createGlobalOutsideOfFunctionLowering(
403       const std::function<void()> &createGlobals) {
404     // FIXME: get rid of the bogus function context and instantiate the
405     // globals directly into the module.
406     MLIRContext *context = &getMLIRContext();
407     mlir::FuncOp func = fir::FirOpBuilder::createFunction(
408         mlir::UnknownLoc::get(context), getModuleOp(),
409         fir::NameUniquer::doGenerated("Sham"),
410         mlir::FunctionType::get(context, llvm::None, llvm::None));
411     func.addEntryBlock();
412     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
413     createGlobals();
414     if (mlir::Region *region = func.getCallableRegion())
415       region->dropAllReferences();
416     func.erase();
417     delete builder;
418     builder = nullptr;
419     localSymbols.clear();
420   }
421   /// Instantiate the data from a BLOCK DATA unit.
422   void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) {
423     createGlobalOutsideOfFunctionLowering([&]() {
424       Fortran::lower::AggregateStoreMap fakeMap;
425       for (const auto &[_, sym] : bdunit.symTab) {
426         if (sym->has<Fortran::semantics::ObjectEntityDetails>()) {
427           Fortran::lower::pft::Variable var(*sym, true);
428           instantiateVar(var, fakeMap);
429         }
430       }
431     });
432   }
433 
434   /// Map mlir function block arguments to the corresponding Fortran dummy
435   /// variables. When the result is passed as a hidden argument, the Fortran
436   /// result is also mapped. The symbol map is used to hold this mapping.
437   void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
438                             const Fortran::lower::CalleeInterface &callee) {
439     assert(builder && "require a builder object at this point");
440     using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
441     auto mapPassedEntity = [&](const auto arg) -> void {
442       if (arg.passBy == PassBy::AddressAndLength) {
443         // TODO: now that fir call has some attributes regarding character
444         // return, PassBy::AddressAndLength should be retired.
445         mlir::Location loc = toLocation();
446         fir::factory::CharacterExprHelper charHelp{*builder, loc};
447         mlir::Value box =
448             charHelp.createEmboxChar(arg.firArgument, arg.firLength);
449         addSymbol(arg.entity->get(), box);
450       } else {
451         if (arg.entity.has_value()) {
452           addSymbol(arg.entity->get(), arg.firArgument);
453         } else {
454           assert(funit.parentHasHostAssoc());
455           funit.parentHostAssoc().internalProcedureBindings(*this,
456                                                             localSymbols);
457         }
458       }
459     };
460     for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
461          callee.getPassedArguments())
462       mapPassedEntity(arg);
463 
464     // Allocate local skeleton instances of dummies from other entry points.
465     // Most of these locals will not survive into final generated code, but
466     // some will.  It is illegal to reference them at run time if they do.
467     for (const Fortran::semantics::Symbol *arg :
468          funit.nonUniversalDummyArguments) {
469       if (lookupSymbol(*arg))
470         continue;
471       mlir::Type type = genType(*arg);
472       // TODO: Account for VALUE arguments (and possibly other variants).
473       type = builder->getRefType(type);
474       addSymbol(*arg, builder->create<fir::UndefOp>(toLocation(), type));
475     }
476     if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
477             passedResult = callee.getPassedResult()) {
478       mapPassedEntity(*passedResult);
479       // FIXME: need to make sure things are OK here. addSymbol may not be OK
480       if (funit.primaryResult &&
481           passedResult->entity->get() != *funit.primaryResult)
482         addSymbol(*funit.primaryResult,
483                   getSymbolAddress(passedResult->entity->get()));
484     }
485   }
486 
487   /// Instantiate variable \p var and add it to the symbol map.
488   /// See ConvertVariable.cpp.
489   void instantiateVar(const Fortran::lower::pft::Variable &var,
490                       Fortran::lower::AggregateStoreMap &storeMap) {
491     Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
492   }
493 
494   /// Prepare to translate a new function
495   void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
496     assert(!builder && "expected nullptr");
497     Fortran::lower::CalleeInterface callee(funit, *this);
498     mlir::FuncOp func = callee.addEntryBlockAndMapArguments();
499     func.setVisibility(mlir::SymbolTable::Visibility::Public);
500     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
501     assert(builder && "FirOpBuilder did not instantiate");
502     builder->setInsertionPointToStart(&func.front());
503 
504     mapDummiesAndResults(funit, callee);
505 
506     // Note: not storing Variable references because getOrderedSymbolTable
507     // below returns a temporary.
508     llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
509 
510     // Backup actual argument for entry character results
511     // with different lengths. It needs to be added to the non
512     // primary results symbol before mapSymbolAttributes is called.
513     Fortran::lower::SymbolBox resultArg;
514     if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
515             passedResult = callee.getPassedResult())
516       resultArg = lookupSymbol(passedResult->entity->get());
517 
518     Fortran::lower::AggregateStoreMap storeMap;
519     // The front-end is currently not adding module variables referenced
520     // in a module procedure as host associated. As a result we need to
521     // instantiate all module variables here if this is a module procedure.
522     // It is likely that the front-end behavior should change here.
523     // This also applies to internal procedures inside module procedures.
524     if (auto *module = Fortran::lower::pft::getAncestor<
525             Fortran::lower::pft::ModuleLikeUnit>(funit))
526       for (const Fortran::lower::pft::Variable &var :
527            module->getOrderedSymbolTable())
528         instantiateVar(var, storeMap);
529 
530     mlir::Value primaryFuncResultStorage;
531     for (const Fortran::lower::pft::Variable &var :
532          funit.getOrderedSymbolTable()) {
533       // Always instantiate aggregate storage blocks.
534       if (var.isAggregateStore()) {
535         instantiateVar(var, storeMap);
536         continue;
537       }
538       const Fortran::semantics::Symbol &sym = var.getSymbol();
539       if (funit.parentHasHostAssoc()) {
540         // Never instantitate host associated variables, as they are already
541         // instantiated from an argument tuple. Instead, just bind the symbol to
542         // the reference to the host variable, which must be in the map.
543         const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
544         if (funit.parentHostAssoc().isAssociated(ultimate)) {
545           Fortran::lower::SymbolBox hostBox =
546               localSymbols.lookupSymbol(ultimate);
547           assert(hostBox && "host association is not in map");
548           localSymbols.addSymbol(sym, hostBox.toExtendedValue());
549           continue;
550         }
551       }
552       if (!sym.IsFuncResult() || !funit.primaryResult) {
553         instantiateVar(var, storeMap);
554       } else if (&sym == funit.primaryResult) {
555         instantiateVar(var, storeMap);
556         primaryFuncResultStorage = getSymbolAddress(sym);
557       } else {
558         deferredFuncResultList.push_back(var);
559       }
560     }
561 
562     // If this is a host procedure with host associations, then create the tuple
563     // of pointers for passing to the internal procedures.
564     if (!funit.getHostAssoc().empty())
565       funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
566 
567     /// TODO: should use same mechanism as equivalence?
568     /// One blocking point is character entry returns that need special handling
569     /// since they are not locally allocated but come as argument. CHARACTER(*)
570     /// is not something that fit wells with equivalence lowering.
571     for (const Fortran::lower::pft::Variable &altResult :
572          deferredFuncResultList) {
573       if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
574               passedResult = callee.getPassedResult())
575         addSymbol(altResult.getSymbol(), resultArg.getAddr());
576       Fortran::lower::StatementContext stmtCtx;
577       Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
578                                           stmtCtx, primaryFuncResultStorage);
579     }
580 
581     // Create most function blocks in advance.
582     createEmptyGlobalBlocks(funit.evaluationList);
583 
584     // Reinstate entry block as the current insertion point.
585     builder->setInsertionPointToEnd(&func.front());
586 
587     if (callee.hasAlternateReturns()) {
588       // Create a local temp to hold the alternate return index.
589       // Give it an integer index type and the subroutine name (for dumps).
590       // Attach it to the subroutine symbol in the localSymbols map.
591       // Initialize it to zero, the "fallthrough" alternate return value.
592       const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
593       mlir::Location loc = toLocation();
594       mlir::Type idxTy = builder->getIndexType();
595       mlir::Value altResult =
596           builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
597       addSymbol(symbol, altResult);
598       mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
599       builder->create<fir::StoreOp>(loc, zero, altResult);
600     }
601 
602     if (Fortran::lower::pft::Evaluation *alternateEntryEval =
603             funit.getEntryEval())
604       genFIRBranch(alternateEntryEval->lexicalSuccessor->block);
605   }
606 
607   /// Create global blocks for the current function.  This eliminates the
608   /// distinction between forward and backward targets when generating
609   /// branches.  A block is "global" if it can be the target of a GOTO or
610   /// other source code branch.  A block that can only be targeted by a
611   /// compiler generated branch is "local".  For example, a DO loop preheader
612   /// block containing loop initialization code is global.  A loop header
613   /// block, which is the target of the loop back edge, is local.  Blocks
614   /// belong to a region.  Any block within a nested region must be replaced
615   /// with a block belonging to that region.  Branches may not cross region
616   /// boundaries.
617   void createEmptyGlobalBlocks(
618       std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
619     mlir::Region *region = &builder->getRegion();
620     for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
621       if (eval.isNewBlock)
622         eval.block = builder->createBlock(region);
623       if (eval.isConstruct() || eval.isDirective()) {
624         if (eval.lowerAsUnstructured()) {
625           createEmptyGlobalBlocks(eval.getNestedEvaluations());
626         } else if (eval.hasNestedEvaluations()) {
627           // A structured construct that is a target starts a new block.
628           Fortran::lower::pft::Evaluation &constructStmt =
629               eval.getFirstNestedEvaluation();
630           if (constructStmt.isNewBlock)
631             constructStmt.block = builder->createBlock(region);
632         }
633       }
634     }
635   }
636 
637   /// Lower a procedure (nest).
638   void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
639     if (!funit.isMainProgram()) {
640       const Fortran::semantics::Symbol &procSymbol =
641           funit.getSubprogramSymbol();
642       if (procSymbol.owner().IsSubmodule()) {
643         TODO(toLocation(), "support submodules");
644         return;
645       }
646     }
647     setCurrentPosition(funit.getStartingSourceLoc());
648     for (int entryIndex = 0, last = funit.entryPointList.size();
649          entryIndex < last; ++entryIndex) {
650       funit.setActiveEntry(entryIndex);
651       startNewFunction(funit); // the entry point for lowering this procedure
652       for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
653         genFIR(eval);
654       endNewFunction(funit);
655     }
656     funit.setActiveEntry(0);
657     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
658       lowerFunc(f); // internal procedure
659   }
660 
661   /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
662   /// declarative construct.
663   void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
664     setCurrentPosition(mod.getStartingSourceLoc());
665     createGlobalOutsideOfFunctionLowering([&]() {
666       for (const Fortran::lower::pft::Variable &var :
667            mod.getOrderedSymbolTable()) {
668         // Only define the variables owned by this module.
669         const Fortran::semantics::Scope *owningScope = var.getOwningScope();
670         if (!owningScope || mod.getScope() == *owningScope)
671           Fortran::lower::defineModuleVariable(*this, var);
672       }
673       for (auto &eval : mod.evaluationList)
674         genFIR(eval);
675     });
676   }
677 
678   /// Lower functions contained in a module.
679   void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
680     for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions)
681       lowerFunc(f);
682   }
683 
684   mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
685 
686   /// Record a binding for the ssa-value of the tuple for this function.
687   void bindHostAssocTuple(mlir::Value val) override final {
688     assert(!hostAssocTuple && val);
689     hostAssocTuple = val;
690   }
691 
692 private:
693   FirConverter() = delete;
694   FirConverter(const FirConverter &) = delete;
695   FirConverter &operator=(const FirConverter &) = delete;
696 
697   //===--------------------------------------------------------------------===//
698   // Helper member functions
699   //===--------------------------------------------------------------------===//
700 
701   mlir::Value createFIRExpr(mlir::Location loc,
702                             const Fortran::lower::SomeExpr *expr,
703                             Fortran::lower::StatementContext &stmtCtx) {
704     return fir::getBase(genExprValue(*expr, stmtCtx, &loc));
705   }
706 
707   /// Find the symbol in the local map or return null.
708   Fortran::lower::SymbolBox
709   lookupSymbol(const Fortran::semantics::Symbol &sym) {
710     if (Fortran::lower::SymbolBox v = localSymbols.lookupSymbol(sym))
711       return v;
712     return {};
713   }
714 
715   /// Find the symbol in the inner-most level of the local map or return null.
716   Fortran::lower::SymbolBox
717   shallowLookupSymbol(const Fortran::semantics::Symbol &sym) {
718     if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym))
719       return v;
720     return {};
721   }
722 
723   /// Add the symbol to the local map and return `true`. If the symbol is
724   /// already in the map and \p forced is `false`, the map is not updated.
725   /// Instead the value `false` is returned.
726   bool addSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val,
727                  bool forced = false) {
728     if (!forced && lookupSymbol(sym))
729       return false;
730     localSymbols.addSymbol(sym, val, forced);
731     return true;
732   }
733 
734   bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {
735     return cat == Fortran::common::TypeCategory::Integer ||
736            cat == Fortran::common::TypeCategory::Real ||
737            cat == Fortran::common::TypeCategory::Complex ||
738            cat == Fortran::common::TypeCategory::Logical;
739   }
740   bool isCharacterCategory(Fortran::common::TypeCategory cat) {
741     return cat == Fortran::common::TypeCategory::Character;
742   }
743   bool isDerivedCategory(Fortran::common::TypeCategory cat) {
744     return cat == Fortran::common::TypeCategory::Derived;
745   }
746 
747   mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval,
748                             Fortran::parser::Label label) {
749     const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
750         eval.getOwningProcedure()->labelEvaluationMap;
751     const auto iter = labelEvaluationMap.find(label);
752     assert(iter != labelEvaluationMap.end() && "label missing from map");
753     mlir::Block *block = iter->second->block;
754     assert(block && "missing labeled evaluation block");
755     return block;
756   }
757 
758   void genFIRBranch(mlir::Block *targetBlock) {
759     assert(targetBlock && "missing unconditional target block");
760     builder->create<cf::BranchOp>(toLocation(), targetBlock);
761   }
762 
763   void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,
764                                mlir::Block *falseTarget) {
765     assert(trueTarget && "missing conditional branch true block");
766     assert(falseTarget && "missing conditional branch false block");
767     mlir::Location loc = toLocation();
768     mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);
769     builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, llvm::None,
770                                             falseTarget, llvm::None);
771   }
772   void genFIRConditionalBranch(mlir::Value cond,
773                                Fortran::lower::pft::Evaluation *trueTarget,
774                                Fortran::lower::pft::Evaluation *falseTarget) {
775     genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
776   }
777   void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
778                                mlir::Block *trueTarget,
779                                mlir::Block *falseTarget) {
780     Fortran::lower::StatementContext stmtCtx;
781     mlir::Value cond =
782         createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
783     stmtCtx.finalize();
784     genFIRConditionalBranch(cond, trueTarget, falseTarget);
785   }
786   void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
787                                Fortran::lower::pft::Evaluation *trueTarget,
788                                Fortran::lower::pft::Evaluation *falseTarget) {
789     Fortran::lower::StatementContext stmtCtx;
790     mlir::Value cond =
791         createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
792     stmtCtx.finalize();
793     genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
794   }
795 
796   //===--------------------------------------------------------------------===//
797   // Termination of symbolically referenced execution units
798   //===--------------------------------------------------------------------===//
799 
800   /// END of program
801   ///
802   /// Generate the cleanup block before the program exits
803   void genExitRoutine() {
804     if (blockIsUnterminated())
805       builder->create<mlir::func::ReturnOp>(toLocation());
806   }
807   void genFIR(const Fortran::parser::EndProgramStmt &) { genExitRoutine(); }
808 
809   /// END of procedure-like constructs
810   ///
811   /// Generate the cleanup block before the procedure exits
812   void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) {
813     const Fortran::semantics::Symbol &resultSym =
814         functionSymbol.get<Fortran::semantics::SubprogramDetails>().result();
815     Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym);
816     mlir::Location loc = toLocation();
817     if (!resultSymBox) {
818       mlir::emitError(loc, "failed lowering function return");
819       return;
820     }
821     mlir::Value resultVal = resultSymBox.match(
822         [&](const fir::CharBoxValue &x) -> mlir::Value {
823           return fir::factory::CharacterExprHelper{*builder, loc}
824               .createEmboxChar(x.getBuffer(), x.getLen());
825         },
826         [&](const auto &) -> mlir::Value {
827           mlir::Value resultRef = resultSymBox.getAddr();
828           mlir::Type resultType = genType(resultSym);
829           mlir::Type resultRefType = builder->getRefType(resultType);
830           // A function with multiple entry points returning different types
831           // tags all result variables with one of the largest types to allow
832           // them to share the same storage.  Convert this to the actual type.
833           if (resultRef.getType() != resultRefType)
834             resultRef = builder->createConvert(loc, resultRefType, resultRef);
835           return builder->create<fir::LoadOp>(loc, resultRef);
836         });
837     builder->create<mlir::func::ReturnOp>(loc, resultVal);
838   }
839 
840   /// Get the return value of a call to \p symbol, which is a subroutine entry
841   /// point that has alternative return specifiers.
842   const mlir::Value
843   getAltReturnResult(const Fortran::semantics::Symbol &symbol) {
844     assert(Fortran::semantics::HasAlternateReturns(symbol) &&
845            "subroutine does not have alternate returns");
846     return getSymbolAddress(symbol);
847   }
848 
849   void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit,
850                            const Fortran::semantics::Symbol &symbol) {
851     if (mlir::Block *finalBlock = funit.finalBlock) {
852       // The current block must end with a terminator.
853       if (blockIsUnterminated())
854         builder->create<mlir::cf::BranchOp>(toLocation(), finalBlock);
855       // Set insertion point to final block.
856       builder->setInsertionPoint(finalBlock, finalBlock->end());
857     }
858     if (Fortran::semantics::IsFunction(symbol)) {
859       genReturnSymbol(symbol);
860     } else if (Fortran::semantics::HasAlternateReturns(symbol)) {
861       mlir::Value retval = builder->create<fir::LoadOp>(
862           toLocation(), getAltReturnResult(symbol));
863       builder->create<mlir::func::ReturnOp>(toLocation(), retval);
864     } else {
865       genExitRoutine();
866     }
867   }
868 
869   //
870   // Statements that have control-flow semantics
871   //
872 
873   /// Generate an If[Then]Stmt condition or its negation.
874   template <typename A>
875   mlir::Value genIfCondition(const A *stmt, bool negate = false) {
876     mlir::Location loc = toLocation();
877     Fortran::lower::StatementContext stmtCtx;
878     mlir::Value condExpr = createFIRExpr(
879         loc,
880         Fortran::semantics::GetExpr(
881             std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),
882         stmtCtx);
883     stmtCtx.finalize();
884     mlir::Value cond =
885         builder->createConvert(loc, builder->getI1Type(), condExpr);
886     if (negate)
887       cond = builder->create<mlir::arith::XOrIOp>(
888           loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1));
889     return cond;
890   }
891 
892   static bool
893   isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) {
894     return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
895            !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
896            !Fortran::evaluate::HasVectorSubscript(expr);
897   }
898 
899   [[maybe_unused]] static bool
900   isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
901     const Fortran::semantics::Symbol *sym =
902         Fortran::evaluate::GetFirstSymbol(expr);
903     return sym && sym->IsFuncResult();
904   }
905 
906   static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
907     const Fortran::semantics::Symbol *sym =
908         Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr);
909     return sym && Fortran::semantics::IsAllocatable(*sym);
910   }
911 
912   /// Shared for both assignments and pointer assignments.
913   void genAssignment(const Fortran::evaluate::Assignment &assign) {
914     Fortran::lower::StatementContext stmtCtx;
915     mlir::Location loc = toLocation();
916     if (explicitIterationSpace()) {
917       Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols);
918       explicitIterSpace.genLoopNest();
919     }
920     std::visit(
921         Fortran::common::visitors{
922             // [1] Plain old assignment.
923             [&](const Fortran::evaluate::Assignment::Intrinsic &) {
924               const Fortran::semantics::Symbol *sym =
925                   Fortran::evaluate::GetLastSymbol(assign.lhs);
926 
927               if (!sym)
928                 TODO(loc, "assignment to pointer result of function reference");
929 
930               std::optional<Fortran::evaluate::DynamicType> lhsType =
931                   assign.lhs.GetType();
932               assert(lhsType && "lhs cannot be typeless");
933               // Assignment to polymorphic allocatables may require changing the
934               // variable dynamic type (See Fortran 2018 10.2.1.3 p3).
935               if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs))
936                 TODO(loc, "assignment to polymorphic allocatable");
937 
938               // Note: No ad-hoc handling for pointers is required here. The
939               // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
940               // on a pointer returns the target address and not the address of
941               // the pointer variable.
942 
943               if (assign.lhs.Rank() > 0 || explicitIterationSpace()) {
944                 // Array assignment
945                 // See Fortran 2018 10.2.1.3 p5, p6, and p7
946                 genArrayAssignment(assign, stmtCtx);
947                 return;
948               }
949 
950               // Scalar assignment
951               const bool isNumericScalar =
952                   isNumericScalarCategory(lhsType->category());
953               fir::ExtendedValue rhs = isNumericScalar
954                                            ? genExprValue(assign.rhs, stmtCtx)
955                                            : genExprAddr(assign.rhs, stmtCtx);
956               bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs);
957               llvm::Optional<fir::factory::MutableBoxReallocation> lhsRealloc;
958               llvm::Optional<fir::MutableBoxValue> lhsMutableBox;
959               auto lhs = [&]() -> fir::ExtendedValue {
960                 if (lhsIsWholeAllocatable) {
961                   lhsMutableBox = genExprMutableBox(loc, assign.lhs);
962                   llvm::SmallVector<mlir::Value> lengthParams;
963                   if (const fir::CharBoxValue *charBox = rhs.getCharBox())
964                     lengthParams.push_back(charBox->getLen());
965                   else if (fir::isDerivedWithLengthParameters(rhs))
966                     TODO(loc, "assignment to derived type allocatable with "
967                               "length parameters");
968                   lhsRealloc = fir::factory::genReallocIfNeeded(
969                       *builder, loc, *lhsMutableBox,
970                       /*shape=*/llvm::None, lengthParams);
971                   return lhsRealloc->newValue;
972                 }
973                 return genExprAddr(assign.lhs, stmtCtx);
974               }();
975 
976               if (isNumericScalar) {
977                 // Fortran 2018 10.2.1.3 p8 and p9
978                 // Conversions should have been inserted by semantic analysis,
979                 // but they can be incorrect between the rhs and lhs. Correct
980                 // that here.
981                 mlir::Value addr = fir::getBase(lhs);
982                 mlir::Value val = fir::getBase(rhs);
983                 // A function with multiple entry points returning different
984                 // types tags all result variables with one of the largest
985                 // types to allow them to share the same storage.  Assignment
986                 // to a result variable of one of the other types requires
987                 // conversion to the actual type.
988                 mlir::Type toTy = genType(assign.lhs);
989                 mlir::Value cast =
990                     builder->convertWithSemantics(loc, toTy, val);
991                 if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) {
992                   assert(isFuncResultDesignator(assign.lhs) && "type mismatch");
993                   addr = builder->createConvert(
994                       toLocation(), builder->getRefType(toTy), addr);
995                 }
996                 builder->create<fir::StoreOp>(loc, cast, addr);
997               } else if (isCharacterCategory(lhsType->category())) {
998                 // Fortran 2018 10.2.1.3 p10 and p11
999                 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
1000                     lhs, rhs);
1001               } else if (isDerivedCategory(lhsType->category())) {
1002                 // Fortran 2018 10.2.1.3 p13 and p14
1003                 // Recursively gen an assignment on each element pair.
1004                 fir::factory::genRecordAssignment(*builder, loc, lhs, rhs);
1005               } else {
1006                 llvm_unreachable("unknown category");
1007               }
1008               if (lhsIsWholeAllocatable)
1009                 fir::factory::finalizeRealloc(
1010                     *builder, loc, lhsMutableBox.getValue(),
1011                     /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false,
1012                     lhsRealloc.getValue());
1013             },
1014 
1015             // [2] User defined assignment. If the context is a scalar
1016             // expression then call the procedure.
1017             [&](const Fortran::evaluate::ProcedureRef &procRef) {
1018               Fortran::lower::StatementContext &ctx =
1019                   explicitIterationSpace() ? explicitIterSpace.stmtContext()
1020                                            : stmtCtx;
1021               Fortran::lower::createSubroutineCall(
1022                   *this, procRef, explicitIterSpace, implicitIterSpace,
1023                   localSymbols, ctx, /*isUserDefAssignment=*/true);
1024             },
1025 
1026             // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
1027             // bounds-spec is a lower bound value.
1028             [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
1029               if (IsProcedure(assign.rhs))
1030                 TODO(loc, "procedure pointer assignment");
1031               std::optional<Fortran::evaluate::DynamicType> lhsType =
1032                   assign.lhs.GetType();
1033               std::optional<Fortran::evaluate::DynamicType> rhsType =
1034                   assign.rhs.GetType();
1035               // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
1036               if ((lhsType && lhsType->IsPolymorphic()) ||
1037                   (rhsType && rhsType->IsPolymorphic()))
1038                 TODO(loc, "pointer assignment involving polymorphic entity");
1039 
1040               // FIXME: in the explicit space context, we want to use
1041               // ScalarArrayExprLowering here.
1042               fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
1043               llvm::SmallVector<mlir::Value> lbounds;
1044               for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
1045                 lbounds.push_back(
1046                     fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
1047               Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs,
1048                                                   lbounds, stmtCtx);
1049               if (explicitIterationSpace()) {
1050                 mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
1051                 if (!inners.empty()) {
1052                   // TODO: should force a copy-in/copy-out here.
1053                   // e.g., obj%ptr(i+1) => obj%ptr(i)
1054                   builder->create<fir::ResultOp>(loc, inners);
1055                 }
1056               }
1057             },
1058 
1059             // [4] Pointer assignment with bounds-remapping. R1036: a
1060             // bounds-remapping is a pair, lower bound and upper bound.
1061             [&](const Fortran::evaluate::Assignment::BoundsRemapping
1062                     &boundExprs) {
1063               std::optional<Fortran::evaluate::DynamicType> lhsType =
1064                   assign.lhs.GetType();
1065               std::optional<Fortran::evaluate::DynamicType> rhsType =
1066                   assign.rhs.GetType();
1067               // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
1068               if ((lhsType && lhsType->IsPolymorphic()) ||
1069                   (rhsType && rhsType->IsPolymorphic()))
1070                 TODO(loc, "pointer assignment involving polymorphic entity");
1071 
1072               // FIXME: in the explicit space context, we want to use
1073               // ScalarArrayExprLowering here.
1074               fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
1075               if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
1076                       assign.rhs)) {
1077                 fir::factory::disassociateMutableBox(*builder, loc, lhs);
1078                 return;
1079               }
1080               llvm::SmallVector<mlir::Value> lbounds;
1081               llvm::SmallVector<mlir::Value> ubounds;
1082               for (const std::pair<Fortran::evaluate::ExtentExpr,
1083                                    Fortran::evaluate::ExtentExpr> &pair :
1084                    boundExprs) {
1085                 const Fortran::evaluate::ExtentExpr &lbExpr = pair.first;
1086                 const Fortran::evaluate::ExtentExpr &ubExpr = pair.second;
1087                 lbounds.push_back(
1088                     fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
1089                 ubounds.push_back(
1090                     fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx)));
1091               }
1092               // Do not generate a temp in case rhs is an array section.
1093               fir::ExtendedValue rhs =
1094                   isArraySectionWithoutVectorSubscript(assign.rhs)
1095                       ? Fortran::lower::createSomeArrayBox(
1096                             *this, assign.rhs, localSymbols, stmtCtx)
1097                       : genExprAddr(assign.rhs, stmtCtx);
1098               fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs,
1099                                                          rhs, lbounds, ubounds);
1100               if (explicitIterationSpace()) {
1101                 mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
1102                 if (!inners.empty()) {
1103                   // TODO: should force a copy-in/copy-out here.
1104                   // e.g., obj%ptr(i+1) => obj%ptr(i)
1105                   builder->create<fir::ResultOp>(loc, inners);
1106                 }
1107               }
1108             },
1109         },
1110         assign.u);
1111     if (explicitIterationSpace())
1112       Fortran::lower::createArrayMergeStores(*this, explicitIterSpace);
1113   }
1114 
1115   /// Lowering of CALL statement
1116   void genFIR(const Fortran::parser::CallStmt &stmt) {
1117     Fortran::lower::StatementContext stmtCtx;
1118     Fortran::lower::pft::Evaluation &eval = getEval();
1119     setCurrentPosition(stmt.v.source);
1120     assert(stmt.typedCall && "Call was not analyzed");
1121     // Call statement lowering shares code with function call lowering.
1122     mlir::Value res = Fortran::lower::createSubroutineCall(
1123         *this, *stmt.typedCall, explicitIterSpace, implicitIterSpace,
1124         localSymbols, stmtCtx, /*isUserDefAssignment=*/false);
1125     if (!res)
1126       return; // "Normal" subroutine call.
1127     // Call with alternate return specifiers.
1128     // The call returns an index that selects an alternate return branch target.
1129     llvm::SmallVector<int64_t> indexList;
1130     llvm::SmallVector<mlir::Block *> blockList;
1131     int64_t index = 0;
1132     for (const Fortran::parser::ActualArgSpec &arg :
1133          std::get<std::list<Fortran::parser::ActualArgSpec>>(stmt.v.t)) {
1134       const auto &actual = std::get<Fortran::parser::ActualArg>(arg.t);
1135       if (const auto *altReturn =
1136               std::get_if<Fortran::parser::AltReturnSpec>(&actual.u)) {
1137         indexList.push_back(++index);
1138         blockList.push_back(blockOfLabel(eval, altReturn->v));
1139       }
1140     }
1141     blockList.push_back(eval.nonNopSuccessor().block); // default = fallthrough
1142     stmtCtx.finalize();
1143     builder->create<fir::SelectOp>(toLocation(), res, indexList, blockList);
1144   }
1145 
1146   void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
1147     Fortran::lower::StatementContext stmtCtx;
1148     Fortran::lower::pft::Evaluation &eval = getEval();
1149     mlir::Value selectExpr =
1150         createFIRExpr(toLocation(),
1151                       Fortran::semantics::GetExpr(
1152                           std::get<Fortran::parser::ScalarIntExpr>(stmt.t)),
1153                       stmtCtx);
1154     stmtCtx.finalize();
1155     llvm::SmallVector<int64_t> indexList;
1156     llvm::SmallVector<mlir::Block *> blockList;
1157     int64_t index = 0;
1158     for (Fortran::parser::Label label :
1159          std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
1160       indexList.push_back(++index);
1161       blockList.push_back(blockOfLabel(eval, label));
1162     }
1163     blockList.push_back(eval.nonNopSuccessor().block); // default
1164     builder->create<fir::SelectOp>(toLocation(), selectExpr, indexList,
1165                                    blockList);
1166   }
1167 
1168   void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
1169     Fortran::lower::StatementContext stmtCtx;
1170     Fortran::lower::pft::Evaluation &eval = getEval();
1171     mlir::Value expr = createFIRExpr(
1172         toLocation(),
1173         Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)),
1174         stmtCtx);
1175     stmtCtx.finalize();
1176     mlir::Type exprType = expr.getType();
1177     mlir::Location loc = toLocation();
1178     if (exprType.isSignlessInteger()) {
1179       // Arithmetic expression has Integer type.  Generate a SelectCaseOp
1180       // with ranges {(-inf:-1], 0=default, [1:inf)}.
1181       MLIRContext *context = builder->getContext();
1182       llvm::SmallVector<mlir::Attribute> attrList;
1183       llvm::SmallVector<mlir::Value> valueList;
1184       llvm::SmallVector<mlir::Block *> blockList;
1185       attrList.push_back(fir::UpperBoundAttr::get(context));
1186       valueList.push_back(builder->createIntegerConstant(loc, exprType, -1));
1187       blockList.push_back(blockOfLabel(eval, std::get<1>(stmt.t)));
1188       attrList.push_back(fir::LowerBoundAttr::get(context));
1189       valueList.push_back(builder->createIntegerConstant(loc, exprType, 1));
1190       blockList.push_back(blockOfLabel(eval, std::get<3>(stmt.t)));
1191       attrList.push_back(mlir::UnitAttr::get(context)); // 0 is the "default"
1192       blockList.push_back(blockOfLabel(eval, std::get<2>(stmt.t)));
1193       builder->create<fir::SelectCaseOp>(loc, expr, attrList, valueList,
1194                                          blockList);
1195       return;
1196     }
1197     // Arithmetic expression has Real type.  Generate
1198     //   sum = expr + expr  [ raise an exception if expr is a NaN ]
1199     //   if (sum < 0.0) goto L1 else if (sum > 0.0) goto L3 else goto L2
1200     auto sum = builder->create<mlir::arith::AddFOp>(loc, expr, expr);
1201     auto zero = builder->create<mlir::arith::ConstantOp>(
1202         loc, exprType, builder->getFloatAttr(exprType, 0.0));
1203     auto cond1 = builder->create<mlir::arith::CmpFOp>(
1204         loc, mlir::arith::CmpFPredicate::OLT, sum, zero);
1205     mlir::Block *elseIfBlock =
1206         builder->getBlock()->splitBlock(builder->getInsertionPoint());
1207     genFIRConditionalBranch(cond1, blockOfLabel(eval, std::get<1>(stmt.t)),
1208                             elseIfBlock);
1209     startBlock(elseIfBlock);
1210     auto cond2 = builder->create<mlir::arith::CmpFOp>(
1211         loc, mlir::arith::CmpFPredicate::OGT, sum, zero);
1212     genFIRConditionalBranch(cond2, blockOfLabel(eval, std::get<3>(stmt.t)),
1213                             blockOfLabel(eval, std::get<2>(stmt.t)));
1214   }
1215 
1216   void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
1217     // Program requirement 1990 8.2.4 -
1218     //
1219     //   At the time of execution of an assigned GOTO statement, the integer
1220     //   variable must be defined with the value of a statement label of a
1221     //   branch target statement that appears in the same scoping unit.
1222     //   Note that the variable may be defined with a statement label value
1223     //   only by an ASSIGN statement in the same scoping unit as the assigned
1224     //   GOTO statement.
1225 
1226     mlir::Location loc = toLocation();
1227     Fortran::lower::pft::Evaluation &eval = getEval();
1228     const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap =
1229         eval.getOwningProcedure()->assignSymbolLabelMap;
1230     const Fortran::semantics::Symbol &symbol =
1231         *std::get<Fortran::parser::Name>(stmt.t).symbol;
1232     auto selectExpr =
1233         builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol));
1234     auto iter = symbolLabelMap.find(symbol);
1235     if (iter == symbolLabelMap.end()) {
1236       // Fail for a nonconforming program unit that does not have any ASSIGN
1237       // statements.  The front end should check for this.
1238       mlir::emitError(loc, "(semantics issue) no assigned goto targets");
1239       exit(1);
1240     }
1241     auto labelSet = iter->second;
1242     llvm::SmallVector<int64_t> indexList;
1243     llvm::SmallVector<mlir::Block *> blockList;
1244     auto addLabel = [&](Fortran::parser::Label label) {
1245       indexList.push_back(label);
1246       blockList.push_back(blockOfLabel(eval, label));
1247     };
1248     // Add labels from an explicit list.  The list may have duplicates.
1249     for (Fortran::parser::Label label :
1250          std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
1251       if (labelSet.count(label) &&
1252           std::find(indexList.begin(), indexList.end(), label) ==
1253               indexList.end()) { // ignore duplicates
1254         addLabel(label);
1255       }
1256     }
1257     // Absent an explicit list, add all possible label targets.
1258     if (indexList.empty())
1259       for (auto &label : labelSet)
1260         addLabel(label);
1261     // Add a nop/fallthrough branch to the switch for a nonconforming program
1262     // unit that violates the program requirement above.
1263     blockList.push_back(eval.nonNopSuccessor().block); // default
1264     builder->create<fir::SelectOp>(loc, selectExpr, indexList, blockList);
1265   }
1266 
1267   void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
1268     TODO(toLocation(), "DoConstruct lowering");
1269   }
1270 
1271   void genFIR(const Fortran::parser::IfConstruct &) {
1272     mlir::Location loc = toLocation();
1273     Fortran::lower::pft::Evaluation &eval = getEval();
1274     if (eval.lowerAsStructured()) {
1275       // Structured fir.if nest.
1276       fir::IfOp topIfOp, currentIfOp;
1277       for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
1278         auto genIfOp = [&](mlir::Value cond) {
1279           auto ifOp = builder->create<fir::IfOp>(loc, cond, /*withElse=*/true);
1280           builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
1281           return ifOp;
1282         };
1283         if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
1284           topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
1285         } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
1286           topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
1287         } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
1288           builder->setInsertionPointToStart(
1289               &currentIfOp.getElseRegion().front());
1290           currentIfOp = genIfOp(genIfCondition(s));
1291         } else if (e.isA<Fortran::parser::ElseStmt>()) {
1292           builder->setInsertionPointToStart(
1293               &currentIfOp.getElseRegion().front());
1294         } else if (e.isA<Fortran::parser::EndIfStmt>()) {
1295           builder->setInsertionPointAfter(topIfOp);
1296         } else {
1297           genFIR(e, /*unstructuredContext=*/false);
1298         }
1299       }
1300       return;
1301     }
1302 
1303     // Unstructured branch sequence.
1304     for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
1305       auto genIfBranch = [&](mlir::Value cond) {
1306         if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit
1307           genFIRConditionalBranch(cond, e.parentConstruct->constructExit,
1308                                   e.controlSuccessor);
1309         else // non-empty block
1310           genFIRConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor);
1311       };
1312       if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
1313         maybeStartBlock(e.block);
1314         genIfBranch(genIfCondition(s, e.negateCondition));
1315       } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
1316         maybeStartBlock(e.block);
1317         genIfBranch(genIfCondition(s, e.negateCondition));
1318       } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
1319         startBlock(e.block);
1320         genIfBranch(genIfCondition(s));
1321       } else {
1322         genFIR(e);
1323       }
1324     }
1325   }
1326 
1327   void genFIR(const Fortran::parser::CaseConstruct &) {
1328     TODO(toLocation(), "CaseConstruct lowering");
1329   }
1330 
1331   template <typename A>
1332   void genNestedStatement(const Fortran::parser::Statement<A> &stmt) {
1333     setCurrentPosition(stmt.source);
1334     genFIR(stmt.statement);
1335   }
1336 
1337   /// Force the binding of an explicit symbol. This is used to bind and re-bind
1338   /// a concurrent control symbol to its value.
1339   void forceControlVariableBinding(const Fortran::semantics::Symbol *sym,
1340                                    mlir::Value inducVar) {
1341     mlir::Location loc = toLocation();
1342     assert(sym && "There must be a symbol to bind");
1343     mlir::Type toTy = genType(*sym);
1344     // FIXME: this should be a "per iteration" temporary.
1345     mlir::Value tmp = builder->createTemporary(
1346         loc, toTy, toStringRef(sym->name()),
1347         llvm::ArrayRef<mlir::NamedAttribute>{
1348             Fortran::lower::getAdaptToByRefAttr(*builder)});
1349     mlir::Value cast = builder->createConvert(loc, toTy, inducVar);
1350     builder->create<fir::StoreOp>(loc, cast, tmp);
1351     localSymbols.addSymbol(*sym, tmp, /*force=*/true);
1352   }
1353 
1354   /// Process a concurrent header for a FORALL. (Concurrent headers for DO
1355   /// CONCURRENT loops are lowered elsewhere.)
1356   void genFIR(const Fortran::parser::ConcurrentHeader &header) {
1357     llvm::SmallVector<mlir::Value> lows;
1358     llvm::SmallVector<mlir::Value> highs;
1359     llvm::SmallVector<mlir::Value> steps;
1360     if (explicitIterSpace.isOutermostForall()) {
1361       // For the outermost forall, we evaluate the bounds expressions once.
1362       // Contrastingly, if this forall is nested, the bounds expressions are
1363       // assumed to be pure, possibly dependent on outer concurrent control
1364       // variables, possibly variant with respect to arguments, and will be
1365       // re-evaluated.
1366       mlir::Location loc = toLocation();
1367       mlir::Type idxTy = builder->getIndexType();
1368       Fortran::lower::StatementContext &stmtCtx =
1369           explicitIterSpace.stmtContext();
1370       auto lowerExpr = [&](auto &e) {
1371         return fir::getBase(genExprValue(e, stmtCtx));
1372       };
1373       for (const Fortran::parser::ConcurrentControl &ctrl :
1374            std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
1375         const Fortran::lower::SomeExpr *lo =
1376             Fortran::semantics::GetExpr(std::get<1>(ctrl.t));
1377         const Fortran::lower::SomeExpr *hi =
1378             Fortran::semantics::GetExpr(std::get<2>(ctrl.t));
1379         auto &optStep =
1380             std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t);
1381         lows.push_back(builder->createConvert(loc, idxTy, lowerExpr(*lo)));
1382         highs.push_back(builder->createConvert(loc, idxTy, lowerExpr(*hi)));
1383         steps.push_back(
1384             optStep.has_value()
1385                 ? builder->createConvert(
1386                       loc, idxTy,
1387                       lowerExpr(*Fortran::semantics::GetExpr(*optStep)))
1388                 : builder->createIntegerConstant(loc, idxTy, 1));
1389       }
1390     }
1391     auto lambda = [&, lows, highs, steps]() {
1392       // Create our iteration space from the header spec.
1393       mlir::Location loc = toLocation();
1394       mlir::Type idxTy = builder->getIndexType();
1395       llvm::SmallVector<fir::DoLoopOp> loops;
1396       Fortran::lower::StatementContext &stmtCtx =
1397           explicitIterSpace.stmtContext();
1398       auto lowerExpr = [&](auto &e) {
1399         return fir::getBase(genExprValue(e, stmtCtx));
1400       };
1401       const bool outermost = !lows.empty();
1402       std::size_t headerIndex = 0;
1403       for (const Fortran::parser::ConcurrentControl &ctrl :
1404            std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
1405         const Fortran::semantics::Symbol *ctrlVar =
1406             std::get<Fortran::parser::Name>(ctrl.t).symbol;
1407         mlir::Value lb;
1408         mlir::Value ub;
1409         mlir::Value by;
1410         if (outermost) {
1411           assert(headerIndex < lows.size());
1412           if (headerIndex == 0)
1413             explicitIterSpace.resetInnerArgs();
1414           lb = lows[headerIndex];
1415           ub = highs[headerIndex];
1416           by = steps[headerIndex++];
1417         } else {
1418           const Fortran::lower::SomeExpr *lo =
1419               Fortran::semantics::GetExpr(std::get<1>(ctrl.t));
1420           const Fortran::lower::SomeExpr *hi =
1421               Fortran::semantics::GetExpr(std::get<2>(ctrl.t));
1422           auto &optStep =
1423               std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t);
1424           lb = builder->createConvert(loc, idxTy, lowerExpr(*lo));
1425           ub = builder->createConvert(loc, idxTy, lowerExpr(*hi));
1426           by = optStep.has_value()
1427                    ? builder->createConvert(
1428                          loc, idxTy,
1429                          lowerExpr(*Fortran::semantics::GetExpr(*optStep)))
1430                    : builder->createIntegerConstant(loc, idxTy, 1);
1431         }
1432         auto lp = builder->create<fir::DoLoopOp>(
1433             loc, lb, ub, by, /*unordered=*/true,
1434             /*finalCount=*/false, explicitIterSpace.getInnerArgs());
1435         if (!loops.empty() || !outermost)
1436           builder->create<fir::ResultOp>(loc, lp.getResults());
1437         explicitIterSpace.setInnerArgs(lp.getRegionIterArgs());
1438         builder->setInsertionPointToStart(lp.getBody());
1439         forceControlVariableBinding(ctrlVar, lp.getInductionVar());
1440         loops.push_back(lp);
1441       }
1442       if (outermost)
1443         explicitIterSpace.setOuterLoop(loops[0]);
1444       explicitIterSpace.appendLoops(loops);
1445       if (const auto &mask =
1446               std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(
1447                   header.t);
1448           mask.has_value()) {
1449         mlir::Type i1Ty = builder->getI1Type();
1450         fir::ExtendedValue maskExv =
1451             genExprValue(*Fortran::semantics::GetExpr(mask.value()), stmtCtx);
1452         mlir::Value cond =
1453             builder->createConvert(loc, i1Ty, fir::getBase(maskExv));
1454         auto ifOp = builder->create<fir::IfOp>(
1455             loc, explicitIterSpace.innerArgTypes(), cond,
1456             /*withElseRegion=*/true);
1457         builder->create<fir::ResultOp>(loc, ifOp.getResults());
1458         builder->setInsertionPointToStart(&ifOp.getElseRegion().front());
1459         builder->create<fir::ResultOp>(loc, explicitIterSpace.getInnerArgs());
1460         builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
1461       }
1462     };
1463     // Push the lambda to gen the loop nest context.
1464     explicitIterSpace.pushLoopNest(lambda);
1465   }
1466 
1467   void genFIR(const Fortran::parser::ForallAssignmentStmt &stmt) {
1468     std::visit([&](const auto &x) { genFIR(x); }, stmt.u);
1469   }
1470 
1471   void genFIR(const Fortran::parser::EndForallStmt &) {
1472     cleanupExplicitSpace();
1473   }
1474 
1475   template <typename A>
1476   void prepareExplicitSpace(const A &forall) {
1477     if (!explicitIterSpace.isActive())
1478       analyzeExplicitSpace(forall);
1479     localSymbols.pushScope();
1480     explicitIterSpace.enter();
1481   }
1482 
1483   /// Cleanup all the FORALL context information when we exit.
1484   void cleanupExplicitSpace() {
1485     explicitIterSpace.leave();
1486     localSymbols.popScope();
1487   }
1488 
1489   /// Generate FIR for a FORALL statement.
1490   void genFIR(const Fortran::parser::ForallStmt &stmt) {
1491     prepareExplicitSpace(stmt);
1492     genFIR(std::get<
1493                Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
1494                stmt.t)
1495                .value());
1496     genFIR(std::get<Fortran::parser::UnlabeledStatement<
1497                Fortran::parser::ForallAssignmentStmt>>(stmt.t)
1498                .statement);
1499     cleanupExplicitSpace();
1500   }
1501 
1502   /// Generate FIR for a FORALL construct.
1503   void genFIR(const Fortran::parser::ForallConstruct &forall) {
1504     prepareExplicitSpace(forall);
1505     genNestedStatement(
1506         std::get<
1507             Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>(
1508             forall.t));
1509     for (const Fortran::parser::ForallBodyConstruct &s :
1510          std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) {
1511       std::visit(
1512           Fortran::common::visitors{
1513               [&](const Fortran::parser::WhereConstruct &b) { genFIR(b); },
1514               [&](const Fortran::common::Indirection<
1515                   Fortran::parser::ForallConstruct> &b) { genFIR(b.value()); },
1516               [&](const auto &b) { genNestedStatement(b); }},
1517           s.u);
1518     }
1519     genNestedStatement(
1520         std::get<Fortran::parser::Statement<Fortran::parser::EndForallStmt>>(
1521             forall.t));
1522   }
1523 
1524   /// Lower the concurrent header specification.
1525   void genFIR(const Fortran::parser::ForallConstructStmt &stmt) {
1526     genFIR(std::get<
1527                Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
1528                stmt.t)
1529                .value());
1530   }
1531 
1532   void genFIR(const Fortran::parser::CompilerDirective &) {
1533     TODO(toLocation(), "CompilerDirective lowering");
1534   }
1535 
1536   void genFIR(const Fortran::parser::OpenACCConstruct &) {
1537     TODO(toLocation(), "OpenACCConstruct lowering");
1538   }
1539 
1540   void genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &) {
1541     TODO(toLocation(), "OpenACCDeclarativeConstruct lowering");
1542   }
1543 
1544   void genFIR(const Fortran::parser::OpenMPConstruct &omp) {
1545     mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
1546     localSymbols.pushScope();
1547     Fortran::lower::genOpenMPConstruct(*this, getEval(), omp);
1548 
1549     for (Fortran::lower::pft::Evaluation &e : getEval().getNestedEvaluations())
1550       genFIR(e);
1551     localSymbols.popScope();
1552     builder->restoreInsertionPoint(insertPt);
1553   }
1554 
1555   void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &) {
1556     TODO(toLocation(), "OpenMPDeclarativeConstruct lowering");
1557   }
1558 
1559   void genFIR(const Fortran::parser::SelectCaseStmt &) {
1560     TODO(toLocation(), "SelectCaseStmt lowering");
1561   }
1562 
1563   fir::ExtendedValue
1564   genAssociateSelector(const Fortran::lower::SomeExpr &selector,
1565                        Fortran::lower::StatementContext &stmtCtx) {
1566     return isArraySectionWithoutVectorSubscript(selector)
1567                ? Fortran::lower::createSomeArrayBox(*this, selector,
1568                                                     localSymbols, stmtCtx)
1569                : genExprAddr(selector, stmtCtx);
1570   }
1571 
1572   void genFIR(const Fortran::parser::AssociateConstruct &) {
1573     Fortran::lower::StatementContext stmtCtx;
1574     Fortran::lower::pft::Evaluation &eval = getEval();
1575     for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
1576       if (auto *stmt = e.getIf<Fortran::parser::AssociateStmt>()) {
1577         if (eval.lowerAsUnstructured())
1578           maybeStartBlock(e.block);
1579         localSymbols.pushScope();
1580         for (const Fortran::parser::Association &assoc :
1581              std::get<std::list<Fortran::parser::Association>>(stmt->t)) {
1582           Fortran::semantics::Symbol &sym =
1583               *std::get<Fortran::parser::Name>(assoc.t).symbol;
1584           const Fortran::lower::SomeExpr &selector =
1585               *sym.get<Fortran::semantics::AssocEntityDetails>().expr();
1586           localSymbols.addSymbol(sym, genAssociateSelector(selector, stmtCtx));
1587         }
1588       } else if (e.getIf<Fortran::parser::EndAssociateStmt>()) {
1589         if (eval.lowerAsUnstructured())
1590           maybeStartBlock(e.block);
1591         stmtCtx.finalize();
1592         localSymbols.popScope();
1593       } else {
1594         genFIR(e);
1595       }
1596     }
1597   }
1598 
1599   void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) {
1600     TODO(toLocation(), "BlockConstruct lowering");
1601   }
1602 
1603   void genFIR(const Fortran::parser::BlockStmt &) {
1604     TODO(toLocation(), "BlockStmt lowering");
1605   }
1606 
1607   void genFIR(const Fortran::parser::EndBlockStmt &) {
1608     TODO(toLocation(), "EndBlockStmt lowering");
1609   }
1610 
1611   void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {
1612     TODO(toLocation(), "ChangeTeamConstruct lowering");
1613   }
1614 
1615   void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) {
1616     TODO(toLocation(), "ChangeTeamStmt lowering");
1617   }
1618 
1619   void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) {
1620     TODO(toLocation(), "EndChangeTeamStmt lowering");
1621   }
1622 
1623   void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) {
1624     TODO(toLocation(), "CriticalConstruct lowering");
1625   }
1626 
1627   void genFIR(const Fortran::parser::CriticalStmt &) {
1628     TODO(toLocation(), "CriticalStmt lowering");
1629   }
1630 
1631   void genFIR(const Fortran::parser::EndCriticalStmt &) {
1632     TODO(toLocation(), "EndCriticalStmt lowering");
1633   }
1634 
1635   void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) {
1636     TODO(toLocation(), "SelectRankConstruct lowering");
1637   }
1638 
1639   void genFIR(const Fortran::parser::SelectRankStmt &) {
1640     TODO(toLocation(), "SelectRankStmt lowering");
1641   }
1642 
1643   void genFIR(const Fortran::parser::SelectRankCaseStmt &) {
1644     TODO(toLocation(), "SelectRankCaseStmt lowering");
1645   }
1646 
1647   void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {
1648     TODO(toLocation(), "SelectTypeConstruct lowering");
1649   }
1650 
1651   void genFIR(const Fortran::parser::SelectTypeStmt &) {
1652     TODO(toLocation(), "SelectTypeStmt lowering");
1653   }
1654 
1655   void genFIR(const Fortran::parser::TypeGuardStmt &) {
1656     TODO(toLocation(), "TypeGuardStmt lowering");
1657   }
1658 
1659   //===--------------------------------------------------------------------===//
1660   // IO statements (see io.h)
1661   //===--------------------------------------------------------------------===//
1662 
1663   void genFIR(const Fortran::parser::BackspaceStmt &stmt) {
1664     mlir::Value iostat = genBackspaceStatement(*this, stmt);
1665     genIoConditionBranches(getEval(), stmt.v, iostat);
1666   }
1667 
1668   void genFIR(const Fortran::parser::CloseStmt &stmt) {
1669     mlir::Value iostat = genCloseStatement(*this, stmt);
1670     genIoConditionBranches(getEval(), stmt.v, iostat);
1671   }
1672 
1673   void genFIR(const Fortran::parser::EndfileStmt &stmt) {
1674     mlir::Value iostat = genEndfileStatement(*this, stmt);
1675     genIoConditionBranches(getEval(), stmt.v, iostat);
1676   }
1677 
1678   void genFIR(const Fortran::parser::FlushStmt &stmt) {
1679     mlir::Value iostat = genFlushStatement(*this, stmt);
1680     genIoConditionBranches(getEval(), stmt.v, iostat);
1681   }
1682 
1683   void genFIR(const Fortran::parser::InquireStmt &stmt) {
1684     mlir::Value iostat = genInquireStatement(*this, stmt);
1685     if (const auto *specs =
1686             std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u))
1687       genIoConditionBranches(getEval(), *specs, iostat);
1688   }
1689 
1690   void genFIR(const Fortran::parser::OpenStmt &stmt) {
1691     mlir::Value iostat = genOpenStatement(*this, stmt);
1692     genIoConditionBranches(getEval(), stmt.v, iostat);
1693   }
1694 
1695   void genFIR(const Fortran::parser::PrintStmt &stmt) {
1696     genPrintStatement(*this, stmt);
1697   }
1698 
1699   void genFIR(const Fortran::parser::ReadStmt &stmt) {
1700     mlir::Value iostat = genReadStatement(*this, stmt);
1701     genIoConditionBranches(getEval(), stmt.controls, iostat);
1702   }
1703 
1704   void genFIR(const Fortran::parser::RewindStmt &stmt) {
1705     mlir::Value iostat = genRewindStatement(*this, stmt);
1706     genIoConditionBranches(getEval(), stmt.v, iostat);
1707   }
1708 
1709   void genFIR(const Fortran::parser::WaitStmt &stmt) {
1710     mlir::Value iostat = genWaitStatement(*this, stmt);
1711     genIoConditionBranches(getEval(), stmt.v, iostat);
1712   }
1713 
1714   void genFIR(const Fortran::parser::WriteStmt &stmt) {
1715     mlir::Value iostat = genWriteStatement(*this, stmt);
1716     genIoConditionBranches(getEval(), stmt.controls, iostat);
1717   }
1718 
1719   template <typename A>
1720   void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
1721                               const A &specList, mlir::Value iostat) {
1722     if (!iostat)
1723       return;
1724 
1725     mlir::Block *endBlock = nullptr;
1726     mlir::Block *eorBlock = nullptr;
1727     mlir::Block *errBlock = nullptr;
1728     for (const auto &spec : specList) {
1729       std::visit(Fortran::common::visitors{
1730                      [&](const Fortran::parser::EndLabel &label) {
1731                        endBlock = blockOfLabel(eval, label.v);
1732                      },
1733                      [&](const Fortran::parser::EorLabel &label) {
1734                        eorBlock = blockOfLabel(eval, label.v);
1735                      },
1736                      [&](const Fortran::parser::ErrLabel &label) {
1737                        errBlock = blockOfLabel(eval, label.v);
1738                      },
1739                      [](const auto &) {}},
1740                  spec.u);
1741     }
1742     if (!endBlock && !eorBlock && !errBlock)
1743       return;
1744 
1745     mlir::Location loc = toLocation();
1746     mlir::Type indexType = builder->getIndexType();
1747     mlir::Value selector = builder->createConvert(loc, indexType, iostat);
1748     llvm::SmallVector<int64_t> indexList;
1749     llvm::SmallVector<mlir::Block *> blockList;
1750     if (eorBlock) {
1751       indexList.push_back(Fortran::runtime::io::IostatEor);
1752       blockList.push_back(eorBlock);
1753     }
1754     if (endBlock) {
1755       indexList.push_back(Fortran::runtime::io::IostatEnd);
1756       blockList.push_back(endBlock);
1757     }
1758     if (errBlock) {
1759       indexList.push_back(0);
1760       blockList.push_back(eval.nonNopSuccessor().block);
1761       // ERR label statement is the default successor.
1762       blockList.push_back(errBlock);
1763     } else {
1764       // Fallthrough successor statement is the default successor.
1765       blockList.push_back(eval.nonNopSuccessor().block);
1766     }
1767     builder->create<fir::SelectOp>(loc, selector, indexList, blockList);
1768   }
1769 
1770   //===--------------------------------------------------------------------===//
1771   // Memory allocation and deallocation
1772   //===--------------------------------------------------------------------===//
1773 
1774   void genFIR(const Fortran::parser::AllocateStmt &stmt) {
1775     Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
1776   }
1777 
1778   void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
1779     Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
1780   }
1781 
1782   /// Nullify pointer object list
1783   ///
1784   /// For each pointer object, reset the pointer to a disassociated status.
1785   /// We do this by setting each pointer to null.
1786   void genFIR(const Fortran::parser::NullifyStmt &stmt) {
1787     mlir::Location loc = toLocation();
1788     for (auto &pointerObject : stmt.v) {
1789       const Fortran::lower::SomeExpr *expr =
1790           Fortran::semantics::GetExpr(pointerObject);
1791       assert(expr);
1792       fir::MutableBoxValue box = genExprMutableBox(loc, *expr);
1793       fir::factory::disassociateMutableBox(*builder, loc, box);
1794     }
1795   }
1796 
1797   //===--------------------------------------------------------------------===//
1798 
1799   void genFIR(const Fortran::parser::EventPostStmt &stmt) {
1800     TODO(toLocation(), "EventPostStmt lowering");
1801   }
1802 
1803   void genFIR(const Fortran::parser::EventWaitStmt &stmt) {
1804     TODO(toLocation(), "EventWaitStmt lowering");
1805   }
1806 
1807   void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
1808     TODO(toLocation(), "FormTeamStmt lowering");
1809   }
1810 
1811   void genFIR(const Fortran::parser::LockStmt &stmt) {
1812     TODO(toLocation(), "LockStmt lowering");
1813   }
1814 
1815   /// Return true if the current context is a conditionalized and implied
1816   /// iteration space.
1817   bool implicitIterationSpace() { return !implicitIterSpace.empty(); }
1818 
1819   /// Return true if context is currently an explicit iteration space. A scalar
1820   /// assignment expression may be contextually within a user-defined iteration
1821   /// space, transforming it into an array expression.
1822   bool explicitIterationSpace() { return explicitIterSpace.isActive(); }
1823 
1824   /// Generate an array assignment.
1825   /// This is an assignment expression with rank > 0. The assignment may or may
1826   /// not be in a WHERE and/or FORALL context.
1827   void genArrayAssignment(const Fortran::evaluate::Assignment &assign,
1828                           Fortran::lower::StatementContext &stmtCtx) {
1829     if (isWholeAllocatable(assign.lhs)) {
1830       // Assignment to allocatables may require the lhs to be
1831       // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3
1832       Fortran::lower::createAllocatableArrayAssignment(
1833           *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
1834           localSymbols, stmtCtx);
1835       return;
1836     }
1837 
1838     if (!implicitIterationSpace() && !explicitIterationSpace()) {
1839       // No masks and the iteration space is implied by the array, so create a
1840       // simple array assignment.
1841       Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs,
1842                                                 localSymbols, stmtCtx);
1843       return;
1844     }
1845 
1846     // If there is an explicit iteration space, generate an array assignment
1847     // with a user-specified iteration space and possibly with masks. These
1848     // assignments may *appear* to be scalar expressions, but the scalar
1849     // expression is evaluated at all points in the user-defined space much like
1850     // an ordinary array assignment. More specifically, the semantics inside the
1851     // FORALL much more closely resembles that of WHERE than a scalar
1852     // assignment.
1853     // Otherwise, generate a masked array assignment. The iteration space is
1854     // implied by the lhs array expression.
1855     Fortran::lower::createAnyMaskedArrayAssignment(
1856         *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
1857         localSymbols,
1858         explicitIterationSpace() ? explicitIterSpace.stmtContext()
1859                                  : implicitIterSpace.stmtContext());
1860   }
1861 
1862   void genFIR(const Fortran::parser::WhereConstruct &c) {
1863     implicitIterSpace.growStack();
1864     genNestedStatement(
1865         std::get<
1866             Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(
1867             c.t));
1868     for (const auto &body :
1869          std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))
1870       genFIR(body);
1871     for (const auto &e :
1872          std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>(
1873              c.t))
1874       genFIR(e);
1875     if (const auto &e =
1876             std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>(
1877                 c.t);
1878         e.has_value())
1879       genFIR(*e);
1880     genNestedStatement(
1881         std::get<Fortran::parser::Statement<Fortran::parser::EndWhereStmt>>(
1882             c.t));
1883   }
1884   void genFIR(const Fortran::parser::WhereBodyConstruct &body) {
1885     std::visit(
1886         Fortran::common::visitors{
1887             [&](const Fortran::parser::Statement<
1888                 Fortran::parser::AssignmentStmt> &stmt) {
1889               genNestedStatement(stmt);
1890             },
1891             [&](const Fortran::parser::Statement<Fortran::parser::WhereStmt>
1892                     &stmt) { genNestedStatement(stmt); },
1893             [&](const Fortran::common::Indirection<
1894                 Fortran::parser::WhereConstruct> &c) { genFIR(c.value()); },
1895         },
1896         body.u);
1897   }
1898   void genFIR(const Fortran::parser::WhereConstructStmt &stmt) {
1899     implicitIterSpace.append(Fortran::semantics::GetExpr(
1900         std::get<Fortran::parser::LogicalExpr>(stmt.t)));
1901   }
1902   void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {
1903     genNestedStatement(
1904         std::get<
1905             Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>(
1906             ew.t));
1907     for (const auto &body :
1908          std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
1909       genFIR(body);
1910   }
1911   void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) {
1912     implicitIterSpace.append(Fortran::semantics::GetExpr(
1913         std::get<Fortran::parser::LogicalExpr>(stmt.t)));
1914   }
1915   void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) {
1916     genNestedStatement(
1917         std::get<Fortran::parser::Statement<Fortran::parser::ElsewhereStmt>>(
1918             ew.t));
1919     for (const auto &body :
1920          std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
1921       genFIR(body);
1922   }
1923   void genFIR(const Fortran::parser::ElsewhereStmt &stmt) {
1924     implicitIterSpace.append(nullptr);
1925   }
1926   void genFIR(const Fortran::parser::EndWhereStmt &) {
1927     implicitIterSpace.shrinkStack();
1928   }
1929 
1930   void genFIR(const Fortran::parser::WhereStmt &stmt) {
1931     Fortran::lower::StatementContext stmtCtx;
1932     const auto &assign = std::get<Fortran::parser::AssignmentStmt>(stmt.t);
1933     implicitIterSpace.growStack();
1934     implicitIterSpace.append(Fortran::semantics::GetExpr(
1935         std::get<Fortran::parser::LogicalExpr>(stmt.t)));
1936     genAssignment(*assign.typedAssignment->v);
1937     implicitIterSpace.shrinkStack();
1938   }
1939 
1940   void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) {
1941     genAssignment(*stmt.typedAssignment->v);
1942   }
1943 
1944   void genFIR(const Fortran::parser::AssignmentStmt &stmt) {
1945     genAssignment(*stmt.typedAssignment->v);
1946   }
1947 
1948   void genFIR(const Fortran::parser::SyncAllStmt &stmt) {
1949     TODO(toLocation(), "SyncAllStmt lowering");
1950   }
1951 
1952   void genFIR(const Fortran::parser::SyncImagesStmt &stmt) {
1953     TODO(toLocation(), "SyncImagesStmt lowering");
1954   }
1955 
1956   void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) {
1957     TODO(toLocation(), "SyncMemoryStmt lowering");
1958   }
1959 
1960   void genFIR(const Fortran::parser::SyncTeamStmt &stmt) {
1961     TODO(toLocation(), "SyncTeamStmt lowering");
1962   }
1963 
1964   void genFIR(const Fortran::parser::UnlockStmt &stmt) {
1965     TODO(toLocation(), "UnlockStmt lowering");
1966   }
1967 
1968   void genFIR(const Fortran::parser::AssignStmt &stmt) {
1969     const Fortran::semantics::Symbol &symbol =
1970         *std::get<Fortran::parser::Name>(stmt.t).symbol;
1971     mlir::Location loc = toLocation();
1972     mlir::Value labelValue = builder->createIntegerConstant(
1973         loc, genType(symbol), std::get<Fortran::parser::Label>(stmt.t));
1974     builder->create<fir::StoreOp>(loc, labelValue, getSymbolAddress(symbol));
1975   }
1976 
1977   void genFIR(const Fortran::parser::FormatStmt &) {
1978     // do nothing.
1979 
1980     // FORMAT statements have no semantics. They may be lowered if used by a
1981     // data transfer statement.
1982   }
1983 
1984   void genFIR(const Fortran::parser::PauseStmt &stmt) {
1985     genPauseStatement(*this, stmt);
1986   }
1987 
1988   void genFIR(const Fortran::parser::FailImageStmt &stmt) {
1989     TODO(toLocation(), "FailImageStmt lowering");
1990   }
1991 
1992   // call STOP, ERROR STOP in runtime
1993   void genFIR(const Fortran::parser::StopStmt &stmt) {
1994     genStopStatement(*this, stmt);
1995   }
1996 
1997   void genFIR(const Fortran::parser::ReturnStmt &stmt) {
1998     Fortran::lower::pft::FunctionLikeUnit *funit =
1999         getEval().getOwningProcedure();
2000     assert(funit && "not inside main program, function or subroutine");
2001     if (funit->isMainProgram()) {
2002       genExitRoutine();
2003       return;
2004     }
2005     mlir::Location loc = toLocation();
2006     if (stmt.v) {
2007       // Alternate return statement - If this is a subroutine where some
2008       // alternate entries have alternate returns, but the active entry point
2009       // does not, ignore the alternate return value.  Otherwise, assign it
2010       // to the compiler-generated result variable.
2011       const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol();
2012       if (Fortran::semantics::HasAlternateReturns(symbol)) {
2013         Fortran::lower::StatementContext stmtCtx;
2014         const Fortran::lower::SomeExpr *expr =
2015             Fortran::semantics::GetExpr(*stmt.v);
2016         assert(expr && "missing alternate return expression");
2017         mlir::Value altReturnIndex = builder->createConvert(
2018             loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx));
2019         builder->create<fir::StoreOp>(loc, altReturnIndex,
2020                                       getAltReturnResult(symbol));
2021       }
2022     }
2023     // Branch to the last block of the SUBROUTINE, which has the actual return.
2024     if (!funit->finalBlock) {
2025       mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
2026       funit->finalBlock = builder->createBlock(&builder->getRegion());
2027       builder->restoreInsertionPoint(insPt);
2028     }
2029     builder->create<mlir::cf::BranchOp>(loc, funit->finalBlock);
2030   }
2031 
2032   void genFIR(const Fortran::parser::CycleStmt &) {
2033     TODO(toLocation(), "CycleStmt lowering");
2034   }
2035 
2036   void genFIR(const Fortran::parser::ExitStmt &) {
2037     TODO(toLocation(), "ExitStmt lowering");
2038   }
2039 
2040   void genFIR(const Fortran::parser::GotoStmt &) {
2041     genFIRBranch(getEval().controlSuccessor->block);
2042   }
2043 
2044   void genFIR(const Fortran::parser::CaseStmt &) {
2045     TODO(toLocation(), "CaseStmt lowering");
2046   }
2047 
2048   void genFIR(const Fortran::parser::ElseIfStmt &) {
2049     TODO(toLocation(), "ElseIfStmt lowering");
2050   }
2051 
2052   void genFIR(const Fortran::parser::ElseStmt &) {
2053     TODO(toLocation(), "ElseStmt lowering");
2054   }
2055 
2056   void genFIR(const Fortran::parser::EndDoStmt &) {
2057     TODO(toLocation(), "EndDoStmt lowering");
2058   }
2059 
2060   void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {
2061     TODO(toLocation(), "EndMpSubprogramStmt lowering");
2062   }
2063 
2064   void genFIR(const Fortran::parser::EndSelectStmt &) {
2065     TODO(toLocation(), "EndSelectStmt lowering");
2066   }
2067 
2068   // Nop statements - No code, or code is generated at the construct level.
2069   void genFIR(const Fortran::parser::AssociateStmt &) {}     // nop
2070   void genFIR(const Fortran::parser::ContinueStmt &) {}      // nop
2071   void genFIR(const Fortran::parser::EndAssociateStmt &) {}  // nop
2072   void genFIR(const Fortran::parser::EndFunctionStmt &) {}   // nop
2073   void genFIR(const Fortran::parser::EndIfStmt &) {}         // nop
2074   void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
2075   void genFIR(const Fortran::parser::EntryStmt &) {}         // nop
2076 
2077   void genFIR(const Fortran::parser::IfStmt &) {
2078     TODO(toLocation(), "IfStmt lowering");
2079   }
2080 
2081   void genFIR(const Fortran::parser::IfThenStmt &) {
2082     TODO(toLocation(), "IfThenStmt lowering");
2083   }
2084 
2085   void genFIR(const Fortran::parser::NonLabelDoStmt &) {
2086     TODO(toLocation(), "NonLabelDoStmt lowering");
2087   }
2088 
2089   void genFIR(const Fortran::parser::OmpEndLoopDirective &) {
2090     TODO(toLocation(), "OmpEndLoopDirective lowering");
2091   }
2092 
2093   void genFIR(const Fortran::parser::NamelistStmt &) {
2094     TODO(toLocation(), "NamelistStmt lowering");
2095   }
2096 
2097   void genFIR(Fortran::lower::pft::Evaluation &eval,
2098               bool unstructuredContext = true) {
2099     if (unstructuredContext) {
2100       // When transitioning from unstructured to structured code,
2101       // the structured code could be a target that starts a new block.
2102       maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured()
2103                           ? eval.getFirstNestedEvaluation().block
2104                           : eval.block);
2105     }
2106 
2107     setCurrentEval(eval);
2108     setCurrentPosition(eval.position);
2109     eval.visit([&](const auto &stmt) { genFIR(stmt); });
2110   }
2111 
2112   //===--------------------------------------------------------------------===//
2113   // Analysis on a nested explicit iteration space.
2114   //===--------------------------------------------------------------------===//
2115 
2116   void analyzeExplicitSpace(const Fortran::parser::ConcurrentHeader &header) {
2117     explicitIterSpace.pushLevel();
2118     for (const Fortran::parser::ConcurrentControl &ctrl :
2119          std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
2120       const Fortran::semantics::Symbol *ctrlVar =
2121           std::get<Fortran::parser::Name>(ctrl.t).symbol;
2122       explicitIterSpace.addSymbol(ctrlVar);
2123     }
2124     if (const auto &mask =
2125             std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(
2126                 header.t);
2127         mask.has_value())
2128       analyzeExplicitSpace(*Fortran::semantics::GetExpr(*mask));
2129   }
2130   template <bool LHS = false, typename A>
2131   void analyzeExplicitSpace(const Fortran::evaluate::Expr<A> &e) {
2132     explicitIterSpace.exprBase(&e, LHS);
2133   }
2134   void analyzeExplicitSpace(const Fortran::evaluate::Assignment *assign) {
2135     auto analyzeAssign = [&](const Fortran::lower::SomeExpr &lhs,
2136                              const Fortran::lower::SomeExpr &rhs) {
2137       analyzeExplicitSpace</*LHS=*/true>(lhs);
2138       analyzeExplicitSpace(rhs);
2139     };
2140     std::visit(
2141         Fortran::common::visitors{
2142             [&](const Fortran::evaluate::ProcedureRef &procRef) {
2143               // Ensure the procRef expressions are the one being visited.
2144               assert(procRef.arguments().size() == 2);
2145               const Fortran::lower::SomeExpr *lhs =
2146                   procRef.arguments()[0].value().UnwrapExpr();
2147               const Fortran::lower::SomeExpr *rhs =
2148                   procRef.arguments()[1].value().UnwrapExpr();
2149               assert(lhs && rhs &&
2150                      "user defined assignment arguments must be expressions");
2151               analyzeAssign(*lhs, *rhs);
2152             },
2153             [&](const auto &) { analyzeAssign(assign->lhs, assign->rhs); }},
2154         assign->u);
2155     explicitIterSpace.endAssign();
2156   }
2157   void analyzeExplicitSpace(const Fortran::parser::ForallAssignmentStmt &stmt) {
2158     std::visit([&](const auto &s) { analyzeExplicitSpace(s); }, stmt.u);
2159   }
2160   void analyzeExplicitSpace(const Fortran::parser::AssignmentStmt &s) {
2161     analyzeExplicitSpace(s.typedAssignment->v.operator->());
2162   }
2163   void analyzeExplicitSpace(const Fortran::parser::PointerAssignmentStmt &s) {
2164     analyzeExplicitSpace(s.typedAssignment->v.operator->());
2165   }
2166   void analyzeExplicitSpace(const Fortran::parser::WhereConstruct &c) {
2167     analyzeExplicitSpace(
2168         std::get<
2169             Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(
2170             c.t)
2171             .statement);
2172     for (const Fortran::parser::WhereBodyConstruct &body :
2173          std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))
2174       analyzeExplicitSpace(body);
2175     for (const Fortran::parser::WhereConstruct::MaskedElsewhere &e :
2176          std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>(
2177              c.t))
2178       analyzeExplicitSpace(e);
2179     if (const auto &e =
2180             std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>(
2181                 c.t);
2182         e.has_value())
2183       analyzeExplicitSpace(e.operator->());
2184   }
2185   void analyzeExplicitSpace(const Fortran::parser::WhereConstructStmt &ws) {
2186     const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(
2187         std::get<Fortran::parser::LogicalExpr>(ws.t));
2188     addMaskVariable(exp);
2189     analyzeExplicitSpace(*exp);
2190   }
2191   void analyzeExplicitSpace(
2192       const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {
2193     analyzeExplicitSpace(
2194         std::get<
2195             Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>(
2196             ew.t)
2197             .statement);
2198     for (const Fortran::parser::WhereBodyConstruct &e :
2199          std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
2200       analyzeExplicitSpace(e);
2201   }
2202   void analyzeExplicitSpace(const Fortran::parser::WhereBodyConstruct &body) {
2203     std::visit(Fortran::common::visitors{
2204                    [&](const Fortran::common::Indirection<
2205                        Fortran::parser::WhereConstruct> &wc) {
2206                      analyzeExplicitSpace(wc.value());
2207                    },
2208                    [&](const auto &s) { analyzeExplicitSpace(s.statement); }},
2209                body.u);
2210   }
2211   void analyzeExplicitSpace(const Fortran::parser::MaskedElsewhereStmt &stmt) {
2212     const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(
2213         std::get<Fortran::parser::LogicalExpr>(stmt.t));
2214     addMaskVariable(exp);
2215     analyzeExplicitSpace(*exp);
2216   }
2217   void
2218   analyzeExplicitSpace(const Fortran::parser::WhereConstruct::Elsewhere *ew) {
2219     for (const Fortran::parser::WhereBodyConstruct &e :
2220          std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew->t))
2221       analyzeExplicitSpace(e);
2222   }
2223   void analyzeExplicitSpace(const Fortran::parser::WhereStmt &stmt) {
2224     const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(
2225         std::get<Fortran::parser::LogicalExpr>(stmt.t));
2226     addMaskVariable(exp);
2227     analyzeExplicitSpace(*exp);
2228     const std::optional<Fortran::evaluate::Assignment> &assign =
2229         std::get<Fortran::parser::AssignmentStmt>(stmt.t).typedAssignment->v;
2230     assert(assign.has_value() && "WHERE has no statement");
2231     analyzeExplicitSpace(assign.operator->());
2232   }
2233   void analyzeExplicitSpace(const Fortran::parser::ForallStmt &forall) {
2234     analyzeExplicitSpace(
2235         std::get<
2236             Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
2237             forall.t)
2238             .value());
2239     analyzeExplicitSpace(std::get<Fortran::parser::UnlabeledStatement<
2240                              Fortran::parser::ForallAssignmentStmt>>(forall.t)
2241                              .statement);
2242     analyzeExplicitSpacePop();
2243   }
2244   void
2245   analyzeExplicitSpace(const Fortran::parser::ForallConstructStmt &forall) {
2246     analyzeExplicitSpace(
2247         std::get<
2248             Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
2249             forall.t)
2250             .value());
2251   }
2252   void analyzeExplicitSpace(const Fortran::parser::ForallConstruct &forall) {
2253     analyzeExplicitSpace(
2254         std::get<
2255             Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>(
2256             forall.t)
2257             .statement);
2258     for (const Fortran::parser::ForallBodyConstruct &s :
2259          std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) {
2260       std::visit(Fortran::common::visitors{
2261                      [&](const Fortran::common::Indirection<
2262                          Fortran::parser::ForallConstruct> &b) {
2263                        analyzeExplicitSpace(b.value());
2264                      },
2265                      [&](const Fortran::parser::WhereConstruct &w) {
2266                        analyzeExplicitSpace(w);
2267                      },
2268                      [&](const auto &b) { analyzeExplicitSpace(b.statement); }},
2269                  s.u);
2270     }
2271     analyzeExplicitSpacePop();
2272   }
2273 
2274   void analyzeExplicitSpacePop() { explicitIterSpace.popLevel(); }
2275 
2276   void addMaskVariable(Fortran::lower::FrontEndExpr exp) {
2277     // Note: use i8 to store bool values. This avoids round-down behavior found
2278     // with sequences of i1. That is, an array of i1 will be truncated in size
2279     // and be too small. For example, a buffer of type fir.array<7xi1> will have
2280     // 0 size.
2281     mlir::Type i64Ty = builder->getIntegerType(64);
2282     mlir::TupleType ty = fir::factory::getRaggedArrayHeaderType(*builder);
2283     mlir::Type buffTy = ty.getType(1);
2284     mlir::Type shTy = ty.getType(2);
2285     mlir::Location loc = toLocation();
2286     mlir::Value hdr = builder->createTemporary(loc, ty);
2287     // FIXME: Is there a way to create a `zeroinitializer` in LLVM-IR dialect?
2288     // For now, explicitly set lazy ragged header to all zeros.
2289     // auto nilTup = builder->createNullConstant(loc, ty);
2290     // builder->create<fir::StoreOp>(loc, nilTup, hdr);
2291     mlir::Type i32Ty = builder->getIntegerType(32);
2292     mlir::Value zero = builder->createIntegerConstant(loc, i32Ty, 0);
2293     mlir::Value zero64 = builder->createIntegerConstant(loc, i64Ty, 0);
2294     mlir::Value flags = builder->create<fir::CoordinateOp>(
2295         loc, builder->getRefType(i64Ty), hdr, zero);
2296     builder->create<fir::StoreOp>(loc, zero64, flags);
2297     mlir::Value one = builder->createIntegerConstant(loc, i32Ty, 1);
2298     mlir::Value nullPtr1 = builder->createNullConstant(loc, buffTy);
2299     mlir::Value var = builder->create<fir::CoordinateOp>(
2300         loc, builder->getRefType(buffTy), hdr, one);
2301     builder->create<fir::StoreOp>(loc, nullPtr1, var);
2302     mlir::Value two = builder->createIntegerConstant(loc, i32Ty, 2);
2303     mlir::Value nullPtr2 = builder->createNullConstant(loc, shTy);
2304     mlir::Value shape = builder->create<fir::CoordinateOp>(
2305         loc, builder->getRefType(shTy), hdr, two);
2306     builder->create<fir::StoreOp>(loc, nullPtr2, shape);
2307     implicitIterSpace.addMaskVariable(exp, var, shape, hdr);
2308     explicitIterSpace.outermostContext().attachCleanup(
2309         [builder = this->builder, hdr, loc]() {
2310           fir::runtime::genRaggedArrayDeallocate(loc, *builder, hdr);
2311         });
2312   }
2313 
2314   //===--------------------------------------------------------------------===//
2315 
2316   Fortran::lower::LoweringBridge &bridge;
2317   Fortran::evaluate::FoldingContext foldingContext;
2318   fir::FirOpBuilder *builder = nullptr;
2319   Fortran::lower::pft::Evaluation *evalPtr = nullptr;
2320   Fortran::lower::SymMap localSymbols;
2321   Fortran::parser::CharBlock currentPosition;
2322 
2323   /// Tuple of host assoicated variables.
2324   mlir::Value hostAssocTuple;
2325   Fortran::lower::ImplicitIterSpace implicitIterSpace;
2326   Fortran::lower::ExplicitIterSpace explicitIterSpace;
2327 };
2328 
2329 } // namespace
2330 
2331 Fortran::evaluate::FoldingContext
2332 Fortran::lower::LoweringBridge::createFoldingContext() const {
2333   return {getDefaultKinds(), getIntrinsicTable()};
2334 }
2335 
2336 void Fortran::lower::LoweringBridge::lower(
2337     const Fortran::parser::Program &prg,
2338     const Fortran::semantics::SemanticsContext &semanticsContext) {
2339   std::unique_ptr<Fortran::lower::pft::Program> pft =
2340       Fortran::lower::createPFT(prg, semanticsContext);
2341   if (dumpBeforeFir)
2342     Fortran::lower::dumpPFT(llvm::errs(), *pft);
2343   FirConverter converter{*this};
2344   converter.run(*pft);
2345 }
2346 
2347 Fortran::lower::LoweringBridge::LoweringBridge(
2348     mlir::MLIRContext &context,
2349     const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds,
2350     const Fortran::evaluate::IntrinsicProcTable &intrinsics,
2351     const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
2352     fir::KindMapping &kindMap)
2353     : defaultKinds{defaultKinds}, intrinsics{intrinsics}, cooked{&cooked},
2354       context{context}, kindMap{kindMap} {
2355   // Register the diagnostic handler.
2356   context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
2357     llvm::raw_ostream &os = llvm::errs();
2358     switch (diag.getSeverity()) {
2359     case mlir::DiagnosticSeverity::Error:
2360       os << "error: ";
2361       break;
2362     case mlir::DiagnosticSeverity::Remark:
2363       os << "info: ";
2364       break;
2365     case mlir::DiagnosticSeverity::Warning:
2366       os << "warning: ";
2367       break;
2368     default:
2369       break;
2370     }
2371     if (!diag.getLocation().isa<UnknownLoc>())
2372       os << diag.getLocation() << ": ";
2373     os << diag << '\n';
2374     os.flush();
2375     return mlir::success();
2376   });
2377 
2378   // Create the module and attach the attributes.
2379   module = std::make_unique<mlir::ModuleOp>(
2380       mlir::ModuleOp::create(mlir::UnknownLoc::get(&context)));
2381   assert(module.get() && "module was not created");
2382   fir::setTargetTriple(*module.get(), triple);
2383   fir::setKindMapping(*module.get(), kindMap);
2384 }
2385