From f953583deaad1dc8926449f092516d217d101608 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Tue, 26 Feb 2019 14:26:28 -0800 Subject: [PATCH] [flang] checkpoint Original-commit: flang-compiler/f18@4d907e3184da8e236d7a3c524cbb4630886f75c9 Reviewed-on: https://github.com/flang-compiler/f18/pull/304 Tree-same-pre-rewrite: false --- flang/lib/common/enum-set.h | 20 +++ flang/lib/common/fortran.h | 2 + flang/lib/common/indirection.h | 5 +- flang/lib/evaluate/CMakeLists.txt | 1 + flang/lib/evaluate/characteristics.cc | 132 ++++++++++++++++++ flang/lib/evaluate/characteristics.h | 97 +++++++++++++ flang/lib/evaluate/expression.cc | 2 +- flang/lib/evaluate/intrinsics.cc | 35 ++++- flang/lib/evaluate/intrinsics.h | 15 +- flang/lib/semantics/expression.cc | 3 + flang/lib/semantics/resolve-names.cc | 110 +++++++++------ flang/test/semantics/CMakeLists.txt | 1 + flang/test/semantics/procinterface01.f90 | 232 ++++++++++++++++++++++--------- 13 files changed, 536 insertions(+), 119 deletions(-) create mode 100644 flang/lib/evaluate/characteristics.cc create mode 100644 flang/lib/evaluate/characteristics.h diff --git a/flang/lib/common/enum-set.h b/flang/lib/common/enum-set.h index 3859b65..fc32b85 100644 --- a/flang/lib/common/enum-set.h +++ b/flang/lib/common/enum-set.h @@ -26,6 +26,8 @@ #include #include #include +#include +#include #include namespace Fortran::common { @@ -195,6 +197,24 @@ public: } } + template void IterateOverMembers(const FUNC &f) const { + EnumSet copy{*this}; + while (auto least{copy.LeastElement()}) { + f(*least); + copy.erase(*least); + } + } + + std::ostream &Dump( + std::ostream &o, std::string EnumToString(enumerationType)) const { + char sep{'{'}; + IterateOverMembers([&](auto e) { + o << sep << EnumToString(e); + sep = ','; + }); + return o << (sep == '{' ? "{}" : "}"); + } + private: bitsetType bitset_; }; diff --git a/flang/lib/common/fortran.h b/flang/lib/common/fortran.h index 2cda418..2482ed7 100644 --- a/flang/lib/common/fortran.h +++ b/flang/lib/common/fortran.h @@ -38,5 +38,7 @@ ENUM_CLASS(ImportKind, Default, Only, None, All) ENUM_CLASS(TypeParamAttr, Kind, Len) ENUM_CLASS(RelationalOperator, LT, LE, EQ, NE, GE, GT) + +ENUM_CLASS(Intent, Default, In, Out, InOut) } #endif // FORTRAN_COMMON_FORTRAN_H_ diff --git a/flang/lib/common/indirection.h b/flang/lib/common/indirection.h index b661e84..41095cb 100644 --- a/flang/lib/common/indirection.h +++ b/flang/lib/common/indirection.h @@ -153,9 +153,12 @@ public: p_ = p; } + bool operator==(const A &x) const { + return p_ != nullptr && (p_ == &x || *p_ == x); + } bool operator==(const OwningPointer &that) const { return (p_ == nullptr && that.p_ == nullptr) || - (p_ != nullptr && that.p_ != nullptr && *p_ == *that.p_); + (that.p_ != nullptr && *this == *that.p_); } private: diff --git a/flang/lib/evaluate/CMakeLists.txt b/flang/lib/evaluate/CMakeLists.txt index 3c0e4e1..e61e503 100644 --- a/flang/lib/evaluate/CMakeLists.txt +++ b/flang/lib/evaluate/CMakeLists.txt @@ -14,6 +14,7 @@ add_library(FortranEvaluate call.cc + characteristics.cc common.cc complex.cc constant.cc diff --git a/flang/lib/evaluate/characteristics.cc b/flang/lib/evaluate/characteristics.cc new file mode 100644 index 0000000..182ed28 --- /dev/null +++ b/flang/lib/evaluate/characteristics.cc @@ -0,0 +1,132 @@ +// 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. + +#include "characteristics.h" +#include +#include +#include + +using namespace std::literals::string_literals; + +namespace Fortran::evaluate::characteristics { + +bool DummyDataObject::operator==(const DummyDataObject &that) const { + return attrs == that.attrs && intent == that.intent && type == that.type && + shape == that.shape && coshape == that.coshape; +} + +std::ostream &DummyDataObject::Dump(std::ostream &o) const { + attrs.Dump(o, EnumToString); + if (intent != common::Intent::Default) { + o << "INTENT(" << common::EnumToString(intent) << ')'; + } + // TODO pmk WIP: generalize this too + if (type.category == common::TypeCategory::Character) { + if (characterLength.get() == nullptr) { + o << type.AsFortran(":"s); + } else { + std::stringstream ss; + characterLength->AsFortran(ss); + o << type.AsFortran(ss.str()); + } + } else { + o << type.AsFortran(); + } + if (!shape.empty()) { + char sep{'('}; + for (const auto &expr : shape) { + o << sep; + sep = ','; + if (expr.has_value()) { + expr->AsFortran(o); + } else { + o << ':'; + } + } + o << ')'; + } + if (!coshape.empty()) { + char sep{'['}; + for (const auto &expr : coshape) { + expr.AsFortran(o << sep); + sep = ','; + } + } + return o; +} + +bool DummyProcedure::operator==(const DummyProcedure &that) const { + return attrs == that.attrs && explicitProcedure == that.explicitProcedure; +} + +std::ostream &DummyProcedure::Dump(std::ostream &o) const { + attrs.Dump(o, EnumToString); + if (explicitProcedure.get() != nullptr) { + explicitProcedure->Dump(o); + } + return o; +} + +std::ostream &AlternateReturn::Dump(std::ostream &o) const { return o << '*'; } + +bool FunctionResult::operator==(const FunctionResult &that) const { + return attrs == that.attrs && type == that.type && rank == that.rank; +} + +std::ostream &FunctionResult::Dump(std::ostream &o) const { + attrs.Dump(o, EnumToString); + if (type.category == TypeCategory::Character) { + if (characterLength.get() == nullptr) { + o << type.AsFortran("*"s); + } else { + std::stringstream ss; + characterLength->AsFortran(o); + o << type.AsFortran(ss.str()); + } + } else { + o << type.AsFortran(); + } + return o << " rank " << rank; +} + +bool Procedure::operator==(const Procedure &that) const { + return attrs == that.attrs && dummyArguments == that.dummyArguments && + functionResult == that.functionResult; +} + +std::ostream &Procedure::Dump(std::ostream &o) const { + attrs.Dump(o, EnumToString); + if (functionResult.has_value()) { + functionResult->Dump(o << "TYPE(") << ") FUNCTION"; + } else { + o << "SUBROUTINE"; + } + char sep{'('}; + for (const auto &dummy : dummyArguments) { + o << sep; + sep = ','; + std::visit([&](const auto &x) { x.Dump(o); }, dummy); + } + return o << (sep == '(' ? "()" : ")"); +} +} + +namespace Fortran::common { +template class OwningPointer; +template<> +OwningPointer::~OwningPointer() { + delete p_; + p_ = nullptr; +} +} diff --git a/flang/lib/evaluate/characteristics.h b/flang/lib/evaluate/characteristics.h new file mode 100644 index 0000000..8495e2a --- /dev/null +++ b/flang/lib/evaluate/characteristics.h @@ -0,0 +1,97 @@ +// 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. + +// Defines data structures to represent "characteristics" of Fortran +// procedures and other entities as they are specified in section 15.3 +// of Fortran 2018. + +#ifndef FORTRAN_EVALUATE_CHARACTERISTICS_H_ +#define FORTRAN_EVALUATE_CHARACTERISTICS_H_ + +#include "expression.h" +#include "type.h" +#include "../common/fortran.h" +#include "../common/idioms.h" +#include "../common/indirection.h" +#include "../common/enum-set.h" +#include +#include +#include +#include + +// Forward declare Procedure so dummy procedures can use it indirectly +namespace Fortran::evaluate::characteristics { +struct Procedure; +} +namespace Fortran::common { +extern template class OwningPointer; +} + +namespace Fortran::evaluate::characteristics { + +// 15.3.2.2 +struct DummyDataObject { + ENUM_CLASS(Attr, AssumedRank, Optional, Allocatable, Asynchronous, + Contiguous, Value, Volatile, Polymorphic, Pointer, Target) + DynamicType type; + std::unique_ptr> characterLength; + std::vector>> shape; + std::vector> coshape; + common::Intent intent{common::Intent::Default}; + common::EnumSet attrs; + bool operator==(const DummyDataObject &) const; + std::ostream &Dump(std::ostream &) const; +}; + +// 15.3.2.3 +struct DummyProcedure { + ENUM_CLASS(Attr, Pointer, Optional) + common::OwningPointer explicitProcedure; + common::EnumSet attrs; + bool operator==(const DummyProcedure &) const; + std::ostream &Dump(std::ostream &) const; +}; + +// 15.3.2.4 +struct AlternateReturn { + bool operator==(const AlternateReturn &) const { return true; } + std::ostream &Dump(std::ostream &) const; +}; + +// 15.3.2.1 +using DummyArgument = std::variant; + +// 15.3.3 +struct FunctionResult { + ENUM_CLASS(Attr, Polymorphic, Allocatable, Pointer, Contiguous, + ProcedurePointer) + DynamicType type; + std::unique_ptr> characterLength; + int rank{0}; + common::EnumSet attrs; + bool operator==(const FunctionResult &) const; + std::ostream &Dump(std::ostream &) const; +}; + +// 15.3.1 +struct Procedure { + ENUM_CLASS(Attr, Pure, Elemental, Bind_C) + std::optional functionResult; // absent means subroutine + std::vector dummyArguments; + common::EnumSet attrs; + bool operator==(const Procedure &) const; + std::ostream &Dump(std::ostream &) const; +}; +} +#endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_ diff --git a/flang/lib/evaluate/expression.cc b/flang/lib/evaluate/expression.cc index dcb6d4f..b321b10 100644 --- a/flang/lib/evaluate/expression.cc +++ b/flang/lib/evaluate/expression.cc @@ -322,9 +322,9 @@ FOR_EACH_INTRINSIC_KIND(template class ArrayConstructor) // definitions for all the necessary types are available, to obviate a // need to include lib/evaluate/*.h headers in the parser proper. namespace Fortran::common { +template class OwningPointer; template<> OwningPointer::~OwningPointer() { delete p_; p_ = nullptr; } -template class OwningPointer; } diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc index 1d8ed95..7d7351e 100644 --- a/flang/lib/evaluate/intrinsics.cc +++ b/flang/lib/evaluate/intrinsics.cc @@ -1180,6 +1180,8 @@ public: } } + bool IsIntrinsic(const std::string &) const; + std::optional Probe(const CallCharacteristics &, ActualArguments &, parser::ContextualMessages *) const; @@ -1196,6 +1198,20 @@ private: DynamicType GetSpecificType(const TypePattern &) const; }; +bool IntrinsicProcTable::Implementation::IsIntrinsic( + const std::string &name) const { + auto specificRange{specificFuncs_.equal_range(name)}; + if (specificRange.first != specificRange.second) { + return true; + } + auto genericRange{genericFuncs_.equal_range(name)}; + if (genericRange.first != genericRange.second) { + return true; + } + // special cases + return name == "null"; // TODO more +} + // Probe the configured intrinsic procedure pattern tables in search of a // match for a given procedure reference. std::optional IntrinsicProcTable::Implementation::Probe( @@ -1278,9 +1294,17 @@ IntrinsicProcTable::Implementation::IsUnrestrictedSpecificIntrinsicFunction( } else { result.genericName = name; } - result.numArguments = specific.CountArguments(); - result.argumentType = GetSpecificType(specific.dummy[0].typePattern); - result.resultType = GetSpecificType(specific.result); + result.attrs.set(characteristics::Procedure::Attr::Pure); + result.attrs.set(characteristics::Procedure::Attr::Elemental); + int dummies{specific.CountArguments()}; + for (int j{0}; j < dummies; ++j) { + characteristics::DummyDataObject dummy{ + GetSpecificType(specific.dummy[j].typePattern)}; + dummy.intent = common::Intent::In; + result.dummyArguments.emplace_back(std::move(dummy)); + } + result.functionResult.emplace( + characteristics::FunctionResult{GetSpecificType(specific.result)}); return result; } } @@ -1308,6 +1332,11 @@ IntrinsicProcTable IntrinsicProcTable::Configure( return result; } +bool IntrinsicProcTable::IsIntrinsic(const std::string &name) const { + CHECK(impl_ != nullptr || !"IntrinsicProcTable: not configured"); + return impl_->IsIntrinsic(name); +} + std::optional IntrinsicProcTable::Probe( const CallCharacteristics &call, ActualArguments &arguments, parser::ContextualMessages *messages) const { diff --git a/flang/lib/evaluate/intrinsics.h b/flang/lib/evaluate/intrinsics.h index a1b1628..7d9729b 100644 --- a/flang/lib/evaluate/intrinsics.h +++ b/flang/lib/evaluate/intrinsics.h @@ -16,6 +16,7 @@ #define FORTRAN_EVALUATE_INTRINSICS_H_ #include "call.h" +#include "characteristics.h" #include "type.h" #include "../common/default-kinds.h" #include "../parser/char-block.h" @@ -37,13 +38,11 @@ struct SpecificCall { ActualArguments arguments; }; -struct UnrestrictedSpecificIntrinsicFunctionInterface { +struct UnrestrictedSpecificIntrinsicFunctionInterface + : public characteristics::Procedure { std::string genericName; - int numArguments; // 1 or 2 - // These are the types of the argument(s) and the function result. - // If there are multiple arguments, they all have the same type. - // All are intrinsic types with default kinds. - DynamicType argumentType, resultType; + // N.B. If there are multiple arguments, they all have the same type. + // All argument and result types are intrinsic types with default kinds. }; class IntrinsicProcTable { @@ -55,6 +54,10 @@ public: static IntrinsicProcTable Configure( const common::IntrinsicTypeDefaultKinds &); + // Check whether a name should be allowed to appear on an INTRINSIC + // statement. + bool IsIntrinsic(const std::string &) const; + // Probe the intrinsics for a match against a specific call. // On success, the actual arguments are transferred to the result // in dummy argument order. diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc index 97bb1b6..317faeb 100644 --- a/flang/lib/semantics/expression.cc +++ b/flang/lib/semantics/expression.cc @@ -1555,6 +1555,9 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context, // TODO: C1002: Allow a whole assumed-size array to appear if the dummy // argument would accept it. Handle by special-casing the context // ActualArg -> Variable -> Designator. + // TODO: Actual arguments that are procedures and procedure pointers need to + // be detected and represented (they're not expressions). + // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed. ActualArguments arguments; for (const auto &arg : std::get>(funcRef.v.t)) { diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index 79a5ea1..3d3924f 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/flang/lib/semantics/resolve-names.cc @@ -727,6 +727,7 @@ protected: void CheckCommonBlocks(); void CheckSaveStmts(); bool CheckNotInBlock(const char *); + bool NameIsKnownOrIntrinsic(const parser::Name &); private: // The attribute corresponding to the statement containing an ObjectDecl @@ -956,6 +957,7 @@ public: bool Pre(const parser::ImplicitStmt &); void Post(const parser::PointerObject &); void Post(const parser::AllocateObject &); + bool Pre(const parser::PointerAssignmentStmt &); void Post(const parser::PointerAssignmentStmt &); void Post(const parser::Designator &); template void Post(const parser::LoopBounds &); @@ -2553,7 +2555,6 @@ bool DeclarationVisitor::Pre(const parser::IntentStmt &x) { HandleAttributeStmt(IntentSpecToAttr(intentSpec), names); } bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) { - // TODO pmk: actually look up the intrinsic return HandleAttributeStmt(Attr::INTRINSIC, x.v); } bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) { @@ -2579,6 +2580,10 @@ bool DeclarationVisitor::HandleAttributeStmt( } Symbol &DeclarationVisitor::HandleAttributeStmt( Attr attr, const parser::Name &name) { + if (attr == Attr::INTRINSIC && + !context().intrinsics().IsIntrinsic(name.source.ToString())) { + Say(name.source, "'%s' is not a known intrinsic procedure"_err_en_US); + } auto *symbol{FindInScope(currScope(), name)}; if (symbol) { // symbol was already there: set attribute on it @@ -3041,52 +3046,45 @@ void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) { } bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { if (auto *name{std::get_if(&x.u)}) { - if (FindSymbol(*name) != nullptr) { - return false; - } - if (HandleUnrestrictedSpecificIntrinsicFunction(*name)) { - return false; - } + return !NameIsKnownOrIntrinsic(*name); } return true; } bool DeclarationVisitor::Pre(const parser::ProcInterface &x) { if (auto *name{std::get_if(&x.u)}) { - if (FindSymbol(*name) != nullptr) { - return false; - } - if (HandleUnrestrictedSpecificIntrinsicFunction(*name)) { - return false; - } - // Simple names (lacking parameters and size) of intrinsic types re - // ambiguous in Fortran when used as instances of proc-interface. - // The parser recognizes them as interface-names since they can be - // overridden. When they turn out (here) to not be names of explicit - // interfaces, we need to replace their parses. - auto &proc{const_cast(x)}; - if (name->source == "integer"s) { - proc.u = parser::IntrinsicTypeSpec{parser::IntegerTypeSpec{std::nullopt}}; - } else if (name->source == "real") { - proc.u = parser::IntrinsicTypeSpec{ - parser::IntrinsicTypeSpec::Real{std::nullopt}}; - } else if (name->source == "doubleprecision") { - proc.u = parser::IntrinsicTypeSpec{ - parser::IntrinsicTypeSpec::DoublePrecision{}}; - } else if (name->source == "complex") { - proc.u = parser::IntrinsicTypeSpec{ - parser::IntrinsicTypeSpec::Complex{std::nullopt}}; - } else if (name->source == "character") { - proc.u = parser::IntrinsicTypeSpec{ - parser::IntrinsicTypeSpec::Character{std::nullopt}}; - } else if (name->source == "logical") { - proc.u = parser::IntrinsicTypeSpec{ - parser::IntrinsicTypeSpec::Logical{std::nullopt}}; - } else if (name->source == "doublecomplex") { - proc.u = - parser::IntrinsicTypeSpec{parser::IntrinsicTypeSpec::DoubleComplex{}}; - } else if (name->source == "ncharacter") { - proc.u = parser::IntrinsicTypeSpec{ - parser::IntrinsicTypeSpec::NCharacter{std::nullopt}}; + if (!FindSymbol(*name) && + !HandleUnrestrictedSpecificIntrinsicFunction(*name)) { + // Simple names (lacking parameters and size) of intrinsic types re + // ambiguous in Fortran when used as instances of proc-interface. + // The parser recognizes them as interface-names since they can be + // overridden. If they turn out (here) to not be names of explicit + // interfaces, we need to replace their parses. + auto &proc{const_cast(x)}; + if (name->source == "integer") { + proc.u = + parser::IntrinsicTypeSpec{parser::IntegerTypeSpec{std::nullopt}}; + } else if (name->source == "real") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Real{std::nullopt}}; + } else if (name->source == "doubleprecision") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::DoublePrecision{}}; + } else if (name->source == "complex") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Complex{std::nullopt}}; + } else if (name->source == "character") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Character{std::nullopt}}; + } else if (name->source == "logical") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Logical{std::nullopt}}; + } else if (name->source == "doublecomplex") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::DoubleComplex{}}; + } else if (name->source == "ncharacter") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::NCharacter{std::nullopt}}; + } } } return true; @@ -3527,6 +3525,11 @@ Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) { return Resolve(name, currScope().MakeCommonBlock(name.source)); } +bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) { + return FindSymbol(name) != nullptr || + HandleUnrestrictedSpecificIntrinsicFunction(name); +} + // Check if this derived type can be in a COMMON block. void DeclarationVisitor::CheckCommonBlockDerivedType( const SourceName &name, const Symbol &typeSymbol) { @@ -3560,7 +3563,6 @@ void DeclarationVisitor::CheckCommonBlockDerivedType( bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction( const parser::Name &name) { - // TODO pmk: invoke this on unresolved actual arguments, too if (context() .intrinsics() .IsUnrestrictedSpecificIntrinsicFunction(name.source.ToString()) @@ -3568,7 +3570,7 @@ bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction( // Unrestricted specific intrinsic function names (e.g., "cos") // are acceptable as procedure interfaces. Scope *scope{&currScope()}; - if (scope->kind() == Scope::Kind::DerivedType) { + while (scope->kind() == Scope::Kind::DerivedType) { scope = &scope->parent(); } Symbol &symbol{MakeSymbol(*scope, name.source, Attrs{Attr::INTRINSIC})}; @@ -4545,6 +4547,26 @@ void ResolveNamesVisitor::Post(const parser::AllocateObject &x) { }, x.u); } +bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) { + // Resolve unrestricted specific intrinsic procedures as in "p => cos". + const auto &expr{std::get(x.t)}; + if (const auto *designator{ + std::get_if>(&expr.u)}) { + if (const parser::Name * + name{std::visit( + common::visitors{ + [](const parser::ObjectName &n) { return &n; }, + [](const parser::DataRef &dataRef) { + return std::get_if(&dataRef.u); + }, + [](const auto &) -> const parser::Name * { return nullptr; }, + }, + (*designator)->u)}) { + return !NameIsKnownOrIntrinsic(*name); + } + } + return true; +} void ResolveNamesVisitor::Post(const parser::PointerAssignmentStmt &x) { ResolveDataRef(std::get(x.t)); } diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index e6934d3..aee5ec4 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -89,6 +89,7 @@ set(SYMBOL_TESTS symbol11.f90 kinds01.f90 kinds03.f90 + procinterface01.f90 ) # These test files have expected .mod file contents in the source diff --git a/flang/test/semantics/procinterface01.f90 b/flang/test/semantics/procinterface01.f90 index e315a42d..adee9c6 100644 --- a/flang/test/semantics/procinterface01.f90 +++ b/flang/test/semantics/procinterface01.f90 @@ -12,83 +12,187 @@ ! See the License for the specific language governing permissions and ! limitations under the License. -! Tests for "proc-interface" semantics +! Tests for "proc-interface" semantics. ! These cases are all valid. +!DEF: /module1 Module module module1 - abstract interface - real elemental function abstract1(x) - real, intent(in) :: x - end function abstract1 - end interface - interface - real elemental function explicit1(x) - real, intent(in) :: x - end function explicit1 - integer function logical(x) ! name is ambiguous vs. decl-type-spec - real, intent(in) :: x - end function logical - character(1) function tan(x) - real, intent(in) :: x - end function tan - end interface - type :: derived1 - procedure(abstract1), pointer, nopass :: p1 => nested1 - procedure(explicit1), pointer, nopass :: p2 => nested1 - procedure(logical), pointer, nopass :: p3 => nested2 - procedure(logical(kind=4)), pointer, nopass :: p4 => nested3 - procedure(complex), pointer, nopass :: p5 => nested4 - procedure(sin), pointer, nopass :: p6 => nested1 - procedure(sin), pointer, nopass :: p7 => cos - procedure(tan), pointer, nopass :: p8 => nested5 - end type derived1 - contains - real elemental function nested1(x) - real, intent(in) :: x - nested1 = x + 1. - end function nested1 - integer function nested2(x) - real, intent(in) :: x - nested2 = x + 2. - end function nested2 - logical function nested3(x) - real, intent(in) :: x - nested3 = x > 0 - end function nested3 - complex function nested4(x) - real, intent(in) :: x - nested4 = cmplx(x + 4., 6.) - end function nested4 - character function nested5(x) - real, intent(in) :: x - nested5 = 'a' - end function nested5 + abstract interface + !DEF: /module1/abstract1/abstract1 ObjectEntity REAL(4) + !DEF: /module1/abstract1/x INTENT(IN) ObjectEntity REAL(4) + real elemental function abstract1(x) + !REF: /module1/abstract1/x + real, intent(in) :: x + end function abstract1 + end interface + + interface + !DEF: /module1/explicit1/explicit1 ObjectEntity REAL(4) + !DEF: /module1/explicit1/x INTENT(IN) ObjectEntity REAL(4) + real elemental function explicit1(x) + !REF: /module1/explicit1/x + real, intent(in) :: x + end function explicit1 + !DEF: /module1/logical/logical ObjectEntity INTEGER(4) + !DEF: /module1/logical/x INTENT(IN) ObjectEntity REAL(4) + integer function logical(x) + !REF: /module1/logical/x + real, intent(in) :: x + end function logical + !DEF: /module1/tan/tan ObjectEntity CHARACTER(1_4,1) + !DEF: /module1/tan/x INTENT(IN) ObjectEntity REAL(4) + character(len=1) function tan(x) + !REF: /module1/tan/x + real, intent(in) :: x + end function tan + end interface + + !DEF: /module1/derived1 PUBLIC DerivedType + type :: derived1 + !DEF: /module1/abstract1 ELEMENTAL, PUBLIC Subprogram + !DEF: /module1/derived1/p1 NOPASS, POINTER ProcEntity + !DEF: /module1/nested1 ELEMENTAL, PUBLIC Subprogram + procedure(abstract1), pointer, nopass :: p1 => nested1 + !DEF: /module1/explicit1 ELEMENTAL, EXTERNAL, PUBLIC Subprogram + !DEF: /module1/derived1/p2 NOPASS, POINTER ProcEntity + !REF: /module1/nested1 + procedure(explicit1), pointer, nopass :: p2 => nested1 + !DEF: /module1/logical EXTERNAL, PUBLIC Subprogram + !DEF: /module1/derived1/p3 NOPASS, POINTER ProcEntity + !DEF: /module1/nested2 PUBLIC Subprogram + procedure(logical), pointer, nopass :: p3 => nested2 + !DEF: /module1/derived1/p4 NOPASS, POINTER ProcEntity LOGICAL(4) + !DEF: /module1/nested3 PUBLIC Subprogram + procedure(logical(kind=4)), pointer, nopass :: p4 => nested3 + !DEF: /module1/derived1/p5 NOPASS, POINTER ProcEntity COMPLEX(4) + !DEF: /module1/nested4 PUBLIC Subprogram + procedure(complex), pointer, nopass :: p5 => nested4 + !DEF: /module1/derived1/p6 NOPASS, POINTER ProcEntity + !REF: /module1/nested1 + ! NOTE: sin is not dumped as a DEF here because specific + ! intrinsic functions are represented with MiscDetails + ! and those are omitted from dumping. + procedure(sin), pointer, nopass :: p6 => nested1 + !DEF: /module1/derived1/p7 NOPASS, POINTER ProcEntity + procedure(sin), pointer, nopass :: p7 => cos + !DEF: /module1/tan EXTERNAL, PUBLIC Subprogram + !DEF: /module1/derived1/p8 NOPASS, POINTER ProcEntity + !DEF: /module1/nested5 PUBLIC Subprogram + procedure(tan), pointer, nopass :: p8 => nested5 + end type derived1 + +contains + + !DEF: /module1/nested1/nested1 ObjectEntity REAL(4) + !DEF: /module1/nested1/x INTENT(IN) ObjectEntity REAL(4) + real elemental function nested1(x) + !REF: /module1/nested1/x + real, intent(in) :: x + !REF: /module1/nested1/nested1 + !REF: /module1/nested1/x + nested1 = x+1. + end function nested1 + + !DEF: /module1/nested2/nested2 ObjectEntity INTEGER(4) + !DEF: /module1/nested2/x INTENT(IN) ObjectEntity REAL(4) + integer function nested2(x) + !REF: /module1/nested2/x + real, intent(in) :: x + !REF: /module1/nested2/nested2 + !REF: /module1/nested2/x + nested2 = x+2. + end function nested2 + + !DEF: /module1/nested3/nested3 ObjectEntity LOGICAL(4) + !DEF: /module1/nested3/x INTENT(IN) ObjectEntity REAL(4) + logical function nested3(x) + !REF: /module1/nested3/x + real, intent(in) :: x + !REF: /module1/nested3/nested3 + !REF: /module1/nested3/x + nested3 = x>0 + end function nested3 + + !DEF: /module1/nested4/nested4 ObjectEntity COMPLEX(4) + !DEF: /module1/nested4/x INTENT(IN) ObjectEntity REAL(4) + complex function nested4(x) + !REF: /module1/nested4/x + real, intent(in) :: x + !REF: /module1/nested4/nested4 + !DEF: /cmplx EXTERNAL (implicit) ProcEntity REAL(4) + !REF: /module1/nested4/x + nested4 = cmplx(x+4., 6.) + end function nested4 + + !DEF: /module1/nested5/nested5 ObjectEntity CHARACTER(1_8,1) + !DEF: /module1/nested5/x INTENT(IN) ObjectEntity REAL(4) + character function nested5(x) + !REF: /module1/nested5/x + real, intent(in) :: x + !REF: /module1/nested5/nested5 + nested5 = "a" + end function nested5 end module module1 +!DEF: /explicit1/explicit1 ObjectEntity REAL(4) +!DEF: /explicit1/x INTENT(IN) ObjectEntity REAL(4) real elemental function explicit1(x) - real, intent(in) :: x - explicit1 = -x + !REF: /explicit1/x + real, intent(in) :: x + !REF: /explicit1/explicit1 + !REF: /explicit1/x + explicit1 = -x end function explicit1 +!DEF: /logical/logical ObjectEntity INTEGER(4) +!DEF: /logical/x INTENT(IN) ObjectEntity REAL(4) integer function logical(x) - real, intent(in) :: x - logical = x + 3. + !REF: /logical/x + real, intent(in) :: x + !REF: /logical/logical + !REF: /logical/x + logical = x+3. end function logical +!DEF: /tan/tan ObjectEntity REAL(4) +!DEF: /tan/x INTENT(IN) ObjectEntity REAL(4) real function tan(x) - real, intent(in) :: x - tan = x + 5. + !REF: /tan/x + real, intent(in) :: x + !REF: /tan/tan + !REF: /tan/x + tan = x+5. end function tan +!DEF: /main MainProgram program main - use module1 - type(derived1) :: instance - if (instance%p1(1.) /= 2.) print *, "p1 failed" - if (instance%p2(1.) /= 2.) print *, "p2 failed" - if (instance%p3(1.) /= 3) print *, "p3 failed" - if (.not. instance%p4(1.)) print *, "p4 failed" - if (instance%p5(1.) /= (5.,6.)) print *, "p5 failed" - if (instance%p6(1.) /= 2.) print *, "p6 failed" - if (instance%p7(0.) /= 1.) print *, "p7 failed" - if (instance%p8(1.) /= 'a') print *, "p8 failed" + !REF: /module1 + use :: module1 + !DEF: /main/derived1 Use + !DEF: /main/instance ObjectEntity TYPE(derived1) + type(derived1) :: instance + !REF: /main/instance + !REF: /module1/derived1/p1 + if (instance%p1(1.)/=2.) print *, "p1 failed" + !REF: /main/instance + !REF: /module1/derived1/p2 + if (instance%p2(1.)/=2.) print *, "p2 failed" + !REF: /main/instance + !REF: /module1/derived1/p3 + if (instance%p3(1.)/=3) print *, "p3 failed" + !REF: /main/instance + !REF: /module1/derived1/p4 + if (.not.instance%p4(1.)) print *, "p4 failed" + !REF: /main/instance + !REF: /module1/derived1/p5 + if (instance%p5(1.)/=(5.,6.)) print *, "p5 failed" + !REF: /main/instance + !REF: /module1/derived1/p6 + if (instance%p6(1.)/=2.) print *, "p6 failed" + !REF: /main/instance + !REF: /module1/derived1/p7 + if (instance%p7(0.)/=1.) print *, "p7 failed" + !REF: /main/instance + !REF: /module1/derived1/p8 + if (instance%p8(1.)/="a") print *, "p8 failed" end program main -- 2.7.4