#include <cstddef>
#include <initializer_list>
#include <optional>
+#include <ostream>
+#include <string>
#include <type_traits>
namespace Fortran::common {
}
}
+ template<typename FUNC> 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_;
};
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_
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:
add_library(FortranEvaluate
call.cc
+ characteristics.cc
common.cc
complex.cc
constant.cc
--- /dev/null
+// 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 <ostream>
+#include <sstream>
+#include <string>
+
+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<evaluate::characteristics::Procedure>;
+template<>
+OwningPointer<evaluate::characteristics::Procedure>::~OwningPointer() {
+ delete p_;
+ p_ = nullptr;
+}
+}
--- /dev/null
+// 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 <memory>
+#include <ostream>
+#include <variant>
+#include <vector>
+
+// Forward declare Procedure so dummy procedures can use it indirectly
+namespace Fortran::evaluate::characteristics {
+struct Procedure;
+}
+namespace Fortran::common {
+extern template class OwningPointer<evaluate::characteristics::Procedure>;
+}
+
+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<Expr<SubscriptInteger>> characterLength;
+ std::vector<std::optional<Expr<SubscriptInteger>>> shape;
+ std::vector<Expr<SubscriptInteger>> coshape;
+ common::Intent intent{common::Intent::Default};
+ common::EnumSet<Attr, 32> 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<Procedure> explicitProcedure;
+ common::EnumSet<Attr, 32> 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<DummyDataObject, DummyProcedure, AlternateReturn>;
+
+// 15.3.3
+struct FunctionResult {
+ ENUM_CLASS(Attr, Polymorphic, Allocatable, Pointer, Contiguous,
+ ProcedurePointer)
+ DynamicType type;
+ std::unique_ptr<Expr<SubscriptInteger>> characterLength;
+ int rank{0};
+ common::EnumSet<Attr, 32> 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> functionResult; // absent means subroutine
+ std::vector<DummyArgument> dummyArguments;
+ common::EnumSet<Attr, 32> attrs;
+ bool operator==(const Procedure &) const;
+ std::ostream &Dump(std::ostream &) const;
+};
+}
+#endif // FORTRAN_EVALUATE_CHARACTERISTICS_H_
// 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<evaluate::GenericExprWrapper>;
template<> OwningPointer<evaluate::GenericExprWrapper>::~OwningPointer() {
delete p_;
p_ = nullptr;
}
-template class OwningPointer<evaluate::GenericExprWrapper>;
}
}
}
+ bool IsIntrinsic(const std::string &) const;
+
std::optional<SpecificCall> Probe(const CallCharacteristics &,
ActualArguments &, parser::ContextualMessages *) const;
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<SpecificCall> IntrinsicProcTable::Implementation::Probe(
} 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;
}
}
return result;
}
+bool IntrinsicProcTable::IsIntrinsic(const std::string &name) const {
+ CHECK(impl_ != nullptr || !"IntrinsicProcTable: not configured");
+ return impl_->IsIntrinsic(name);
+}
+
std::optional<SpecificCall> IntrinsicProcTable::Probe(
const CallCharacteristics &call, ActualArguments &arguments,
parser::ContextualMessages *messages) const {
#define FORTRAN_EVALUATE_INTRINSICS_H_
#include "call.h"
+#include "characteristics.h"
#include "type.h"
#include "../common/default-kinds.h"
#include "../parser/char-block.h"
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 {
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.
// 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<std::list<parser::ActualArgSpec>>(funcRef.v.t)) {
void CheckCommonBlocks();
void CheckSaveStmts();
bool CheckNotInBlock(const char *);
+ bool NameIsKnownOrIntrinsic(const parser::Name &);
private:
// The attribute corresponding to the statement containing an ObjectDecl
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<typename T> void Post(const parser::LoopBounds<T> &);
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) {
}
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
}
bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) {
if (auto *name{std::get_if<parser::Name>(&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<parser::Name>(&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<parser::ProcInterface &>(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<parser::ProcInterface &>(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;
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) {
bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
const parser::Name &name) {
- // TODO pmk: invoke this on unresolved actual arguments, too
if (context()
.intrinsics()
.IsUnrestrictedSpecificIntrinsicFunction(name.source.ToString())
// 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})};
},
x.u);
}
+bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) {
+ // Resolve unrestricted specific intrinsic procedures as in "p => cos".
+ const auto &expr{std::get<parser::Expr>(x.t)};
+ if (const auto *designator{
+ std::get_if<common::Indirection<parser::Designator>>(&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<parser::Name>(&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<parser::DataRef>(x.t));
}
symbol11.f90
kinds01.f90
kinds03.f90
+ procinterface01.f90
)
# These test files have expected .mod file contents in the source
! 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
projects / platform / upstream / llvm.git / commitdiff