diff --git a/flang/include/flang/Evaluate/intrinsics.h b/flang/include/flang/Evaluate/intrinsics.h --- a/flang/include/flang/Evaluate/intrinsics.h +++ b/flang/include/flang/Evaluate/intrinsics.h @@ -23,6 +23,10 @@ class raw_ostream; } +namespace Fortran::semantics { +class Scope; +} + namespace Fortran::evaluate { class FoldingContext; @@ -74,6 +78,9 @@ static IntrinsicProcTable Configure( const common::IntrinsicTypeDefaultKinds &); + // Make *this aware of the __Fortran_builtins module to expose TEAM_TYPE &c. + void SupplyBuiltins(const semantics::Scope &) const; + // Check whether a name should be allowed to appear on an INTRINSIC // statement. bool IsIntrinsic(const std::string &) const; diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1050,6 +1050,15 @@ bool IsFunctionResult(const Symbol &); bool IsKindTypeParameter(const Symbol &); bool IsLenTypeParameter(const Symbol &); +bool IsExtensibleType(const DerivedTypeSpec *); +bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name); +// Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV? +bool IsTeamType(const DerivedTypeSpec *); +// Is this derived type TEAM_TYPE, C_PTR, or C_FUNPTR? +bool IsBadCoarrayType(const DerivedTypeSpec *); +// Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING +bool IsIsoCType(const DerivedTypeSpec *); +bool IsEventTypeOrLockType(const DerivedTypeSpec *); // ResolveAssociations() traverses use associations and host associations // like GetUltimate(), but also resolves through whole variable associations diff --git a/flang/include/flang/Evaluate/variable.h b/flang/include/flang/Evaluate/variable.h --- a/flang/include/flang/Evaluate/variable.h +++ b/flang/include/flang/Evaluate/variable.h @@ -226,7 +226,7 @@ // R914 coindexed-named-object // R924 image-selector, R926 image-selector-spec. -// C824 severely limits the usage of derived types with coarray ultimate +// C825 severely limits the usage of derived types with coarray ultimate // components: they can't be pointers, allocatables, arrays, coarrays, or // function results. They can be components of other derived types. // Although the F'2018 Standard never prohibits multiple image-selectors diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h --- a/flang/include/flang/Semantics/semantics.h +++ b/flang/include/flang/Semantics/semantics.h @@ -174,6 +174,13 @@ SourceName SaveTempName(std::string &&); SourceName GetTempName(const Scope &); + // Locate and process the contents of a built-in module on demand + Scope *GetBuiltinModule(const char *name); + + // Defines builtinsScope_ from the __Fortran_builtins module + void UseFortranBuiltinsModule(); + const Scope *GetBuiltinsScope() const { return builtinsScope_; } + private: void CheckIndexVarRedefine( const parser::CharBlock &, const Symbol &, parser::MessageFixedText &&); @@ -202,6 +209,7 @@ activeIndexVars_; UnorderedSymbolSet errorSymbols_; std::set tempNames_; + const Scope *builtinsScope_{nullptr}; // module __Fortran_builtins }; class Semantics { diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -97,13 +97,6 @@ bool IsBindCProcedure(const Scope &); bool IsProcName(const Symbol &); // proc-name bool IsFunctionResultWithSameNameAsFunction(const Symbol &); -bool IsExtensibleType(const DerivedTypeSpec *); -bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name); -// Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV -bool IsTeamType(const DerivedTypeSpec *); -// Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING -bool IsIsoCType(const DerivedTypeSpec *); -bool IsEventTypeOrLockType(const DerivedTypeSpec *); bool IsOrContainsEventOrLockComponent(const Symbol &); bool CanBeTypeBoundProc(const Symbol *); // Does a non-PARAMETER symbol have explicit initialization with =value or diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -16,6 +16,7 @@ #include "flang/Evaluate/shape.h" #include "flang/Evaluate/tools.h" #include "flang/Evaluate/type.h" +#include "flang/Semantics/scope.h" #include "flang/Semantics/tools.h" #include "llvm/Support/raw_ostream.h" #include @@ -105,7 +106,7 @@ static constexpr TypePattern DefaultLogical{ LogicalType, KindCode::defaultLogicalKind}; static constexpr TypePattern BOZ{IntType, KindCode::typeless}; -static constexpr TypePattern TEAM_TYPE{IntType, KindCode::teamType}; +static constexpr TypePattern TeamType{DerivedType, KindCode::teamType}; static constexpr TypePattern DoublePrecision{ RealType, KindCode::doublePrecision}; static constexpr TypePattern DoublePrecisionComplex{ @@ -237,6 +238,8 @@ common::Intent::In}; static constexpr IntrinsicDummyArgument OptionalMASK{"mask", AnyLogical, Rank::conformable, Optionality::optional, common::Intent::In}; +static constexpr IntrinsicDummyArgument OptionalTEAM{ + "team", TeamType, Rank::scalar, Optionality::optional, common::Intent::In}; struct IntrinsicInterface { static constexpr int maxArguments{7}; // if not a MAX/MIN(...) @@ -247,7 +250,7 @@ IntrinsicClass intrinsicClass{IntrinsicClass::elementalFunction}; std::optional Match(const CallCharacteristics &, const common::IntrinsicTypeDefaultKinds &, ActualArguments &, - FoldingContext &context) const; + FoldingContext &context, const semantics::Scope *builtins) const; int CountArguments() const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; }; @@ -452,6 +455,8 @@ {"floor", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, {"fraction", {{"x", SameReal}}, SameReal}, {"gamma", {{"x", SameReal}}, SameReal}, + {"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}}, + TeamType, Rank::scalar, IntrinsicClass::transformationalFunction}, {"huge", {{"x", SameIntOrReal, Rank::anyOrAssumedRank}}, SameIntOrReal, Rank::scalar, IntrinsicClass::inquiryFunction}, {"hypot", {{"x", OperandReal}, {"y", OperandReal}}, OperandReal}, @@ -476,10 +481,7 @@ {"ichar", {{"c", AnyChar}, DefaultingKIND}, KINDInt}, {"ieor", {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}}, SameInt}, {"ieor", {{"i", BOZ}, {"j", SameInt}}, SameInt}, - {"image_status", - {{"image", SameInt}, - {"team", TEAM_TYPE, Rank::scalar, Optionality::optional}}, - DefaultInt}, + {"image_status", {{"image", SameInt}, OptionalTEAM}, DefaultInt}, {"index", {{"string", SameChar}, {"substring", SameChar}, {"back", AnyLogical, Rank::scalar, Optionality::optional}, @@ -746,11 +748,14 @@ {"tan", {{"x", SameFloating}}, SameFloating}, {"tand", {{"x", SameFloating}}, SameFloating}, {"tanh", {{"x", SameFloating}}, SameFloating}, - // optional team dummy arguments needed to complete the following - // this_image versions - {"this_image", {{"coarray", AnyData, Rank::coarray}, OptionalDIM}, + {"team_number", {OptionalTEAM}, DefaultInt, Rank::scalar, + IntrinsicClass::transformationalFunction}, + {"this_image", + {{"coarray", AnyData, Rank::coarray}, RequiredDIM, OptionalTEAM}, + DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, + {"this_image", {{"coarray", AnyData, Rank::coarray}, OptionalTEAM}, DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, - {"this_image", {}, DefaultInt, Rank::scalar, + {"this_image", {OptionalTEAM}, DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar, IntrinsicClass::inquiryFunction}, @@ -824,8 +829,8 @@ }; // TODO: Coarray intrinsic functions -// LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX, -// STOPPED_IMAGES, TEAM_NUMBER, COSHAPE +// LCOBOUND, UCOBOUND, FAILED_IMAGES, IMAGE_INDEX, +// STOPPED_IMAGES, COSHAPE // TODO: Non-standard intrinsic functions // AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, @@ -1129,12 +1134,34 @@ // TODO: Atomic intrinsic subroutines: ATOMIC_ADD &al. // TODO: Collective intrinsic subroutines: CO_BROADCAST &al. +// Finds a built-in derived type and returns it as a DynamicType. +static DynamicType GetBuiltinDerivedType( + const semantics::Scope *builtinsScope, const char *which) { + if (!builtinsScope) { + common::die("INTERNAL: The __fortran_builtins module was not found, and " + "the type '%s' was required", + which); + } + auto iter{ + builtinsScope->find(semantics::SourceName{which, std::strlen(which)})}; + if (iter == builtinsScope->cend()) { + common::die( + "INTERNAL: The __fortran_builtins module does not define the type '%s'", + which); + } + const semantics::Symbol &symbol{*iter->second}; + const semantics::Scope &scope{DEREF(symbol.scope())}; + const semantics::DerivedTypeSpec &derived{DEREF(scope.derivedTypeSpec())}; + return DynamicType{derived}; +} + // Intrinsic interface matching against the arguments of a particular // procedure reference. std::optional IntrinsicInterface::Match( const CallCharacteristics &call, const common::IntrinsicTypeDefaultKinds &defaults, - ActualArguments &arguments, FoldingContext &context) const { + ActualArguments &arguments, FoldingContext &context, + const semantics::Scope *builtinsScope) const { auto &messages{context.messages()}; // Attempt to construct a 1-1 correspondence between the dummy arguments in // a particular intrinsic procedure's generic interface and the actual @@ -1293,9 +1320,13 @@ switch (d.typePattern.kindCode) { case KindCode::none: case KindCode::typeless: - case KindCode::teamType: // TODO: TEAM_TYPE argOk = false; break; + case KindCode::teamType: + argOk = !type->IsUnlimitedPolymorphic() && + type->category() == TypeCategory::Derived && + semantics::IsTeamType(&type->GetDerivedTypeSpec()); + break; case KindCode::defaultIntegerKind: argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Integer); break; @@ -1620,9 +1651,14 @@ resultType = DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()}; break; + case KindCode::teamType: + CHECK(result.categorySet == DerivedType); + CHECK(*category == TypeCategory::Derived); + resultType = DynamicType{ + GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")}; + break; case KindCode::defaultCharKind: case KindCode::typeless: - case KindCode::teamType: case KindCode::any: case KindCode::kindArg: case KindCode::dimArg: @@ -1728,10 +1764,20 @@ dummyArgs.emplace_back(dummyArgs[sameDummyArg.value()]); } else { auto category{d.typePattern.categorySet.LeastElement().value()}; - characteristics::TypeAndShape typeAndShape{ - DynamicType{category, defaults.GetDefaultKind(category)}}; - dummyArgs.emplace_back(std::string{d.keyword}, - characteristics::DummyDataObject{std::move(typeAndShape)}); + if (category == TypeCategory::Derived) { + // TODO: any other built-in derived types used as optional intrinsic + // dummies? + CHECK(d.typePattern.kindCode == KindCode::teamType); + characteristics::TypeAndShape typeAndShape{ + GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")}; + dummyArgs.emplace_back(std::string{d.keyword}, + characteristics::DummyDataObject{std::move(typeAndShape)}); + } else { + characteristics::TypeAndShape typeAndShape{ + DynamicType{category, defaults.GetDefaultKind(category)}}; + dummyArgs.emplace_back(std::string{d.keyword}, + characteristics::DummyDataObject{std::move(typeAndShape)}); + } } dummyArgs.back().SetOptional(); } @@ -1772,6 +1818,10 @@ } } + void SupplyBuiltins(const semantics::Scope &builtins) { + builtinsScope_ = &builtins; + } + bool IsIntrinsic(const std::string &) const; bool IsIntrinsicFunction(const std::string &) const; bool IsIntrinsicSubroutine(const std::string &) const; @@ -1779,8 +1829,8 @@ IntrinsicClass GetIntrinsicClass(const std::string &) const; std::string GetGenericIntrinsicName(const std::string &) const; - std::optional Probe(const CallCharacteristics &, - ActualArguments &, FoldingContext &, const IntrinsicProcTable &) const; + std::optional Probe( + const CallCharacteristics &, ActualArguments &, FoldingContext &) const; std::optional IsSpecificIntrinsicFunction( const std::string &) const; @@ -1797,6 +1847,7 @@ std::multimap genericFuncs_; std::multimap specificFuncs_; std::multimap subroutines_; + const semantics::Scope *builtinsScope_{nullptr}; }; bool IntrinsicProcTable::Implementation::IsIntrinsicFunction( @@ -2228,7 +2279,7 @@ // match for a given procedure reference. std::optional IntrinsicProcTable::Implementation::Probe( const CallCharacteristics &call, ActualArguments &arguments, - FoldingContext &context, const IntrinsicProcTable &intrinsics) const { + FoldingContext &context) const { // All special cases handled here before the table probes below must // also be recognized as special names in IsIntrinsicSubroutine(). @@ -2248,8 +2299,8 @@ if (call.isSubroutineCall) { auto subrRange{subroutines_.equal_range(call.name)}; for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) { - if (auto specificCall{ - iter->second->Match(call, defaults_, arguments, context)}) { + if (auto specificCall{iter->second->Match( + call, defaults_, arguments, context, builtinsScope_)}) { return specificCall; } } @@ -2270,8 +2321,8 @@ auto matchOrBufferMessages{ [&](const IntrinsicInterface &intrinsic, parser::Messages &buffer) -> std::optional { - if (auto specificCall{ - intrinsic.Match(call, defaults_, arguments, localContext)}) { + if (auto specificCall{intrinsic.Match( + call, defaults_, arguments, localContext, builtinsScope_)}) { if (finalBuffer) { finalBuffer->Annex(std::move(localBuffer)); } @@ -2416,35 +2467,40 @@ return result; } +void IntrinsicProcTable::SupplyBuiltins( + const semantics::Scope &builtins) const { + DEREF(impl_.get()).SupplyBuiltins(builtins); +} + bool IntrinsicProcTable::IsIntrinsic(const std::string &name) const { - return DEREF(impl_).IsIntrinsic(name); + return DEREF(impl_.get()).IsIntrinsic(name); } bool IntrinsicProcTable::IsIntrinsicFunction(const std::string &name) const { - return DEREF(impl_).IsIntrinsicFunction(name); + return DEREF(impl_.get()).IsIntrinsicFunction(name); } bool IntrinsicProcTable::IsIntrinsicSubroutine(const std::string &name) const { - return DEREF(impl_).IsIntrinsicSubroutine(name); + return DEREF(impl_.get()).IsIntrinsicSubroutine(name); } IntrinsicClass IntrinsicProcTable::GetIntrinsicClass( const std::string &name) const { - return DEREF(impl_).GetIntrinsicClass(name); + return DEREF(impl_.get()).GetIntrinsicClass(name); } std::string IntrinsicProcTable::GetGenericIntrinsicName( const std::string &name) const { - return DEREF(impl_).GetGenericIntrinsicName(name); + return DEREF(impl_.get()).GetGenericIntrinsicName(name); } std::optional IntrinsicProcTable::Probe( const CallCharacteristics &call, ActualArguments &arguments, FoldingContext &context) const { - return DEREF(impl_).Probe(call, arguments, context, *this); + return DEREF(impl_.get()).Probe(call, arguments, context); } std::optional IntrinsicProcTable::IsSpecificIntrinsicFunction(const std::string &name) const { - return DEREF(impl_).IsSpecificIntrinsicFunction(name); + return DEREF(impl_.get()).IsSpecificIntrinsicFunction(name); } llvm::raw_ostream &TypePattern::Dump(llvm::raw_ostream &o) const { @@ -2510,7 +2566,7 @@ } llvm::raw_ostream &IntrinsicProcTable::Dump(llvm::raw_ostream &o) const { - return impl_->Dump(o); + return DEREF(impl_.get()).Dump(o); } // In general C846 prohibits allocatable coarrays to be passed to INTENT(OUT) diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1186,6 +1186,40 @@ return param && param->attr() == common::TypeParamAttr::Len; } +bool IsExtensibleType(const DerivedTypeSpec *derived) { + return derived && !IsIsoCType(derived) && + !derived->typeSymbol().attrs().test(Attr::BIND_C) && + !derived->typeSymbol().get().sequence(); +} + +bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) { + if (!derived) { + return false; + } else { + const auto &symbol{derived->typeSymbol()}; + return &symbol.owner() == symbol.owner().context().GetBuiltinsScope() && + symbol.name() == "__builtin_"s + name; + } +} + +bool IsIsoCType(const DerivedTypeSpec *derived) { + return IsBuiltinDerivedType(derived, "c_ptr") || + IsBuiltinDerivedType(derived, "c_funptr"); +} + +bool IsTeamType(const DerivedTypeSpec *derived) { + return IsBuiltinDerivedType(derived, "team_type"); +} + +bool IsBadCoarrayType(const DerivedTypeSpec *derived) { + return IsTeamType(derived) || IsIsoCType(derived); +} + +bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) { + return IsBuiltinDerivedType(derivedTypeSpec, "event_type") || + IsBuiltinDerivedType(derivedTypeSpec, "lock_type"); +} + int CountLenParameters(const DerivedTypeSpec &type) { return std::count_if(type.parameters().begin(), type.parameters().end(), [](const auto &pair) { return pair.second.isLen(); }); diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -455,24 +455,30 @@ CheckAssumedTypeEntity(symbol, details); WarnMissingFinal(symbol); if (!details.coshape().empty()) { - bool isDeferredShape{details.coshape().IsDeferredShape()}; + bool isDeferredCoshape{details.coshape().IsDeferredShape()}; if (IsAllocatable(symbol)) { - if (!isDeferredShape) { // C827 + if (!isDeferredCoshape) { // C827 messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred" " coshape"_err_en_US, symbol.name()); } } else if (symbol.owner().IsDerivedType()) { // C746 std::string deferredMsg{ - isDeferredShape ? "" : " and have a deferred coshape"}; + isDeferredCoshape ? "" : " and have a deferred coshape"}; messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE" " attribute%s"_err_en_US, symbol.name(), deferredMsg); } else { if (!details.coshape().IsAssumedSize()) { // C828 messages_.Say( - "Component '%s' is a non-ALLOCATABLE coarray and must have" - " an explicit coshape"_err_en_US, + "'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US, + symbol.name()); + } + } + if (const DeclTypeSpec * type{details.type()}) { + if (IsBadCoarrayType(type->AsDerived())) { // C747 & C824 + messages_.Say( + "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US, symbol.name()); } } diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -3083,7 +3083,7 @@ parser::CharBlock intrinsic, ActualArguments &&arguments) { if (std::optional specificCall{ context_.intrinsics().Probe(CallCharacteristics{intrinsic.ToString()}, - arguments, context_.foldingContext())}) { + arguments, GetFoldingContext())}) { return MakeFunctionRef(intrinsic, ProcedureDesignator{std::move(specificCall->specificIntrinsic)}, std::move(specificCall->arguments)); diff --git a/flang/lib/Semantics/mod-file.h b/flang/lib/Semantics/mod-file.h --- a/flang/lib/Semantics/mod-file.h +++ b/flang/lib/Semantics/mod-file.h @@ -70,7 +70,8 @@ // Find and read the module file for a module or submodule. // If ancestor is specified, look for a submodule of that module. // Return the Scope for that module/submodule or nullptr on error. - Scope *Read(const SourceName &, Scope *ancestor = nullptr); + Scope *Read( + const SourceName &, Scope *ancestor = nullptr, bool silent = false); private: SemanticsContext &context_; diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -805,7 +805,8 @@ return expectSum == actualSum; } -Scope *ModFileReader::Read(const SourceName &name, Scope *ancestor) { +Scope *ModFileReader::Read( + const SourceName &name, Scope *ancestor, bool silent) { std::string ancestorName; // empty for module if (ancestor) { if (auto *scope{ancestor->FindSubmodule(name)}) { @@ -826,10 +827,12 @@ auto path{ModFileName(name, ancestorName, context_.moduleFileSuffix())}; const auto *sourceFile{parsing.Prescan(path, options)}; if (parsing.messages().AnyFatalError()) { - for (auto &msg : parsing.messages().messages()) { - std::string str{msg.ToString()}; - Say(name, ancestorName, parser::MessageFixedText{str.c_str(), str.size()}, - path); + if (!silent) { + for (auto &msg : parsing.messages().messages()) { + std::string str{msg.ToString()}; + Say(name, ancestorName, + parser::MessageFixedText{str.c_str(), str.size()}, path); + } } return nullptr; } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -4224,17 +4224,7 @@ "POINTER or ALLOCATABLE"_err_en_US); } } - if (!coarraySpec().empty()) { // C747 - if (IsTeamType(derived)) { - Say("A coarray component may not be of type TEAM_TYPE from " - "ISO_FORTRAN_ENV"_err_en_US); - } else { - if (IsIsoCType(derived)) { - Say("A coarray component may not be of type C_PTR or C_FUNPTR from " - "ISO_C_BINDING"_err_en_US); - } - } - } + // TODO: This would be more appropriate in CheckDerivedType() if (auto it{FindCoarrayUltimateComponent(*derived)}) { // C748 std::string ultimateName{it.BuildResultDesignatorName()}; // Strip off the leading "%" diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -1071,11 +1071,8 @@ RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables( SemanticsContext &context) { - ModFileReader reader{context}; RuntimeDerivedTypeTables result; - static const char schemataName[]{"__fortran_type_info"}; - SourceName schemataModule{schemataName, std::strlen(schemataName)}; - result.schemata = reader.Read(schemataModule); + result.schemata = context.GetBuiltinModule("__fortran_type_info"); if (result.schemata) { RuntimeTableBuilder builder{context, result}; builder.DescribeTypes(context.globalScope(), false); diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp --- a/flang/lib/Semantics/semantics.cpp +++ b/flang/lib/Semantics/semantics.cpp @@ -342,7 +342,35 @@ return SaveTempName(".F18."s + std::to_string(tempNames_.size())); } +Scope *SemanticsContext::GetBuiltinModule(const char *name) { + return ModFileReader{*this}.Read( + SourceName{name, std::strlen(name)}, nullptr, true /*silence errors*/); +} + +void SemanticsContext::UseFortranBuiltinsModule() { + if (builtinsScope_ == nullptr) { + builtinsScope_ = GetBuiltinModule("__fortran_builtins"); + if (builtinsScope_) { + intrinsics_.SupplyBuiltins(*builtinsScope_); + } + } +} + bool Semantics::Perform() { + // Implicitly USE the __Fortran_builtins module so that special types + // (e.g., __builtin_team_type) are available to semantics, esp. for + // intrinsic checking. + if (!program_.v.empty()) { + const auto *frontModule{std::get_if>( + &program_.v.front().u)}; + if (frontModule && + std::get>(frontModule->value().t) + .statement.v.source == "__fortran_builtins") { + // Don't try to read the builtins module when we're actually building it. + } else { + context_.UseFortranBuiltinsModule(); + } + } return ValidateLabels(context_, program_) && parser::CanonicalizeDo(program_) && // force line break CanonicalizeAcc(context_.messages(), program_) && diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -519,38 +519,6 @@ return nullptr; } -bool IsExtensibleType(const DerivedTypeSpec *derived) { - return derived && !IsIsoCType(derived) && - !derived->typeSymbol().attrs().test(Attr::BIND_C) && - !derived->typeSymbol().get().sequence(); -} - -bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) { - if (!derived) { - return false; - } else { - const auto &symbol{derived->typeSymbol()}; - return symbol.owner().IsModule() && - (symbol.owner().GetName().value() == "__fortran_builtins" || - symbol.owner().GetName().value() == "__fortran_type_info") && - symbol.name() == "__builtin_"s + name; - } -} - -bool IsIsoCType(const DerivedTypeSpec *derived) { - return IsBuiltinDerivedType(derived, "c_ptr") || - IsBuiltinDerivedType(derived, "c_funptr"); -} - -bool IsTeamType(const DerivedTypeSpec *derived) { - return IsBuiltinDerivedType(derived, "team_type"); -} - -bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) { - return IsBuiltinDerivedType(derivedTypeSpec, "event_type") || - IsBuiltinDerivedType(derivedTypeSpec, "lock_type"); -} - bool IsOrContainsEventOrLockComponent(const Symbol &original) { const Symbol &symbol{ResolveAssociations(original)}; if (const auto *details{symbol.detailsIf()}) { diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90 --- a/flang/module/__fortran_builtins.f90 +++ b/flang/module/__fortran_builtins.f90 @@ -12,8 +12,6 @@ ! standard names of the procedures. module __Fortran_builtins - use __Fortran_type_info, only: __builtin_c_ptr, __builtin_c_funptr - intrinsic :: __builtin_c_f_pointer intrinsic :: sizeof ! extension @@ -21,6 +19,14 @@ private :: selected_int_kind integer, parameter, private :: int64 = selected_int_kind(18) + type :: __builtin_c_ptr + integer(kind=int64) :: __address + end type + + type :: __builtin_c_funptr + integer(kind=int64) :: __address + end type + type :: __builtin_event_type integer(kind=int64) :: __count end type @@ -44,4 +50,12 @@ __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, & __builtin_ieee_support_underflow_control + type, private :: __force_derived_type_instantiations + type(__builtin_c_ptr) :: c_ptr + type(__builtin_c_funptr) :: c_funptr + type(__builtin_event_type) :: event_type + type(__builtin_lock_type) :: lock_type + type(__builtin_team_type) :: team_type + end type + end module diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90 --- a/flang/module/__fortran_type_info.f90 +++ b/flang/module/__fortran_type_info.f90 @@ -13,18 +13,12 @@ module __Fortran_type_info + use __Fortran_builtins, only: __builtin_c_ptr, __builtin_c_funptr + private integer, parameter :: int64 = selected_int_kind(18) - type, public :: __builtin_c_ptr - integer(kind=int64) :: __address - end type - - type, public :: __builtin_c_funptr - integer(kind=int64) :: __address - end type - type :: DerivedType ! "TBP" bindings appear first. Inherited bindings, with overrides already ! applied, appear in the initial entries in the same order as they diff --git a/flang/test/Semantics/misc-declarations.f90 b/flang/test/Semantics/misc-declarations.f90 --- a/flang/test/Semantics/misc-declarations.f90 +++ b/flang/test/Semantics/misc-declarations.f90 @@ -6,7 +6,7 @@ module m !ERROR: 'mustbedeferred' is an ALLOCATABLE coarray and must have a deferred coshape real, allocatable :: mustBeDeferred[*] ! C827 - !ERROR: Component 'mustbeexplicit' is a non-ALLOCATABLE coarray and must have an explicit coshape + !ERROR: 'mustbeexplicit' is a non-ALLOCATABLE coarray and must have an explicit coshape real :: mustBeExplicit[:] ! C828 type :: hasCoarray real, allocatable :: coarray[:] diff --git a/flang/test/Semantics/resolve88.f90 b/flang/test/Semantics/resolve88.f90 --- a/flang/test/Semantics/resolve88.f90 +++ b/flang/test/Semantics/resolve88.f90 @@ -41,17 +41,17 @@ end type goodC_funptrCoarrayType type team_typeCoarrayType - !ERROR: A coarray component may not be of type TEAM_TYPE from ISO_FORTRAN_ENV + !ERROR: Coarray 'field' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR type(team_type), allocatable, codimension[:] :: field end type team_typeCoarrayType type c_ptrCoarrayType - !ERROR: A coarray component may not be of type C_PTR or C_FUNPTR from ISO_C_BINDING + !ERROR: Coarray 'field' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR type(c_ptr), allocatable, codimension[:] :: field end type c_ptrCoarrayType type c_funptrCoarrayType - !ERROR: A coarray component may not be of type C_PTR or C_FUNPTR from ISO_C_BINDING + !ERROR: Coarray 'field' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR type(c_funptr), allocatable, codimension[:] :: field end type c_funptrCoarrayType diff --git a/flang/test/Semantics/this_image.f90 b/flang/test/Semantics/this_image.f90 --- a/flang/test/Semantics/this_image.f90 +++ b/flang/test/Semantics/this_image.f90 @@ -3,20 +3,29 @@ subroutine test use, intrinsic :: iso_fortran_env, only: team_type - type(team_type) :: oregon, coteam[*] + type(team_type) :: team + !ERROR: Coarray 'coteam' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR + type(team_type) :: coteam[*] integer :: coscalar[*], coarray(3)[*] save :: coteam, coscalar, coarray ! correct calls, should produce no errors + team = get_team() print *, this_image() + print *, this_image(team) print *, this_image(coarray) - print *, this_image(coscalar,1) - print *, this_image(coarray,1) + print *, this_image(coarray, team) + print *, this_image(coarray, 1) + print *, this_image(coarray, 1, team) + print *, this_image(coscalar) + print *, this_image(coscalar, team) + print *, this_image(coscalar, 1) + print *, this_image(coscalar, 1, team) !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'this_image' print *, this_image(array,1) - ! TODO: More complete testing requires implementation of team_type - ! actual arguments in flang/lib/Evaluate/intrinsics.cpp + print *, team_number() + print *, team_number(team) end subroutine diff --git a/flang/tools/f18/CMakeLists.txt b/flang/tools/f18/CMakeLists.txt --- a/flang/tools/f18/CMakeLists.txt +++ b/flang/tools/f18/CMakeLists.txt @@ -20,12 +20,13 @@ # Create module files directly from the top-level module source directory foreach(filename ${MODULES}) set(base ${FLANG_INTRINSIC_MODULES_DIR}/${filename}) - if(${filename} MATCHES "__fortran_type_info") + if(${filename} MATCHES "__fortran_builtins") set(depends "") - elseif(${filename} MATCHES "__fortran_builtins") - set(depends ${FLANG_INTRINSIC_MODULES_DIR}/__fortran_type_info.mod) else() set(depends ${FLANG_INTRINSIC_MODULES_DIR}/__fortran_builtins.mod) + if(NOT ${filename} MATCHES "__fortran_type_info") + set(depends ${FLANG_INTRINSIC_MODULES_DIR}/__fortran_type_info.mod) + endif() endif() add_custom_command(OUTPUT ${base}.mod COMMAND ${CMAKE_COMMAND} -E make_directory ${FLANG_INTRINSIC_MODULES_DIR}