[flang-commits] [flang] a142501 - [flang] Lower more pointer assignments/disassociation cases
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Tue Mar 15 14:00:37 PDT 2022
Author: Valentin Clement
Date: 2022-03-15T21:58:33+01:00
New Revision: a1425019e7207e8dc53e627aacfd547415a10b35
URL: https://github.com/llvm/llvm-project/commit/a1425019e7207e8dc53e627aacfd547415a10b35
DIFF: https://github.com/llvm/llvm-project/commit/a1425019e7207e8dc53e627aacfd547415a10b35.diff
LOG: [flang] Lower more pointer assignments/disassociation cases
This patch lowers more cases of pointer assignments and
disassociations.
This patch is part of the upstreaming effort from fir-dev branch.
Reviewed By: PeteSteinfeld, schweitz
Differential Revision: https://reviews.llvm.org/D121697
Co-authored-by: V Donaldson <vdonaldson at nvidia.com>
Co-authored-by: Jean Perier <jperier at nvidia.com>
Co-authored-by: mleair <leairmark at gmail.com>
Co-authored-by: Eric Schweitz <eschweitz at nvidia.com>
Added:
flang/test/Lower/nullify.f90
flang/test/Lower/pointer-assignments.f90
flang/test/Lower/pointer-disassociate.f90
flang/test/Lower/pointer-initial-target-2.f90
flang/test/Lower/pointer-initial-target.f90
flang/test/Lower/pointer-reference.f90
flang/test/Lower/pointer-results-as-arguments.f90
flang/test/Lower/pointer-runtime.f90
flang/test/Lower/pointer.f90
Modified:
flang/include/flang/Lower/AbstractConverter.h
flang/include/flang/Lower/ConvertVariable.h
flang/include/flang/Lower/SymbolMap.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/ConvertExpr.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Lower/IntrinsicCall.cpp
flang/lib/Lower/SymbolMap.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h
index 6af5d0149f65c..fc907c2e5ada6 100644
--- a/flang/include/flang/Lower/AbstractConverter.h
+++ b/flang/include/flang/Lower/AbstractConverter.h
@@ -79,6 +79,13 @@ class AbstractConverter {
/// Get the binding of an implied do variable by name.
virtual mlir::Value impliedDoBinding(llvm::StringRef name) = 0;
+ /// Copy the binding of src to target symbol.
+ virtual void copySymbolBinding(SymbolRef src, SymbolRef target) = 0;
+
+ /// Binds the symbol to an fir extended value. The symbol binding will be
+ /// added or replaced at the inner-most level of the local symbol map.
+ virtual void bindSymbol(SymbolRef sym, const fir::ExtendedValue &exval) = 0;
+
/// Get the label set associated with a symbol.
virtual bool lookupLabelSet(SymbolRef sym, pft::LabelSet &labelSet) = 0;
diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h
index a0f277aa62fde..6b439f4e6d141 100644
--- a/flang/include/flang/Lower/ConvertVariable.h
+++ b/flang/include/flang/Lower/ConvertVariable.h
@@ -85,5 +85,11 @@ fir::ExtendedValue
genExtAddrInInitializer(Fortran::lower::AbstractConverter &converter,
mlir::Location loc, const SomeExpr &addr);
+/// Create global variable from a compiler generated object symbol that
+/// describes a derived type for the runtime.
+void createRuntimeTypeInfoGlobal(Fortran::lower::AbstractConverter &converter,
+ mlir::Location loc,
+ const Fortran::semantics::Symbol &typeInfoSym);
+
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_CONVERT_VARIABLE_H
diff --git a/flang/include/flang/Lower/SymbolMap.h b/flang/include/flang/Lower/SymbolMap.h
index 31883cacf50a9..98f4e3cbe486b 100644
--- a/flang/include/flang/Lower/SymbolMap.h
+++ b/flang/include/flang/Lower/SymbolMap.h
@@ -295,6 +295,13 @@ class SymMap {
return lookupSymbol(*sym);
}
+ /// Find `symbol` and return its value if it appears in the inner-most level
+ /// map.
+ SymbolBox shallowLookupSymbol(semantics::SymbolRef sym);
+ SymbolBox shallowLookupSymbol(const semantics::Symbol *sym) {
+ return shallowLookupSymbol(*sym);
+ }
+
/// Add a new binding from the ac-do-variable `var` to `value`.
void pushImpliedDoBinding(AcDoVar var, mlir::Value value) {
impliedDoStack.emplace_back(var, value);
@@ -326,12 +333,13 @@ class SymMap {
private:
/// Add `symbol` to the current map and bind a `box`.
- void makeSym(semantics::SymbolRef sym, const SymbolBox &box,
+ void makeSym(semantics::SymbolRef symRef, const SymbolBox &box,
bool force = false) {
+ const auto *sym = &symRef.get().GetUltimate();
if (force)
- symbolMapStack.back().erase(&*sym);
+ symbolMapStack.back().erase(sym);
assert(box && "cannot add an undefined symbol box");
- symbolMapStack.back().try_emplace(&*sym, box);
+ symbolMapStack.back().try_emplace(sym, box);
}
llvm::SmallVector<llvm::DenseMap<const semantics::Symbol *, SymbolBox>>
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 17c6393cc9e39..900978887c8bb 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -64,32 +64,30 @@ class FirConverter : public Fortran::lower::AbstractConverter {
/// Convert the PFT to FIR.
void run(Fortran::lower::pft::Program &pft) {
- // Primary translation pass.
+ // Preliminary translation pass.
// - Declare all functions that have definitions so that definition
// signatures prevail over call site signatures.
// - Define module variables and OpenMP/OpenACC declarative construct so
// that they are available before lowering any function that may use
// them.
+ // - Translate block data programs so that common block definitions with
+ // data initializations take precedence over other definitions.
for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
- std::visit(Fortran::common::visitors{
- [&](Fortran::lower::pft::FunctionLikeUnit &f) {
- declareFunction(f);
- },
- [&](Fortran::lower::pft::ModuleLikeUnit &m) {
- lowerModuleDeclScope(m);
- for (Fortran::lower::pft::FunctionLikeUnit &f :
- m.nestedFunctions)
- declareFunction(f);
- },
- [&](Fortran::lower::pft::BlockDataUnit &b) {},
- [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {
- setCurrentPosition(
- d.get<Fortran::parser::CompilerDirective>().source);
- mlir::emitWarning(toLocation(),
- "ignoring all compiler directives");
- },
- },
- u);
+ std::visit(
+ Fortran::common::visitors{
+ [&](Fortran::lower::pft::FunctionLikeUnit &f) {
+ declareFunction(f);
+ },
+ [&](Fortran::lower::pft::ModuleLikeUnit &m) {
+ lowerModuleDeclScope(m);
+ for (Fortran::lower::pft::FunctionLikeUnit &f :
+ m.nestedFunctions)
+ declareFunction(f);
+ },
+ [&](Fortran::lower::pft::BlockDataUnit &b) { lowerBlockData(b); },
+ [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
+ },
+ u);
}
// Primary translation pass.
@@ -189,6 +187,26 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return val;
}
+ void copySymbolBinding(Fortran::lower::SymbolRef src,
+ Fortran::lower::SymbolRef target) override final {
+ localSymbols.addSymbol(target, lookupSymbol(src).toExtendedValue());
+ }
+
+ /// Add the symbol binding to the inner-most level of the symbol map and
+ /// return true if it is not already present. Otherwise, return false.
+ bool bindIfNewSymbol(Fortran::lower::SymbolRef sym,
+ const fir::ExtendedValue &exval) {
+ if (shallowLookupSymbol(sym))
+ return false;
+ bindSymbol(sym, exval);
+ return true;
+ }
+
+ void bindSymbol(Fortran::lower::SymbolRef sym,
+ const fir::ExtendedValue &exval) override final {
+ localSymbols.addSymbol(sym, exval, /*forced=*/true);
+ }
+
bool lookupLabelSet(Fortran::lower::SymbolRef sym,
Fortran::lower::pft::LabelSet &labelSet) override final {
Fortran::lower::pft::FunctionLikeUnit &owningProc =
@@ -381,6 +399,42 @@ class FirConverter : public Fortran::lower::AbstractConverter {
localSymbols.clear();
}
+ /// Helper to generate GlobalOps when the builder is not positioned in any
+ /// region block. This is required because the FirOpBuilder assumes it is
+ /// always positioned inside a region block when creating globals, the easiest
+ /// way comply is to create a dummy function and to throw it afterwards.
+ void createGlobalOutsideOfFunctionLowering(
+ const std::function<void()> &createGlobals) {
+ // FIXME: get rid of the bogus function context and instantiate the
+ // globals directly into the module.
+ MLIRContext *context = &getMLIRContext();
+ mlir::FuncOp func = fir::FirOpBuilder::createFunction(
+ mlir::UnknownLoc::get(context), getModuleOp(),
+ fir::NameUniquer::doGenerated("Sham"),
+ mlir::FunctionType::get(context, llvm::None, llvm::None));
+ func.addEntryBlock();
+ builder = new fir::FirOpBuilder(func, bridge.getKindMap());
+ createGlobals();
+ if (mlir::Region *region = func.getCallableRegion())
+ region->dropAllReferences();
+ func.erase();
+ delete builder;
+ builder = nullptr;
+ localSymbols.clear();
+ }
+ /// Instantiate the data from a BLOCK DATA unit.
+ void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) {
+ createGlobalOutsideOfFunctionLowering([&]() {
+ Fortran::lower::AggregateStoreMap fakeMap;
+ for (const auto &[_, sym] : bdunit.symTab) {
+ if (sym->has<Fortran::semantics::ObjectEntityDetails>()) {
+ Fortran::lower::pft::Variable var(*sym, true);
+ instantiateVar(var, fakeMap);
+ }
+ }
+ });
+ }
+
/// Map mlir function block arguments to the corresponding Fortran dummy
/// variables. When the result is passed as a hidden argument, the Fortran
/// result is also mapped. The symbol map is used to hold this mapping.
@@ -611,30 +665,18 @@ class FirConverter : public Fortran::lower::AbstractConverter {
/// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
/// declarative construct.
void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
- // FIXME: get rid of the bogus function context and instantiate the
- // globals directly into the module.
- MLIRContext *context = &getMLIRContext();
setCurrentPosition(mod.getStartingSourceLoc());
- mlir::FuncOp func = fir::FirOpBuilder::createFunction(
- mlir::UnknownLoc::get(context), getModuleOp(),
- fir::NameUniquer::doGenerated("ModuleSham"),
- mlir::FunctionType::get(context, llvm::None, llvm::None));
- func.addEntryBlock();
- builder = new fir::FirOpBuilder(func, bridge.getKindMap());
- for (const Fortran::lower::pft::Variable &var :
- mod.getOrderedSymbolTable()) {
- // Only define the variables owned by this module.
- const Fortran::semantics::Scope *owningScope = var.getOwningScope();
- if (!owningScope || mod.getScope() == *owningScope)
- Fortran::lower::defineModuleVariable(*this, var);
- }
- for (auto &eval : mod.evaluationList)
- genFIR(eval);
- if (mlir::Region *region = func.getCallableRegion())
- region->dropAllReferences();
- func.erase();
- delete builder;
- builder = nullptr;
+ createGlobalOutsideOfFunctionLowering([&]() {
+ for (const Fortran::lower::pft::Variable &var :
+ mod.getOrderedSymbolTable()) {
+ // Only define the variables owned by this module.
+ const Fortran::semantics::Scope *owningScope = var.getOwningScope();
+ if (!owningScope || mod.getScope() == *owningScope)
+ Fortran::lower::defineModuleVariable(*this, var);
+ }
+ for (auto &eval : mod.evaluationList)
+ genFIR(eval);
+ });
}
/// Lower functions contained in a module.
@@ -674,6 +716,14 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return {};
}
+ /// Find the symbol in the inner-most level of the local map or return null.
+ Fortran::lower::SymbolBox
+ shallowLookupSymbol(const Fortran::semantics::Symbol &sym) {
+ if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym))
+ return v;
+ return {};
+ }
+
/// Add the symbol to the local map and return `true`. If the symbol is
/// already in the map and \p forced is `false`, the map is not updated.
/// Instead the value `false` is returned.
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 20959645a8744..eafe098e3c949 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -58,6 +58,11 @@
// to the correct FIR representation in SSA form.
//===----------------------------------------------------------------------===//
+static llvm::cl::opt<bool> generateArrayCoordinate(
+ "gen-array-coor",
+ llvm::cl::desc("in lowering create ArrayCoorOp instead of CoordinateOp"),
+ llvm::cl::init(false));
+
// The default attempts to balance a modest allocation size with expected user
// input to minimize bounds checks and reallocations during dynamic array
// construction. Some user codes may have very large array constructors for
@@ -300,6 +305,12 @@ createInMemoryScalarCopy(fir::FirOpBuilder &builder, mlir::Location loc,
return temp;
}
+// An expression with non-zero rank is an array expression.
+template <typename A>
+static bool isArray(const A &x) {
+ return x.Rank() != 0;
+}
+
/// Is this a variable wrapped in parentheses?
template <typename A>
static bool isParenthesizedVariable(const A &) {
@@ -482,6 +493,21 @@ createBoxProcCharTuple(Fortran::lower::AbstractConverter &converter,
boxProc, charLen);
}
+// Helper to get the ultimate first symbol. This works around the fact that
+// symbol resolution in the front end doesn't always resolve a symbol to its
+// ultimate symbol but may leave placeholder indirections for use and host
+// associations.
+template <typename A>
+const Fortran::semantics::Symbol &getFirstSym(const A &obj) {
+ return obj.GetFirstSymbol().GetUltimate();
+}
+
+// Helper to get the ultimate last symbol.
+template <typename A>
+const Fortran::semantics::Symbol &getLastSym(const A &obj) {
+ return obj.GetLastSymbol().GetUltimate();
+}
+
namespace {
/// Lowering of Fortran::evaluate::Expr<T> expressions
@@ -643,7 +669,6 @@ class ScalarExprLowering {
[&val](auto &) { return val.toExtendedValue(); });
LLVM_DEBUG(llvm::dbgs()
<< "unknown symbol: " << sym << "\nmap: " << symMap << '\n');
- llvm::errs() << "SYM: " << sym << "\n";
fir::emitFatalError(getLoc(), "symbol is not mapped to any IR value");
}
@@ -652,10 +677,23 @@ class ScalarExprLowering {
}
ExtValue genval(Fortran::semantics::SymbolRef sym) {
+ mlir::Location loc = getLoc();
ExtValue var = gen(sym);
if (const fir::UnboxedValue *s = var.getUnboxed())
- if (fir::isReferenceLike(s->getType()))
- return genLoad(*s);
+ if (fir::isReferenceLike(s->getType())) {
+ // A function with multiple entry points returning
diff erent types
+ // tags all result variables with one of the largest types to allow
+ // them to share the same storage. A reference to a result variable
+ // of one of the other types requires conversion to the actual type.
+ fir::UnboxedValue addr = *s;
+ if (Fortran::semantics::IsFunctionResult(sym)) {
+ mlir::Type resultType = converter.genType(*sym);
+ if (addr.getType() != resultType)
+ addr = builder.createConvert(loc, builder.getRefType(resultType),
+ addr);
+ }
+ return genLoad(addr);
+ }
return var;
}
@@ -851,7 +889,7 @@ class ScalarExprLowering {
}
ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) {
- ExtValue exv = desc.base().IsSymbol() ? gen(desc.base().GetLastSymbol())
+ ExtValue exv = desc.base().IsSymbol() ? gen(getLastSym(desc.base()))
: gen(desc.base().GetComponent());
mlir::IndexType idxTy = builder.getIndexType();
mlir::Location loc = getLoc();
@@ -990,6 +1028,30 @@ class ScalarExprLowering {
TODO(getLoc(), "genval Extremum<TC, KIND>");
}
+ // Change the dynamic length information without actually changing the
+ // underlying character storage.
+ fir::ExtendedValue
+ replaceScalarCharacterLength(const fir::ExtendedValue &scalarChar,
+ mlir::Value newLenValue) {
+ mlir::Location loc = getLoc();
+ const fir::CharBoxValue *charBox = scalarChar.getCharBox();
+ if (!charBox)
+ fir::emitFatalError(loc, "expected scalar character");
+ mlir::Value charAddr = charBox->getAddr();
+ auto charType =
+ fir::unwrapPassByRefType(charAddr.getType()).cast<fir::CharacterType>();
+ if (charType.hasConstantLen()) {
+ // Erase previous constant length from the base type.
+ fir::CharacterType::LenType newLen = fir::CharacterType::unknownLen();
+ mlir::Type newCharTy = fir::CharacterType::get(
+ builder.getContext(), charType.getFKind(), newLen);
+ mlir::Type newType = fir::ReferenceType::get(newCharTy);
+ charAddr = builder.createConvert(loc, newType, charAddr);
+ return fir::CharBoxValue{charAddr, newLenValue};
+ }
+ return fir::CharBoxValue{charAddr, newLenValue};
+ }
+
template <int KIND>
ExtValue genval(const Fortran::evaluate::SetLength<KIND> &x) {
TODO(getLoc(), "genval SetLength<KIND>");
@@ -1151,23 +1213,7 @@ class ScalarExprLowering {
inInitializer->rawVals.push_back(val);
}
- /// Convert a ascii scalar literal CHARACTER to IR. (specialization)
- ExtValue
- genAsciiScalarLit(const Fortran::evaluate::Scalar<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Character, 1>> &value,
- int64_t len) {
- assert(value.size() == static_cast<std::uint64_t>(len));
- // Outline character constant in ro data if it is not in an initializer.
- if (!inInitializer)
- return fir::factory::createStringLiteral(builder, getLoc(), value);
- // When in an initializer context, construct the literal op itself and do
- // not construct another constant object in rodata.
- fir::StringLitOp stringLit = builder.createStringLitOp(getLoc(), value);
- mlir::Value lenp = builder.createIntegerConstant(
- getLoc(), builder.getCharacterLengthType(), len);
- return fir::CharBoxValue{stringLit.getResult(), lenp};
- }
- /// Convert a non ascii scalar literal CHARACTER to IR. (specialization)
+ /// Convert a scalar literal CHARACTER to IR.
template <int KIND>
ExtValue
genScalarLit(const Fortran::evaluate::Scalar<Fortran::evaluate::Type<
@@ -1175,20 +1221,29 @@ class ScalarExprLowering {
int64_t len) {
using ET = typename std::decay_t<decltype(value)>::value_type;
if constexpr (KIND == 1) {
- return genAsciiScalarLit(value, len);
+ assert(value.size() == static_cast<std::uint64_t>(len));
+ // Outline character constant in ro data if it is not in an initializer.
+ if (!inInitializer)
+ return fir::factory::createStringLiteral(builder, getLoc(), value);
+ // When in an initializer context, construct the literal op itself and do
+ // not construct another constant object in rodata.
+ fir::StringLitOp stringLit = builder.createStringLitOp(getLoc(), value);
+ mlir::Value lenp = builder.createIntegerConstant(
+ getLoc(), builder.getCharacterLengthType(), len);
+ return fir::CharBoxValue{stringLit.getResult(), lenp};
}
fir::CharacterType type =
fir::CharacterType::get(builder.getContext(), KIND, len);
auto consLit = [&]() -> fir::StringLitOp {
mlir::MLIRContext *context = builder.getContext();
std::int64_t size = static_cast<std::int64_t>(value.size());
- mlir::ShapedType shape = mlir::VectorType::get(
+ mlir::ShapedType shape = mlir::RankedTensorType::get(
llvm::ArrayRef<std::int64_t>{size},
mlir::IntegerType::get(builder.getContext(), sizeof(ET) * 8));
- auto strAttr = mlir::DenseElementsAttr::get(
+ auto denseAttr = mlir::DenseElementsAttr::get(
shape, llvm::ArrayRef<ET>{value.data(), value.size()});
- auto valTag = mlir::StringAttr::get(context, fir::StringLitOp::value());
- mlir::NamedAttribute dataAttr(valTag, strAttr);
+ auto denseTag = mlir::StringAttr::get(context, fir::StringLitOp::xlist());
+ mlir::NamedAttribute dataAttr(denseTag, denseAttr);
auto sizeTag = mlir::StringAttr::get(context, fir::StringLitOp::size());
mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(len));
llvm::SmallVector<mlir::NamedAttribute> attrs = {dataAttr, sizeAttr};
@@ -1206,9 +1261,6 @@ class ScalarExprLowering {
// Otherwise, the string is in a plain old expression so "outline" the value
// by hashconsing it to a constant literal object.
- // FIXME: For wider char types, lowering ought to use an array of i16 or
- // i32. But for now, lowering just fakes that the string value is a range of
- // i8 to get it past the C++ compiler.
std::string globalName =
fir::factory::uniqueCGIdent("cl", (const char *)value.c_str());
fir::GlobalOp global = builder.getNamedGlobal(globalName);
@@ -1390,11 +1442,52 @@ class ScalarExprLowering {
TODO(getLoc(), "genval ComplexPart");
}
+ /// Reference to a substring.
ExtValue gen(const Fortran::evaluate::Substring &s) {
- TODO(getLoc(), "gen Substring");
+ // Get base string
+ auto baseString = std::visit(
+ Fortran::common::visitors{
+ [&](const Fortran::evaluate::DataRef &x) { return gen(x); },
+ [&](const Fortran::evaluate::StaticDataObject::Pointer &p)
+ -> ExtValue {
+ if (std::optional<std::string> str = p->AsString())
+ return fir::factory::createStringLiteral(builder, getLoc(),
+ *str);
+ // TODO: convert StaticDataObject to Constant<T> and use normal
+ // constant path. Beware that StaticDataObject data() takes into
+ // account build machine endianness.
+ TODO(getLoc(),
+ "StaticDataObject::Pointer substring with kind > 1");
+ },
+ },
+ s.parent());
+ llvm::SmallVector<mlir::Value> bounds;
+ mlir::Value lower = genunbox(s.lower());
+ bounds.push_back(lower);
+ if (Fortran::evaluate::MaybeExtentExpr upperBound = s.upper()) {
+ mlir::Value upper = genunbox(*upperBound);
+ bounds.push_back(upper);
+ }
+ fir::factory::CharacterExprHelper charHelper{builder, getLoc()};
+ return baseString.match(
+ [&](const fir::CharBoxValue &x) -> ExtValue {
+ return charHelper.createSubstring(x, bounds);
+ },
+ [&](const fir::CharArrayBoxValue &) -> ExtValue {
+ fir::emitFatalError(
+ getLoc(),
+ "array substring should be handled in array expression");
+ },
+ [&](const auto &) -> ExtValue {
+ fir::emitFatalError(getLoc(), "substring base is not a CharBox");
+ });
}
+
+ /// The value of a substring.
ExtValue genval(const Fortran::evaluate::Substring &ss) {
- TODO(getLoc(), "genval Substring");
+ // FIXME: why is the value of a substring being lowered the same as the
+ // address of a substring?
+ return gen(ss);
}
ExtValue genval(const Fortran::evaluate::Subscript &subs) {
@@ -1628,11 +1721,43 @@ class ScalarExprLowering {
});
}
+ /// Lower an ArrayRef to a fir.array_coor.
+ ExtValue genArrayCoorOp(const ExtValue &exv,
+ const Fortran::evaluate::ArrayRef &aref) {
+ mlir::Location loc = getLoc();
+ mlir::Value addr = fir::getBase(exv);
+ mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType());
+ mlir::Type eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
+ mlir::Type refTy = builder.getRefType(eleTy);
+ mlir::IndexType idxTy = builder.getIndexType();
+ llvm::SmallVector<mlir::Value> arrayCoorArgs;
+ // The ArrayRef is expected to be scalar here, arrays are handled in array
+ // expression lowering. So no vector subscript or triplet is expected here.
+ for (const auto &sub : aref.subscript()) {
+ ExtValue subVal = genSubscript(sub);
+ assert(fir::isUnboxedValue(subVal));
+ arrayCoorArgs.push_back(
+ builder.createConvert(loc, idxTy, fir::getBase(subVal)));
+ }
+ mlir::Value shape = builder.createShape(loc, exv);
+ mlir::Value elementAddr = builder.create<fir::ArrayCoorOp>(
+ loc, refTy, addr, shape, /*slice=*/mlir::Value{}, arrayCoorArgs,
+ fir::getTypeParams(exv));
+ return fir::factory::arrayElementToExtendedValue(builder, loc, exv,
+ elementAddr);
+ }
+
+ /// Return the coordinate of the array reference.
ExtValue gen(const Fortran::evaluate::ArrayRef &aref) {
- ExtValue base = aref.base().IsSymbol() ? gen(aref.base().GetFirstSymbol())
+ ExtValue base = aref.base().IsSymbol() ? gen(getFirstSym(aref.base()))
: gen(aref.base().GetComponent());
+ // Check for command-line override to use array_coor op.
+ if (generateArrayCoordinate)
+ return genArrayCoorOp(base, aref);
+ // Otherwise, use coordinate_of op.
return genCoordinateOp(base, aref);
}
+
ExtValue genval(const Fortran::evaluate::ArrayRef &aref) {
return genLoad(gen(aref));
}
@@ -1690,6 +1815,59 @@ class ScalarExprLowering {
return details->stmtFunction().has_value();
return false;
}
+ /// Generate Statement function calls
+ ExtValue genStmtFunctionRef(const Fortran::evaluate::ProcedureRef &procRef) {
+ const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
+ assert(symbol && "expected symbol in ProcedureRef of statement functions");
+ const auto &details = symbol->get<Fortran::semantics::SubprogramDetails>();
+
+ // Statement functions have their own scope, we just need to associate
+ // the dummy symbols to argument expressions. They are no
+ // optional/alternate return arguments. Statement functions cannot be
+ // recursive (directly or indirectly) so it is safe to add dummy symbols to
+ // the local map here.
+ symMap.pushScope();
+ for (auto [arg, bind] :
+ llvm::zip(details.dummyArgs(), procRef.arguments())) {
+ assert(arg && "alternate return in statement function");
+ assert(bind && "optional argument in statement function");
+ const auto *expr = bind->UnwrapExpr();
+ // TODO: assumed type in statement function, that surprisingly seems
+ // allowed, probably because nobody thought of restricting this usage.
+ // gfortran/ifort compiles this.
+ assert(expr && "assumed type used as statement function argument");
+ // As per Fortran 2018 C1580, statement function arguments can only be
+ // scalars, so just pass the box with the address. The only care is to
+ // to use the dummy character explicit length if any instead of the
+ // actual argument length (that can be bigger).
+ if (const Fortran::semantics::DeclTypeSpec *type = arg->GetType())
+ if (type->category() == Fortran::semantics::DeclTypeSpec::Character)
+ if (const Fortran::semantics::MaybeIntExpr &lenExpr =
+ type->characterTypeSpec().length().GetExplicit()) {
+ mlir::Value len = fir::getBase(genval(*lenExpr));
+ // F2018 7.4.4.2 point 5.
+ len = Fortran::lower::genMaxWithZero(builder, getLoc(), len);
+ symMap.addSymbol(*arg,
+ replaceScalarCharacterLength(gen(*expr), len));
+ continue;
+ }
+ symMap.addSymbol(*arg, gen(*expr));
+ }
+
+ // Explicitly map statement function host associated symbols to their
+ // parent scope lowered symbol box.
+ for (const Fortran::semantics::SymbolRef &sym :
+ Fortran::evaluate::CollectSymbols(*details.stmtFunction()))
+ if (const auto *details =
+ sym->detailsIf<Fortran::semantics::HostAssocDetails>())
+ if (!symMap.lookupSymbol(*sym))
+ symMap.addSymbol(*sym, gen(details->symbol()));
+
+ ExtValue result = genval(details.stmtFunction().value());
+ LLVM_DEBUG(llvm::dbgs() << "stmt-function: " << result << '\n');
+ symMap.popScope();
+ return result;
+ }
/// Helper to package a Value and its properties into an ExtendedValue.
static ExtValue toExtendedValue(mlir::Location loc, mlir::Value base,
@@ -2152,6 +2330,25 @@ class ScalarExprLowering {
return temp;
}
+ /// Generate copy-out if needed and free the temporary for an argument that
+ /// has been copied-in into a contiguous temp.
+ void genCopyOut(const CopyOutPair ©OutPair) {
+ mlir::Location loc = getLoc();
+ if (!copyOutPair.restrictCopyAndFreeAtRuntime) {
+ if (copyOutPair.argMayBeModifiedByCall)
+ genArrayCopy(copyOutPair.var, copyOutPair.temp);
+ builder.create<fir::FreeMemOp>(loc, fir::getBase(copyOutPair.temp));
+ return;
+ }
+ builder.genIfThen(loc, *copyOutPair.restrictCopyAndFreeAtRuntime)
+ .genThen([&]() {
+ if (copyOutPair.argMayBeModifiedByCall)
+ genArrayCopy(copyOutPair.var, copyOutPair.temp);
+ builder.create<fir::FreeMemOp>(loc, fir::getBase(copyOutPair.temp));
+ })
+ .end();
+ }
+
/// Lower a non-elemental procedure reference.
ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
llvm::Optional<mlir::Type> resultType) {
@@ -2164,7 +2361,7 @@ class ScalarExprLowering {
return genIntrinsicRef(procRef, *intrinsic, resultType);
if (isStatementFunctionCall(procRef))
- TODO(loc, "Lower statement function call");
+ return genStmtFunctionRef(procRef);
Fortran::lower::CallerInterface caller(procRef, converter);
using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
@@ -2229,6 +2426,28 @@ class ScalarExprLowering {
continue;
}
const bool actualArgIsVariable = Fortran::evaluate::IsVariable(*expr);
+ if (arg.passBy == PassBy::BaseAddressValueAttribute) {
+ mlir::Value temp;
+ if (isArray(*expr)) {
+ auto val = genBoxArg(*expr);
+ if (!actualArgIsVariable)
+ temp = getBase(val);
+ else {
+ ExtValue copy = genArrayTempFromMold(val, ".copy");
+ genArrayCopy(copy, val);
+ temp = fir::getBase(copy);
+ }
+ } else {
+ mlir::Value val = fir::getBase(genval(*expr));
+ temp = builder.createTemporary(
+ loc, val.getType(),
+ llvm::ArrayRef<mlir::NamedAttribute>{
+ Fortran::lower::getAdaptToByRefAttr(builder)});
+ builder.create<fir::StoreOp>(loc, val, temp);
+ }
+ caller.placeInput(arg, temp);
+ continue;
+ }
if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar) {
const bool actualIsSimplyContiguous =
!actualArgIsVariable || Fortran::evaluate::IsSimplyContiguous(
@@ -2238,13 +2457,50 @@ class ScalarExprLowering {
if (actualArgIsVariable && arg.isOptional()) {
if (Fortran::evaluate::IsAllocatableOrPointerObject(
*expr, converter.getFoldingContext())) {
- TODO(loc, "Allocatable or pointer argument");
+ // Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated,
+ // it is as if the argument was absent. The main care here is to
+ // not do a copy-in/copy-out because the temp address, even though
+ // pointing to a null size storage, would not be a nullptr and
+ // therefore the argument would not be considered absent on the
+ // callee side. Note: if wholeSymbol is optional, it cannot be
+ // absent as per 15.5.2.12 point 7. and 8. We rely on this to
+ // un-conditionally read the allocatable/pointer descriptor here.
+ if (actualIsSimplyContiguous)
+ return genBoxArg(*expr);
+ fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr);
+ mlir::Value isAssociated =
+ fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
+ mutableBox);
+ fir::ExtendedValue actualExv =
+ fir::factory::genMutableBoxRead(builder, loc, mutableBox);
+ return genCopyIn(actualExv, arg, copyOutPairs, isAssociated);
}
if (const Fortran::semantics::Symbol *wholeSymbol =
Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(
*expr))
if (Fortran::semantics::IsOptional(*wholeSymbol)) {
- TODO(loc, "procedureref optional arg");
+ ExtValue actualArg = gen(*expr);
+ mlir::Value actualArgBase = fir::getBase(actualArg);
+ if (!actualArgBase.getType().isa<fir::BoxType>())
+ return actualArg;
+ // Do not read wholeSymbol descriptor that may be a nullptr in
+ // case wholeSymbol is absent.
+ // Absent descriptor cannot be read. To avoid any issue in
+ // copy-in/copy-out, and when retrieving the address/length
+ // create an descriptor pointing to a null address here if the
+ // fir.box is absent.
+ mlir::Value isPresent = builder.create<fir::IsPresentOp>(
+ loc, builder.getI1Type(), actualArgBase);
+ mlir::Type boxType = actualArgBase.getType();
+ mlir::Value emptyBox = fir::factory::createUnallocatedBox(
+ builder, loc, boxType, llvm::None);
+ auto safeToReadBox = builder.create<mlir::arith::SelectOp>(
+ loc, isPresent, actualArgBase, emptyBox);
+ fir::ExtendedValue safeToReadExv =
+ fir::substBase(actualArg, safeToReadBox);
+ if (actualIsSimplyContiguous)
+ return safeToReadExv;
+ return genCopyIn(safeToReadExv, arg, copyOutPairs, isPresent);
}
// Fall through: The actual argument can safely be
// copied-in/copied-out without any care if needed.
@@ -2309,7 +2565,25 @@ class ScalarExprLowering {
// (Fortran 2018 15.5.2.12 point 1).
if (arg.isOptional() && Fortran::evaluate::IsAllocatableOrPointerObject(
*expr, converter.getFoldingContext())) {
- TODO(loc, "optional allocatable or pointer argument");
+ // Note that passing an absent allocatable to a non-allocatable
+ // optional dummy argument is illegal (15.5.2.12 point 3 (8)). So
+ // nothing has to be done to generate an absent argument in this case,
+ // and it is OK to unconditionally read the mutable box here.
+ fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr);
+ mlir::Value isAllocated =
+ fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
+ mutableBox);
+ auto absent = builder.create<fir::AbsentOp>(loc, argTy);
+ /// For now, assume it is not OK to pass the allocatable/pointer
+ /// descriptor to a non pointer/allocatable dummy. That is a strict
+ /// interpretation of 18.3.6 point 4 that stipulates the descriptor
+ /// has the dummy attributes in BIND(C) contexts.
+ mlir::Value box = builder.createBox(
+ loc, fir::factory::genMutableBoxRead(builder, loc, mutableBox));
+ // Need the box types to be exactly similar for the selectOp.
+ mlir::Value convertedBox = builder.createConvert(loc, argTy, box);
+ caller.placeInput(arg, builder.create<mlir::arith::SelectOp>(
+ loc, isAllocated, convertedBox, absent));
} else {
// Make sure a variable address is only passed if the expression is
// actually a variable.
@@ -2324,7 +2598,10 @@ class ScalarExprLowering {
caller.placeAddressAndLengthInput(arg, fir::getBase(argRef),
fir::getLen(argRef));
} else if (arg.passBy == PassBy::CharProcTuple) {
- TODO(loc, "procedureref CharProcTuple");
+ ExtValue argRef = genExtAddr(*expr);
+ mlir::Value tuple = createBoxProcCharTuple(
+ converter, argTy, fir::getBase(argRef), fir::getLen(argRef));
+ caller.placeInput(arg, tuple);
} else {
TODO(loc, "pass by value in non elemental function call");
}
@@ -2332,11 +2609,16 @@ class ScalarExprLowering {
ExtValue result = genCallOpAndResult(caller, callSiteType, resultType);
- // // Copy-out temps that were created for non contiguous variable arguments
- // if
- // // needed.
- // for (const auto ©OutPair : copyOutPairs)
- // genCopyOut(copyOutPair);
+ // Sync pointers and allocatables that may have been modified during the
+ // call.
+ for (const auto &mutableBox : mutableModifiedByCall)
+ fir::factory::syncMutableBoxFromIRBox(builder, loc, mutableBox);
+ // Handle case where result was passed as argument
+
+ // Copy-out temps that were created for non contiguous variable arguments if
+ // needed.
+ for (const auto ©OutPair : copyOutPairs)
+ genCopyOut(copyOutPair);
return result;
}
@@ -2453,11 +2735,8 @@ class ScalarExprLowering {
}
template <typename A>
- ExtValue genval(const Fortran::evaluate::Expr<A> &x) {
- if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) ||
- inInitializer)
- return std::visit([&](const auto &e) { return genval(e); }, x.u);
- return asArray(x);
+ bool isScalar(const A &x) {
+ return x.Rank() == 0;
}
/// Helper to detect Transformational function reference.
@@ -2519,10 +2798,12 @@ class ScalarExprLowering {
return asArrayArg(x);
return asArray(x);
}
-
template <typename A>
- bool isScalar(const A &x) {
- return x.Rank() == 0;
+ ExtValue genval(const Fortran::evaluate::Expr<A> &x) {
+ if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) ||
+ inInitializer)
+ return std::visit([&](const auto &e) { return genval(e); }, x.u);
+ return asArray(x);
}
template <int KIND>
@@ -2545,6 +2826,10 @@ class ScalarExprLowering {
}
template <typename A>
ExtValue genref(const A &a) {
+ if (inInitializer) {
+ // Initialization expressions can never allocate memory.
+ return genval(a);
+ }
mlir::Type storageType = converter.genType(toEvExpr(a));
return placeScalarValueInMemory(builder, getLoc(), genval(a), storageType);
}
@@ -5171,7 +5456,7 @@ class ArrayExprLowering {
},
[&](const Fortran::evaluate::Component *x) {
auto fieldTy = fir::FieldType::get(builder.getContext());
- llvm::StringRef name = toStringRef(x->GetLastSymbol().name());
+ llvm::StringRef name = toStringRef(getLastSym(*x).name());
auto recTy = ty.cast<fir::RecordType>();
ty = recTy.getType(name);
auto fld = builder.create<fir::FieldIndexOp>(
@@ -5298,7 +5583,7 @@ class ArrayExprLowering {
CC genImplicitArrayAccess(const A &x, ComponentPath &components) {
components.reversePath.push_back(ImplicitSubscripts{});
ExtValue exv = asScalarRef(x);
- // lowerPath(exv, components);
+ lowerPath(exv, components);
auto lambda = genarr(exv, components);
return [=](IterSpace iters) { return lambda(components.pc(iters)); };
}
@@ -5805,8 +6090,8 @@ class ArrayExprLowering {
void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) {
if (!destShape.empty())
return;
- // if (explicitSpaceIsActive() && determineShapeWithSlice(lhs))
- // return;
+ if (explicitSpaceIsActive() && determineShapeWithSlice(lhs))
+ return;
mlir::Type idxTy = builder.getIndexType();
mlir::Location loc = getLoc();
if (std::optional<Fortran::evaluate::ConstantSubscripts> constantShape =
@@ -5816,6 +6101,79 @@ class ArrayExprLowering {
destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent));
}
+ bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) {
+ return false;
+ }
+ bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) {
+ TODO(getLoc(), "coarray ref");
+ return false;
+ }
+ bool genShapeFromDataRef(const Fortran::evaluate::Component &x) {
+ return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false;
+ }
+ bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) {
+ if (x.Rank() == 0)
+ return false;
+ if (x.base().Rank() > 0)
+ if (genShapeFromDataRef(x.base()))
+ return true;
+ // x has rank and x.base did not produce a shape.
+ ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base()))
+ : asScalarRef(x.base().GetComponent());
+ mlir::Location loc = getLoc();
+ mlir::IndexType idxTy = builder.getIndexType();
+ llvm::SmallVector<mlir::Value> definedShape =
+ fir::factory::getExtents(builder, loc, exv);
+ mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+ for (auto ss : llvm::enumerate(x.subscript())) {
+ std::visit(Fortran::common::visitors{
+ [&](const Fortran::evaluate::Triplet &trip) {
+ // For a subscript of triple notation, we compute the
+ // range of this dimension of the iteration space.
+ auto lo = [&]() {
+ if (auto optLo = trip.lower())
+ return fir::getBase(asScalar(*optLo));
+ return getLBound(exv, ss.index(), one);
+ }();
+ auto hi = [&]() {
+ if (auto optHi = trip.upper())
+ return fir::getBase(asScalar(*optHi));
+ return getUBound(exv, ss.index(), one);
+ }();
+ auto step = builder.createConvert(
+ loc, idxTy, fir::getBase(asScalar(trip.stride())));
+ auto extent = builder.genExtentFromTriplet(loc, lo, hi,
+ step, idxTy);
+ destShape.push_back(extent);
+ },
+ [&](auto) {}},
+ ss.value().u);
+ }
+ return true;
+ }
+ bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) {
+ if (x.IsSymbol())
+ return genShapeFromDataRef(getFirstSym(x));
+ return genShapeFromDataRef(x.GetComponent());
+ }
+ bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) {
+ return std::visit([&](const auto &v) { return genShapeFromDataRef(v); },
+ x.u);
+ }
+
+ /// When in an explicit space, the ranked component must be evaluated to
+ /// determine the actual number of iterations when slicing triples are
+ /// present. Lower these expressions here.
+ bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) {
+ LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump(
+ llvm::dbgs() << "determine shape of:\n", lhs));
+ // FIXME: We may not want to use ExtractDataRef here since it doesn't deal
+ // with substrings, etc.
+ std::optional<Fortran::evaluate::DataRef> dref =
+ Fortran::evaluate::ExtractDataRef(lhs);
+ return dref.has_value() ? genShapeFromDataRef(*dref) : false;
+ }
+
ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) {
mlir::Type resTy = converter.genType(exp);
return std::visit(
@@ -5908,11 +6266,33 @@ class ArrayExprLowering {
return abstractArrayExtValue(iterSpace.outerResult());
}
+ /// Compute the shape of a slice.
+ llvm::SmallVector<mlir::Value> computeSliceShape(mlir::Value slice) {
+ llvm::SmallVector<mlir::Value> slicedShape;
+ auto slOp = mlir::cast<fir::SliceOp>(slice.getDefiningOp());
+ mlir::Operation::operand_range triples = slOp.getTriples();
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Location loc = getLoc();
+ for (unsigned i = 0, end = triples.size(); i < end; i += 3) {
+ if (!mlir::isa_and_nonnull<fir::UndefOp>(
+ triples[i + 1].getDefiningOp())) {
+ // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0)
+ // See Fortran 2018 9.5.3.3.2 section for more details.
+ mlir::Value res = builder.genExtentFromTriplet(
+ loc, triples[i], triples[i + 1], triples[i + 2], idxTy);
+ slicedShape.emplace_back(res);
+ } else {
+ // do nothing. `..., i, ...` case, so dimension is dropped.
+ }
+ }
+ return slicedShape;
+ }
+
/// Get the shape from an ArrayOperand. The shape of the array is adjusted if
/// the array was sliced.
llvm::SmallVector<mlir::Value> getShape(ArrayOperand array) {
- // if (array.slice)
- // return computeSliceShape(array.slice);
+ if (array.slice)
+ return computeSliceShape(array.slice);
if (array.memref.getType().isa<fir::BoxType>())
return fir::factory::readExtents(builder, getLoc(),
fir::BoxValue{array.memref});
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index c030bb00e99da..b421a03ed54d9 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -16,6 +16,7 @@
#include "flang/Lower/BoxAnalyzer.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertExpr.h"
+#include "flang/Lower/IntrinsicCall.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/PFTBuilder.h"
#include "flang/Lower/StatementContext.h"
@@ -30,50 +31,12 @@
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Support/FIRContext.h"
#include "flang/Optimizer/Support/FatalError.h"
+#include "flang/Semantics/runtime-type-info.h"
#include "flang/Semantics/tools.h"
#include "llvm/Support/Debug.h"
#define DEBUG_TYPE "flang-lower-variable"
-/// Helper to retrieve a copy of a character literal string from a SomeExpr.
-/// Required to build character global initializers.
-template <int KIND>
-static llvm::Optional<std::tuple<std::string, std::size_t>>
-getCharacterLiteralCopy(
- const Fortran::evaluate::Expr<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, KIND>>
- &x) {
- if (const auto *con =
- Fortran::evaluate::UnwrapConstantValue<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Character, KIND>>(x))
- if (auto val = con->GetScalarValue())
- return std::tuple<std::string, std::size_t>{
- std::string{(const char *)val->c_str(),
- KIND * (std::size_t)con->LEN()},
- (std::size_t)con->LEN()};
- return llvm::None;
-}
-static llvm::Optional<std::tuple<std::string, std::size_t>>
-getCharacterLiteralCopy(
- const Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter> &x) {
- return std::visit([](const auto &e) { return getCharacterLiteralCopy(e); },
- x.u);
-}
-static llvm::Optional<std::tuple<std::string, std::size_t>>
-getCharacterLiteralCopy(const Fortran::lower::SomeExpr &x) {
- if (const auto *e = Fortran::evaluate::UnwrapExpr<
- Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter>>(x))
- return getCharacterLiteralCopy(*e);
- return llvm::None;
-}
-template <typename A>
-static llvm::Optional<std::tuple<std::string, std::size_t>>
-getCharacterLiteralCopy(const std::optional<A> &x) {
- if (x)
- return getCharacterLiteralCopy(*x);
- return llvm::None;
-}
-
/// Helper to lower a scalar expression using a specific symbol mapping.
static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter,
mlir::Location loc,
@@ -123,6 +86,23 @@ static bool isConstant(const Fortran::semantics::Symbol &sym) {
sym.test(Fortran::semantics::Symbol::Flag::ReadOnly);
}
+/// Is this a compiler generated symbol to describe derived types ?
+static bool isRuntimeTypeInfoData(const Fortran::semantics::Symbol &sym) {
+ // So far, use flags to detect if this symbol were generated during
+ // semantics::BuildRuntimeDerivedTypeTables(). Scope cannot be used since the
+ // symbols are injected in the user scopes defining the described derived
+ // types. A robustness improvement for this test could be to get hands on the
+ // semantics::RuntimeDerivedTypeTables and to check if the symbol names
+ // belongs to this structure.
+ return sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated) &&
+ sym.test(Fortran::semantics::Symbol::Flag::ReadOnly);
+}
+
+static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable &var,
+ llvm::StringRef globalName,
+ mlir::StringAttr linkage);
+
/// Create the global op declaration without any initializer
static fir::GlobalOp declareGlobal(Fortran::lower::AbstractConverter &converter,
const Fortran::lower::pft::Variable &var,
@@ -131,6 +111,11 @@ static fir::GlobalOp declareGlobal(Fortran::lower::AbstractConverter &converter,
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
if (fir::GlobalOp global = builder.getNamedGlobal(globalName))
return global;
+ // Always define linkonce data since it may be optimized out from the module
+ // that actually owns the variable if it does not refers to it.
+ if (linkage == builder.createLinkOnceODRLinkage() ||
+ linkage == builder.createLinkOnceLinkage())
+ return defineGlobal(converter, var, globalName, linkage);
const Fortran::semantics::Symbol &sym = var.getSymbol();
mlir::Location loc = converter.genLocation(sym.name());
// Resolve potential host and module association before checking that this
@@ -444,27 +429,16 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
} else if (const auto *details =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
if (details->init()) {
- if (fir::isa_char(symTy)) {
- // CHARACTER literal
- if (auto chLit = getCharacterLiteralCopy(details->init().value())) {
- mlir::StringAttr init =
- builder.getStringAttr(std::get<std::string>(*chLit));
- global->setAttr(global.getInitValAttrName(), init);
- } else {
- fir::emitFatalError(loc, "CHARACTER has unexpected initial value");
- }
- } else {
- createGlobalInitialization(
- builder, global, [&](fir::FirOpBuilder &builder) {
- Fortran::lower::StatementContext stmtCtx(
- /*cleanupProhibited=*/true);
- fir::ExtendedValue initVal = genInitializerExprValue(
- converter, loc, details->init().value(), stmtCtx);
- mlir::Value castTo =
- builder.createConvert(loc, symTy, fir::getBase(initVal));
- builder.create<fir::HasValueOp>(loc, castTo);
- });
- }
+ createGlobalInitialization(
+ builder, global, [&](fir::FirOpBuilder &builder) {
+ Fortran::lower::StatementContext stmtCtx(
+ /*cleanupProhibited=*/true);
+ fir::ExtendedValue initVal = genInitializerExprValue(
+ converter, loc, details->init().value(), stmtCtx);
+ mlir::Value castTo =
+ builder.createConvert(loc, symTy, fir::getBase(initVal));
+ builder.create<fir::HasValueOp>(loc, castTo);
+ });
} else if (hasDefaultInitialization(sym)) {
createGlobalInitialization(
builder, global, [&](fir::FirOpBuilder &builder) {
@@ -498,6 +472,12 @@ static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter,
static mlir::StringAttr
getLinkageAttribute(fir::FirOpBuilder &builder,
const Fortran::lower::pft::Variable &var) {
+ // Runtime type info for a same derived type is identical in each compilation
+ // unit. It desired to avoid having to link against module that only define a
+ // type. Therefore the runtime type info is generated everywhere it is needed
+ // with `linkonce_odr` LLVM linkage.
+ if (var.hasSymbol() && isRuntimeTypeInfoData(var.getSymbol()))
+ return builder.createLinkOnceODRLinkage();
if (var.isModuleVariable())
return {}; // external linkage
// Otherwise, the variable is owned by a procedure and must not be visible in
@@ -557,6 +537,49 @@ static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter,
return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg);
}
+/// Must \p var be default initialized at runtime when entering its scope.
+static bool
+mustBeDefaultInitializedAtRuntime(const Fortran::lower::pft::Variable &var) {
+ if (!var.hasSymbol())
+ return false;
+ const Fortran::semantics::Symbol &sym = var.getSymbol();
+ if (var.isGlobal())
+ // Global variables are statically initialized.
+ return false;
+ if (Fortran::semantics::IsDummy(sym) && !Fortran::semantics::IsIntentOut(sym))
+ return false;
+ // Local variables (including function results), and intent(out) dummies must
+ // be default initialized at runtime if their type has default initialization.
+ return hasDefaultInitialization(sym);
+}
+
+/// Call default initialization runtime routine to initialize \p var.
+static void
+defaultInitializeAtRuntime(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable &var,
+ Fortran::lower::SymMap &symMap) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::Location loc = converter.getCurrentLocation();
+ const Fortran::semantics::Symbol &sym = var.getSymbol();
+ fir::ExtendedValue exv = symMap.lookupSymbol(sym).toExtendedValue();
+ if (Fortran::semantics::IsOptional(sym)) {
+ // 15.5.2.12 point 3, absent optional dummies are not initialized.
+ // Creating descriptor/passing null descriptor to the runtime would
+ // create runtime crashes.
+ auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
+ fir::getBase(exv));
+ builder.genIfThen(loc, isPresent)
+ .genThen([&]() {
+ auto box = builder.createBox(loc, exv);
+ fir::runtime::genDerivedTypeInitialize(builder, loc, box);
+ })
+ .end();
+ } else {
+ mlir::Value box = builder.createBox(loc, exv);
+ fir::runtime::genDerivedTypeInitialize(builder, loc, box);
+ }
+}
+
/// Instantiate a local variable. Precondition: Each variable will be visited
/// such that if its properties depend on other variables, the variables upon
/// which its properties depend will already have been visited.
@@ -566,6 +589,161 @@ static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
assert(!var.isAlias());
Fortran::lower::StatementContext stmtCtx;
mapSymbolAttributes(converter, var, symMap, stmtCtx);
+ if (mustBeDefaultInitializedAtRuntime(var))
+ defaultInitializeAtRuntime(converter, var, symMap);
+}
+
+//===----------------------------------------------------------------===//
+// Aliased (EQUIVALENCE) variables instantiation
+//===----------------------------------------------------------------===//
+
+/// Insert \p aggregateStore instance into an AggregateStoreMap.
+static void insertAggregateStore(Fortran::lower::AggregateStoreMap &storeMap,
+ const Fortran::lower::pft::Variable &var,
+ mlir::Value aggregateStore) {
+ std::size_t off = var.getAggregateStore().getOffset();
+ Fortran::lower::AggregateStoreKey key = {var.getOwningScope(), off};
+ storeMap[key] = aggregateStore;
+}
+
+/// Retrieve the aggregate store instance of \p alias from an
+/// AggregateStoreMap.
+static mlir::Value
+getAggregateStore(Fortran::lower::AggregateStoreMap &storeMap,
+ const Fortran::lower::pft::Variable &alias) {
+ Fortran::lower::AggregateStoreKey key = {alias.getOwningScope(),
+ alias.getAlias()};
+ auto iter = storeMap.find(key);
+ assert(iter != storeMap.end());
+ return iter->second;
+}
+
+/// Build the name for the storage of a global equivalence.
+static std::string mangleGlobalAggregateStore(
+ const Fortran::lower::pft::Variable::AggregateStore &st) {
+ return Fortran::lower::mangle::mangleName(st.getNamingSymbol());
+}
+
+/// Build the type for the storage of an equivalence.
+static mlir::Type
+getAggregateType(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable::AggregateStore &st) {
+ if (const Fortran::semantics::Symbol *initSym = st.getInitialValueSymbol())
+ return converter.genType(*initSym);
+ mlir::IntegerType byteTy = converter.getFirOpBuilder().getIntegerType(8);
+ return fir::SequenceType::get(std::get<1>(st.interval), byteTy);
+}
+
+/// Define a GlobalOp for the storage of a global equivalence described
+/// by \p aggregate. The global is named \p aggName and is created with
+/// the provided \p linkage.
+/// If any of the equivalence members are initialized, an initializer is
+/// created for the equivalence.
+/// This is to be used when lowering the scope that owns the equivalence
+/// (as opposed to simply using it through host or use association).
+/// This is not to be used for equivalence of common block members (they
+/// already have the common block GlobalOp for them, see defineCommonBlock).
+static fir::GlobalOp defineGlobalAggregateStore(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable::AggregateStore &aggregate,
+ llvm::StringRef aggName, mlir::StringAttr linkage) {
+ assert(aggregate.isGlobal() && "not a global interval");
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ fir::GlobalOp global = builder.getNamedGlobal(aggName);
+ if (global && globalIsInitialized(global))
+ return global;
+ mlir::Location loc = converter.getCurrentLocation();
+ mlir::Type aggTy = getAggregateType(converter, aggregate);
+ if (!global)
+ global = builder.createGlobal(loc, aggTy, aggName, linkage);
+
+ if (const Fortran::semantics::Symbol *initSym =
+ aggregate.getInitialValueSymbol())
+ if (const auto *objectDetails =
+ initSym->detailsIf<Fortran::semantics::ObjectEntityDetails>())
+ if (objectDetails->init()) {
+ createGlobalInitialization(
+ builder, global, [&](fir::FirOpBuilder &builder) {
+ Fortran::lower::StatementContext stmtCtx;
+ mlir::Value initVal = fir::getBase(genInitializerExprValue(
+ converter, loc, objectDetails->init().value(), stmtCtx));
+ builder.create<fir::HasValueOp>(loc, initVal);
+ });
+ return global;
+ }
+ // Equivalence has no Fortran initial value. Create an undefined FIR initial
+ // value to ensure this is consider an object definition in the IR regardless
+ // of the linkage.
+ createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &builder) {
+ Fortran::lower::StatementContext stmtCtx;
+ mlir::Value initVal = builder.create<fir::UndefOp>(loc, aggTy);
+ builder.create<fir::HasValueOp>(loc, initVal);
+ });
+ return global;
+}
+
+/// Declare a GlobalOp for the storage of a global equivalence described
+/// by \p aggregate. The global is named \p aggName and is created with
+/// the provided \p linkage.
+/// No initializer is built for the created GlobalOp.
+/// This is to be used when lowering the scope that uses members of an
+/// equivalence it through host or use association.
+/// This is not to be used for equivalence of common block members (they
+/// already have the common block GlobalOp for them, see defineCommonBlock).
+static fir::GlobalOp declareGlobalAggregateStore(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::lower::pft::Variable::AggregateStore &aggregate,
+ llvm::StringRef aggName, mlir::StringAttr linkage) {
+ assert(aggregate.isGlobal() && "not a global interval");
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ if (fir::GlobalOp global = builder.getNamedGlobal(aggName))
+ return global;
+ mlir::Type aggTy = getAggregateType(converter, aggregate);
+ return builder.createGlobal(loc, aggTy, aggName, linkage);
+}
+
+/// This is an aggregate store for a set of EQUIVALENCED variables. Create the
+/// storage on the stack or global memory and add it to the map.
+static void
+instantiateAggregateStore(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable &var,
+ Fortran::lower::AggregateStoreMap &storeMap) {
+ assert(var.isAggregateStore() && "not an interval");
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::IntegerType i8Ty = builder.getIntegerType(8);
+ mlir::Location loc = converter.getCurrentLocation();
+ std::string aggName = mangleGlobalAggregateStore(var.getAggregateStore());
+ if (var.isGlobal()) {
+ fir::GlobalOp global;
+ auto &aggregate = var.getAggregateStore();
+ mlir::StringAttr linkage = getLinkageAttribute(builder, var);
+ if (var.isModuleVariable()) {
+ // A module global was or will be defined when lowering the module. Emit
+ // only a declaration if the global does not exist at that point.
+ global = declareGlobalAggregateStore(converter, loc, aggregate, aggName,
+ linkage);
+ } else {
+ global =
+ defineGlobalAggregateStore(converter, aggregate, aggName, linkage);
+ }
+ auto addr = builder.create<fir::AddrOfOp>(loc, global.resultType(),
+ global.getSymbol());
+ auto size = std::get<1>(var.getInterval());
+ fir::SequenceType::Shape shape(1, size);
+ auto seqTy = fir::SequenceType::get(shape, i8Ty);
+ mlir::Type refTy = builder.getRefType(seqTy);
+ mlir::Value aggregateStore = builder.createConvert(loc, refTy, addr);
+ insertAggregateStore(storeMap, var, aggregateStore);
+ return;
+ }
+ // This is a local aggregate, allocate an anonymous block of memory.
+ auto size = std::get<1>(var.getInterval());
+ fir::SequenceType::Shape shape(1, size);
+ auto seqTy = fir::SequenceType::get(shape, i8Ty);
+ mlir::Value local =
+ builder.allocateLocal(loc, seqTy, aggName, "", llvm::None, llvm::None,
+ /*target=*/false);
+ insertAggregateStore(storeMap, var, local);
}
/// Cast an alias address (variable part of an equivalence) to fir.ptr so that
@@ -580,6 +758,40 @@ static mlir::Value castAliasToPointer(fir::FirOpBuilder &builder,
aliasAddr);
}
+/// Instantiate a member of an equivalence. Compute its address in its
+/// aggregate storage and lower its attributes.
+static void instantiateAlias(Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::pft::Variable &var,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::AggregateStoreMap &storeMap) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ assert(var.isAlias());
+ const Fortran::semantics::Symbol &sym = var.getSymbol();
+ const mlir::Location loc = converter.genLocation(sym.name());
+ mlir::IndexType idxTy = builder.getIndexType();
+ std::size_t aliasOffset = var.getAlias();
+ mlir::Value store = getAggregateStore(storeMap, var);
+ mlir::IntegerType i8Ty = builder.getIntegerType(8);
+ mlir::Type i8Ptr = builder.getRefType(i8Ty);
+ mlir::Value offset = builder.createIntegerConstant(
+ loc, idxTy, sym.GetUltimate().offset() - aliasOffset);
+ auto ptr = builder.create<fir::CoordinateOp>(loc, i8Ptr, store,
+ mlir::ValueRange{offset});
+ mlir::Value preAlloc =
+ castAliasToPointer(builder, loc, converter.genType(sym), ptr);
+ Fortran::lower::StatementContext stmtCtx;
+ mapSymbolAttributes(converter, var, symMap, stmtCtx, preAlloc);
+ // Default initialization is possible for equivalence members: see
+ // F2018 19.5.3.4. Note that if several equivalenced entities have
+ // default initialization, they must have the same type, and the standard
+ // allows the storage to be default initialized several times (this has
+ // no consequences other than wasting some execution time). For now,
+ // do not try optimizing this to single default initializations of
+ // the equivalenced storages. Keep lowering simple.
+ if (mustBeDefaultInitializedAtRuntime(var))
+ defaultInitializeAtRuntime(converter, var, symMap);
+}
+
//===--------------------------------------------------------------===//
// COMMON blocks instantiation
//===--------------------------------------------------------------===//
@@ -1392,13 +1604,131 @@ void Fortran::lower::mapSymbolAttributes(
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArrayStaticChar &x) {
- TODO(loc, "DynamicArrayStaticChar variable lowering");
+ mlir::Value addr;
+ mlir::Value len;
+ mlir::Value argBox;
+ auto charLen = x.charLen();
+ // if element type is a CHARACTER, determine the LEN value
+ if (isDummy) {
+ mlir::Value actualArg = symMap.lookupSymbol(sym).getAddr();
+ if (auto boxTy = actualArg.getType().dyn_cast<fir::BoxType>()) {
+ argBox = actualArg;
+ mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
+ addr = builder.create<fir::BoxAddrOp>(loc, refTy, argBox);
+ } else {
+ addr = charHelp.createUnboxChar(actualArg).first;
+ }
+ // Set/override LEN with a constant
+ len = builder.createIntegerConstant(loc, idxTy, charLen);
+ } else {
+ // local CHARACTER variable
+ len = builder.createIntegerConstant(loc, idxTy, charLen);
+ }
+
+ // cast to the known constant parts from the declaration
+ mlir::Type castTy = builder.getRefType(converter.genType(var));
+ if (addr)
+ addr = builder.createConvert(loc, castTy, addr);
+ if (x.lboundAllOnes()) {
+ // if lower bounds are all ones, build simple shaped object
+ llvm::SmallVector<mlir::Value> shape;
+ populateShape(shape, x.bounds, argBox);
+ if (isDummy) {
+ symMap.addCharSymbolWithShape(sym, addr, len, shape, true);
+ return;
+ }
+ // local CHARACTER array
+ mlir::Value local =
+ createNewLocal(converter, loc, var, preAlloc, shape);
+ symMap.addCharSymbolWithShape(sym, local, len, shape);
+ return;
+ }
+ // if object is an array process the lower bound and extent values
+ llvm::SmallVector<mlir::Value> extents;
+ llvm::SmallVector<mlir::Value> lbounds;
+ populateLBoundsExtents(lbounds, extents, x.bounds, argBox);
+ if (isDummy) {
+ symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds,
+ true);
+ return;
+ }
+ // local CHARACTER array with computed bounds
+ assert(Fortran::lower::isExplicitShape(sym));
+ mlir::Value local =
+ createNewLocal(converter, loc, var, preAlloc, extents);
+ symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArrayDynamicChar &x) {
- TODO(loc, "DynamicArrayDynamicChar variable lowering");
+ mlir::Value addr;
+ mlir::Value len;
+ mlir::Value argBox;
+ auto charLen = x.charLen();
+ // if element type is a CHARACTER, determine the LEN value
+ if (isDummy) {
+ mlir::Value actualArg = symMap.lookupSymbol(sym).getAddr();
+ if (auto boxTy = actualArg.getType().dyn_cast<fir::BoxType>()) {
+ argBox = actualArg;
+ mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
+ addr = builder.create<fir::BoxAddrOp>(loc, refTy, argBox);
+ if (charLen)
+ // Set/override LEN with an expression.
+ len = genExplicitCharLen(charLen);
+ else
+ // Get the length from the actual arguments.
+ len = charHelp.readLengthFromBox(argBox);
+ } else {
+ std::pair<mlir::Value, mlir::Value> unboxchar =
+ charHelp.createUnboxChar(actualArg);
+ addr = unboxchar.first;
+ if (charLen) {
+ // Set/override LEN with an expression
+ len = genExplicitCharLen(charLen);
+ } else {
+ // Get the length from the actual arguments.
+ len = unboxchar.second;
+ }
+ }
+ } else {
+ // local CHARACTER variable
+ len = genExplicitCharLen(charLen);
+ }
+ llvm::SmallVector<mlir::Value> lengths = {len};
+
+ // cast to the known constant parts from the declaration
+ mlir::Type castTy = builder.getRefType(converter.genType(var));
+ if (addr)
+ addr = builder.createConvert(loc, castTy, addr);
+ if (x.lboundAllOnes()) {
+ // if lower bounds are all ones, build simple shaped object
+ llvm::SmallVector<mlir::Value> shape;
+ populateShape(shape, x.bounds, argBox);
+ if (isDummy) {
+ symMap.addCharSymbolWithShape(sym, addr, len, shape, true);
+ return;
+ }
+ // local CHARACTER array
+ mlir::Value local =
+ createNewLocal(converter, loc, var, preAlloc, shape, lengths);
+ symMap.addCharSymbolWithShape(sym, local, len, shape);
+ return;
+ }
+ // Process the lower bound and extent values.
+ llvm::SmallVector<mlir::Value> extents;
+ llvm::SmallVector<mlir::Value> lbounds;
+ populateLBoundsExtents(lbounds, extents, x.bounds, argBox);
+ if (isDummy) {
+ symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds,
+ true);
+ return;
+ }
+ // local CHARACTER array with computed bounds
+ assert(Fortran::lower::isExplicitShape(sym));
+ mlir::Value local =
+ createNewLocal(converter, loc, var, preAlloc, extents, lengths);
+ symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds);
},
//===--------------------------------------------------------------===//
@@ -1413,14 +1743,18 @@ void Fortran::lower::defineModuleVariable(
AbstractConverter &converter, const Fortran::lower::pft::Variable &var) {
// Use empty linkage for module variables, which makes them available
// for use in another unit.
- mlir::StringAttr externalLinkage;
+ mlir::StringAttr linkage =
+ getLinkageAttribute(converter.getFirOpBuilder(), var);
if (!var.isGlobal())
fir::emitFatalError(converter.getCurrentLocation(),
"attempting to lower module variable as local");
// Define aggregate storages for equivalenced objects.
if (var.isAggregateStore()) {
- const mlir::Location loc = converter.genLocation(var.getSymbol().name());
- TODO(loc, "defineModuleVariable aggregateStore");
+ const Fortran::lower::pft::Variable::AggregateStore &aggregate =
+ var.getAggregateStore();
+ std::string aggName = mangleGlobalAggregateStore(aggregate);
+ defineGlobalAggregateStore(converter, aggregate, aggName, linkage);
+ return;
}
const Fortran::semantics::Symbol &sym = var.getSymbol();
if (const Fortran::semantics::Symbol *common =
@@ -1431,24 +1765,22 @@ void Fortran::lower::defineModuleVariable(
// Do nothing. Mapping will be done on user side.
} else {
std::string globalName = Fortran::lower::mangle::mangleName(sym);
- defineGlobal(converter, var, globalName, externalLinkage);
+ defineGlobal(converter, var, globalName, linkage);
}
}
void Fortran::lower::instantiateVariable(AbstractConverter &converter,
const pft::Variable &var,
- SymMap &symMap,
+ Fortran::lower::SymMap &symMap,
AggregateStoreMap &storeMap) {
- const Fortran::semantics::Symbol &sym = var.getSymbol();
- const mlir::Location loc = converter.genLocation(sym.name());
if (var.isAggregateStore()) {
- TODO(loc, "instantiateVariable AggregateStore");
+ instantiateAggregateStore(converter, var, storeMap);
} else if (const Fortran::semantics::Symbol *common =
Fortran::semantics::FindCommonBlockContaining(
var.getSymbol().GetUltimate())) {
instantiateCommon(converter, *common, var, symMap);
} else if (var.isAlias()) {
- TODO(loc, "instantiateVariable Alias");
+ instantiateAlias(converter, var, symMap, storeMap);
} else if (var.isGlobal()) {
instantiateGlobal(converter, var, symMap);
} else {
@@ -1503,3 +1835,13 @@ void Fortran::lower::mapCallInterfaceSymbols(
}
}
}
+
+void Fortran::lower::createRuntimeTypeInfoGlobal(
+ Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+ const Fortran::semantics::Symbol &typeInfoSym) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ std::string globalName = Fortran::lower::mangle::mangleName(typeInfoSym);
+ auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true);
+ mlir::StringAttr linkage = getLinkageAttribute(builder, var);
+ defineGlobal(converter, var, globalName, linkage);
+}
diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp
index f8bc373ddcb8c..a690c339dd1d7 100644
--- a/flang/lib/Lower/IntrinsicCall.cpp
+++ b/flang/lib/Lower/IntrinsicCall.cpp
@@ -105,6 +105,9 @@ static bool isAbsent(llvm::ArrayRef<fir::ExtendedValue> args, size_t argIndex) {
return args.size() <= argIndex || isAbsent(args[argIndex]);
}
+/// Test if an ExtendedValue is present.
+static bool isPresent(const fir::ExtendedValue &exv) { return !isAbsent(exv); }
+
/// Process calls to Maxval, Minval, Product, Sum intrinsic functions that
/// take a DIM argument.
template <typename FD>
@@ -277,6 +280,7 @@ struct IntrinsicLibrary {
mlir::Value genIand(mlir::Type, llvm::ArrayRef<mlir::Value>);
mlir::Value genIbits(mlir::Type, llvm::ArrayRef<mlir::Value>);
fir::ExtendedValue genLbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+ fir::ExtendedValue genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genSize(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
fir::ExtendedValue genUbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
@@ -390,6 +394,7 @@ static constexpr IntrinsicHandler handlers[]{
{"iand", &I::genIand},
{"ibits", &I::genIbits},
{"min", &I::genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>},
+ {"null", &I::genNull, {{{"mold", asInquired}}}, /*isElemental=*/false},
{"sum",
&I::genSum,
{{{"array", asBox},
@@ -1399,6 +1404,23 @@ mlir::Value IntrinsicLibrary::genExtremum(mlir::Type,
return result;
}
+// NULL
+fir::ExtendedValue
+IntrinsicLibrary::genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue> args) {
+ // NULL() without MOLD must be handled in the contexts where it can appear
+ // (see table 16.5 of Fortran 2018 standard).
+ assert(args.size() == 1 && isPresent(args[0]) &&
+ "MOLD argument required to lower NULL outside of any context");
+ const auto *mold = args[0].getBoxOf<fir::MutableBoxValue>();
+ assert(mold && "MOLD must be a pointer or allocatable");
+ fir::BoxType boxType = mold->getBoxTy();
+ mlir::Value boxStorage = builder.createTemporary(loc, boxType);
+ mlir::Value box = fir::factory::createUnallocatedBox(
+ builder, loc, boxType, mold->nonDeferredLenParams());
+ builder.create<fir::StoreOp>(loc, box, boxStorage);
+ return fir::MutableBoxValue(boxStorage, mold->nonDeferredLenParams(), {});
+}
+
// SUM
fir::ExtendedValue
IntrinsicLibrary::genSum(mlir::Type resultType,
diff --git a/flang/lib/Lower/SymbolMap.cpp b/flang/lib/Lower/SymbolMap.cpp
index 2cf5062109afc..414c4f0f5c9e9 100644
--- a/flang/lib/Lower/SymbolMap.cpp
+++ b/flang/lib/Lower/SymbolMap.cpp
@@ -31,7 +31,8 @@ void Fortran::lower::SymMap::addSymbol(Fortran::semantics::SymbolRef sym,
}
Fortran::lower::SymbolBox
-Fortran::lower::SymMap::lookupSymbol(Fortran::semantics::SymbolRef sym) {
+Fortran::lower::SymMap::lookupSymbol(Fortran::semantics::SymbolRef symRef) {
+ Fortran::semantics::SymbolRef sym = symRef.get().GetUltimate();
for (auto jmap = symbolMapStack.rbegin(), jend = symbolMapStack.rend();
jmap != jend; ++jmap) {
auto iter = jmap->find(&*sym);
@@ -41,6 +42,15 @@ Fortran::lower::SymMap::lookupSymbol(Fortran::semantics::SymbolRef sym) {
return SymbolBox::None{};
}
+Fortran::lower::SymbolBox Fortran::lower::SymMap::shallowLookupSymbol(
+ Fortran::semantics::SymbolRef symRef) {
+ auto &map = symbolMapStack.back();
+ auto iter = map.find(&symRef.get().GetUltimate());
+ if (iter != map.end())
+ return iter->second;
+ return SymbolBox::None{};
+}
+
mlir::Value
Fortran::lower::SymMap::lookupImpliedDo(Fortran::lower::SymMap::AcDoVar var) {
for (auto [marker, binding] : llvm::reverse(impliedDoStack))
diff --git a/flang/test/Lower/nullify.f90 b/flang/test/Lower/nullify.f90
new file mode 100644
index 0000000000000..f9fd3d8430077
--- /dev/null
+++ b/flang/test/Lower/nullify.f90
@@ -0,0 +1,51 @@
+! Test lowering of nullify-statement
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+
+! -----------------------------------------------------------------------------
+! Test NULLIFY(p)
+! -----------------------------------------------------------------------------
+
+
+! CHECK-LABEL: func @_QPtest_scalar(
+! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}})
+subroutine test_scalar(p)
+ real, pointer :: p
+ ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr<f32>
+ ! CHECK: %[[box:.*]] = fir.embox %[[null]] : (!fir.ptr<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ nullify(p)
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_scalar_char(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}})
+ subroutine test_scalar_char(p)
+ character(:), pointer :: p
+ ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[box:.*]] = fir.embox %[[null]] typeparams %c0{{.*}} : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ nullify(p)
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_array(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}})
+ subroutine test_array(p)
+ real, pointer :: p(:)
+ ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}}
+ ! CHECK: %[[box:.*]] = fir.embox %[[null]](%[[shape]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ nullify(p)
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_list(
+ ! CHECK-SAME: %[[p1:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}}, %[[p2:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}})
+ subroutine test_list(p1, p2)
+ real, pointer :: p1, p2(:)
+ ! CHECK: fir.zero_bits !fir.ptr<f32>
+ ! CHECK: fir.store %{{.*}} to %[[p1]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+
+ ! CHECK: fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+ ! CHECK: fir.store %{{.*}} to %[[p2]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ nullify(p1, p2)
+ end subroutine
diff --git a/flang/test/Lower/pointer-assignments.f90 b/flang/test/Lower/pointer-assignments.f90
new file mode 100644
index 0000000000000..dcc6fb0f27d28
--- /dev/null
+++ b/flang/test/Lower/pointer-assignments.f90
@@ -0,0 +1,356 @@
+! Test lowering of pointer assignments
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+
+! Note that p => NULL() are tested in pointer-disassociate.f90
+
+! -----------------------------------------------------------------------------
+! Test simple pointer assignments to contiguous right-hand side
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest_scalar(
+! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}}, %[[x:.*]]: !fir.ref<f32> {{{.*}}, fir.target})
+subroutine test_scalar(p, x)
+ real, target :: x
+ real, pointer :: p
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ p => x
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_scalar_char(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target})
+ subroutine test_scalar_char(p, x)
+ character(*), target :: x
+ character(:), pointer :: p
+ ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+ ! CHECK: %[[box:.*]] = fir.embox %[[c]]#0 typeparams %[[c]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ p => x
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_array(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.ref<!fir.array<100xf32>> {{{.*}}, fir.target})
+ subroutine test_array(p, x)
+ real, target :: x(100)
+ real, pointer :: p(:)
+ ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}}
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p => x
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_array_char(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target}) {
+ subroutine test_array_char(p, x)
+ character(*), target :: x(100)
+ character(:), pointer :: p(:)
+ ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+ ! CHECK: %[[xaddr:.*]] = fir.convert %[[c]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<100x!fir.char<1,?>>>
+ ! CHECK-DAG: %[[xaddr2:.*]] = fir.convert %[[xaddr]] : (!fir.ref<!fir.array<100x!fir.char<1,?>>>) -> !fir.ref<!fir.array<?x!fir.char<1,?>>>
+ ! CHECK-DAG: %[[shape:.*]] = fir.shape %c100{{.*}}
+ ! CHECK: %[[box:.*]] = fir.embox %[[xaddr2]](%[[shape]]) typeparams %[[c]]#1
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>
+ p => x
+ end subroutine
+
+ ! Test 10.2.2.3 point 10: lower bounds requirements:
+ ! pointer takes lbounds from rhs if no bounds spec.
+ ! CHECK-LABEL: func @_QPtest_array_with_lbs(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ subroutine test_array_with_lbs(p, x)
+ real, target :: x(51:150)
+ real, pointer :: p(:)
+ ! CHECK: %[[shape:.*]] = fir.shape_shift %c51{{.*}}, %c100{{.*}}
+ ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p => x
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test pointer assignments with bound specs to contiguous right-hand side
+ ! -----------------------------------------------------------------------------
+
+ ! Test 10.2.2.3 point 10: lower bounds requirements:
+ ! pointer takes lbounds from bound spec if specified
+ ! CHECK-LABEL: func @_QPtest_array_with_new_lbs(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ subroutine test_array_with_new_lbs(p, x)
+ real, target :: x(51:150)
+ real, pointer :: p(:)
+ ! CHECK: %[[shape:.*]] = fir.shape_shift %c4{{.*}}, %c100{{.*}}
+ ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p(4:) => x
+ end subroutine
+
+ ! Test F2018 10.2.2.3 point 9: bounds remapping
+ ! CHECK-LABEL: func @_QPtest_array_remap(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>{{.*}}, %[[x:.*]]: !fir.ref<!fir.array<100xf32>> {{{.*}}, fir.target})
+ subroutine test_array_remap(p, x)
+ real, target :: x(100)
+ real, pointer :: p(:, :)
+ ! CHECK-DAG: %[[c2_idx:.*]] = fir.convert %c2{{.*}} : (i64) -> index
+ ! CHECK-DAG: %[[c11_idx:.*]] = fir.convert %c11{{.*}} : (i64) -> index
+ ! CHECK-DAG: %[[
diff 0:.*]] = arith.subi %[[c11_idx]], %[[c2_idx]] : index
+ ! CHECK-DAG: %[[ext0:.*]] = arith.addi %[[
diff 0:.*]], %c1{{.*}} : index
+ ! CHECK-DAG: %[[c3_idx:.*]] = fir.convert %c3{{.*}} : (i64) -> index
+ ! CHECK-DAG: %[[c12_idx:.*]] = fir.convert %c12{{.*}} : (i64) -> index
+ ! CHECK-DAG: %[[
diff 1:.*]] = arith.subi %[[c12_idx]], %[[c3_idx]] : index
+ ! CHECK-DAG: %[[ext1:.*]] = arith.addi %[[
diff 1]], %c1{{.*}} : index
+ ! CHECK-DAG: %[[addrCast:.*]] = fir.convert %[[x]] : (!fir.ref<!fir.array<100xf32>>) -> !fir.ref<!fir.array<?x?xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape_shift %c2{{.*}}, %[[ext0]], %c3{{.*}}, %[[ext1]]
+ ! CHECK: %[[box:.*]] = fir.embox %[[addrCast]](%[[shape]]) : (!fir.ref<!fir.array<?x?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+ p(2:11, 3:12) => x
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_array_char_remap(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?x!fir.char<1,?>>>>>{{.*}}, %[[x:.*]]: !fir.boxchar<1> {{{.*}}, fir.target})
+ subroutine test_array_char_remap(p, x)
+ ! CHECK: %[[unbox:.*]]:2 = fir.unboxchar %[[x]]
+ character(*), target :: x(100)
+ character(:), pointer :: p(:, :)
+ ! CHECK: subi
+ ! CHECK: %[[ext0:.*]] = arith.addi
+ ! CHECK: subi
+ ! CHECK: %[[ext1:.*]] = arith.addi
+ ! CHECK: %[[shape:.*]] = fir.shape_shift %c2{{.*}}, %[[ext0]], %c3{{.*}}, %[[ext1]]
+ ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) typeparams %[[unbox]]#1 : (!fir.ref<!fir.array<?x?x!fir.char<1,?>>>, !fir.shapeshift<2>, index) -> !fir.box<!fir.ptr<!fir.array<?x?x!fir.char<1,?>>>>
+ ! CHECK: fir.store %[[box]] to %[[p]]
+ p(2:11, 3:12) => x
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test simple pointer assignments to non contiguous right-hand side
+ ! -----------------------------------------------------------------------------
+
+ ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
+ subroutine test_array_non_contig_rhs(p, x)
+ real, target :: x(:)
+ real, pointer :: p(:)
+ ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p => x
+ end subroutine
+
+ ! Test 10.2.2.3 point 10: lower bounds requirements:
+ ! pointer takes lbounds from rhs if no bounds spec.
+ ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs_lbs(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
+ subroutine test_array_non_contig_rhs_lbs(p, x)
+ real, target :: x(7:)
+ real, pointer :: p(:)
+ ! CHECK: %[[c7_idx:.*]] = fir.convert %c7{{.*}} : (i64) -> index
+ ! CHECK: %[[shift:.*]] = fir.shift %[[c7_idx]] : (index) -> !fir.shift<1>
+ ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shift]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+
+ ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p => x
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs2(
+ ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<!fir.array<200xf32>> {{{.*}}, fir.target}) {
+ ! CHECK: %[[VAL_2:.*]] = arith.constant 200 : index
+ ! CHECK: %[[VAL_3:.*]] = arith.constant 10 : i64
+ ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
+ ! CHECK: %[[VAL_5:.*]] = arith.constant 3 : i64
+ ! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
+ ! CHECK: %[[VAL_7:.*]] = arith.constant 160 : i64
+ ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
+ ! CHECK: %[[VAL_9:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+ ! CHECK: %[[VAL_10:.*]] = fir.slice %[[VAL_4]], %[[VAL_8]], %[[VAL_6]] : (index, index, index) -> !fir.slice<1>
+ ! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_1]](%[[VAL_9]]) {{\[}}%[[VAL_10]]] : (!fir.ref<!fir.array<200xf32>>, !fir.shape<1>, !fir.slice<1>) -> !fir.box<!fir.array<?xf32>>
+ ! CHECK: %[[VAL_12:.*]] = fir.rebox %[[VAL_11]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[VAL_12]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ ! CHECK: return
+ ! CHECK: }
+
+ subroutine test_array_non_contig_rhs2(p, x)
+ real, target :: x(200)
+ real, pointer :: p(:)
+ p => x(10:160:3)
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test pointer assignments with bound specs to non contiguous right-hand side
+ ! -----------------------------------------------------------------------------
+
+
+ ! Test 10.2.2.3 point 10: lower bounds requirements:
+ ! pointer takes lbounds from bound spec if specified
+ ! CHECK-LABEL: func @_QPtest_array_non_contig_rhs_new_lbs(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
+ subroutine test_array_non_contig_rhs_new_lbs(p, x)
+ real, target :: x(7:)
+ real, pointer :: p(:)
+ ! CHECK: %[[shift:.*]] = fir.shift %c4{{.*}}
+ ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shift]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+
+ ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p(4:) => x
+ end subroutine
+
+ ! Test F2018 10.2.2.3 point 9: bounds remapping
+ ! CHECK-LABEL: func @_QPtest_array_non_contig_remap(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>{{.*}}, %[[x:.*]]: !fir.box<!fir.array<?xf32>> {{{.*}}, fir.target})
+ subroutine test_array_non_contig_remap(p, x)
+ real, target :: x(:)
+ real, pointer :: p(:, :)
+ ! CHECK: subi
+ ! CHECK: %[[ext0:.*]] = arith.addi
+ ! CHECK: subi
+ ! CHECK: %[[ext1:.*]] = arith.addi
+ ! CHECK: %[[shape:.*]] = fir.shape_shift %{{.*}}, %[[ext0]], %{{.*}}, %[[ext1]]
+ ! CHECK: %[[rebox:.*]] = fir.rebox %[[x]](%[[shape]]) : (!fir.box<!fir.array<?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: fir.store %[[rebox]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+ p(2:11, 3:12) => x
+ end subroutine
+
+ ! Test remapping a slice
+
+ ! CHECK-LABEL: func @_QPtest_array_non_contig_remap_slice(
+ ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<!fir.array<400xf32>> {{{.*}}, fir.target}) {
+ ! CHECK: %[[VAL_2:.*]] = arith.constant 400 : index
+ ! CHECK: %[[VAL_3:.*]] = arith.constant 2 : i64
+ ! CHECK: %[[VAL_4:.*]] = arith.constant 11 : i64
+ ! CHECK: %[[VAL_5:.*]] = arith.constant 3 : i64
+ ! CHECK: %[[VAL_6:.*]] = arith.constant 12 : i64
+ ! CHECK: %[[VAL_7:.*]] = arith.constant 51 : i64
+ ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
+ ! CHECK: %[[VAL_9:.*]] = arith.constant 3 : i64
+ ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i64) -> index
+ ! CHECK: %[[VAL_11:.*]] = arith.constant 350 : i64
+ ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index
+ ! CHECK: %[[VAL_13:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+ ! CHECK: %[[VAL_14:.*]] = fir.slice %[[VAL_8]], %[[VAL_12]], %[[VAL_10]] : (index, index, index) -> !fir.slice<1>
+ ! CHECK: %[[VAL_15:.*]] = fir.embox %[[VAL_1]](%[[VAL_13]]) {{\[}}%[[VAL_14]]] : (!fir.ref<!fir.array<400xf32>>, !fir.shape<1>, !fir.slice<1>) -> !fir.box<!fir.array<?xf32>>
+ ! CHECK: %[[VAL_16:.*]] = arith.constant 1 : index
+ ! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
+ ! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
+ ! CHECK: %[[VAL_19:.*]] = arith.subi %[[VAL_18]], %[[VAL_17]] : index
+ ! CHECK: %[[VAL_20:.*]] = arith.addi %[[VAL_19]], %[[VAL_16]] : index
+ ! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
+ ! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_6]] : (i64) -> index
+ ! CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_22]], %[[VAL_21]] : index
+ ! CHECK: %[[VAL_24:.*]] = arith.addi %[[VAL_23]], %[[VAL_16]] : index
+ ! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
+ ! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
+ ! CHECK: %[[VAL_27:.*]] = fir.shape_shift %[[VAL_25]], %[[VAL_20]], %[[VAL_26]], %[[VAL_24]] : (index, index, index, index) -> !fir.shapeshift<2>
+ ! CHECK: %[[VAL_28:.*]] = fir.rebox %[[VAL_15]](%[[VAL_27]]) : (!fir.box<!fir.array<?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: fir.store %[[VAL_28]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+ ! CHECK: return
+ ! CHECK: }
+ subroutine test_array_non_contig_remap_slice(p, x)
+ real, target :: x(400)
+ real, pointer :: p(:, :)
+ p(2:11, 3:12) => x(51:350:3)
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test pointer assignments that involves LHS pointers lowered to local variables
+ ! instead of a fir.ref<fir.box>, and RHS that are fir.box
+ ! -----------------------------------------------------------------------------
+
+ ! CHECK-LABEL: func @_QPissue857(
+ ! CHECK-SAME: %[[rhs:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>>
+ subroutine issue857(rhs)
+ type t
+ integer :: i
+ end type
+ type(t), pointer :: rhs, lhs
+ ! CHECK: %[[lhs:.*]] = fir.alloca !fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>
+ ! CHECK: %[[box_load:.*]] = fir.load %[[rhs]] : !fir.ref<!fir.box<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>>
+ ! CHECK: %[[addr:.*]] = fir.box_addr %[[box_load]] : (!fir.box<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>) -> !fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>
+ ! CHECK: fir.store %[[addr]] to %[[lhs]] : !fir.ref<!fir.ptr<!fir.type<_QFissue857Tt{i:i32}>>>
+ lhs => rhs
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPissue857_array(
+ ! CHECK-SAME: %[[rhs:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>>
+ subroutine issue857_array(rhs)
+ type t
+ integer :: i
+ end type
+ type(t), contiguous, pointer :: rhs(:), lhs(:)
+ ! CHECK-DAG: %[[lhs_addr:.*]] = fir.alloca !fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>> {uniq_name = "_QFissue857_arrayElhs.addr"}
+ ! CHECK-DAG: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_arrayElhs.lb0"}
+ ! CHECK-DAG: %[[lhs_ext:.*]] = fir.alloca index {uniq_name = "_QFissue857_arrayElhs.ext0"}
+ ! CHECK: %[[box:.*]] = fir.load %[[rhs]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>>
+ ! CHECK: %[[lb:.*]]:3 = fir.box_dims %[[box]], %c{{.*}} : (!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>, index) -> (index, index, index)
+ ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>) -> !fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>
+ ! CHECK: %[[ext:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>, index) -> (index, index, index)
+ ! CHECK-DAG: fir.store %[[addr]] to %[[lhs_addr]] : !fir.ref<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_arrayTt{i:i32}>>>>
+ ! CHECK-DAG: fir.store %[[ext]]#1 to %[[lhs_ext]] : !fir.ref<index>
+ ! CHECK-DAG: fir.store %[[lb]]#0 to %[[lhs_lb]] : !fir.ref<index>
+ lhs => rhs
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPissue857_array_shift(
+ subroutine issue857_array_shift(rhs)
+ ! Test lower bounds is the one from the shift
+ type t
+ integer :: i
+ end type
+ type(t), contiguous, pointer :: rhs(:), lhs(:)
+ ! CHECK: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_shiftElhs.lb0"}
+ ! CHECK: %[[c42:.*]] = fir.convert %c42{{.*}} : (i64) -> index
+ ! CHECK: fir.store %[[c42]] to %[[lhs_lb]] : !fir.ref<index>
+ lhs(42:) => rhs
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPissue857_array_remap
+ subroutine issue857_array_remap(rhs)
+ ! Test lower bounds is the one from the shift
+ type t
+ integer :: i
+ end type
+ type(t), contiguous, pointer :: rhs(:, :), lhs(:)
+ ! CHECK-DAG: %[[lhs_addr:.*]] = fir.alloca !fir.ptr<!fir.array<?x!fir.type<_QFissue857_array_remapTt{i:i32}>>> {uniq_name = "_QFissue857_array_remapElhs.addr"}
+ ! CHECK-DAG: %[[lhs_lb:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_remapElhs.lb0"}
+ ! CHECK-DAG: %[[lhs_ext:.*]] = fir.alloca index {uniq_name = "_QFissue857_array_remapElhs.ext0"}
+
+ ! CHECK: %[[c101:.*]] = fir.convert %c101_i64 : (i64) -> index
+ ! CHECK: %[[c200:.*]] = fir.convert %c200_i64 : (i64) -> index
+ ! CHECK: %[[sub:.*]] = arith.subi %[[c200]], %[[c101]] : index
+ ! CHECK: %[[extent:.*]] = arith.addi %[[sub]], %c1{{.*}} : index
+ ! CHECK: %[[addr:.*]] = fir.box_addr %{{.*}} : (!fir.box<!fir.ptr<!fir.array<?x?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>>) -> !fir.ptr<!fir.array<?x?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>
+ ! CHECK: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<!fir.array<?x?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>) -> !fir.ptr<!fir.array<?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>
+ ! CHECK: fir.store %[[addr_cast]] to %[[lhs_addr]] : !fir.ref<!fir.ptr<!fir.array<?x!fir.type<_QFissue857_array_remapTt{i:i32}>>>>
+ ! CHECK: fir.store %[[extent]] to %[[lhs_ext]] : !fir.ref<index>
+ ! CHECK: %[[c101_2:.*]] = fir.convert %c101{{.*}} : (i64) -> index
+ ! CHECK: fir.store %[[c101_2]] to %[[lhs_lb]] : !fir.ref<index>
+ lhs(101:200) => rhs
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPissue857_char
+ subroutine issue857_char(rhs)
+ ! Only check that the length is taken from the fir.box created for the slice.
+ ! CHECK-DAG: %[[lhs1_len:.*]] = fir.alloca index {uniq_name = "_QFissue857_charElhs1.len"}
+ ! CHECK-DAG: %[[lhs2_len:.*]] = fir.alloca index {uniq_name = "_QFissue857_charElhs2.len"}
+ character(:), contiguous, pointer :: lhs1(:), lhs2(:, :)
+ character(*), target :: rhs(100)
+ ! CHECK: %[[len:.*]] = fir.box_elesize %{{.*}} : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
+ ! CHECK: fir.store %[[len]] to %[[lhs1_len]] : !fir.ref<index>
+ lhs1 => rhs(1:50:1)
+ ! CHECK: %[[len2:.*]] = fir.box_elesize %{{.*}} : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
+ ! CHECK: fir.store %[[len2]] to %[[lhs2_len]] : !fir.ref<index>
+ lhs2(1:2, 1:25) => rhs(1:50:1)
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPissue1180(
+ ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {{{.*}}, fir.target}) {
+ subroutine issue1180(x)
+ integer, target :: x
+ integer, pointer :: p
+ common /some_common/ p
+ ! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QBsome_common) : !fir.ref<!fir.array<24xi8>>
+ ! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.array<24xi8>>) -> !fir.ref<!fir.array<?xi8>>
+ ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
+ ! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref<i8>) -> !fir.ref<!fir.box<!fir.ptr<i32>>>
+ ! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_0]] : (!fir.ref<i32>) -> !fir.box<!fir.ptr<i32>>
+ ! CHECK: fir.store %[[VAL_6]] to %[[VAL_5]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
+ p => x
+ end subroutine
diff --git a/flang/test/Lower/pointer-disassociate.f90 b/flang/test/Lower/pointer-disassociate.f90
new file mode 100644
index 0000000000000..c05bcfdeff97f
--- /dev/null
+++ b/flang/test/Lower/pointer-disassociate.f90
@@ -0,0 +1,106 @@
+! Test lowering of pointer disassociation
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+
+! -----------------------------------------------------------------------------
+! Test p => NULL()
+! -----------------------------------------------------------------------------
+
+
+! CHECK-LABEL: func @_QPtest_scalar(
+! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}})
+subroutine test_scalar(p)
+ real, pointer :: p
+ ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr<f32>
+ ! CHECK: %[[box:.*]] = fir.embox %[[null]] : (!fir.ptr<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ p => NULL()
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_scalar_char(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}})
+ subroutine test_scalar_char(p)
+ character(:), pointer :: p
+ ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[box:.*]] = fir.embox %[[null]] typeparams %c0{{.*}} : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ p => NULL()
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_array(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}})
+ subroutine test_array(p)
+ real, pointer :: p(:)
+ ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}}
+ ! CHECK: %[[box:.*]] = fir.embox %[[null]](%[[shape]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p => NULL()
+ end subroutine
+
+ ! Test p(lb, ub) => NULL() which is none sens but is not illegal.
+ ! CHECK-LABEL: func @_QPtest_array_remap(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}})
+ subroutine test_array_remap(p)
+ real, pointer :: p(:)
+ ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}}
+ ! CHECK: %[[box:.*]] = fir.embox %[[null]](%[[shape]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p(10:20) => NULL()
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test p => NULL(MOLD)
+ ! -----------------------------------------------------------------------------
+
+ ! CHECK-LABEL: func @_QPtest_scalar_mold(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{[^,]*}},
+ subroutine test_scalar_mold(p, x)
+ real, pointer :: p, x
+ ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.ptr<f32>>
+ ! CHECK: %[[VAL_1:.*]] = fir.zero_bits !fir.ptr<f32>
+ ! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]] : (!fir.ptr<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32>
+ ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_4]] : (!fir.ptr<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.store %[[VAL_5]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ p => NULL(x)
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_scalar_char_mold(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{[^,]*}},
+ subroutine test_scalar_char_mold(p, x)
+ character(:), pointer :: p, x
+ ! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: %[[VAL_8:.*]] = fir.zero_bits !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_10:.*]] = fir.embox %[[VAL_8]] typeparams %[[VAL_9]] : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[VAL_10]] to %[[VAL_7]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ ! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_7]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ ! CHECK: %[[VAL_12:.*]] = fir.box_elesize %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.char<1,?>>>) -> index
+ ! CHECK: %[[VAL_13:.*]] = fir.box_addr %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_13]] typeparams %[[VAL_12]] : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.store %[[VAL_14]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ p => NULL(x)
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPtest_array_mold(
+ ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{[^,]*}},
+ subroutine test_array_mold(p, x)
+ real, pointer :: p(:), x(:)
+ ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: %[[VAL_1:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+ ! CHECK: %[[VAL_2:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_3:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+ ! CHECK: %[[VAL_4:.*]] = fir.embox %[[VAL_1]](%[[VAL_3]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ ! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ ! CHECK: %[[VAL_6:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_5]], %[[VAL_6]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+ ! CHECK: %[[VAL_8:.*]] = fir.shift %[[VAL_7]]#0 : (index) -> !fir.shift<1>
+ ! CHECK: %[[VAL_9:.*]] = fir.rebox %[[VAL_5]](%[[VAL_8]]) : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.store %[[VAL_9]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ p => NULL(x)
+ end subroutine
diff --git a/flang/test/Lower/pointer-initial-target-2.f90 b/flang/test/Lower/pointer-initial-target-2.f90
new file mode 100644
index 0000000000000..9a8679ae40945
--- /dev/null
+++ b/flang/test/Lower/pointer-initial-target-2.f90
@@ -0,0 +1,79 @@
+! Test lowering of pointer initial target
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! This tests focus on the scope context of initial data target.
+! More complete tests regarding the initial data target expression
+! are done in pointer-initial-target.f90.
+
+! Test pointer initial data target in modules
+module some_mod
+ real, target :: x(100)
+ real, pointer :: p(:) => x
+ ! CHECK-LABEL: fir.global @_QMsome_modEp : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QMsome_modEx) : !fir.ref<!fir.array<100xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ end module
+
+ ! Test initial data target in a common block
+ module some_mod_2
+ real, target :: x(100), y(10:209)
+ common /com/ x, y
+ save :: /com/
+ real, pointer :: p(:) => y
+ ! CHECK-LABEL: fir.global @_QMsome_mod_2Ep : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+ ! CHECK: %[[c:.*]] = fir.address_of(@_QBcom) : !fir.ref<!fir.array<1200xi8>>
+ ! CHECK: %[[com:.*]] = fir.convert %[[c]] : (!fir.ref<!fir.array<1200xi8>>) -> !fir.ref<!fir.array<?xi8>>
+ ! CHECK: %[[yRaw:.*]] = fir.coordinate_of %[[com]], %c400{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
+ ! CHECK: %[[y:.*]] = fir.convert %[[yRaw]] : (!fir.ref<i8>) -> !fir.ref<!fir.array<200xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape_shift %c10{{.*}}, %c200{{.*}} : (index, index) -> !fir.shapeshift<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[y]](%[[shape]]) : (!fir.ref<!fir.array<200xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ end module
+
+ ! Test pointer initial data target with pointer in common blocks
+ block data
+ real, pointer :: p
+ real, save, target :: b
+ common /a/ p
+ data p /b/
+ ! CHECK-LABEL: fir.global @_QBa : tuple<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: %[[undef:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref<f32>
+ ! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: %[[a:.*]] = fir.insert_value %[[undef]], %[[box]], [0 : index] : (tuple<!fir.box<!fir.ptr<f32>>>, !fir.box<!fir.ptr<f32>>) -> tuple<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.has_value %[[a]] : tuple<!fir.box<!fir.ptr<f32>>>
+ end block data
+
+ ! Test pointer in a common with initial target in the same common.
+ block data snake
+ integer, target :: b = 42
+ integer, pointer :: p => b
+ common /snake/ p, b
+ ! CHECK-LABEL: fir.global @_QBsnake : tuple<!fir.box<!fir.ptr<i32>>, i32>
+ ! CHECK: %[[tuple0:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<i32>>, i32>
+ ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>
+ ! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>) -> !fir.ref<!fir.array<?xi8>>
+ ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
+ ! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref<i8>) -> !fir.ref<i32>
+ ! CHECK: %[[box:.*]] = fir.embox %[[bAddr]] : (!fir.ref<i32>) -> !fir.box<!fir.ptr<i32>>
+ ! CHECK: %[[tuple1:.*]] = fir.insert_value %[[tuple0]], %[[box]], [0 : index] : (tuple<!fir.box<!fir.ptr<i32>>, i32>, !fir.box<!fir.ptr<i32>>) -> tuple<!fir.box<!fir.ptr<i32>>, i32>
+ ! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple1]], %c42{{.*}}, [1 : index] : (tuple<!fir.box<!fir.ptr<i32>>, i32>, i32) -> tuple<!fir.box<!fir.ptr<i32>>, i32>
+ ! CHECK: fir.has_value %[[tuple2]] : tuple<!fir.box<!fir.ptr<i32>>, i32>
+ end block data
+
+ ! Test two common depending on each others because of initial data
+ ! targets
+ block data tied
+ real, target :: x1 = 42
+ real, target :: x2 = 43
+ real, pointer :: p1 => x2
+ real, pointer :: p2 => x1
+ common /c1/ x1, p1
+ common /c2/ x2, p2
+ ! CHECK-LABEL: fir.global @_QBc1 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.address_of(@_QBc2) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+ ! CHECK-LABEL: fir.global @_QBc2 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.address_of(@_QBc1) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+ end block data
diff --git a/flang/test/Lower/pointer-initial-target.f90 b/flang/test/Lower/pointer-initial-target.f90
new file mode 100644
index 0000000000000..720dec834b813
--- /dev/null
+++ b/flang/test/Lower/pointer-initial-target.f90
@@ -0,0 +1,186 @@
+! Test lowering of pointer initial target
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! -----------------------------------------------------------------------------
+! Test scalar initial data target that are simple names
+! -----------------------------------------------------------------------------
+
+subroutine scalar()
+ real, save, target :: x
+ real, pointer :: p => x
+ ! CHECK-LABEL: fir.global internal @_QFscalarEp : !fir.box<!fir.ptr<f32>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalarEx) : !fir.ref<f32>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<f32>>
+ end subroutine
+
+ subroutine scalar_char()
+ character(10), save, target :: x
+ character(:), pointer :: p => x
+ ! CHECK-LABEL: fir.global internal @_QFscalar_charEp : !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_charEx) : !fir.ref<!fir.char<1,10>>
+ ! CHECK: %[[xCast:.*]] = fir.convert %[[x]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ptr<!fir.char<1,?>>
+ ! CHECK: %[[box:.*]] = fir.embox %[[xCast]] typeparams %c10{{.*}} : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.char<1,?>>>
+ end subroutine
+
+ subroutine scalar_char_2()
+ character(10), save, target :: x
+ character(10), pointer :: p => x
+ ! CHECK-LABEL: fir.global internal @_QFscalar_char_2Ep : !fir.box<!fir.ptr<!fir.char<1,10>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_char_2Ex) : !fir.ref<!fir.char<1,10>>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref<!fir.char<1,10>>) -> !fir.box<!fir.ptr<!fir.char<1,10>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.char<1,10>>>
+ end subroutine
+
+ subroutine scalar_derived()
+ type t
+ real :: x
+ integer :: i
+ end type
+ type(t), save, target :: x
+ type(t), pointer :: p => x
+ ! CHECK-LABEL: fir.global internal @_QFscalar_derivedEp : !fir.box<!fir.ptr<!fir.type<_QFscalar_derivedTt{x:f32,i:i32}>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_derivedEx) : !fir.ref<!fir.type<_QFscalar_derivedTt{x:f32,i:i32}>>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]] : (!fir.ref<!fir.type<_QFscalar_derivedTt{x:f32,i:i32}>>) -> !fir.box<!fir.ptr<!fir.type<_QFscalar_derivedTt{x:f32,i:i32}>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.type<_QFscalar_derivedTt{x:f32,i:i32}>>>
+ end subroutine
+
+ subroutine scalar_null()
+ real, pointer :: p => NULL()
+ ! CHECK-LABEL: fir.global internal @_QFscalar_nullEp : !fir.box<!fir.ptr<f32>>
+ ! CHECK: %[[zero:.*]] = fir.zero_bits !fir.ptr<f32>
+ ! CHECK: %[[box:.*]] = fir.embox %[[zero]] : (!fir.ptr<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<f32>>
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test array initial data target that are simple names
+ ! -----------------------------------------------------------------------------
+
+ subroutine array()
+ real, save, target :: x(100)
+ real, pointer :: p(:) => x
+ ! CHECK-LABEL: fir.global internal @_QFarrayEp : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFarrayEx) : !fir.ref<!fir.array<100xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ end subroutine
+
+ subroutine array_char()
+ character(10), save, target :: x(20)
+ character(:), pointer :: p(:) => x
+ ! CHECK-LABEL: fir.global internal @_QFarray_charEp : !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFarray_charEx) : !fir.ref<!fir.array<20x!fir.char<1,10>>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c20{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK: %[[xCast:.*]] = fir.convert %[[x]] : (!fir.ref<!fir.array<20x!fir.char<1,10>>>) -> !fir.ptr<!fir.array<?x!fir.char<1,?>>>
+ ! CHECK: %[[box:.*]] = fir.embox %[[xCast]](%[[shape]]) typeparams %c10{{.*}} : (!fir.ptr<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>
+ end subroutine
+
+ subroutine array_char_2()
+ character(10), save, target :: x(20)
+ character(10), pointer :: p(:) => x
+ ! CHECK-LABEL: fir.global internal @_QFarray_char_2Ep : !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,10>>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFarray_char_2Ex) : !fir.ref<!fir.array<20x!fir.char<1,10>>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c20{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<20x!fir.char<1,10>>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,10>>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,10>>>>
+ end subroutine
+
+ subroutine array_derived()
+ type t
+ real :: x
+ integer :: i
+ end type
+ type(t), save, target :: x(100)
+ type(t), pointer :: p(:) => x
+ ! CHECK-LABEL: fir.global internal @_QFarray_derivedEp : !fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFarray_derivedTt{x:f32,i:i32}>>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFarray_derivedEx) : !fir.ref<!fir.array<100x!fir.type<_QFarray_derivedTt{x:f32,i:i32}>>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<100x!fir.type<_QFarray_derivedTt{x:f32,i:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFarray_derivedTt{x:f32,i:i32}>>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?x!fir.type<_QFarray_derivedTt{x:f32,i:i32}>>>>
+ end subroutine
+
+ subroutine array_null()
+ real, pointer :: p(:) => NULL()
+ ! CHECK-LABEL: fir.global internal @_QFarray_nullEp : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: %[[zero:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[zero]](%[[shape]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test scalar initial data target that are data references
+ ! -----------------------------------------------------------------------------
+
+ subroutine scalar_ref()
+ real, save, target :: x(4:100)
+ real, pointer :: p => x(50)
+ ! CHECK-LABEL: fir.global internal @_QFscalar_refEp : !fir.box<!fir.ptr<f32>> {
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_refEx) : !fir.ref<!fir.array<97xf32>>
+ ! CHECK: %[[lb:.*]] = fir.convert %c4 : (index) -> i64
+ ! CHECK: %[[idx:.*]] = arith.subi %c50{{.*}}, %[[lb]] : i64
+ ! CHECK: %[[elt:.*]] = fir.coordinate_of %[[x]], %[[idx]] : (!fir.ref<!fir.array<97xf32>>, i64) -> !fir.ref<f32>
+ ! CHECK: %[[box:.*]] = fir.embox %[[elt]] : (!fir.ref<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<f32>>
+ end subroutine
+
+ subroutine scalar_char_ref()
+ character(20), save, target :: x(100)
+ character(10), pointer :: p => x(6)(7:16)
+ ! CHECK-LABEL: fir.global internal @_QFscalar_char_refEp : !fir.box<!fir.ptr<!fir.char<1,10>>>
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QFscalar_char_refEx) : !fir.ref<!fir.array<100x!fir.char<1,20>>>
+ ! CHECK: %[[idx:.*]] = arith.subi %c6{{.*}}, %c1{{.*}} : i64
+ ! CHECK: %[[elt:.*]] = fir.coordinate_of %[[x]], %[[idx]] : (!fir.ref<!fir.array<100x!fir.char<1,20>>>, i64) -> !fir.ref<!fir.char<1,20>>
+ ! CHECK: %[[eltCast:.*]] = fir.convert %[[elt:.*]] : (!fir.ref<!fir.char<1,20>>) -> !fir.ref<!fir.array<20x!fir.char<1>>>
+ ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[eltCast]], %{{.*}} : (!fir.ref<!fir.array<20x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
+ ! CHECK: %[[substring:.*]] = fir.convert %[[coor]] : (!fir.ref<!fir.char<1>>) -> !fir.ref<!fir.char<1,?>>
+ ! CHECK: %[[substringCast:.*]] = fir.convert %[[substring]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ptr<!fir.char<1,10>>
+ ! CHECK: %[[box:.*]] = fir.embox %[[substringCast]] : (!fir.ptr<!fir.char<1,10>>) -> !fir.box<!fir.ptr<!fir.char<1,10>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.char<1,10>>>
+ end subroutine
+
+ ! -----------------------------------------------------------------------------
+ ! Test array initial data target that are data references
+ ! -----------------------------------------------------------------------------
+
+
+ subroutine array_ref()
+ real, save, target :: x(4:103, 5:104)
+ real, pointer :: p(:) => x(10, 20:100:2)
+ end subroutine
+
+ ! CHECK-LABEL: fir.global internal @_QFarray_refEp : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+ ! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QFarray_refEx) : !fir.ref<!fir.array<100x100xf32>>
+ ! CHECK: %[[VAL_1:.*]] = arith.constant 4 : index
+ ! CHECK: %[[VAL_2:.*]] = arith.constant 100 : index
+ ! CHECK: %[[VAL_3:.*]] = arith.constant 5 : index
+ ! CHECK: %[[VAL_4:.*]] = arith.constant 100 : index
+ ! CHECK: %[[VAL_5:.*]] = arith.constant 1 : index
+ ! CHECK: %[[VAL_6:.*]] = arith.constant 1 : index
+ ! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i64
+ ! CHECK: %[[VAL_8:.*]] = fir.undefined index
+ ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
+ ! CHECK: %[[VAL_10:.*]] = arith.subi %[[VAL_9]], %[[VAL_1]] : index
+ ! CHECK: %[[VAL_11:.*]] = arith.constant 20 : i64
+ ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index
+ ! CHECK: %[[VAL_13:.*]] = arith.constant 2 : i64
+ ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (i64) -> index
+ ! CHECK: %[[VAL_15:.*]] = arith.constant 100 : i64
+ ! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i64) -> index
+ ! CHECK: %[[VAL_17:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_18:.*]] = arith.subi %[[VAL_16]], %[[VAL_12]] : index
+ ! CHECK: %[[VAL_19:.*]] = arith.addi %[[VAL_18]], %[[VAL_14]] : index
+ ! CHECK: %[[VAL_20:.*]] = arith.divsi %[[VAL_19]], %[[VAL_14]] : index
+ ! CHECK: %[[VAL_21:.*]] = arith.cmpi sgt, %[[VAL_20]], %[[VAL_17]] : index
+ ! CHECK: %[[VAL_22:.*]] = arith.select %[[VAL_21]], %[[VAL_20]], %[[VAL_17]] : index
+ ! CHECK: %[[VAL_23:.*]] = fir.shape_shift %[[VAL_1]], %[[VAL_2]], %[[VAL_3]], %[[VAL_4]] : (index, index, index, index) -> !fir.shapeshift<2>
+ ! CHECK: %[[VAL_24:.*]] = fir.slice %[[VAL_7]], %[[VAL_8]], %[[VAL_8]], %[[VAL_12]], %[[VAL_16]], %[[VAL_14]] : (i64, index, index, index, index, index) -> !fir.slice<2>
+ ! CHECK: %[[VAL_25:.*]] = fir.embox %[[VAL_0]](%[[VAL_23]]) {{\[}}%[[VAL_24]]] : (!fir.ref<!fir.array<100x100xf32>>, !fir.shapeshift<2>, !fir.slice<2>) -> !fir.box<!fir.array<?xf32>>
+ ! CHECK: %[[VAL_26:.*]] = fir.embox %[[VAL_0]](%[[VAL_23]]) {{\[}}%[[VAL_24]]] : (!fir.ref<!fir.array<100x100xf32>>, !fir.shapeshift<2>, !fir.slice<2>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.has_value %[[VAL_26]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: }
+
\ No newline at end of file
diff --git a/flang/test/Lower/pointer-reference.f90 b/flang/test/Lower/pointer-reference.f90
new file mode 100644
index 0000000000000..54e0b00358bc6
--- /dev/null
+++ b/flang/test/Lower/pointer-reference.f90
@@ -0,0 +1,180 @@
+! Test lowering of references to pointers
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Assigning/reading to scalar pointer target.
+! CHECK-LABEL: func @_QPscal_ptr(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}})
+subroutine scal_ptr(p)
+ real, pointer :: p
+ real :: x
+ ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]]
+ ! CHECK: %[[addr:.*]] = fir.box_addr %[[boxload]]
+ ! CHECK: fir.store %{{.*}} to %[[addr]]
+ p = 3.
+
+ ! CHECK: %[[boxload2:.*]] = fir.load %[[arg0]]
+ ! CHECK: %[[addr2:.*]] = fir.box_addr %[[boxload2]]
+ ! CHECK: %[[val:.*]] = fir.load %[[addr2]]
+ ! CHECK: fir.store %[[val]] to %{{.*}}
+ x = p
+ end subroutine
+
+ ! Assigning/reading scalar character pointer target.
+ ! CHECK-LABEL: func @_QPchar_ptr(
+ ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,12>>>>{{.*}})
+ subroutine char_ptr(p)
+ character(12), pointer :: p
+ character(12) :: x
+
+ ! CHECK-DAG: %[[str:.*]] = fir.address_of(@_QQcl.68656C6C6F20776F726C6421) : !fir.ref<!fir.char<1,12>>
+ ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]]
+ ! CHECK: %[[addr:.*]] = fir.box_addr %[[boxload]]
+ ! CHECK-DAG: %[[one:.*]] = arith.constant 1
+ ! CHECK-DAG: %[[size:.*]] = fir.convert %{{.*}} : (index) -> i64
+ ! CHECK: %[[count:.*]] = arith.muli %[[one]], %[[size]] : i64
+ ! CHECK: %[[dst:.*]] = fir.convert %[[addr]] : (!fir.ptr<!fir.char<1,12>>) -> !fir.ref<i8>
+ ! CHECK: %[[src:.*]] = fir.convert %[[str]] : (!fir.ref<!fir.char<1,12>>) -> !fir.ref<i8>
+ ! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[dst]], %[[src]], %5, %false) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
+ p = "hello world!"
+
+ ! CHECK: %[[boxload2:.*]] = fir.load %[[arg0]]
+ ! CHECK: %[[addr2:.*]] = fir.box_addr %[[boxload2]]
+ ! CHECK: %[[count:.*]] = arith.muli %{{.*}}, %{{.*}} : i64
+ ! CHECK: %[[dst:.*]] = fir.convert %{{.*}} : (!fir.ref<!fir.char<1,12>>) -> !fir.ref<i8>
+ ! CHECK: %[[src:.*]] = fir.convert %[[addr2]] : (!fir.ptr<!fir.char<1,12>>) -> !fir.ref<i8>
+ ! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[dst]], %[[src]], %[[count]], %{{.*}}) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
+ x = p
+ end subroutine
+
+ ! Reading from pointer in array expression
+ ! CHECK-LABEL: func @_QParr_ptr_read(
+ ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}})
+ subroutine arr_ptr_read(p)
+ real, pointer :: p(:)
+ real :: x(100)
+ ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]]
+ ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[boxload]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+ ! CHECK: %[[lb:.*]] = fir.shift %[[dims]]#0 : (index) -> !fir.shift<1>
+ ! CHECK: fir.array_load %[[boxload]](%[[lb]]) : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>) -> !fir.array<?xf32>
+ x = p
+ end subroutine
+
+ ! Reading from contiguous pointer in array expression
+ ! CHECK-LABEL: func @_QParr_contig_ptr_read(
+ ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {{{.*}}, fir.contiguous})
+ subroutine arr_contig_ptr_read(p)
+ real, pointer, contiguous :: p(:)
+ real :: x(100)
+ ! CHECK: %[[boxload:.*]] = fir.load %[[arg0]]
+ ! CHECK-DAG: %[[dims:.*]]:3 = fir.box_dims %[[boxload]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+ ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[boxload]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.ptr<!fir.array<?xf32>>
+ ! CHECK-DAG: %[[shape:.*]] = fir.shape_shift %[[dims]]#0, %[[dims]]#1 : (index, index) -> !fir.shapeshift<1>
+ ! CHECK: fir.array_load %[[addr]](%[[shape]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shapeshift<1>) -> !fir.array<?xf32>
+ x = p
+ end subroutine
+
+ ! Assigning to pointer target in array expression
+
+ ! CHECK-LABEL: func @_QParr_ptr_target_write(
+ ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}}) {
+ ! CHECK: %[[VAL_1:.*]] = arith.constant 100 : index
+ ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.array<100xf32> {bindc_name = "x", uniq_name = "_QFarr_ptr_target_writeEx"}
+ ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+ ! CHECK: %[[VAL_6:.*]] = arith.constant 2 : i64
+ ! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> index
+ ! CHECK: %[[VAL_8:.*]] = arith.constant 6 : i64
+ ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i64) -> index
+ ! CHECK: %[[VAL_10:.*]] = arith.constant 601 : i64
+ ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i64) -> index
+ ! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_13:.*]] = arith.subi %[[VAL_11]], %[[VAL_7]] : index
+ ! CHECK: %[[VAL_14:.*]] = arith.addi %[[VAL_13]], %[[VAL_9]] : index
+ ! CHECK: %[[VAL_15:.*]] = arith.divsi %[[VAL_14]], %[[VAL_9]] : index
+ ! CHECK: %[[VAL_16:.*]] = arith.cmpi sgt, %[[VAL_15]], %[[VAL_12]] : index
+ ! CHECK: %[[VAL_17:.*]] = arith.select %[[VAL_16]], %[[VAL_15]], %[[VAL_12]] : index
+ ! CHECK: %[[VAL_18:.*]] = fir.shift %[[VAL_5]]#0 : (index) -> !fir.shift<1>
+ ! CHECK: %[[VAL_19:.*]] = fir.slice %[[VAL_7]], %[[VAL_11]], %[[VAL_9]] : (index, index, index) -> !fir.slice<1>
+ ! CHECK: %[[VAL_20:.*]] = fir.array_load %[[VAL_3]](%[[VAL_18]]) {{\[}}%[[VAL_19]]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>, !fir.slice<1>) -> !fir.array<?xf32>
+ ! CHECK: %[[VAL_21:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1>
+ ! CHECK: %[[VAL_22:.*]] = fir.array_load %[[VAL_2]](%[[VAL_21]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.array<100xf32>
+ ! CHECK: %[[VAL_23:.*]] = arith.constant 1 : index
+ ! CHECK: %[[VAL_24:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_25:.*]] = arith.subi %[[VAL_17]], %[[VAL_23]] : index
+ ! CHECK: %[[VAL_26:.*]] = fir.do_loop %[[VAL_27:.*]] = %[[VAL_24]] to %[[VAL_25]] step %[[VAL_23]] unordered iter_args(%[[VAL_28:.*]] = %[[VAL_20]]) -> (!fir.array<?xf32>) {
+ ! CHECK: %[[VAL_29:.*]] = fir.array_fetch %[[VAL_22]], %[[VAL_27]] : (!fir.array<100xf32>, index) -> f32
+ ! CHECK: %[[VAL_30:.*]] = fir.array_update %[[VAL_28]], %[[VAL_29]], %[[VAL_27]] : (!fir.array<?xf32>, f32, index) -> !fir.array<?xf32>
+ ! CHECK: fir.result %[[VAL_30]] : !fir.array<?xf32>
+ ! CHECK: }
+ ! CHECK: fir.array_merge_store %[[VAL_20]], %[[VAL_31:.*]] to %[[VAL_3]]{{\[}}%[[VAL_19]]] : !fir.array<?xf32>, !fir.array<?xf32>, !fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.slice<1>
+ ! CHECK: return
+ ! CHECK: }
+
+ subroutine arr_ptr_target_write(p)
+ real, pointer :: p(:)
+ real :: x(100)
+ p(2:601:6) = x
+ end subroutine
+
+ ! Assigning to contiguous pointer target in array expression
+
+ ! CHECK-LABEL: func @_QParr_contig_ptr_target_write(
+ ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {{{.*}}, fir.contiguous}) {
+ ! CHECK: %[[VAL_1:.*]] = arith.constant 100 : index
+ ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.array<100xf32> {bindc_name = "x", uniq_name = "_QFarr_contig_ptr_target_writeEx"}
+ ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+ ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+ ! CHECK: %[[VAL_6:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.ptr<!fir.array<?xf32>>
+ ! CHECK: %[[VAL_7:.*]] = arith.constant 2 : i64
+ ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
+ ! CHECK: %[[VAL_9:.*]] = arith.constant 6 : i64
+ ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i64) -> index
+ ! CHECK: %[[VAL_11:.*]] = arith.constant 601 : i64
+ ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index
+ ! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_14:.*]] = arith.subi %[[VAL_12]], %[[VAL_8]] : index
+ ! CHECK: %[[VAL_15:.*]] = arith.addi %[[VAL_14]], %[[VAL_10]] : index
+ ! CHECK: %[[VAL_16:.*]] = arith.divsi %[[VAL_15]], %[[VAL_10]] : index
+ ! CHECK: %[[VAL_17:.*]] = arith.cmpi sgt, %[[VAL_16]], %[[VAL_13]] : index
+ ! CHECK: %[[VAL_18:.*]] = arith.select %[[VAL_17]], %[[VAL_16]], %[[VAL_13]] : index
+ ! CHECK: %[[VAL_19:.*]] = fir.shape_shift %[[VAL_5]]#0, %[[VAL_5]]#1 : (index, index) -> !fir.shapeshift<1>
+ ! CHECK: %[[VAL_20:.*]] = fir.slice %[[VAL_8]], %[[VAL_12]], %[[VAL_10]] : (index, index, index) -> !fir.slice<1>
+ ! CHECK: %[[VAL_21:.*]] = fir.array_load %[[VAL_6]](%[[VAL_19]]) {{\[}}%[[VAL_20]]] : (!fir.ptr<!fir.array<?xf32>>, !fir.shapeshift<1>, !fir.slice<1>) -> !fir.array<?xf32>
+ ! CHECK: %[[VAL_22:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1>
+ ! CHECK: %[[VAL_23:.*]] = fir.array_load %[[VAL_2]](%[[VAL_22]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.array<100xf32>
+ ! CHECK: %[[VAL_24:.*]] = arith.constant 1 : index
+ ! CHECK: %[[VAL_25:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_26:.*]] = arith.subi %[[VAL_18]], %[[VAL_24]] : index
+ ! CHECK: %[[VAL_27:.*]] = fir.do_loop %[[VAL_28:.*]] = %[[VAL_25]] to %[[VAL_26]] step %[[VAL_24]] unordered iter_args(%[[VAL_29:.*]] = %[[VAL_21]]) -> (!fir.array<?xf32>) {
+ ! CHECK: %[[VAL_30:.*]] = fir.array_fetch %[[VAL_23]], %[[VAL_28]] : (!fir.array<100xf32>, index) -> f32
+ ! CHECK: %[[VAL_31:.*]] = fir.array_update %[[VAL_29]], %[[VAL_30]], %[[VAL_28]] : (!fir.array<?xf32>, f32, index) -> !fir.array<?xf32>
+ ! CHECK: fir.result %[[VAL_31]] : !fir.array<?xf32>
+ ! CHECK: }
+ ! CHECK: fir.array_merge_store %[[VAL_21]], %[[VAL_32:.*]] to %[[VAL_6]]{{\[}}%[[VAL_20]]] : !fir.array<?xf32>, !fir.array<?xf32>, !fir.ptr<!fir.array<?xf32>>, !fir.slice<1>
+ ! CHECK: return
+ ! CHECK: }
+
+ subroutine arr_contig_ptr_target_write(p)
+ real, pointer, contiguous :: p(:)
+ real :: x(100)
+ p(2:601:6) = x
+ end subroutine
+
+ ! CHECK-LABEL: func @_QPpointer_result_as_value
+ subroutine pointer_result_as_value()
+ ! Test that function pointer results used as values are correctly loaded.
+ interface
+ function returns_int_pointer()
+ integer, pointer :: returns_int_pointer
+ end function
+ end interface
+ ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.ptr<i32>> {bindc_name = ".result"}
+ ! CHECK: %[[VAL_6:.*]] = fir.call @_QPreturns_int_pointer() : () -> !fir.box<!fir.ptr<i32>>
+ ! CHECK: fir.save_result %[[VAL_6]] to %[[VAL_0]] : !fir.box<!fir.ptr<i32>>, !fir.ref<!fir.box<!fir.ptr<i32>>>
+ ! CHECK: %[[VAL_7:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
+ ! CHECK: %[[VAL_8:.*]] = fir.box_addr %[[VAL_7]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
+ ! CHECK: fir.load %[[VAL_8]] : !fir.ptr<i32>
+ print *, returns_int_pointer()
+ end subroutine
diff --git a/flang/test/Lower/pointer-results-as-arguments.f90 b/flang/test/Lower/pointer-results-as-arguments.f90
new file mode 100644
index 0000000000000..f7ee5ca521ac8
--- /dev/null
+++ b/flang/test/Lower/pointer-results-as-arguments.f90
@@ -0,0 +1,85 @@
+! Test passing pointers results to pointer dummy arguments
+! RUN: bbc %s -o - | FileCheck %s
+
+module presults
+ interface
+ subroutine bar_scalar(x)
+ real, pointer :: x
+ end subroutine
+ subroutine bar(x)
+ real, pointer :: x(:, :)
+ end subroutine
+ function get_scalar_pointer()
+ real, pointer :: get_scalar_pointer
+ end function
+ function get_pointer()
+ real, pointer :: get_pointer(:, :)
+ end function
+ end interface
+ real, pointer :: x
+ real, pointer :: xa(:, :)
+ contains
+
+ ! CHECK-LABEL: test_scalar_null
+ subroutine test_scalar_null()
+ ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.ptr<f32>>
+ ! CHECK: %[[VAL_1:.*]] = fir.zero_bits !fir.ptr<f32>
+ ! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]] : (!fir.ptr<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.call @_QPbar_scalar(%[[VAL_0]]) : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> ()
+ call bar_scalar(null())
+ end subroutine
+
+ ! CHECK-LABEL: test_scalar_null_mold
+ subroutine test_scalar_null_mold()
+ ! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box<!fir.ptr<f32>>
+ ! CHECK: %[[VAL_4:.*]] = fir.zero_bits !fir.ptr<f32>
+ ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_4]] : (!fir.ptr<f32>) -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.store %[[VAL_5]] to %[[VAL_3]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.call @_QPbar_scalar(%[[VAL_3]]) : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> ()
+ call bar_scalar(null(x))
+ end subroutine
+
+ ! CHECK-LABEL: test_scalar_result
+ subroutine test_scalar_result()
+ ! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.box<!fir.ptr<f32>> {bindc_name = ".result"}
+ ! CHECK: %[[VAL_7:.*]] = fir.call @_QPget_scalar_pointer() : () -> !fir.box<!fir.ptr<f32>>
+ ! CHECK: fir.save_result %[[VAL_7]] to %[[VAL_6]] : !fir.box<!fir.ptr<f32>>, !fir.ref<!fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.call @_QPbar_scalar(%[[VAL_6]]) : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> ()
+ call bar_scalar(get_scalar_pointer())
+ end subroutine
+
+ ! CHECK-LABEL: test_null
+ subroutine test_null()
+ ! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_9:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: %[[VAL_10:.*]] = fir.zero_bits !fir.ptr<!fir.array<?x?xf32>>
+ ! CHECK: %[[VAL_11:.*]] = fir.shape %[[VAL_8]], %[[VAL_8]] : (index, index) -> !fir.shape<2>
+ ! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_10]](%[[VAL_11]]) : (!fir.ptr<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: fir.store %[[VAL_12]] to %[[VAL_9]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+ ! CHECK: fir.call @_QPbar(%[[VAL_9]]) : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> ()
+ call bar(null())
+ end subroutine
+
+ ! CHECK-LABEL: test_null_mold
+ subroutine test_null_mold()
+ ! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index
+ ! CHECK: %[[VAL_14:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: %[[VAL_15:.*]] = fir.zero_bits !fir.ptr<!fir.array<?x?xf32>>
+ ! CHECK: %[[VAL_16:.*]] = fir.shape %[[VAL_13]], %[[VAL_13]] : (index, index) -> !fir.shape<2>
+ ! CHECK: %[[VAL_17:.*]] = fir.embox %[[VAL_15]](%[[VAL_16]]) : (!fir.ptr<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: fir.store %[[VAL_17]] to %[[VAL_14]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+ ! CHECK: fir.call @_QPbar(%[[VAL_14]]) : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> ()
+ call bar(null(xa))
+ end subroutine
+
+ ! CHECK-LABEL: test_result
+ subroutine test_result()
+ ! CHECK: %[[VAL_18:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>> {bindc_name = ".result"}
+ ! CHECK: %[[VAL_19:.*]] = fir.call @_QPget_pointer() : () -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+ ! CHECK: fir.save_result %[[VAL_19]] to %[[VAL_18]] : !fir.box<!fir.ptr<!fir.array<?x?xf32>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+ ! CHECK: fir.call @_QPbar(%[[VAL_18]]) : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> ()
+ call bar(get_pointer())
+ end subroutine
+
+ end module
diff --git a/flang/test/Lower/pointer-runtime.f90 b/flang/test/Lower/pointer-runtime.f90
new file mode 100644
index 0000000000000..8ca05471799cb
--- /dev/null
+++ b/flang/test/Lower/pointer-runtime.f90
@@ -0,0 +1,50 @@
+! RUN: bbc -emit-fir -use-alloc-runtime %s -o - | FileCheck %s
+
+! Test lowering of allocatables using runtime for allocate/deallocate statements.
+! CHECK-LABEL: _QPpointer_runtime(
+subroutine pointer_runtime(n)
+ integer :: n
+ character(:), pointer :: scalar, array(:)
+ ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFpointer_runtimeEscalar"}
+ ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.ptr<!fir.char<1,?>>
+ ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %c0{{.*}} : (!fir.ptr<!fir.char<1,?>>, index) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+ ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+
+ ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFpointer_runtimeEarray"}
+ ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.ptr<!fir.array<?x!fir.char<1,?>>>
+ ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %c0{{.*}} : (!fir.ptr<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>
+ ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>
+
+ allocate(character(10):: scalar, array(30))
+ ! CHECK-DAG: %[[sBoxCast1:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK-DAG: %[[ten1:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
+ ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[sBoxCast1]], %[[ten1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
+ ! CHECK-NOT: PointerSetBounds
+ ! CHECK: %[[sBoxCast2:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK: fir.call @{{.*}}PointerAllocate(%[[sBoxCast2]]
+
+ ! CHECK-DAG: %[[aBoxCast1:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK-DAG: %[[ten2:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
+ ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[aBoxCast1]], %[[ten2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
+ ! CHECK: %[[aBoxCast2:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK: fir.call @{{.*}}PointerSetBounds(%[[aBoxCast2]]
+ ! CHECK: %[[aBoxCast3:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK: fir.call @{{.*}}PointerAllocate(%[[aBoxCast3]]
+
+ deallocate(scalar, array)
+ ! CHECK: %[[sBoxCast3:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK: fir.call @{{.*}}PointerDeallocate(%[[sBoxCast3]]
+ ! CHECK: %[[aBoxCast4:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK: fir.call @{{.*}}PointerDeallocate(%[[aBoxCast4]]
+
+ ! only testing that the correct length is set in the descriptor.
+ allocate(character(n):: scalar, array(40))
+ ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref<i32>
+ ! CHECK-DAG: %[[ncast1:.*]] = fir.convert %[[n]] : (i32) -> i64
+ ! CHECK-DAG: %[[sBoxCast4:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[sBoxCast4]], %[[ncast1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
+ ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[n]] : (i32) -> i64
+ ! CHECK-DAG: %[[aBoxCast5:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
+ ! CHECK: fir.call @{{.*}}PointerNullifyCharacter(%[[aBoxCast5]], %[[ncast2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
+ end subroutine
diff --git a/flang/test/Lower/pointer.f90 b/flang/test/Lower/pointer.f90
new file mode 100644
index 0000000000000..34c7fd2b23519
--- /dev/null
+++ b/flang/test/Lower/pointer.f90
@@ -0,0 +1,45 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! TODO: Descriptor (fir.box) will most likely be used for pointers
+! (at least for the character case below). This code is hitting a
+! hard todo until pointers are handled correctly.
+! XFAIL: true
+
+! CHECK-LABEL: func @_QPpointertests
+subroutine pointerTests
+ ! CHECK: fir.global internal @_QFpointertestsEptr1 : !fir.ptr<i32>
+ integer, pointer :: ptr1 => NULL()
+ ! CHECK: %[[c0:.*]] = arith.constant 0 : index
+ ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
+ ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<i32>
+ ! CHECK: fir.has_value [[reg2]] : !fir.ptr<i32>
+
+ ! CHECK: fir.global internal @_QFpointertestsEptr2 : !fir.ptr<f32>
+ real, pointer :: ptr2 => NULL()
+ ! CHECK: %[[c0:.*]] = arith.constant 0 : index
+ ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
+ ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<f32>
+ ! CHECK: fir.has_value [[reg2]] : !fir.ptr<f32>
+
+ ! CHECK: fir.global internal @_QFpointertestsEptr3 : !fir.ptr<!fir.complex<4>>
+ complex, pointer :: ptr3 => NULL()
+ ! CHECK: %[[c0:.*]] = arith.constant 0 : index
+ ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
+ ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<!fir.complex<4>>
+ ! CHECK: fir.has_value [[reg2]] : !fir.ptr<!fir.complex<4>>
+
+ ! CHECK: fir.global internal @_QFpointertestsEptr4 : !fir.ptr<!fir.char<1,?>>
+ character(:), pointer :: ptr4 => NULL()
+ ! CHECK: %[[c0:.*]] = arith.constant 0 : index
+ ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
+ ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<!fir.char<1,?>>
+ ! CHECK: fir.has_value [[reg2]] : !fir.ptr<!fir.char<1,?>>
+
+ ! CHECK: fir.global internal @_QFpointertestsEptr5 : !fir.ptr<!fir.logical<4>>
+ logical, pointer :: ptr5 => NULL()
+ ! CHECK: %[[c0:.*]] = arith.constant 0 : index
+ ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
+ ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<!fir.logical<4>>
+ ! CHECK: fir.has_value [[reg2]] : !fir.ptr<!fir.logical<4>>
+
+ end subroutine pointerTests
More information about the flang-commits
mailing list