From 5a18e79d5a632874e01458c5b38c0c1e21cc1f27 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Mon, 11 Mar 2019 15:39:11 -0700 Subject: [PATCH] [flang] Remove OwningPointer and ForwardReference Use std::unique_ptr<> with custom deleter for forward-referenced owned pointer. Move CopyableIndirection into common, add documentation, clean up. Remove OwningPointer and ForwardReference Use std::unique_ptr<> with custom deleter for forward-referenced owned pointer. Use CopyableIndirection clean up from merge after split Complete characterization fold conversions of arrays Clean up subscripts to constant arrays Elemental unary operations complete Support assumed type TYPE(*) in actual arguments clean up some TODOs recognize TYPE(*) arguments to intrinsics Complete folding of array operations Finish elementwise array folding, add test, debug characterize intrinsics, fix some bugs Clean up build Type compatibility and shape conformance checks on pointer assignments Original-commit: flang-compiler/f18@99d734c6213c7188ad7b031258d0163826d562ec Reviewed-on: https://github.com/flang-compiler/f18/pull/442 Tree-same-pre-rewrite: false --- flang/lib/evaluate/characteristics.h | 4 +- flang/lib/evaluate/decimal.h | 4 +- flang/lib/evaluate/type.h | 5 +- flang/lib/semantics/assignment.cc | 224 +++++++++++++- flang/lib/semantics/assignment.h | 6 +- flang/lib/semantics/expression.cc | 483 ++++++++++++++++++------------- flang/lib/semantics/expression.h | 17 +- flang/lib/semantics/resolve-names.cc | 26 +- flang/lib/semantics/symbol.cc | 32 +- flang/lib/semantics/symbol.h | 17 +- flang/test/evaluate/folding01.f90 | 4 +- flang/test/evaluate/folding02.f90 | 4 + flang/test/evaluate/test_folding.sh | 6 +- flang/test/semantics/CMakeLists.txt | 2 + flang/test/semantics/expr-errors01.f90 | 40 +++ flang/test/semantics/null01.f90 | 90 ++++++ flang/test/semantics/procinterface01.f90 | 8 +- flang/test/semantics/resolve43.f90 | 2 +- flang/test/semantics/structconst01.f90 | 8 +- flang/test/semantics/structconst02.f90 | 6 +- flang/test/semantics/structconst03.f90 | 32 +- flang/test/semantics/structconst04.f90 | 32 +- 22 files changed, 751 insertions(+), 301 deletions(-) create mode 100644 flang/test/semantics/expr-errors01.f90 create mode 100644 flang/test/semantics/null01.f90 diff --git a/flang/lib/evaluate/characteristics.h b/flang/lib/evaluate/characteristics.h index 3bbdae0..47ab784 100644 --- a/flang/lib/evaluate/characteristics.h +++ b/flang/lib/evaluate/characteristics.h @@ -194,9 +194,7 @@ struct Procedure { DummyArguments dummyArguments; Attrs attrs; -// TODO pmk: restore private accessibility after merging -// changes to lib/semantics -// private: +private: Procedure() {} }; } diff --git a/flang/lib/evaluate/decimal.h b/flang/lib/evaluate/decimal.h index 1992083..340a8b2 100644 --- a/flang/lib/evaluate/decimal.h +++ b/flang/lib/evaluate/decimal.h @@ -1,4 +1,4 @@ -// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved. +// Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved. // // Licensed under the Apache License, Version 2.0 (the "License"); // you may not use this file except in compliance with the License. @@ -25,7 +25,7 @@ // This is a helper class for use in floating-point conversions // to and from decimal representations. It holds a multiple-precision -// integer value using digits in radix that is a large power of ten. +// integer value using digits of a radix that is a large power of ten. // (A radix of 10**18 (one quintillion) is the largest that could be used // because this radix is the largest power of ten such that 10 times that // value will fit in an unsigned 64-bit binary integer; a radix of 10**8, diff --git a/flang/lib/evaluate/type.h b/flang/lib/evaluate/type.h index de4088f..b62a9f2 100644 --- a/flang/lib/evaluate/type.h +++ b/flang/lib/evaluate/type.h @@ -159,12 +159,11 @@ public: const semantics::DerivedTypeSpec *derived{nullptr}; // TYPE(T), CLASS(T) bool isPolymorphic{false}; // CLASS(T), CLASS(*) -// TODO pmk: restore private accessibility once changes are -// merged into lib/semantics -// private: +private: constexpr DynamicType() {} }; + template struct TypeBase { static constexpr TypeCategory category{CATEGORY}; static constexpr int kind{KIND}; diff --git a/flang/lib/semantics/assignment.cc b/flang/lib/semantics/assignment.cc index 60782d6..50ba312 100644 --- a/flang/lib/semantics/assignment.cc +++ b/flang/lib/semantics/assignment.cc @@ -17,6 +17,7 @@ #include "symbol.h" #include "tools.h" #include "../common/idioms.h" +#include "../evaluate/characteristics.h" #include "../evaluate/expression.h" #include "../evaluate/fold.h" #include "../evaluate/tools.h" @@ -25,9 +26,218 @@ #include "../parser/parse-tree.h" #include #include +#include using namespace Fortran::parser::literals; +namespace Fortran::evaluate { + +template +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &, const Symbol &symbol, const A &) { + // Default catch-all when RHS of pointer assignment isn't recognized + messages.Say("Pointer target assigned to '%s' must be a designator or " + "a call to a pointer-valued function"_err_en_US, + symbol.name().ToString().c_str()); +} + +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, + const NullPointer &f) { + // LHS = NULL() without MOLD=; this is always fine +} + +template +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, + const FunctionRef &f) { + const Symbol *ultimate{nullptr}; + std::string funcName; + if (const auto *symbol{f.proc().GetSymbol()}) { + funcName = symbol->name().ToString(); + ultimate = &symbol->GetUltimate(); + } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) { + funcName = intrinsic->name; + } + if (auto proc{Characterize(f.proc(), intrinsics)}) { + std::optional error; + if (const auto &funcResult{proc->functionResult}) { + const auto *frProc{funcResult->IsProcedurePointer()}; + if (IsProcedurePointer(lhs)) { + // Shouldn't be here in this function unless lhs + // is an object pointer. + error = "Procedure pointer '%s' assigned with result of " + "reference to function '%s' that does not return a " + "procedure pointer"_err_en_US; + } else if (frProc != nullptr) { + error = "Object pointer '%s' assigned with result of " + "reference to function '%s' that is a procedure " + "pointer"_err_en_US; + } else if (!funcResult->attrs.test( + characteristics::FunctionResult::Attr::Pointer)) { + error = "Pointer '%s' assigned with result of " + "reference to function '%s' that is a not a " + "pointer"_err_en_US; + } else if (lhs.attrs().test(semantics::Attr::CONTIGUOUS) && + !funcResult->attrs.test( + characteristics::FunctionResult::Attr::Contiguous)) { + error = "Contiguous pointer '%s' assigned with result of " + "reference to function '%s' that is not " + "contiguous"_err_en_US; + } else if (auto lhsTypeAndShape{ + characteristics::TypeAndShape::Characterize(lhs)}) { + const auto *frTypeAndShape{funcResult->GetTypeAndShape()}; + CHECK(frTypeAndShape != nullptr); + if (!lhsTypeAndShape->IsCompatibleWith(messages, *frTypeAndShape)) { + error = "Pointer '%s' assigned with result of reference to " + "function '%s' whose pointer result has an " + "incompatible type or shape"_err_en_US; + } + } + } else { + error = "Pointer assigned with non-existent " + "result of reference to procedure"_err_en_US; + } + if (error.has_value()) { + if (auto *msg{messages.Say( + *error, lhs.name().ToString().c_str(), funcName.c_str())}) { + msg->Attach(lhs.name(), "Declaration of pointer"_en_US); + if (ultimate != nullptr) { + msg->Attach(ultimate->name(), "Declaration of function"_en_US); + } + } + } + } +} + +template +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, + const Designator &d) { + if (const auto *symbol{d.GetBaseObject().symbol()}) { + const Symbol &ultimate{symbol->GetUltimate()}; + std::optional error; + if (IsProcedurePointer(lhs)) { + // Shouldn't be here in this function unless lhs is an + // object pointer. + error = "In assignment to procedure pointer '%s', the " + "target is not a procedure or procedure pointer"_err_en_US; + } else if (!ultimate.template has() || + !ultimate.attrs().HasAny(semantics::Attrs( + {semantics::Attr::POINTER, semantics::Attr::TARGET}))) { + error = "In assignment to object pointer '%s', the target '%s' " + "is not an object with POINTER or TARGET attributes"_err_en_US; + } else if (auto rhsTypeAndShape{characteristics::TypeAndShape::Characterize( + d.GetLastSymbol())}) { + if (auto lhsTypeAndShape{ + characteristics::TypeAndShape::Characterize(lhs)}) { + if (!lhsTypeAndShape->IsCompatibleWith(messages, *rhsTypeAndShape)) { + error = "Pointer '%s' assigned to object '%s' with " + "incompatible type or shape"_err_en_US; + } + } + } + if (error.has_value()) { + if (auto *msg{messages.Say(*error, lhs.name().ToString().c_str(), + ultimate.name().ToString().c_str())}) { + msg->Attach(lhs.name(), "Declaration of pointer being assigned"_en_US) + .Attach(ultimate.name(), "Declaration of pointer target"_en_US); + } + } + } else { + // P => "character literal"(1:3) + messages.Say("Pointer target is not a named entity"_err_en_US); + } +} + +// Common handling for procedure pointer right-hand sides +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, + parser::CharBlock rhsName, bool isCall, + std::optional &&targetChars) { + std::optional error; + if (IsProcedurePointer(lhs)) { + if (auto ptrProc{ + characteristics::Procedure::Characterize(lhs, intrinsics)}) { + if (targetChars.has_value()) { + if (!(*ptrProc == *targetChars)) { + if (isCall) { + error = "Procedure pointer '%s' assigned with result of " + "reference to function '%s' that is an incompatible " + "procedure pointer"_err_en_US; + } else { + error = "Procedure pointer '%s' assigned to incompatible " + "procedure designator '%s'"_err_en_US; + } + } + } else { + error = "In assignment to procedure pointer '%s', the " + "characteristics of the target procedure '%s' could " + "not be determined"_err_en_US; + } + } else { + error = "In assignment to procedure pointer '%s', its " + "characteristics could not be determined"_err_en_US; + } + } else { + error = "In assignment to object pointer '%s', the target '%s' " + "is a procedure designator"_err_en_US; + } + if (error.has_value()) { + if (auto *msg{messages.Say(*error, lhs.name().ToString().c_str(), + rhsName.ToString().c_str())}) { + msg->Attach(lhs.name(), "Declaration of pointer being assigned"_en_US); + } + } +} + +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, + const ProcedureDesignator &d) { + CheckPointerAssignment(messages, intrinsics, lhs, d.GetName(), false, + Characterize(d, intrinsics)); +} + +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, + const ProcedureRef &ref) { + auto chars{Characterize(ref, intrinsics)}; + if (chars.has_value()) { + if (chars->functionResult.has_value()) { + if (const auto *proc{chars->functionResult->IsProcedurePointer()}) { + characteristics::Procedure rChars{std::move(*proc)}; + chars = std::move(rChars); + } + } + } + CheckPointerAssignment( + messages, intrinsics, lhs, ref.proc().GetName(), true, std::move(chars)); +} + +template +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, const Expr &x) { + std::visit( + [&](const auto &x) { + CheckPointerAssignment(messages, intrinsics, lhs, x); + }, + x.u); +} + +void CheckPointerAssignment(parser::ContextualMessages &messages, + const IntrinsicProcTable &intrinsics, const Symbol &lhs, + const evaluate::Expr &rhs) { + // TODO: Acquire values of deferred type parameters &/or array bounds + // from the RHS. + const Symbol &ultimate{lhs.GetUltimate()}; + std::visit( + [&](const auto &x) { + CheckPointerAssignment(messages, intrinsics, ultimate, x); + }, + rhs.u); +} +} + namespace Fortran::semantics { using ControlExpr = evaluate::Expr; @@ -47,7 +257,6 @@ struct Control { struct ForallContext { explicit ForallContext(const ForallContext *that) : outer{that} {} - // TODO pmk: Is this needed? Does semantics already track these kinds? std::optional GetActiveIntKind(const parser::CharBlock &name) const { const auto iter{activeNames.find(name)}; if (iter != activeNames.cend()) { @@ -71,7 +280,7 @@ struct WhereContext { explicit WhereContext(MaskExpr &&x) : thisMaskExpr{std::move(x)} {} const WhereContext *outer{nullptr}; - const ForallContext *forall{nullptr}; // innermost FORALL + const ForallContext *forall{nullptr}; // innermost enclosing FORALL std::optional constructName; MaskExpr thisMaskExpr; // independent of outer WHERE, if any MaskExpr cumulativeMaskExpr{thisMaskExpr}; @@ -88,7 +297,6 @@ public: : context_{c.context_}, messages_{c.messages_}, forall_{&f} {} bool operator==(const AssignmentContext &x) const { return this == &x; } - bool operator!=(const AssignmentContext &x) const { return this != &x; } void Analyze(const parser::AssignmentStmt &); void Analyze(const parser::PointerAssignmentStmt &); @@ -133,9 +341,6 @@ private: } // namespace Fortran::semantics -template class Fortran::common::Indirection< - Fortran::semantics::AssignmentContext>; - namespace Fortran::semantics { void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) { @@ -153,6 +358,7 @@ void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) { // TODO: Warn if some name in forall_->activeNames or its outer // contexts does not appear on LHS } + // TODO continue here, using CheckPointerAssignment() } void AssignmentContext::Analyze(const parser::WhereStmt &stmt) { @@ -363,7 +569,7 @@ public: private: SemanticsContext &context_; }; - } - -} // namespace Fortran::semantics +} +template class Fortran::common::Indirection< + Fortran::semantics::AssignmentContext>; diff --git a/flang/lib/semantics/assignment.h b/flang/lib/semantics/assignment.h index 51981c6..cdec8e3 100644 --- a/flang/lib/semantics/assignment.h +++ b/flang/lib/semantics/assignment.h @@ -33,8 +33,10 @@ struct ForallConstruct; } namespace Fortran::evaluate { -void CheckPointerAssignment(parser::ContextualMessages &, const Symbol &, - const evaluate::Expr &); +class IntrinsicProcTable; +void CheckPointerAssignment(parser::ContextualMessages &, + const IntrinsicProcTable &, const Symbol &lhs, + const evaluate::Expr &rhs); } namespace Fortran::semantics { diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc index 62b1e69..3a5749e 100644 --- a/flang/lib/semantics/expression.cc +++ b/flang/lib/semantics/expression.cc @@ -13,6 +13,7 @@ // limitations under the License. #include "expression.h" +#include "assignment.h" #include "scope.h" #include "semantics.h" #include "symbol.h" @@ -24,6 +25,7 @@ #include "../parser/characters.h" #include "../parser/parse-tree-visitor.h" #include "../parser/parse-tree.h" +#include #include #include #include @@ -46,18 +48,16 @@ namespace Fortran::evaluate { using common::TypeCategory; -// If a generic expression simply wraps a DataRef, extract it. -// TODO: put in tools.h? +// If an expression simply wraps a DataRef, extract and return it. template common::IfNoLvalue, A> ExtractDataRef(A &&) { return std::nullopt; } -template std::optional ExtractDataRef(Designator &&d) { +template std::optional ExtractDataRef(Designator &&d) { return std::visit( [](auto &&x) -> std::optional { - using Ty = std::decay_t; - if constexpr (common::HasMember) { + if constexpr (common::HasMember) { return {DataRef{std::move(x)}}; } return std::nullopt; @@ -65,35 +65,9 @@ template std::optional ExtractDataRef(Designator &&d) { std::move(d.u)); } -template -std::optional ExtractDataRef(Expr> &&expr) { - using Ty = ResultType; - if (auto *designator{std::get_if>(&expr.u)}) { - return ExtractDataRef(std::move(*designator)); - } else { - return std::nullopt; - } -} - -template -std::optional ExtractDataRef(Expr> &&expr) { - return std::visit( - [](auto &&specificExpr) { - return ExtractDataRef(std::move(specificExpr)); - }, - std::move(expr.u)); -} - -static std::optional ExtractDataRef(Expr &&expr) { +template std::optional ExtractDataRef(Expr &&expr) { return std::visit( - common::visitors{ - [](BOZLiteralConstant &&) -> std::optional { - return std::nullopt; - }, - [](NullPointer &&) -> std::optional { return std::nullopt; }, - [](auto &&catExpr) { return ExtractDataRef(std::move(catExpr)); }, - }, - std::move(expr.u)); + [](auto &&x) { return ExtractDataRef(std::move(x)); }, std::move(expr.u)); } template @@ -105,6 +79,7 @@ std::optional ExtractDataRef(std::optional &&x) { } struct DynamicTypeWithLength : public DynamicType { + explicit DynamicTypeWithLength(const DynamicType &t) : DynamicType{t} {} std::optional> LEN() const; std::optional> length; }; @@ -155,7 +130,6 @@ static std::optional AnalyzeTypeSpec( // Wraps a object in an explicitly typed representation (e.g., Designator<> // or FunctionRef<>) that has been instantiated on a dynamically chosen type. -// TODO: move to tools.h? template typename WRAPPER, typename WRAPPED> common::IfNoLvalue WrapperHelper(int kind, WRAPPED &&x) { @@ -188,14 +162,27 @@ common::IfNoLvalue TypedWrapper( } } -// Wraps a data reference in a typed Designator<>. -static MaybeExpr Designate(DataRef &&ref) { - if (std::optional dyType{ - DynamicType::From(ref.GetLastSymbol().GetUltimate())}) { +// Wraps a data reference in a typed Designator<>, and a procedure +// or procedure pointer reference in a ProcedureDesignator. +MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) { + const Symbol &symbol{ref.GetLastSymbol().GetUltimate()}; + if (semantics::IsProcedure(symbol)) { + if (auto *component{std::get_if(&ref.u)}) { + return Expr{ProcedureDesignator{std::move(*component)}}; + } else { + CHECK(std::holds_alternative(ref.u)); + return Expr{ProcedureDesignator{symbol}}; + } + } else if (auto dyType{DynamicType::From(symbol)}) { return TypedWrapper( std::move(*dyType), std::move(ref)); + } else if (const auto *declTypeSpec{symbol.GetType()}) { + if (declTypeSpec->category() == semantics::DeclTypeSpec::TypeStar) { + Say("TYPE(*) assumed-type dummy argument '%s' may not be " + "used except as an actual argument"_err_en_US, + symbol.name().ToString().c_str()); + } } - // TODO: graceful errors on CLASS(*) and TYPE(*) misusage return std::nullopt; } @@ -213,7 +200,7 @@ MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) { } if (subscripts != symbolRank) { Say("Reference to rank-%d object '%s' has %d subscripts"_err_en_US, - symbolRank, symbol.name().ToString().data(), subscripts); + symbolRank, symbol.name().ToString().c_str(), subscripts); } else if (subscripts == 0) { // nothing to check } else if (Component * component{std::get_if(&ref.base())}) { @@ -226,7 +213,7 @@ MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) { if (subscriptRank > 0) { Say("Subscripts of component '%s' of rank-%d derived type " "array have rank %d but must all be scalar"_err_en_US, - symbol.name().ToString().data(), baseRank, subscriptRank); + symbol.name().ToString().c_str(), baseRank, subscriptRank); } } } else if (const auto *details{ @@ -236,7 +223,7 @@ MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) { if (!last->upper().has_value() && details->IsAssumedSize()) { Say("Assumed-size array '%s' must have explicit final " "subscript upper bound value"_err_en_US, - symbol.name().ToString().data()); + symbol.name().ToString().c_str()); } } } @@ -275,7 +262,7 @@ MaybeExpr ExpressionAnalyzer::TopLevelChecks(DataRef &&dataRef) { if (baseRank > 0) { Say("Reference to whole rank-%d component '%%%s' of " "rank-%d array of derived type is not allowed"_err_en_US, - componentRank, symbol.name().ToString().data(), baseRank); + componentRank, symbol.name().ToString().c_str(), baseRank); } else { addSubscripts = true; } @@ -479,8 +466,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) { // letter used in an exponent part (e.g., the 'E' in "6.02214E+23") // should agree. In the absence of an explicit kind parameter, any exponent // letter determines the kind. Otherwise, defaults apply. - // TODO: warn on inexact conversions? - auto &defaults{context().defaultKinds()}; + auto &defaults{context_.defaultKinds()}; int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)}; const char *end{x.real.source.end()}; std::optional letterKind; @@ -662,6 +648,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) { // A bare reference to a derived type parameter (within a parameterized // derived type definition) return AsMaybeExpr(MakeTypeParamInquiry(&ultimate)); + } else if (MaybeExpr result{Designate(DataRef{ultimate})}) { + return result; } else { return Designate(DataRef{*n.symbol}); } @@ -914,8 +902,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) { "a designator"_err_en_US); } } else if (dtSpec == nullptr || dtSpec->scope() == nullptr) { - Say(name, - "TODO: base of component reference lacks a derived type"_err_en_US); + CHECK(context_.AnyFatalError()); + return std::nullopt; } else if (std::optional dataRef{ ExtractDataRef(std::move(*dtExpr))}) { if (auto component{ @@ -923,7 +911,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) { return Designate(DataRef{std::move(*component)}); } else { Say(name, "component is not in scope of derived TYPE(%s)"_err_en_US, - dtSpec->typeSymbol().name().ToString().data()); + dtSpec->typeSymbol().name().ToString().c_str()); } } else { Say(name, @@ -953,12 +941,10 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) { } else if (kind == MiscKind::KindParamInquiry || kind == MiscKind::LenParamInquiry) { // Convert x%KIND -> intrinsic KIND(x), x%LEN -> intrinsic LEN(x) - SpecificIntrinsic func{name.ToString(), characteristics::Procedure{}}; - return TypedWrapper(GetDefaultKindOfType(TypeCategory::Integer), - ProcedureRef{ProcedureDesignator{std::move(func)}, - ActualArguments{ActualArgument{std::move(*base)}}}); + return MakeFunctionRef( + name, ActualArguments{ActualArgument{std::move(*base)}}); } else { - common::die("unexpected kind"); + common::die("unexpected MiscDetails::Kind"); } } else { Say(name, "derived type required before component reference"_err_en_US); @@ -1015,11 +1001,11 @@ private: }; void ArrayConstructorContext::Push(MaybeExpr &&x) { - if (x.has_value()) { - DynamicTypeWithLength xType; - if (auto dyType{x->GetType()}) { - *static_cast(&xType) = *dyType; - } + if (!x.has_value()) { + return; + } + if (auto dyType{x->GetType()}) { + DynamicTypeWithLength xType{*dyType}; if (Expr * charExpr{UnwrapExpr>(*x)}) { CHECK(xType.category == TypeCategory::Character); xType.length = @@ -1033,7 +1019,6 @@ void ArrayConstructorContext::Push(MaybeExpr &&x) { // the values as the type of a numeric constructed array, convert all // of the other values to that type. Alternative: let the first value // determine the type, and convert the others to that type. - // TODO pmk: better type compatibility checks for derived types CHECK(!explicitType_); type_ = std::move(xType); constantLength_ = ToInt64(type_->length); @@ -1127,7 +1112,7 @@ void ArrayConstructorContext::Add(const parser::AcValue &x) { if (!inserted) { SayAt(name, "Implied DO index is active in surrounding implied DO loop " - "and cannot have the same name"_err_en_US); + "and may not have the same name"_err_en_US); } std::optional> lower{ GetSpecificIntExpr(bounds.lower)}; @@ -1227,7 +1212,6 @@ MaybeExpr ExpressionAnalyzer::Analyze( auto &parsedType{std::get(structure.t)}; parser::CharBlock typeName{std::get(parsedType.t).source}; if (parsedType.derivedTypeSpec == nullptr) { - Say("INTERNAL: parser::StructureConstructor lacks type"_err_en_US); return std::nullopt; } const auto &spec{*parsedType.derivedTypeSpec}; @@ -1236,9 +1220,9 @@ MaybeExpr ExpressionAnalyzer::Analyze( if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796 if (auto *msg{Say(typeName, - "ABSTRACT derived type '%s' cannot be used in a " + "ABSTRACT derived type '%s' may not be used in a " "structure constructor"_err_en_US, - typeName.ToString().data())}) { + typeName.ToString().c_str())}) { msg->Attach( typeSymbol.name(), "Declaration of ABSTRACT derived type"_en_US); } @@ -1259,18 +1243,32 @@ MaybeExpr ExpressionAnalyzer::Analyze( std::set unavailable; bool anyKeyword{false}; StructureConstructor result{spec}; - bool checkConflicts{true}; + bool checkConflicts{true}; // until we hit one for (const auto &component : std::get>(structure.t)) { const parser::Expr &expr{ std::get(component.t).v.value()}; parser::CharBlock source{expr.source}; + auto &messages{GetContextualMessages()}; + auto restorer{messages.SetLocation(source)}; const Symbol *symbol{nullptr}; if (const auto &kw{std::get>(component.t)}) { + anyKeyword = true; source = kw->v.source; symbol = kw->v.symbol; - anyKeyword = true; + if (symbol == nullptr) { + auto componentIter{std::find_if(components.begin(), components.end(), + [=](const Symbol *symbol) { return symbol->name() == source; })}; + if (componentIter != components.end()) { + symbol = *componentIter; + } + } + if (symbol == nullptr) { // C7101 + Say(source, + "Keyword '%s=' does not name a component of derived type '%s'"_err_en_US, + source.ToString().c_str(), typeName.ToString().c_str()); + } } else { if (anyKeyword) { // C7100 Say(source, @@ -1278,8 +1276,9 @@ MaybeExpr ExpressionAnalyzer::Analyze( checkConflicts = false; // stem cascade } while (nextAnonymous != components.end()) { - symbol = *nextAnonymous++; - if (!symbol->test(Symbol::Flag::ParentComp)) { + const Symbol *nextSymbol{*nextAnonymous++}; + if (!nextSymbol->test(Symbol::Flag::ParentComp)) { + symbol = nextSymbol; break; } } @@ -1288,13 +1287,6 @@ MaybeExpr ExpressionAnalyzer::Analyze( } } if (symbol != nullptr) { - if (symbol->has()) { - Say(source, - "Type parameter '%s' cannot be a component of this structure " - "constructor"_err_en_US, - symbol->name().ToString().data()); - continue; - } if (checkConflicts) { auto componentIter{ std::find(components.begin(), components.end(), symbol)}; @@ -1303,7 +1295,7 @@ MaybeExpr ExpressionAnalyzer::Analyze( Say(source, "Component '%s' conflicts with another component earlier in " "this structure constructor"_err_en_US, - symbol->name().ToString().data()); + symbol->name().ToString().c_str()); } else if (symbol->test(Symbol::Flag::ParentComp)) { // Make earlier components unavailable once a whole parent appears. for (auto it{components.begin()}; it != componentIter; ++it) { @@ -1321,54 +1313,55 @@ MaybeExpr ExpressionAnalyzer::Analyze( } unavailable.insert(symbol->name()); if (MaybeExpr value{Analyze(expr)}) { - bool isNULL{std::holds_alternative(value->u)}; if (symbol->has()) { - CHECK(symbol->attrs().test(semantics::Attr::POINTER)); - if (!isNULL) { - // TODO C7104: check that procedure pointer components are - // being initialized with compatible procedure designators - Say(expr.source, - "TODO: non-null procedure pointer component value not implemented yet"_err_en_US); - } - } else { - CHECK(symbol->has()); + CHECK(IsPointer(*symbol)); + } else if (symbol->has()) { // C1594(4) - if (!isNULL) { - const auto &innermost{context().FindScope(expr.source)}; - if (const auto *pureFunc{ - semantics::FindPureFunctionContaining(&innermost)}) { + const auto &innermost{context_.FindScope(expr.source)}; + if (const auto *pureFunc{ + semantics::FindPureFunctionContaining(&innermost)}) { + if (const Symbol * + pointer{semantics::FindPointerComponent(*symbol)}) { if (const Symbol * - pointer{semantics::FindPointerComponent(*symbol)}) { - if (const Symbol * - object{semantics::FindExternallyVisibleObject( - *value, *pureFunc)}) { - if (auto *msg{Say(expr.source, - "Externally visible object '%s' must not be " - "associated with pointer component '%s' in a " - "PURE function"_err_en_US, - object->name().ToString().data(), - pointer->name().ToString().data())}) { - msg->Attach(object->name(), "Object declaration"_en_US) - .Attach(pointer->name(), "Pointer declaration"_en_US); - } + object{semantics::FindExternallyVisibleObject( + *value, *pureFunc)}) { + if (auto *msg{Say(expr.source, + "Externally visible object '%s' must not be " + "associated with pointer component '%s' in a " + "PURE function"_err_en_US, + object->name().ToString().c_str(), + pointer->name().ToString().c_str())}) { + msg->Attach(object->name(), "Object declaration"_en_US) + .Attach(pointer->name(), "Pointer declaration"_en_US); } } } } - if (symbol->attrs().test(semantics::Attr::POINTER)) { - if (!isNULL) { - // TODO C7104: check that object pointer components are - // being initialized with compatible object designators - } - } else if (MaybeExpr converted{ - ConvertToType(*symbol, std::move(*value))}) { - result.Add(*symbol, std::move(*converted)); - } else { - if (auto *msg{Say(expr.source, - "Structure constructor value is incompatible with component '%s'"_err_en_US, - symbol->name().ToString().data())}) { - msg->Attach(symbol->name(), "Component declaration"_en_US); - } + } else if (symbol->has()) { + Say(expr.source, + "Type parameter '%s' may not appear as a component " + "of a structure constructor"_err_en_US, + symbol->name().ToString().c_str()); + continue; + } else { + Say(expr.source, + "Component '%s' is neither a procedure pointer " + "nor a data object"_err_en_US, + symbol->name().ToString().c_str()); + continue; + } + if (IsPointer(*symbol)) { + CheckPointerAssignment(messages, context_.intrinsics(), *symbol, + *value); // C7104, C7105 + } else if (MaybeExpr converted{ + ConvertToType(*symbol, std::move(*value))}) { + result.Add(*symbol, std::move(*converted)); + } else { + if (auto *msg{Say(expr.source, + "Value in structure constructor is incompatible with " + "component '%s'"_err_en_US, + symbol->name().ToString().c_str())}) { + msg->Attach(symbol->name(), "Component declaration"_en_US); } } } @@ -1379,7 +1372,7 @@ MaybeExpr ExpressionAnalyzer::Analyze( for (const Symbol *symbol : components) { if (!symbol->test(Symbol::Flag::ParentComp) && unavailable.find(symbol->name()) == unavailable.cend() && - !symbol->attrs().test(semantics::Attr::ALLOCATABLE)) { + !IsAllocatable(*symbol)) { if (const auto *details{ symbol->detailsIf()}) { if (details->init().has_value()) { @@ -1388,7 +1381,7 @@ MaybeExpr ExpressionAnalyzer::Analyze( if (auto *msg{Say(typeName, "Structure constructor lacks a value for " "component '%s'"_err_en_US, - symbol->name().ToString().data())}) { + symbol->name().ToString().c_str())}) { msg->Attach(symbol->name(), "Absent component"_en_US); } } @@ -1405,80 +1398,75 @@ ExpressionAnalyzer::AnalyzeProcedureComponentRef( const parser::StructureComponent &sc{pcr.v.thing}; const auto &name{sc.component.source}; if (MaybeExpr base{Analyze(sc.base)}) { - Symbol *sym{sc.component.symbol}; - if (sym == nullptr) { - Say(sc.component.source, - "procedure component name was not resolved to a symbol"_err_en_US); - } else if (auto *dtExpr{UnwrapExpr>(*base)}) { - const semantics::DerivedTypeSpec *dtSpec{nullptr}; - if (std::optional dtDyTy{dtExpr->GetType()}) { - dtSpec = dtDyTy->derived; - } - if (dtSpec == nullptr || dtSpec->scope() == nullptr) { - Say(name, - "TODO: base of procedure component reference lacks a derived type"_err_en_US); - } else if (std::optional dataRef{ - ExtractDataRef(std::move(*dtExpr))}) { - if (auto component{ - CreateComponent(std::move(*dataRef), *sym, *dtSpec->scope())}) { - return ProcedureDesignator{std::move(*component)}; - } else { - Say(name, - "procedure component is not in scope of derived TYPE(%s)"_err_en_US, - dtSpec->typeSymbol().name().ToString().data()); + if (Symbol * sym{sc.component.symbol}) { + if (auto *dtExpr{UnwrapExpr>(*base)}) { + const semantics::DerivedTypeSpec *dtSpec{nullptr}; + if (std::optional dtDyTy{dtExpr->GetType()}) { + dtSpec = dtDyTy->derived; + } + if (dtSpec != nullptr && dtSpec->scope() != nullptr) { + if (std::optional dataRef{ + ExtractDataRef(std::move(*dtExpr))}) { + if (auto component{CreateComponent( + std::move(*dataRef), *sym, *dtSpec->scope())}) { + return ProcedureDesignator{std::move(*component)}; + } else { + Say(name, + "procedure component is not in scope of derived TYPE(%s)"_err_en_US, + dtSpec->typeSymbol().name().ToString().c_str()); + } + } else { + Say(name, + "base of procedure component reference must be a data reference"_err_en_US); + } } } else { Say(name, - "base of procedure component reference must be a data reference"_err_en_US); + "base of procedure component reference is not a derived type object"_err_en_US); } - } else { - Say(name, - "base of procedure component reference is not a derived type object"_err_en_US); } } + CHECK(context_.messages().AnyFatalError()); return std::nullopt; } auto ExpressionAnalyzer::Procedure(const parser::ProcedureDesignator &pd, - ActualArguments &arguments) -> std::optional { + ActualArguments &arguments) -> std::optional { return std::visit( common::visitors{ - [&](const parser::Name &n) -> std::optional { - const Symbol *symbol{n.symbol}; - if (context_.HasError(symbol)) { + [&](const parser::Name &n) -> std::optional { + if (context_.HasError(n.symbol)) { return std::nullopt; } - if (IsProcedure(*symbol)) { - if (symbol->HasExplicitInterface()) { - // TODO: check actual arguments vs. interface - } else { - CallCharacteristics cc{n.source}; - if (std::optional specificCall{ - context().intrinsics().Probe( - cc, arguments, GetFoldingContext())}) { - return { - CallAndArguments{ProcedureDesignator{std::move( - specificCall->specificIntrinsic)}, - std::move(specificCall->arguments)}}; - } else { - // TODO: if name is not INTRINSIC, call with implicit - // interface - } + const Symbol &symbol{*n.symbol}; + if (!symbol.HasExplicitInterface() || + (symbol.has() && + symbol.get().kind() == + semantics::MiscDetails::Kind::SpecificIntrinsic)) { + // Might be an intrinsic. + if (std::optional specificCall{ + context_.intrinsics().Probe(CallCharacteristics{n.source}, + arguments, GetFoldingContext())}) { + return CalleeAndArguments{ProcedureDesignator{std::move( + specificCall->specificIntrinsic)}, + std::move(specificCall->arguments)}; } - return {CallAndArguments{ - ProcedureDesignator{*symbol}, std::move(arguments)}}; + } + if (symbol.HasExplicitInterface()) { + // TODO: check actual arguments vs. interface } else { - Say(n.source, "not a procedure"_err_en_US); - return std::nullopt; + // TODO: call with implicit interface } + return CalleeAndArguments{ + ProcedureDesignator{symbol}, std::move(arguments)}; }, [&](const parser::ProcComponentRef &pcr) - -> std::optional { + -> std::optional { if (std::optional proc{ AnalyzeProcedureComponentRef(pcr)}) { // TODO distinguish PCR from TBP // TODO optional PASS argument for TBP - return {CallAndArguments{std::move(*proc), std::move(arguments)}}; + return CalleeAndArguments{std::move(*proc), std::move(arguments)}; } else { return std::nullopt; } @@ -1487,6 +1475,25 @@ auto ExpressionAnalyzer::Procedure(const parser::ProcedureDesignator &pd, pd.u); } +static const Symbol *AssumedTypeDummy(const parser::Variable &v) { + if (const auto *designator{ + std::get_if>(&v.u)}) { + if (const auto *dataRef{ + std::get_if(&designator->value().u)}) { + if (const auto *name{std::get_if(&dataRef->u)}) { + if (const Symbol * symbol{name->symbol}) { + if (const auto *type{symbol->GetType()}) { + if (type->category() == semantics::DeclTypeSpec::TypeStar) { + return symbol; + } + } + } + } + } + } + return nullptr; +} + MaybeExpr ExpressionAnalyzer::Analyze( const parser::FunctionReference &funcRef) { // TODO: C1002: Allow a whole assumed-size array to appear if the dummy @@ -1500,10 +1507,13 @@ MaybeExpr ExpressionAnalyzer::Analyze( for (const auto &arg : std::get>(funcRef.v.t)) { MaybeExpr actualArgExpr; + const Symbol *assumedTypeDummy{nullptr}; std::visit( common::visitors{ [&](const common::Indirection &v) { - actualArgExpr = Analyze(v.value()); + if (!(assumedTypeDummy = AssumedTypeDummy(v.value()))) { + actualArgExpr = Analyze(v.value()); + } }, [&](const common::Indirection &x) { actualArgExpr = Analyze(x.value()); @@ -1515,7 +1525,7 @@ MaybeExpr ExpressionAnalyzer::Analyze( Say("TODO: proc component ref actual arg"_err_en_US); }, [&](const parser::AltReturnSpec &) { - Say("alternate return specification cannot appear on function reference"_err_en_US); + Say("alternate return specification may not appear on function reference"_err_en_US); }, [&](const parser::ActualArg::PercentRef &) { Say("TODO: %REF() argument"_err_en_US); @@ -1525,7 +1535,10 @@ MaybeExpr ExpressionAnalyzer::Analyze( }, }, std::get(arg.t).u); - if (actualArgExpr.has_value()) { + if (assumedTypeDummy != nullptr) { + arguments.emplace_back( + std::make_optional(ActualArgument::AssumedType{*assumedTypeDummy})); + } else if (actualArgExpr.has_value()) { arguments.emplace_back(std::make_optional( Fold(GetFoldingContext(), std::move(*actualArgExpr)))); if (const auto &argKW{std::get>(arg.t)}) { @@ -1536,22 +1549,13 @@ MaybeExpr ExpressionAnalyzer::Analyze( } } - // TODO: map user generic to specific procedure - if (std::optional proc{Procedure( + // TODO: map non-intrinsic generic procedure to specific procedure + if (std::optional callee{Procedure( std::get(funcRef.v.t), arguments)}) { - if (std::optional dyType{ - proc->procedureDesignator.GetType()}) { - return TypedWrapper(*dyType, - ProcedureRef{std::move(proc->procedureDesignator), - std::move(proc->arguments)}); - } else { - if (const auto *intrinsic{ - std::get_if(&proc->procedureDesignator.u)}) { - if (intrinsic->name == "null"s && proc->arguments.empty()) { - return {Expr{NullPointer{}}}; - } - } + if (MaybeExpr funcRef{MakeFunctionRef(std::move(*callee))}) { + return funcRef; } + Say("Subroutine called as if it were a function"_err_en_US); } return std::nullopt; } @@ -1842,22 +1846,34 @@ void FixMisparsedFunctionReference( } else { common::die("can't fix misparsed function as array reference"); } - } else if (symbol.has()) { - if constexpr (common::HasMember) { - auto &scope{context.FindScope(name->source)}; - const semantics::DeclTypeSpec &type{ - scope.FindOrInstantiateDerivedType( - semantics::DerivedTypeSpec{symbol}, context)}; - u = funcRef.ConvertToStructureConstructor(type.derivedTypeSpec()); - } else { - common::die("can't fix misparsed function as structure constructor"); + } else { + const Symbol *derivedType{nullptr}; + if (symbol.has()) { + derivedType = &symbol; + } else if (const auto *generic{ + symbol.detailsIf()}) { + derivedType = generic->derivedType(); + } + if (derivedType != nullptr) { + if constexpr (common::HasMember) { + CHECK(derivedType->has()); + auto &scope{context.FindScope(name->source)}; + const semantics::DeclTypeSpec &type{ + scope.FindOrInstantiateDerivedType( + semantics::DerivedTypeSpec{*derivedType}, context)}; + u = funcRef.ConvertToStructureConstructor(type.derivedTypeSpec()); + } else { + common::die( + "can't fix misparsed function as structure constructor"); + } } } } } } -// Common handling of parser::Expr and Parser::Variable +// Common handling of parser::Expr and parser::Variable template MaybeExpr ExpressionAnalyzer::ExprOrVariable(const PARSED &x) { if (!x.typedExpr) { // not yet analyzed @@ -1947,7 +1963,7 @@ bool ExpressionAnalyzer::CheckIntrinsicKind( return true; } else { Say("%s(KIND=%jd) is not a supported type"_err_en_US, - parser::ToUpperCaseLetters(EnumToString(category)).data(), kind); + parser::ToUpperCaseLetters(EnumToString(category)).c_str(), kind); return false; } } @@ -1963,7 +1979,7 @@ bool ExpressionAnalyzer::CheckIntrinsicSize( return true; } Say("%s*%jd is not a supported type"_err_en_US, - parser::ToUpperCaseLetters(EnumToString(category)).data(), size); + parser::ToUpperCaseLetters(EnumToString(category)).c_str(), size); return false; } @@ -1994,27 +2010,86 @@ bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at, if (auto type{result->GetType()}) { if (type->category != category) { Say(at, "Must have %s type, but is %s"_err_en_US, - parser::ToUpperCaseLetters(EnumToString(category)).data(), - parser::ToUpperCaseLetters(type->AsFortran()).data()); + parser::ToUpperCaseLetters(EnumToString(category)).c_str(), + parser::ToUpperCaseLetters(type->AsFortran()).c_str()); return false; } else if (defaultKind) { - int kind{context().defaultKinds().GetDefaultKind(category)}; + int kind{context_.defaultKinds().GetDefaultKind(category)}; if (type->kind != kind) { Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US, - kind, parser::ToUpperCaseLetters(EnumToString(category)).data(), - parser::ToUpperCaseLetters(type->AsFortran()).data()); + kind, parser::ToUpperCaseLetters(EnumToString(category)).c_str(), + parser::ToUpperCaseLetters(type->AsFortran()).c_str()); return false; } } } else { Say(at, "Must have %s type, but is typeless"_err_en_US, - parser::ToUpperCaseLetters(EnumToString(category)).data()); + parser::ToUpperCaseLetters(EnumToString(category)).c_str()); return false; } } return true; } +MaybeExpr ExpressionAnalyzer::MakeFunctionRef( + ProcedureDesignator &&proc, ActualArguments &&arguments) { + if (const auto *intrinsic{std::get_if(&proc.u)}) { + if (intrinsic->name == "null" && arguments.empty()) { + return Expr{NullPointer{}}; + } + } + if (auto chars{Characterize(proc, context_.intrinsics())}) { + if (chars->functionResult.has_value()) { + const auto &result{*chars->functionResult}; + if (result.IsProcedurePointer()) { + return Expr{ + ProcedureRef{std::move(proc), std::move(arguments)}}; + } else { + // Not a procedure pointer, so type and shape are known. + const auto *typeAndShape{result.GetTypeAndShape()}; + CHECK(typeAndShape != nullptr); + return TypedWrapper(typeAndShape->type(), + ProcedureRef{std::move(proc), std::move(arguments)}); + } + } + } + return std::nullopt; +} + +MaybeExpr ExpressionAnalyzer::MakeFunctionRef(CalleeAndArguments &&callee) { + return MakeFunctionRef( + std::move(callee.procedureDesignator), std::move(callee.arguments)); +} + +MaybeExpr ExpressionAnalyzer::MakeFunctionRef( + parser::CharBlock intrinsic, ActualArguments &&arguments) { + if (std::optional specificCall{ + context_.intrinsics().Probe(CallCharacteristics{intrinsic}, arguments, + context_.foldingContext())}) { + return MakeFunctionRef( + ProcedureDesignator{std::move(specificCall->specificIntrinsic)}, + std::move(specificCall->arguments)); + } else { + return std::nullopt; + } +} + +std::optional Characterize( + const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) { + if (const auto *symbol{proc.GetSymbol()}) { + return characteristics::Procedure::Characterize( + symbol->GetUltimate(), intrinsics); + } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) { + return intrinsic->characteristics.value(); + } else { + return std::nullopt; + } +} + +std::optional Characterize( + const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) { + return Characterize(ref.proc(), intrinsics); +} } namespace Fortran::semantics { diff --git a/flang/lib/semantics/expression.h b/flang/lib/semantics/expression.h index 0d66ab2..5b2ab05 100644 --- a/flang/lib/semantics/expression.h +++ b/flang/lib/semantics/expression.h @@ -18,6 +18,7 @@ #include "semantics.h" #include "../common/Fortran.h" #include "../common/indirection.h" +#include "../evaluate/characteristics.h" #include "../evaluate/expression.h" #include "../evaluate/fold.h" #include "../evaluate/tools.h" @@ -84,6 +85,8 @@ using namespace Fortran::parser::literals; namespace Fortran::evaluate { +class IntrinsicProcTable; + struct ResetExprHelper { void Reset(parser::Expr::TypedExpr &x) { x->v = std::nullopt; } void Reset(const parser::Expr &x) { Reset(x.typedExpr); } @@ -284,6 +287,7 @@ private: const parser::SectionSubscript &); std::vector AnalyzeSectionSubscripts( const std::list &); + MaybeExpr Designate(DataRef &&); MaybeExpr CompleteSubscripts(ArrayRef &&); MaybeExpr ApplySubscripts(DataRef &&, std::vector &&); MaybeExpr TopLevelChecks(DataRef &&); @@ -292,14 +296,18 @@ private: std::optional AnalyzeProcedureComponentRef( const parser::ProcComponentRef &); - struct CallAndArguments { + + struct CalleeAndArguments { ProcedureDesignator procedureDesignator; ActualArguments arguments; }; - std::optional Procedure( + std::optional Procedure( const parser::ProcedureDesignator &, ActualArguments &); bool EnforceTypeConstraint(parser::CharBlock, const MaybeExpr &, TypeCategory, bool defaultKind = false); + MaybeExpr MakeFunctionRef(ProcedureDesignator &&, ActualArguments &&); + MaybeExpr MakeFunctionRef(CalleeAndArguments &&); + MaybeExpr MakeFunctionRef(parser::CharBlock intrinsic, ActualArguments &&); semantics::SemanticsContext &context_; std::map acImpliedDos_; // values are INTEGER kinds @@ -324,6 +332,11 @@ void ConformabilityCheck( left.Rank(), right.Rank()); } } + +std::optional Characterize( + const ProcedureDesignator &, const IntrinsicProcTable &); +std::optional Characterize( + const ProcedureRef &, const IntrinsicProcTable &); } // namespace Fortran::evaluate namespace Fortran::semantics { diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index aa2e87b..5a4e5a1 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/flang/lib/semantics/resolve-names.cc @@ -3190,10 +3190,17 @@ void DeclarationVisitor::Post(const parser::ProcDecl &x) { } } auto attrs{HandleSaveName(name.source, GetAttrs())}; - if (currScope().kind() != Scope::Kind::DerivedType) { + DerivedTypeDetails *dtDetails{nullptr}; + if (Symbol * symbol{currScope().symbol()}) { + dtDetails = symbol->detailsIf(); + } + if (dtDetails == nullptr) { attrs.set(Attr::EXTERNAL); } - DeclareProcEntity(name, attrs, interface); + Symbol &symbol{DeclareProcEntity(name, attrs, interface)}; + if (dtDetails != nullptr) { + dtDetails->add_component(symbol); + } } bool DeclarationVisitor::Pre(const parser::TypeBoundProcedurePart &x) { @@ -3317,7 +3324,6 @@ void DeclarationVisitor::Post(const parser::AllocateStmt &) { bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) { auto &parsedType{std::get(x.t)}; const DeclTypeSpec *type{ProcessTypeSpec(parsedType)}; - if (type == nullptr) { return false; } @@ -3329,18 +3335,20 @@ bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) { // N.B C7102 is implicitly enforced by having inaccessible types not // being found in resolution. - + // More constraints are enforced in expression.cc so that they + // can apply to structure constructors that have been converted + // from misparsed function references. for (const auto &component : std::get>(x.t)) { // Visit the component spec expression, but not the keyword, since // we need to resolve its symbol in the scope of the derived type. Walk(std::get(component.t)); if (const auto &kw{std::get>(component.t)}) { - if (const Symbol * symbol{FindInTypeOrParents(*typeScope, kw->v)}) { - CheckAccessibleComponent(kw->v.source, *symbol); // C7102 - } else { // C7101 - Say(kw->v.source, - "Keyword '%s' is not a component of this derived type"_err_en_US); + if (Symbol * symbol{FindInTypeOrParents(*typeScope, kw->v)}) { + if (kw->v.symbol == nullptr) { + kw->v.symbol = symbol; + } + CheckAccessibleComponent(kw->v.source, *symbol); } } } diff --git a/flang/lib/semantics/symbol.cc b/flang/lib/semantics/symbol.cc index 3b87315..edb6637 100644 --- a/flang/lib/semantics/symbol.cc +++ b/flang/lib/semantics/symbol.cc @@ -611,14 +611,6 @@ Symbol &Symbol::Instantiate( return symbol; } -const Symbol *Symbol::GetParentComponent(const Scope *scope) const { - if (scope == nullptr) { - CHECK(scope_ != nullptr); - scope = scope_; - } - return get().GetParentComponent(*scope); -} - const DerivedTypeSpec *Symbol::GetParentTypeSpec(const Scope *scope) const { if (const Symbol * parentComponent{GetParentComponent(scope)}) { const auto &object{parentComponent->get()}; @@ -628,6 +620,18 @@ const DerivedTypeSpec *Symbol::GetParentTypeSpec(const Scope *scope) const { } } +const Symbol *Symbol::GetParentComponent(const Scope *scope) const { + if (const auto *dtDetails{detailsIf()}) { + if (scope == nullptr) { + CHECK(scope_ != nullptr); + scope = scope_; + } + return dtDetails->GetParentComponent(*scope); + } else { + return nullptr; + } +} + void DerivedTypeDetails::add_component(const Symbol &symbol) { if (symbol.test(Symbol::Flag::ParentComp)) { CHECK(componentNames_.empty()); @@ -670,7 +674,7 @@ SymbolList DerivedTypeDetails::OrderComponents(const Scope &scope) const { if (iter != scope.cend()) { const Symbol &symbol{*iter->second}; if (symbol.test(Symbol::Flag::ParentComp)) { - CHECK(result.empty()); + CHECK(result.empty()); // parent component must appear first const DerivedTypeSpec &spec{ symbol.get().type()->derivedTypeSpec()}; result = spec.typeSymbol().get().OrderComponents( @@ -683,12 +687,10 @@ SymbolList DerivedTypeDetails::OrderComponents(const Scope &scope) const { } const Symbol *DerivedTypeDetails::GetParentComponent(const Scope &scope) const { - if (!componentNames_.empty()) { - SourceName extends{componentNames_.front()}; - auto iter{scope.find(extends)}; - if (iter != scope.cend()) { - const Symbol &symbol{*iter->second}; - if (symbol.test(Symbol::Flag::ParentComp)) { + if (auto extends{GetParentComponentName()}) { + if (auto iter{scope.find(*extends)}; iter != scope.cend()) { + if (const Symbol & symbol{*iter->second}; + symbol.test(Symbol::Flag::ParentComp)) { return &symbol; } } diff --git a/flang/lib/semantics/symbol.h b/flang/lib/semantics/symbol.h index 389fcaf..3254f60 100644 --- a/flang/lib/semantics/symbol.h +++ b/flang/lib/semantics/symbol.h @@ -234,6 +234,7 @@ public: // after the components that belong to them. SymbolList OrderComponents(const Scope &) const; + // If this derived type extends another, locate the parent component's symbol. const Symbol *GetParentComponent(const Scope &) const; std::optional GetParentComponentName() const { @@ -510,7 +511,13 @@ public: [](const SubprogramDetails &x) { return x.isFunction() ? x.result().GetType() : nullptr; }, - [](const ProcEntityDetails &x) { return x.interface().type(); }, + [](const ProcEntityDetails &x) { + if (const Symbol * symbol{x.interface().symbol()}) { + return symbol->GetType(); + } else { + return x.interface().type(); + } + }, [](const TypeParamDetails &x) { return x.type(); }, [](const UseDetails &x) { return x.symbol().GetType(); }, [](const auto &) -> const DeclTypeSpec * { return nullptr; }, @@ -586,8 +593,7 @@ public: // Clones the Symbol in the context of a parameterized derived type instance Symbol &Instantiate(Scope &, SemanticsContext &) const; - // If there is a parent component, return a pointer to its - // derived type spec. + // If there is a parent component, return a pointer to its derived type spec. // The Scope * argument defaults to this->scope_ but should be overridden // for a parameterized derived type instantiation with the instance's scope. const DerivedTypeSpec *GetParentTypeSpec(const Scope * = nullptr) const; @@ -605,8 +611,9 @@ private: friend std::ostream &operator<<(std::ostream &, const Symbol &); friend std::ostream &DumpForUnparse(std::ostream &, const Symbol &, bool); - // If the symbol refers to a derived type with a parent component, - // return that parent component's symbol. + // If a derived type's symbol refers to an extended derived type, + // return the parent component's symbol. The scope of the derived type + // can be overridden. const Symbol *GetParentComponent(const Scope * = nullptr) const; template friend class Symbols; diff --git a/flang/test/evaluate/folding01.f90 b/flang/test/evaluate/folding01.f90 index 0b989e0..bf15b7e 100644 --- a/flang/test/evaluate/folding01.f90 +++ b/flang/test/evaluate/folding01.f90 @@ -20,8 +20,8 @@ module m logical, parameter :: test_not1 = .NOT..false. logical, parameter :: test_not2 = .NOT..NOT..true. - logical, parameter :: test_parantheses1 = .NOT.(.false.) - logical, parameter :: test_parantheses2 = .NOT..NOT.(.true.) + logical, parameter :: test_parentheses1 = .NOT.(.false.) + logical, parameter :: test_parentheses2 = .NOT..NOT.(.true.) logical, parameter :: test_and1 = .true..AND..true. logical, parameter :: test_and2 = .NOT.(.false..AND..true.) diff --git a/flang/test/evaluate/folding02.f90 b/flang/test/evaluate/folding02.f90 index 1bdd189..915a71a 100644 --- a/flang/test/evaluate/folding02.f90 +++ b/flang/test/evaluate/folding02.f90 @@ -60,6 +60,7 @@ module m TEST_R4(log10, log10(10.5_4), 1.02118933200836181640625_4) TEST_R4(log_gamma, log_gamma(3.5_4), 1.20097362995147705078125_4) TEST_R4(mod, mod(-8.1_4, 5._4), (-3.1000003814697265625_4)) + TEST_R4(real, real(z'3f800000'), 1._4) TEST_R4(sin, sin(1.6_4), 0.99957358837127685546875_4) TEST_R4(sinh, sinh(0.9_4), 1.0265166759490966796875_4) TEST_R4(sqrt, sqrt(1.1_4), 1.0488088130950927734375_4) @@ -112,6 +113,7 @@ module m 1.200973602347074287166606154642067849636077880859375_8) TEST_R8(mod, mod(-8.1_8, 5._8), & (-3.0999999999999996447286321199499070644378662109375_8)) + TEST_R8(real, real(z'3ff0000000000000',8), 1._8) TEST_R8(sin, sin(1.6_8), & 0.99957360304150510987852840116829611361026763916015625_8) TEST_R8(sinh, sinh(0.9_8), & @@ -142,6 +144,7 @@ module m (1.06469786167144775390625_4,1.12215900421142578125_4)) TEST_C4(atanh, atanh((1.1_4, 0.2_4)), & (1.12215900421142578125_4,1.06469786167144775390625_4)) + TEST_C4(cmplx, cmplx(z'bf800000',z'3f000000'), (-1._4,0.5_4)) TEST_C4(cos, cos((0.9_4, 1.1_4)), & (1.0371677875518798828125_4,(-1.0462486743927001953125_4))) TEST_C4(cosh, cosh((1.1_4, 0.9_4)), & @@ -186,6 +189,7 @@ module m TEST_C8(atanh, atanh((1.1_8, 0.2_8)), & (1.122159092433034910385458715609274804592132568359375_8, & (1.064697821069229721757665174663998186588287353515625_8))) + TEST_C8(cmplx, cmplx(z'bff0000000000000', kind=8), (-1._8,0)) TEST_C8(cos, cos((0.9_8, 1.1_8)), & (1.03716776530046761450876147137023508548736572265625_8, & (-1.0462486051241379758636185215436853468418121337890625_8))) diff --git a/flang/test/evaluate/test_folding.sh b/flang/test/evaluate/test_folding.sh index 11915cc..0987137 100755 --- a/flang/test/evaluate/test_folding.sh +++ b/flang/test/evaluate/test_folding.sh @@ -66,7 +66,11 @@ src2=$temp/all_parameters.log src3=$temp/tested_parameters.log src4=$temp/failures.log -$CMD $src > $src1 # compile, dumping symbols +if $CMD $src > $src1 # compile, dumping symbols +then : +else echo FAIL compilation + exit 1 +fi # Get all PARAMETER declarations sed -e '/, PARAMETER/!d' -e 's/, PARAMETER.*init:/ /' \ diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index a674de5..9462ffb 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -123,6 +123,8 @@ set(ERROR_TESTS allocate12.f90 allocate13.f90 dosemantics01.f90 + expr-errors01.f90 + null01.f90 ) # These test files have expected symbols in the source diff --git a/flang/test/semantics/expr-errors01.f90 b/flang/test/semantics/expr-errors01.f90 new file mode 100644 index 0000000..d0fdd82 --- /dev/null +++ b/flang/test/semantics/expr-errors01.f90 @@ -0,0 +1,40 @@ +! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved. +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +! C1003 - can't parenthesize function call returning procedure pointer +module m1 + type :: dt + procedure(frpp), pointer :: pp + end type dt + contains + subroutine boring + end subroutine boring + function frpp + procedure(boring), pointer :: frpp + frpp => boring + end function frpp + subroutine tests + procedure(boring), pointer :: mypp + type(dt) :: dtinst + mypp => boring ! legal + mypp => (boring) ! legal, not a function reference + !ERROR: A function reference that returns a procedure pointer may not be parenthesized. + mypp => (frpp()) ! C1003 + mypp => frpp() ! legal, not parenthesized + dtinst%pp => frpp + mypp => dtinst%pp() ! legal + !ERROR: A function reference that returns a procedure pointer may not be parenthesized. + mypp => (dtinst%pp()) + end subroutine tests +end module m1 diff --git a/flang/test/semantics/null01.f90 b/flang/test/semantics/null01.f90 new file mode 100644 index 0000000..ca38a2b --- /dev/null +++ b/flang/test/semantics/null01.f90 @@ -0,0 +1,90 @@ +! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved. +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +! NULL() intrinsic function error tests + +subroutine test + interface + subroutine s0 + end subroutine + subroutine s1(j) + integer, intent(in) :: j + end subroutine + function f0() + real :: f0 + end function + function f1(x) + real :: f1 + real, intent(inout) :: x + end function + function f2(p) + import s0 + real :: f1 + procedure(s0), pointer, intent(inout) :: p + end function + function f3() + import s1 + procedure(s1), pointer :: f3 + end function + end interface + type :: dt0 + integer, pointer :: ip0 + end type dt0 + type :: dt1 + integer, pointer :: ip1(:) + end type dt1 + type :: dt2 + procedure(s0), pointer :: pps0 + end type dt2 + type :: dt3 + procedure(s1), pointer :: pps1 + end type dt3 + integer :: j + type(dt0) :: dt0x + type(dt1) :: dt1x + type(dt2) :: dt2x + type(dt3) :: dt3x + integer, pointer :: ip0, ip1(:), ip2(:,:) + integer, allocatable :: ia0, ia1(:), ia2(:,:) + real, pointer :: rp0, rp1(:) + integer, parameter :: ip0r = rank(null(mold=ip0)) + integer, parameter :: ip1r = rank(null(mold=ip1)) + integer, parameter :: ip2r = rank(null(mold=ip2)) + integer, parameter :: eight = ip0r + ip1r + ip2r + 5 + real(kind=eight) :: r8check + ip0 => null() ! ok + ip1 => null() ! ok + ip2 => null() ! ok + !ERROR: MOLD= argument to NULL() must be a pointer or allocatable + ip0 => null(mold=1) + !ERROR: MOLD= argument to NULL() must be a pointer or allocatable + ip0 => null(mold=j) + dt0x = dt0(null()) + dt0x = dt0(ip0=null()) + dt0x = dt0(ip0=null(ip0)) + dt0x = dt0(ip0=null(mold=ip0)) + !ERROR: Target type 'Real(4)' is not compatible with 'Integer(4)' + !ERROR: Pointer 'ip0' assigned with result of reference to function 'null' whose pointer result has an incompatible type or shape + dt0x = dt0(ip0=null(mold=rp0)) + !ERROR: Target type 'Real(4)' is not compatible with 'Integer(4)' + !ERROR: Pointer 'ip1' assigned with result of reference to function 'null' whose pointer result has an incompatible type or shape + dt1x = dt1(ip1=null(mold=rp1)) + dt2x = dt2(pps0=null()) + dt2x = dt2(pps0=null(mold=dt2x%pps0)) + !ERROR: Procedure pointer 'pps0' assigned with result of reference to function 'null' that is an incompatible procedure pointer + dt2x = dt2(pps0=null(mold=dt3x%pps1)) + !ERROR: Procedure pointer 'pps1' assigned with result of reference to function 'null' that is an incompatible procedure pointer + dt3x = dt3(pps1=null(mold=dt2x%pps0)) + dt3x = dt3(pps1=null(mold=dt3x%pps1)) +end subroutine test diff --git a/flang/test/semantics/procinterface01.f90 b/flang/test/semantics/procinterface01.f90 index ee77230..36077b0 100644 --- a/flang/test/semantics/procinterface01.f90 +++ b/flang/test/semantics/procinterface01.f90 @@ -50,15 +50,15 @@ module module1 !DEF: /module1/derived1 PUBLIC DerivedType type :: derived1 !DEF: /module1/abstract1 ELEMENTAL, PUBLIC Subprogram REAL(4) - !DEF: /module1/derived1/p1 NOPASS, POINTER ProcEntity + !DEF: /module1/derived1/p1 NOPASS, POINTER ProcEntity REAL(4) !DEF: /module1/nested1 ELEMENTAL, PUBLIC Subprogram REAL(4) procedure(abstract1), pointer, nopass :: p1 => nested1 !DEF: /module1/explicit1 ELEMENTAL, EXTERNAL, PUBLIC Subprogram REAL(4) - !DEF: /module1/derived1/p2 NOPASS, POINTER ProcEntity + !DEF: /module1/derived1/p2 NOPASS, POINTER ProcEntity REAL(4) !REF: /module1/nested1 procedure(explicit1), pointer, nopass :: p2 => nested1 !DEF: /module1/logical EXTERNAL, PUBLIC Subprogram INTEGER(4) - !DEF: /module1/derived1/p3 NOPASS, POINTER ProcEntity + !DEF: /module1/derived1/p3 NOPASS, POINTER ProcEntity INTEGER(4) !DEF: /module1/nested2 PUBLIC Subprogram INTEGER(4) procedure(logical), pointer, nopass :: p3 => nested2 !DEF: /module1/derived1/p4 NOPASS, POINTER ProcEntity LOGICAL(4) @@ -76,7 +76,7 @@ module module1 !DEF: /module1/derived1/p7 NOPASS, POINTER ProcEntity procedure(sin), pointer, nopass :: p7 => cos !DEF: /module1/tan EXTERNAL, PUBLIC Subprogram CHARACTER(1_4,1) - !DEF: /module1/derived1/p8 NOPASS, POINTER ProcEntity + !DEF: /module1/derived1/p8 NOPASS, POINTER ProcEntity CHARACTER(1_4,1) !DEF: /module1/nested5 PUBLIC Subprogram CHARACTER(1_8,1) procedure(tan), pointer, nopass :: p8 => nested5 end type derived1 diff --git a/flang/test/semantics/resolve43.f90 b/flang/test/semantics/resolve43.f90 index 68439cb..d113456 100644 --- a/flang/test/semantics/resolve43.f90 +++ b/flang/test/semantics/resolve43.f90 @@ -42,7 +42,7 @@ module module1 call type1arg(type1(0)()) call type1arg(type1(0)(1)) call type1arg(type1(0)(n=1)) - !ERROR: Keyword 'bad' is not a component of this derived type + !ERROR: Keyword 'bad=' does not name a component of derived type 'type1' call type1arg(type1(0)(bad=1)) call type2arg(type2(0,0)(n=1,m=2)) call type2arg(type2(0,0)(m=2)) diff --git a/flang/test/semantics/structconst01.f90 b/flang/test/semantics/structconst01.f90 index 8020254..84902fe 100644 --- a/flang/test/semantics/structconst01.f90 +++ b/flang/test/semantics/structconst01.f90 @@ -49,7 +49,7 @@ module module1 call type1arg(type1(0)()) call type1arg(type1(0)(1)) call type1arg(type1(0)(n=1)) - !ERROR: Type parameter 'j' cannot be a component of this structure constructor + !ERROR: Type parameter 'j' may not appear as a component of a structure constructor call type1arg(type1(0)(j=1)) !ERROR: Component 'n' conflicts with another component earlier in this structure constructor call type1arg(type1(0)(1,n=2)) @@ -71,11 +71,11 @@ module module1 call type2arg(type2(0,0)(type1=type1(0)(n=1),n=2,m=3)) !ERROR: Component 'n' conflicts with another component earlier in this structure constructor call type2arg(type2(0,0)(type1=type1(0)(1),n=2,m=3)) - !ERROR: Type parameter 'j' cannot be a component of this structure constructor + !ERROR: Type parameter 'j' may not appear as a component of a structure constructor call type2arg(type2(0,0)(j=1, & - !ERROR: Type parameter 'k' cannot be a component of this structure constructor + !ERROR: Type parameter 'k' may not appear as a component of a structure constructor k=2,m=3)) - !ERROR: ABSTRACT derived type 'abstract' cannot be used in a structure constructor + !ERROR: ABSTRACT derived type 'abstract' may not be used in a structure constructor call abstractarg(abstract(0)(n=1)) end subroutine errors end module module1 diff --git a/flang/test/semantics/structconst02.f90 b/flang/test/semantics/structconst02.f90 index 71ffc98..c8867416 100644 --- a/flang/test/semantics/structconst02.f90 +++ b/flang/test/semantics/structconst02.f90 @@ -44,11 +44,11 @@ module module1 ! call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true._4)) call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true.)) call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true.)) - !ERROR: Structure constructor value is incompatible with component 'ix' + !ERROR: Value in structure constructor is incompatible with component 'ix' call scalararg(scalar(4)(ix='a')) - !ERROR: Structure constructor value is incompatible with component 'ix' + !ERROR: Value in structure constructor is incompatible with component 'ix' call scalararg(scalar(4)(ix=.false.)) - !ERROR: Structure constructor value is incompatible with component 'ix' + !ERROR: Value in structure constructor is incompatible with component 'ix' call scalararg(scalar(4)(ix=[1])) !TODO more! end subroutine errors diff --git a/flang/test/semantics/structconst03.f90 b/flang/test/semantics/structconst03.f90 index 7a19575..708ddcd 100644 --- a/flang/test/semantics/structconst03.f90 +++ b/flang/test/semantics/structconst03.f90 @@ -18,7 +18,7 @@ ! parameters. module usefrom - real :: usedfrom1 + real, target :: usedfrom1 end module usefrom module module1 @@ -55,7 +55,7 @@ module module1 type(has_pointer3) :: hp3 type(t4(k)), allocatable :: link end type t4 - real :: modulevar1 + real, target :: modulevar1 type(has_pointer1) :: modulevar2 type(has_pointer2) :: modulevar3 type(has_pointer3) :: modulevar4 @@ -63,16 +63,16 @@ module module1 contains pure real function pf1(dummy1, dummy2, dummy3, dummy4) - real :: local1 + real, target :: local1 type(t1(0)) :: x1 type(t2(0)) :: x2 type(t3(0)) :: x3 type(t4(0)) :: x4 - real, intent(in) :: dummy1 - real, intent(inout) :: dummy2 + real, intent(in), target :: dummy1 + real, intent(inout), target :: dummy2 real, pointer :: dummy3 - real, intent(inout) :: dummy4[*] - real :: commonvar1 + real, intent(inout), target :: dummy4[*] + real, target :: commonvar1 common /cblock/ commonvar1 pf1 = 0. x1 = t1(0)(local1) @@ -99,15 +99,15 @@ module module1 x4 = t4(0)(modulevar4) contains subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) - real :: local1a + real, target :: local1a type(t1(0)) :: x1a type(t2(0)) :: x2a type(t3(0)) :: x3a type(t4(0)) :: x4a - real, intent(in) :: dummy1a - real, intent(inout) :: dummy2a + real, intent(in), target :: dummy1a + real, intent(inout), target :: dummy2a real, pointer :: dummy3a - real, intent(inout) :: dummy4a[*] + real, intent(inout), target :: dummy4a[*] x1a = t1(0)(local1a) !ERROR: Externally visible object 'usedfrom1' must not be associated with pointer component 'pt1' in a PURE function x1a = t1(0)(usedfrom1) @@ -138,16 +138,16 @@ module module1 end function pf1 impure real function ipf1(dummy1, dummy2, dummy3, dummy4) - real :: local1 + real, target :: local1 type(t1(0)) :: x1 type(t2(0)) :: x2 type(t3(0)) :: x3 type(t4(0)) :: x4 - real, intent(in) :: dummy1 - real, intent(inout) :: dummy2 + real, intent(in), target :: dummy1 + real, intent(inout), target :: dummy2 real, pointer :: dummy3 - real, intent(inout) :: dummy4[*] - real :: commonvar1 + real, intent(inout), target :: dummy4[*] + real, target :: commonvar1 common /cblock/ commonvar1 ipf1 = 0. x1 = t1(0)(local1) diff --git a/flang/test/semantics/structconst04.f90 b/flang/test/semantics/structconst04.f90 index 68c722c..3988bc2 100644 --- a/flang/test/semantics/structconst04.f90 +++ b/flang/test/semantics/structconst04.f90 @@ -17,7 +17,7 @@ ! This test is structconst03.f90 with the type parameters removed. module usefrom - real :: usedfrom1 + real, target :: usedfrom1 end module usefrom module module1 @@ -50,7 +50,7 @@ module module1 type(has_pointer3) :: hp3 type(t4), allocatable :: link end type t4 - real :: modulevar1 + real, target :: modulevar1 type(has_pointer1) :: modulevar2 type(has_pointer2) :: modulevar3 type(has_pointer3) :: modulevar4 @@ -58,16 +58,16 @@ module module1 contains pure real function pf1(dummy1, dummy2, dummy3, dummy4) - real :: local1 + real, target :: local1 type(t1) :: x1 type(t2) :: x2 type(t3) :: x3 type(t4) :: x4 - real, intent(in) :: dummy1 - real, intent(inout) :: dummy2 + real, intent(in), target :: dummy1 + real, intent(inout), target :: dummy2 real, pointer :: dummy3 - real, intent(inout) :: dummy4[*] - real :: commonvar1 + real, intent(inout), target :: dummy4[*] + real, target :: commonvar1 common /cblock/ commonvar1 pf1 = 0. x1 = t1(local1) @@ -94,15 +94,15 @@ module module1 x4 = t4(modulevar4) contains subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) - real :: local1a + real, target :: local1a type(t1) :: x1a type(t2) :: x2a type(t3) :: x3a type(t4) :: x4a - real, intent(in) :: dummy1a - real, intent(inout) :: dummy2a + real, intent(in), target :: dummy1a + real, intent(inout), target :: dummy2a real, pointer :: dummy3a - real, intent(inout) :: dummy4a[*] + real, intent(inout), target :: dummy4a[*] x1a = t1(local1a) !ERROR: Externally visible object 'usedfrom1' must not be associated with pointer component 'pt1' in a PURE function x1a = t1(usedfrom1) @@ -133,16 +133,16 @@ module module1 end function pf1 impure real function ipf1(dummy1, dummy2, dummy3, dummy4) - real :: local1 + real, target :: local1 type(t1) :: x1 type(t2) :: x2 type(t3) :: x3 type(t4) :: x4 - real, intent(in) :: dummy1 - real, intent(inout) :: dummy2 + real, intent(in), target :: dummy1 + real, intent(inout), target :: dummy2 real, pointer :: dummy3 - real, intent(inout) :: dummy4[*] - real :: commonvar1 + real, intent(inout), target :: dummy4[*] + real, target :: commonvar1 common /cblock/ commonvar1 ipf1 = 0. x1 = t1(local1) -- 2.7.4