4269 lines · cpp
1//===-- lib/Semantics/check-declarations.cpp ------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9// Static declaration checking10 11#include "check-declarations.h"12#include "definable.h"13#include "pointer-assignment.h"14#include "flang/Evaluate/check-expression.h"15#include "flang/Evaluate/fold.h"16#include "flang/Evaluate/tools.h"17#include "flang/Parser/characters.h"18#include "flang/Semantics/scope.h"19#include "flang/Semantics/semantics.h"20#include "flang/Semantics/symbol.h"21#include "flang/Semantics/tools.h"22#include "flang/Semantics/type.h"23#include <algorithm>24#include <map>25#include <string>26 27namespace Fortran::semantics {28 29namespace characteristics = evaluate::characteristics;30using characteristics::DummyArgument;31using characteristics::DummyDataObject;32using characteristics::DummyProcedure;33using characteristics::FunctionResult;34using characteristics::Procedure;35 36class DistinguishabilityHelper;37 38class CheckHelper {39public:40 explicit CheckHelper(SemanticsContext &c) : context_{c} {}41 42 SemanticsContext &context() { return context_; }43 void Check() { Check(context_.globalScope()); }44 void Check(const ParamValue &, bool canBeAssumed);45 void Check(const Bound &bound) {46 CheckSpecExpr(bound.GetExplicit(), /*forElementalFunctionResult=*/false);47 }48 void Check(const ShapeSpec &spec) {49 Check(spec.lbound());50 Check(spec.ubound());51 }52 void Check(const ArraySpec &);53 void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);54 void Check(const Symbol &);55 void CheckCommonBlock(const Symbol &);56 void Check(const Scope &);57 const Procedure *Characterize(const Symbol &);58 59private:60 template <typename A>61 void CheckSpecExpr(const A &x, bool forElementalFunctionResult) {62 evaluate::CheckSpecificationExpr(63 x, DEREF(scope_), foldingContext_, forElementalFunctionResult);64 }65 void CheckValue(const Symbol &, const DerivedTypeSpec *);66 void CheckVolatile(const Symbol &, const DerivedTypeSpec *);67 void CheckContiguous(const Symbol &);68 void CheckPointer(const Symbol &);69 void CheckPassArg(70 const Symbol &proc, const Symbol *interface, const WithPassArg &);71 void CheckProcBinding(const Symbol &, const ProcBindingDetails &);72 void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);73 void CheckPointerInitialization(const Symbol &);74 void CheckArraySpec(const Symbol &, const ArraySpec &);75 void CheckProcEntity(const Symbol &, const ProcEntityDetails &);76 void CheckSubprogram(const Symbol &, const SubprogramDetails &);77 void CheckExternal(const Symbol &);78 void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);79 void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);80 bool CheckFinal(81 const Symbol &subroutine, SourceName, const Symbol &derivedType);82 bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name,83 const Symbol &f2, SourceName f2name, const Symbol &derivedType);84 void CheckGeneric(const Symbol &, const GenericDetails &);85 void CheckHostAssoc(const Symbol &, const HostAssocDetails &);86 bool CheckDefinedOperator(87 SourceName, GenericKind, const Symbol &, const Procedure &);88 std::optional<parser::MessageFixedText> CheckNumberOfArgs(89 const GenericKind &, std::size_t);90 bool CheckDefinedOperatorArg(91 const SourceName &, const Symbol &, const Procedure &, std::size_t);92 bool CheckDefinedAssignment(const Symbol &, const Procedure &);93 bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);94 void CollectSpecifics(95 DistinguishabilityHelper &, const Symbol &, const GenericDetails &);96 void CheckSpecifics(const Symbol &, const GenericDetails &);97 void CheckEquivalenceSet(const EquivalenceSet &);98 void CheckEquivalenceObject(const EquivalenceObject &);99 void CheckBlockData(const Scope &);100 void CheckGenericOps(const Scope &);101 bool CheckConflicting(const Symbol &, Attr, Attr);102 void WarnMissingFinal(const Symbol &);103 void CheckSymbolType(const Symbol &); // C702104 bool InPure() const {105 return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);106 }107 bool InElemental() const {108 return innermostSymbol_ && IsElementalProcedure(*innermostSymbol_);109 }110 bool InFunction() const {111 return innermostSymbol_ && IsFunction(*innermostSymbol_);112 }113 bool InInterface() const {114 const SubprogramDetails *subp{innermostSymbol_115 ? innermostSymbol_->detailsIf<SubprogramDetails>()116 : nullptr};117 return subp && subp->isInterface();118 }119 template <typename... A>120 parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) {121 parser::Message *msg{messages_.Say(std::forward<A>(x)...)};122 if (msg && messages_.at().begin() != symbol.name().begin()) {123 evaluate::AttachDeclaration(*msg, symbol);124 }125 return msg;126 }127 bool InModuleFile() const {128 return FindModuleFileContaining(context_.FindScope(messages_.at())) !=129 nullptr;130 }131 template <typename FeatureOrUsageWarning, typename... A>132 parser::Message *Warn(FeatureOrUsageWarning warning, A &&...x) {133 return messages_.Warn(InModuleFile(), context_.languageFeatures(), warning,134 std::forward<A>(x)...);135 }136 template <typename FeatureOrUsageWarning, typename... A>137 parser::Message *Warn(138 FeatureOrUsageWarning warning, parser::CharBlock source, A &&...x) {139 return messages_.Warn(FindModuleFileContaining(context_.FindScope(source)),140 context_.languageFeatures(), warning, source, std::forward<A>(x)...);141 }142 bool IsResultOkToDiffer(const FunctionResult &);143 void CheckGlobalName(const Symbol &);144 void CheckProcedureAssemblyName(const Symbol &symbol);145 void CheckExplicitSave(const Symbol &);146 parser::Messages WhyNotInteroperableDerivedType(const Symbol &);147 parser::Messages WhyNotInteroperableObject(const Symbol &,148 bool allowNonInteroperableType = false, bool forCommonBlock = false);149 parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);150 parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);151 void CheckBindC(const Symbol &);152 // Check functions for defined I/O procedures153 void CheckDefinedIoProc(154 const Symbol &, const GenericDetails &, common::DefinedIo);155 bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);156 void CheckDioDummyIsDerived(157 const Symbol &, const Symbol &, common::DefinedIo ioKind, const Symbol &);158 void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);159 void CheckDioDummyIsScalar(const Symbol &, const Symbol &);160 void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);161 void CheckDioDtvArg(const Symbol &proc, const Symbol &subp, const Symbol *arg,162 common::DefinedIo, const Symbol &generic);163 void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &);164 void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);165 void CheckDioAssumedLenCharacterArg(166 const Symbol &, const Symbol *, std::size_t, Attr);167 void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);168 void CheckDioArgCount(const Symbol &, common::DefinedIo ioKind, std::size_t);169 struct TypeWithDefinedIo {170 const DerivedTypeSpec &type;171 common::DefinedIo ioKind;172 const Symbol &proc;173 const Symbol &generic;174 };175 void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &, common::DefinedIo,176 const Symbol &, const Symbol &generic);177 void CheckModuleProcedureDef(const Symbol &);178 179 SemanticsContext &context_;180 evaluate::FoldingContext &foldingContext_{context_.foldingContext()};181 parser::ContextualMessages &messages_{foldingContext_.messages()};182 const Scope *scope_{nullptr};183 bool scopeIsUninstantiatedPDT_{false};184 // This symbol is the one attached to the innermost enclosing scope185 // that has a symbol.186 const Symbol *innermostSymbol_{nullptr};187 // Cache of calls to Procedure::Characterize(Symbol)188 std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>189 characterizeCache_;190 // Collection of module procedure symbols with non-BIND(C)191 // global names, qualified by their module.192 std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;193 // Collection of symbols with global names, BIND(C) or otherwise194 std::map<std::string, SymbolRef> globalNames_;195 // Collection of external procedures without global definitions196 std::map<std::string, SymbolRef> externalNames_;197 // Collection of target dependent assembly names of external and BIND(C)198 // procedures.199 std::map<std::string, SymbolRef> procedureAssemblyNames_;200 // Derived types that have been examined by WhyNotInteroperable_XXX201 UnorderedSymbolSet examinedByWhyNotInteroperable_;202};203 204class DistinguishabilityHelper {205public:206 DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}207 void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);208 void Check(const Scope &);209 210private:211 void SayNotDistinguishable(const Scope &, const SourceName &, GenericKind,212 const Symbol &, const Symbol &, bool isHardConflict);213 void AttachDeclaration(parser::Message &, const Scope &, const Symbol &);214 215 SemanticsContext &context_;216 struct ProcedureInfo {217 GenericKind kind;218 const Procedure &procedure;219 };220 std::map<SourceName, std::map<const Symbol *, ProcedureInfo>>221 nameToSpecifics_;222};223 224void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {225 if (value.isAssumed()) {226 if (!canBeAssumed) { // C795, C721, C726227 messages_.Say(228 "An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, character named constant, or external function result"_err_en_US);229 }230 } else {231 CheckSpecExpr(value.GetExplicit(), /*forElementalFunctionResult=*/false);232 }233}234 235void CheckHelper::Check(const ArraySpec &shape) {236 for (const auto &spec : shape) {237 Check(spec);238 }239}240 241void CheckHelper::Check(242 const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {243 if (type.category() == DeclTypeSpec::Character) {244 Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);245 } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {246 for (auto &parm : derived->parameters()) {247 Check(parm.second, canHaveAssumedTypeParameters);248 }249 }250}251 252static bool IsBlockData(const Scope &scope) {253 return scope.kind() == Scope::Kind::BlockData;254}255 256static bool IsBlockData(const Symbol &symbol) {257 return symbol.scope() && IsBlockData(*symbol.scope());258}259 260void CheckHelper::Check(const Symbol &symbol) {261 if (symbol.has<UseErrorDetails>()) {262 return;263 }264 if (symbol.name().size() > common::maxNameLen &&265 &symbol == &symbol.GetUltimate()) {266 Warn(common::LanguageFeature::LongNames, symbol.name(),267 "%s has length %d, which is greater than the maximum name length %d"_port_en_US,268 symbol.name(), symbol.name().size(), common::maxNameLen);269 }270 if (context_.HasError(symbol)) {271 return;272 }273 auto restorer{messages_.SetLocation(symbol.name())};274 context_.set_location(symbol.name());275 const DeclTypeSpec *type{symbol.GetType()};276 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};277 bool isDone{false};278 common::visit(279 common::visitors{280 [&](const UseDetails &x) { isDone = true; },281 [&](const HostAssocDetails &x) {282 CheckHostAssoc(symbol, x);283 isDone = true;284 },285 [&](const ProcBindingDetails &x) {286 CheckProcBinding(symbol, x);287 isDone = true;288 },289 [&](const ObjectEntityDetails &x) { CheckObjectEntity(symbol, x); },290 [&](const ProcEntityDetails &x) { CheckProcEntity(symbol, x); },291 [&](const SubprogramDetails &x) { CheckSubprogram(symbol, x); },292 [&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); },293 [&](const GenericDetails &x) { CheckGeneric(symbol, x); },294 [](const auto &) {},295 },296 symbol.details());297 if (symbol.attrs().test(Attr::VOLATILE)) {298 CheckVolatile(symbol, derived);299 }300 if (symbol.attrs().test(Attr::BIND_C)) {301 CheckBindC(symbol);302 }303 if (symbol.attrs().test(Attr::SAVE) &&304 !symbol.implicitAttrs().test(Attr::SAVE)) {305 CheckExplicitSave(symbol);306 }307 if (symbol.attrs().test(Attr::CONTIGUOUS)) {308 CheckContiguous(symbol);309 }310 CheckGlobalName(symbol);311 CheckProcedureAssemblyName(symbol);312 if (symbol.attrs().test(Attr::ASYNCHRONOUS) &&313 !evaluate::IsVariable(symbol)) {314 messages_.Say(315 "An entity may not have the ASYNCHRONOUS attribute unless it is a variable"_err_en_US);316 }317 if (symbol.attrs().HasAny({Attr::INTENT_IN, Attr::INTENT_INOUT,318 Attr::INTENT_OUT, Attr::OPTIONAL, Attr::VALUE}) &&319 !IsDummy(symbol)) {320 if (context_.IsEnabled(321 common::LanguageFeature::IgnoreIrrelevantAttributes)) {322 Warn(common::LanguageFeature::IgnoreIrrelevantAttributes,323 "Only a dummy argument should have an INTENT, VALUE, or OPTIONAL attribute"_warn_en_US);324 } else {325 messages_.Say(326 "Only a dummy argument may have an INTENT, VALUE, or OPTIONAL attribute"_err_en_US);327 }328 } else if (symbol.attrs().test(Attr::VALUE)) {329 CheckValue(symbol, derived);330 }331 332 if (isDone) {333 return; // following checks do not apply334 }335 336 if (symbol.attrs().test(Attr::PROTECTED)) {337 if (symbol.owner().kind() != Scope::Kind::Module) { // C854338 messages_.Say(339 "A PROTECTED entity must be in the specification part of a module"_err_en_US);340 }341 if (!evaluate::IsVariable(symbol) && !IsProcedurePointer(symbol)) { // C855342 messages_.Say(343 "A PROTECTED entity must be a variable or pointer"_err_en_US);344 }345 if (FindCommonBlockContaining(symbol)) { // C856346 messages_.Say(347 "A PROTECTED entity may not be in a common block"_err_en_US);348 }349 }350 if (IsPointer(symbol)) {351 CheckPointer(symbol);352 }353 if (InPure()) {354 if (InInterface()) {355 // Declarations in interface definitions "have no effect" if they356 // are not pertinent to the characteristics of the procedure.357 // Restrictions on entities in pure procedure interfaces don't need358 // enforcement.359 } else if (symbol.has<AssocEntityDetails>() ||360 FindCommonBlockContaining(symbol)) {361 // can look like they have SAVE but are fine in PURE362 } else if (IsSaved(symbol)) {363 if (IsInitialized(symbol)) {364 messages_.Say(365 "A pure subprogram may not initialize a variable"_err_en_US);366 } else {367 messages_.Say(368 "A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);369 }370 }371 if (symbol.attrs().test(Attr::VOLATILE) &&372 (IsDummy(symbol) || !InInterface())) {373 messages_.Say(374 "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);375 }376 if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {377 // The intrinsic procedure C_FUNLOC() gets a pass on this check.378 } else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&379 IsDummy(symbol)) {380 messages_.Say(381 "A dummy procedure of a pure subprogram must be pure"_err_en_US);382 }383 }384 const auto *object{symbol.detailsIf<ObjectEntityDetails>()};385 if (type) { // Section 7.2, paragraph 7; C795386 bool isChar{type->category() == DeclTypeSpec::Character};387 bool canHaveAssumedParameter{(isChar && IsNamedConstant(symbol)) ||388 (IsAssumedLengthCharacter(symbol) && // C722389 (IsExternal(symbol) ||390 ClassifyProcedure(symbol) ==391 ProcedureDefinitionClass::Dummy)) ||392 symbol.test(Symbol::Flag::ParentComp)};393 if (!IsStmtFunctionDummy(symbol)) { // C726394 if (object) {395 canHaveAssumedParameter |= object->isDummy() ||396 (isChar && object->isFuncResult()) ||397 IsStmtFunctionResult(symbol); // Avoids multiple messages398 } else {399 canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();400 }401 }402 if (IsProcedurePointer(symbol) && symbol.HasExplicitInterface()) {403 // Don't check function result types here404 } else {405 Check(*type, canHaveAssumedParameter);406 }407 if (InFunction() && IsFunctionResult(symbol)) {408 if (InPure()) {409 if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585410 messages_.Say(411 "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);412 }413 if (derived) {414 // These cases would be caught be the general validation of local415 // variables in a pure context, but these messages are more specific.416 if (HasImpureFinal(symbol)) { // C1584417 messages_.Say(418 "Result of pure function may not have an impure FINAL subroutine"_err_en_US);419 }420 if (auto bad{421 FindPolymorphicAllocatablePotentialComponent(*derived)}) {422 SayWithDeclaration(*bad,423 "Result of pure function may not have polymorphic ALLOCATABLE potential component '%s'"_err_en_US,424 bad.BuildResultDesignatorName());425 }426 }427 }428 if (InElemental() && isChar) { // F'2023 C15121429 CheckSpecExpr(type->characterTypeSpec().length().GetExplicit(),430 /*forElementalFunctionResult=*/true);431 // TODO: check PDT LEN parameters432 }433 }434 }435 if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723436 if (symbol.attrs().test(Attr::RECURSIVE)) {437 messages_.Say(438 "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);439 }440 if (symbol.Rank() > 0) {441 messages_.Say(442 "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);443 }444 if (!IsStmtFunction(symbol)) {445 if (IsElementalProcedure(symbol)) {446 messages_.Say(447 "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);448 } else if (IsPureProcedure(symbol)) {449 messages_.Say(450 "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);451 }452 }453 if (const Symbol *result{FindFunctionResult(symbol)}) {454 if (IsPointer(*result)) {455 messages_.Say(456 "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);457 }458 }459 if (IsProcedurePointer(symbol) && IsDummy(symbol)) {460 Warn(common::UsageWarning::Portability,461 "A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);462 // The non-dummy case is a hard error that's caught elsewhere.463 }464 }465 if (IsDummy(symbol)) {466 if (IsNamedConstant(symbol)) {467 messages_.Say(468 "A dummy argument may not also be a named constant"_err_en_US);469 }470 } else if (IsFunctionResult(symbol)) {471 if (IsNamedConstant(symbol)) {472 messages_.Say(473 "A function result may not also be a named constant"_err_en_US);474 }475 if (!IsProcedurePointer(symbol) && IsProcedure(symbol)) {476 messages_.Say(477 "A function result may not be a procedure unless it is a procedure pointer"_err_en_US);478 }479 }480 if (IsAutomatic(symbol)) {481 if (const Symbol * common{FindCommonBlockContaining(symbol)}) {482 messages_.Say(483 "Automatic data object '%s' may not appear in COMMON block /%s/"_err_en_US,484 symbol.name(), common->name());485 } else if (symbol.owner().IsModule()) {486 messages_.Say(487 "Automatic data object '%s' may not appear in a module"_err_en_US,488 symbol.name());489 } else if (IsBlockData(symbol.owner())) {490 messages_.Say(491 "Automatic data object '%s' may not appear in a BLOCK DATA subprogram"_err_en_US,492 symbol.name());493 } else if (symbol.owner().kind() == Scope::Kind::MainProgram) {494 if (context_.IsEnabled(common::LanguageFeature::AutomaticInMainProgram)) {495 Warn(common::LanguageFeature::AutomaticInMainProgram,496 "Automatic data object '%s' should not appear in the specification part of a main program"_port_en_US,497 symbol.name());498 } else {499 messages_.Say(500 "Automatic data object '%s' may not appear in the specification part of a main program"_err_en_US,501 symbol.name());502 }503 }504 }505 if (IsProcedure(symbol)) {506 if (IsAllocatable(symbol)) {507 messages_.Say(508 "Procedure '%s' may not be ALLOCATABLE"_err_en_US, symbol.name());509 }510 if (!symbol.HasExplicitInterface() && symbol.Rank() > 0) {511 messages_.Say(512 "Procedure '%s' may not be an array without an explicit interface"_err_en_US,513 symbol.name());514 }515 }516}517 518void CheckHelper::CheckCommonBlock(const Symbol &symbol) {519 CheckGlobalName(symbol);520 const auto &common{symbol.get<CommonBlockDetails>()};521 SourceName location{symbol.name()};522 if (location.empty()) {523 location = common.sourceLocation();524 }525 bool isBindCCommon{symbol.attrs().test(Attr::BIND_C)};526 if (isBindCCommon) {527 CheckBindC(symbol);528 }529 for (auto ref : symbol.get<CommonBlockDetails>().objects()) {530 auto restorer{531 messages_.SetLocation(location.empty() ? ref->name() : location)};532 if (isBindCCommon && ref->has<ObjectEntityDetails>()) {533 if (auto msgs{WhyNotInteroperableObject(*ref,534 /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};535 !msgs.empty()) {536 parser::Message &reason{msgs.messages().front()};537 parser::Message *msg{nullptr};538 if (reason.IsFatal()) {539 msg = messages_.Say(540 "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,541 ref->name(), symbol.name());542 } else {543 msg = messages_.Say(544 "'%s' should not be a member of BIND(C) COMMON block /%s/"_warn_en_US,545 ref->name(), symbol.name());546 }547 if (msg) {548 msg = &msg->Attach(549 std::move(reason.set_severity(parser::Severity::Because)));550 }551 evaluate::AttachDeclaration(msg, *ref);552 }553 }554 if (ref->test(Symbol::Flag::CrayPointee)) {555 evaluate::AttachDeclaration(556 messages_.Say(557 "Cray pointee '%s' may not be a member of COMMON block /%s/"_err_en_US,558 ref->name(), symbol.name()),559 *ref);560 }561 if (IsAllocatable(*ref)) {562 evaluate::AttachDeclaration(563 messages_.Say(564 "ALLOCATABLE object '%s' may not appear in COMMON block /%s/"_err_en_US,565 ref->name(), symbol.name()),566 *ref);567 }568 if (ref->attrs().test(Attr::BIND_C)) {569 evaluate::AttachDeclaration(570 messages_.Say(571 "BIND(C) object '%s' may not appear in COMMON block /%s/"_err_en_US,572 ref->name(), symbol.name()),573 *ref);574 }575 if (IsNamedConstant(*ref)) {576 evaluate::AttachDeclaration(577 messages_.Say(578 "Named constant '%s' may not appear in COMMON block /%s/"_err_en_US,579 ref->name(), symbol.name()),580 *ref);581 }582 if (IsDummy(*ref)) {583 evaluate::AttachDeclaration(584 messages_.Say(585 "Dummy argument '%s' may not appear in COMMON block /%s/"_err_en_US,586 ref->name(), symbol.name()),587 *ref);588 }589 if (ref->IsFuncResult()) {590 evaluate::AttachDeclaration(591 messages_.Say(592 "Function result '%s' may not appear in COMMON block /%s/"_err_en_US,593 ref->name(), symbol.name()),594 *ref);595 }596 if (const auto *type{ref->GetType()}) {597 if (type->category() == DeclTypeSpec::ClassStar) {598 evaluate::AttachDeclaration(599 messages_.Say(600 "Unlimited polymorphic pointer '%s' may not appear in COMMON block /%s/"_err_en_US,601 ref->name(), symbol.name()),602 *ref);603 } else if (const auto *derived{type->AsDerived()}) {604 if (!IsSequenceOrBindCType(derived)) {605 evaluate::AttachDeclaration(606 evaluate::AttachDeclaration(607 messages_.Say(608 "Object '%s' whose derived type '%s' is neither SEQUENCE nor BIND(C) may not appear in COMMON block /%s/"_err_en_US,609 ref->name(), derived->name(), symbol.name()),610 derived->typeSymbol()),611 *ref);612 } else if (auto componentPath{613 derived->ComponentWithDefaultInitialization()}) {614 evaluate::AttachDeclaration(615 evaluate::AttachDeclaration(616 messages_.Say(617 "COMMON block /%s/ may not have the member '%s' whose derived type '%s' has a component '%s' that is ALLOCATABLE or has default initialization"_err_en_US,618 symbol.name(), ref->name(), derived->name(),619 *componentPath),620 derived->typeSymbol()),621 *ref);622 }623 }624 }625 }626}627 628// C859, C860629void CheckHelper::CheckExplicitSave(const Symbol &symbol) {630 const Symbol &ultimate{symbol.GetUltimate()};631 if (ultimate.test(Symbol::Flag::InDataStmt)) {632 // checked elsewhere633 } else if (symbol.has<UseDetails>()) {634 messages_.Say(635 "The USE-associated name '%s' may not have an explicit SAVE attribute"_err_en_US,636 symbol.name());637 } else if (IsDummy(ultimate)) {638 messages_.Say(639 "The dummy argument '%s' may not have an explicit SAVE attribute"_err_en_US,640 symbol.name());641 } else if (IsFunctionResult(ultimate)) {642 messages_.Say(643 "The function result variable '%s' may not have an explicit SAVE attribute"_err_en_US,644 symbol.name());645 } else if (const Symbol * common{FindCommonBlockContaining(ultimate)}) {646 messages_.Say(647 "The entity '%s' in COMMON block /%s/ may not have an explicit SAVE attribute"_err_en_US,648 symbol.name(), common->name());649 } else if (IsAutomatic(ultimate)) {650 messages_.Say(651 "The automatic object '%s' may not have an explicit SAVE attribute"_err_en_US,652 symbol.name());653 } else if (!evaluate::IsVariable(ultimate) && !IsProcedurePointer(ultimate)) {654 messages_.Say(655 "The entity '%s' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block"_err_en_US,656 symbol.name());657 }658}659 660void CheckHelper::CheckValue(661 const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865662 if (IsProcedure(symbol)) {663 messages_.Say(664 "VALUE attribute may apply only to a dummy data object"_err_en_US);665 return; // don't pile on666 }667 if (IsAssumedSizeArray(symbol)) {668 messages_.Say(669 "VALUE attribute may not apply to an assumed-size array"_err_en_US);670 }671 if (evaluate::IsCoarray(symbol)) {672 messages_.Say("VALUE attribute may not apply to a coarray"_err_en_US);673 }674 if (IsAllocatable(symbol)) {675 messages_.Say("VALUE attribute may not apply to an ALLOCATABLE"_err_en_US);676 } else if (IsPointer(symbol)) {677 messages_.Say("VALUE attribute may not apply to a POINTER"_err_en_US);678 }679 if (IsIntentInOut(symbol)) {680 messages_.Say(681 "VALUE attribute may not apply to an INTENT(IN OUT) argument"_err_en_US);682 } else if (IsIntentOut(symbol)) {683 messages_.Say(684 "VALUE attribute may not apply to an INTENT(OUT) argument"_err_en_US);685 }686 if (symbol.attrs().test(Attr::VOLATILE)) {687 messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US);688 }689 if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_)) {690 if (IsOptional(symbol)) {691 messages_.Say(692 "VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US);693 }694 if (symbol.Rank() > 0) {695 messages_.Say(696 "VALUE attribute may not apply to an array in a BIND(C) procedure"_err_en_US);697 }698 }699 if (derived) {700 if (FindCoarrayUltimateComponent(*derived)) {701 messages_.Say(702 "VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);703 }704 }705 if (IsAssumedRank(symbol)) {706 messages_.Say(707 "VALUE attribute may not apply to an assumed-rank array"_err_en_US);708 }709 if (IsAssumedLengthCharacter(symbol)) {710 // F'2008 feature not widely implemented711 Warn(common::UsageWarning::Portability,712 "VALUE attribute on assumed-length CHARACTER may not be portable"_port_en_US);713 }714}715 716void CheckHelper::CheckAssumedTypeEntity( // C709717 const Symbol &symbol, const ObjectEntityDetails &details) {718 if (const DeclTypeSpec *type{symbol.GetType()};719 type && type->category() == DeclTypeSpec::TypeStar) {720 if (!IsDummy(symbol)) {721 messages_.Say(722 "Assumed-type entity '%s' must be a dummy argument"_err_en_US,723 symbol.name());724 } else {725 if (symbol.attrs().test(Attr::ALLOCATABLE)) {726 messages_.Say("Assumed-type argument '%s' cannot have the ALLOCATABLE"727 " attribute"_err_en_US,728 symbol.name());729 }730 if (symbol.attrs().test(Attr::POINTER)) {731 messages_.Say("Assumed-type argument '%s' cannot have the POINTER"732 " attribute"_err_en_US,733 symbol.name());734 }735 if (symbol.attrs().test(Attr::VALUE)) {736 messages_.Say("Assumed-type argument '%s' cannot have the VALUE"737 " attribute"_err_en_US,738 symbol.name());739 }740 if (symbol.attrs().test(Attr::INTENT_OUT)) {741 messages_.Say(742 "Assumed-type argument '%s' cannot be INTENT(OUT)"_err_en_US,743 symbol.name());744 }745 if (evaluate::IsCoarray(symbol)) {746 messages_.Say(747 "Assumed-type argument '%s' cannot be a coarray"_err_en_US,748 symbol.name());749 }750 if (details.IsArray() && details.shape().IsExplicitShape()) {751 messages_.Say("Assumed-type array argument '%s' must be assumed shape,"752 " assumed size, or assumed rank"_err_en_US,753 symbol.name());754 }755 }756 }757}758 759void CheckHelper::CheckObjectEntity(760 const Symbol &symbol, const ObjectEntityDetails &details) {761 CheckSymbolType(symbol);762 CheckArraySpec(symbol, details.shape());763 CheckConflicting(symbol, Attr::ALLOCATABLE, Attr::PARAMETER);764 CheckConflicting(symbol, Attr::ASYNCHRONOUS, Attr::PARAMETER);765 CheckConflicting(symbol, Attr::SAVE, Attr::PARAMETER);766 CheckConflicting(symbol, Attr::TARGET, Attr::PARAMETER);767 CheckConflicting(symbol, Attr::VOLATILE, Attr::PARAMETER);768 Check(details.shape());769 Check(details.coshape());770 if (details.shape().Rank() > common::maxRank) {771 messages_.Say(772 "'%s' has rank %d, which is greater than the maximum supported rank %d"_err_en_US,773 symbol.name(), details.shape().Rank(), common::maxRank);774 } else if (details.shape().Rank() + details.coshape().Rank() >775 common::maxRank) {776 messages_.Say(777 "'%s' has rank %d and corank %d, whose sum is greater than the maximum supported rank %d"_err_en_US,778 symbol.name(), details.shape().Rank(), details.coshape().Rank(),779 common::maxRank);780 }781 CheckAssumedTypeEntity(symbol, details);782 WarnMissingFinal(symbol);783 const DeclTypeSpec *type{details.type()};784 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};785 bool isComponent{symbol.owner().IsDerivedType()};786 const Symbol *commonBlock{FindCommonBlockContaining(symbol)};787 bool isLocalVariable{!commonBlock && !isComponent && !details.isDummy() &&788 symbol.owner().kind() != Scope::Kind::OtherConstruct};789 if (int corank{evaluate::GetCorank(symbol)}; corank > 0) { // it's a coarray790 bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};791 if (IsAllocatable(symbol)) {792 if (!isDeferredCoshape) { // C827793 messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"794 " coshape"_err_en_US,795 symbol.name());796 }797 } else if (isComponent) { // C746798 std::string deferredMsg{799 isDeferredCoshape ? "" : " and have a deferred coshape"};800 messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"801 " attribute%s"_err_en_US,802 symbol.name(), deferredMsg);803 } else {804 if (!details.coshape().CanBeAssumedSize()) { // C828805 messages_.Say(806 "'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US,807 symbol.name());808 }809 }810 if (IsBadCoarrayType(derived)) { // C747 & C824811 messages_.Say(812 "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,813 symbol.name());814 }815 if (IsAssumedRank(symbol)) {816 messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,817 symbol.name());818 }819 if (IsNamedConstant(symbol)) {820 messages_.Say(821 "Coarray '%s' may not be a named constant"_err_en_US, symbol.name());822 }823 if (IsFunctionResult(symbol)) {824 messages_.Say("Function result may not be a coarray"_err_en_US);825 } else if (commonBlock) {826 messages_.Say("Coarray '%s' may not be in COMMON block '/%s/'"_err_en_US,827 symbol.name(), commonBlock->name());828 } else if (isLocalVariable && !IsAllocatableOrPointer(symbol) &&829 !IsSaved(symbol)) {830 messages_.Say(831 "Local coarray must have the SAVE or ALLOCATABLE attribute"_err_en_US);832 }833 for (int j{0}; j < corank; ++j) {834 if (auto lcbv{evaluate::ToInt64(evaluate::Fold(835 context().foldingContext(), evaluate::GetLCOBOUND(symbol, j)))}) {836 if (auto ucbv{837 evaluate::ToInt64(evaluate::Fold(context().foldingContext(),838 evaluate::GetUCOBOUND(symbol, j)))}) {839 if (ucbv < lcbv) {840 messages_.Say(841 "Cobounds %jd:%jd of codimension %d produce an empty coarray"_err_en_US,842 std::intmax_t{*lcbv}, std::intmax_t{*ucbv}, j + 1);843 }844 }845 }846 }847 } else { // not a coarray848 if (!isComponent && !IsPointer(symbol) && derived) {849 if (IsEventTypeOrLockType(derived)) {850 messages_.Say(851 "Variable '%s' with EVENT_TYPE or LOCK_TYPE must be a coarray"_err_en_US,852 symbol.name());853 } else if (auto component{FindEventOrLockPotentialComponent(854 *derived, /*ignoreCoarrays=*/true)}) {855 messages_.Say(856 "Variable '%s' with EVENT_TYPE or LOCK_TYPE potential component '%s' must be a coarray"_err_en_US,857 symbol.name(), component.BuildResultDesignatorName());858 } else if (IsNotifyType(derived)) { // C1612859 messages_.Say(860 "Variable '%s' with NOTIFY_TYPE must be a coarray"_err_en_US,861 symbol.name());862 } else if (auto component{FindNotifyPotentialComponent( // C1611863 *derived, /*ignoreCoarrays=*/true)}) {864 messages_.Say(865 "Variable '%s' with NOTIFY_TYPE potential component '%s' must be a coarray"_err_en_US,866 symbol.name(), component.BuildResultDesignatorName());867 }868 }869 }870 if (details.isDummy()) {871 if (IsIntentOut(symbol)) {872 // Some of these errors would also be caught by the general check873 // for definability of automatically deallocated local variables,874 // but these messages are more specific.875 if (FindUltimateComponent(symbol, [](const Symbol &x) {876 return evaluate::IsCoarray(x) && IsAllocatable(x);877 })) { // C846878 messages_.Say(879 "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);880 }881 if (IsOrContainsEventOrLockComponent(symbol)) { // C847882 messages_.Say(883 "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);884 }885 if (IsOrContainsNotifyComponent(symbol)) { // C1613886 messages_.Say(887 "An INTENT(OUT) dummy argument may not be, or contain, NOTIFY_TYPE"_err_en_US);888 }889 if (IsAssumedSizeArray(symbol)) { // C834890 if (type && type->IsPolymorphic()) {891 messages_.Say(892 "An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US);893 }894 if (derived) {895 if (derived->HasDefaultInitialization()) {896 messages_.Say(897 "An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization"_err_en_US);898 }899 if (IsFinalizable(*derived)) {900 messages_.Say(901 "An INTENT(OUT) assumed-size dummy argument array may not be finalizable"_err_en_US);902 }903 }904 }905 }906 if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&907 !IsPointer(symbol) && !IsIntentIn(symbol) &&908 !symbol.attrs().test(Attr::VALUE)) {909 const char *what{InFunction() ? "function" : "subroutine"};910 bool ok{true};911 if (IsIntentOut(symbol)) {912 if (type && type->IsPolymorphic()) { // C1588913 messages_.Say(914 "An INTENT(OUT) dummy argument of a pure %s may not be polymorphic"_err_en_US,915 what);916 ok = false;917 } else if (derived) {918 if (FindUltimateComponent(*derived, [](const Symbol &x) {919 const DeclTypeSpec *type{x.GetType()};920 return type && type->IsPolymorphic();921 })) { // C1588922 messages_.Say(923 "An INTENT(OUT) dummy argument of a pure %s may not have a polymorphic ultimate component"_err_en_US,924 what);925 ok = false;926 }927 if (HasImpureFinal(symbol)) { // C1587928 messages_.Say(929 "An INTENT(OUT) dummy argument of a pure %s may not have an impure FINAL subroutine"_err_en_US,930 what);931 ok = false;932 }933 }934 } else if (!IsIntentInOut(symbol)) { // C1586935 messages_.Say(936 "non-POINTER dummy argument of pure %s must have INTENT() or VALUE attribute"_err_en_US,937 what);938 ok = false;939 }940 if (ok && InFunction() && !InModuleFile() && !InElemental()) {941 if (context_.IsEnabled(common::LanguageFeature::RelaxedPureDummy)) {942 Warn(common::LanguageFeature::RelaxedPureDummy,943 "non-POINTER dummy argument of pure function should be INTENT(IN) or VALUE"_warn_en_US);944 } else {945 messages_.Say(946 "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);947 }948 }949 }950 if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {951 const Symbol *ownerSymbol{symbol.owner().symbol()};952 bool inModuleProc{ownerSymbol && IsModuleProcedure(*ownerSymbol)};953 bool inExplicitExternalInterface{954 InInterface() && !IsSeparateModuleProcedureInterface(ownerSymbol)};955 if (!InInterface() && !inModuleProc) {956 messages_.Say(957 "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);958 }959 if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&960 details.ignoreTKR().test(common::IgnoreTKR::Rank)) {961 messages_.Say(962 "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);963 }964 if (IsPassedViaDescriptor(symbol)) {965 if (IsAllocatableOrObjectPointer(&symbol) &&966 !ignoreTKR.test(common::IgnoreTKR::Pointer)) {967 if (inExplicitExternalInterface) {968 Warn(common::UsageWarning::IgnoreTKRUsage,969 "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);970 } else {971 messages_.Say(972 "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);973 }974 } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {975 if (ignoreTKR.count() == 1 && IsAssumedRank(symbol)) {976 Warn(common::UsageWarning::IgnoreTKRUsage,977 "!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);978 } else if (inExplicitExternalInterface) {979 Warn(common::UsageWarning::IgnoreTKRUsage,980 "!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);981 } else {982 messages_.Say(983 "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);984 }985 }986 }987 }988 } else if (!details.ignoreTKR().empty()) {989 messages_.Say(990 "!DIR$ IGNORE_TKR directive may apply only to a dummy data argument"_err_en_US);991 }992 if (InElemental()) {993 if (details.isDummy()) { // C15100994 if (details.shape().Rank() > 0) {995 messages_.Say(996 "A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US);997 }998 if (IsAllocatable(symbol)) {999 messages_.Say(1000 "A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US);1001 }1002 if (evaluate::IsCoarray(symbol)) {1003 messages_.Say(1004 "A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US);1005 }1006 if (IsPointer(symbol)) {1007 messages_.Say(1008 "A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US);1009 }1010 if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN,1011 Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // F'2023 C151201012 messages_.Say(1013 "A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US);1014 }1015 } else if (IsFunctionResult(symbol)) { // C151011016 if (details.shape().Rank() > 0) {1017 messages_.Say(1018 "The result of an ELEMENTAL function must be scalar"_err_en_US);1019 }1020 if (IsAllocatable(symbol)) {1021 messages_.Say(1022 "The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US);1023 }1024 if (IsPointer(symbol)) {1025 messages_.Say(1026 "The result of an ELEMENTAL function may not be a POINTER"_err_en_US);1027 }1028 }1029 }1030 if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization1031 CheckPointerInitialization(symbol);1032 if (IsAutomatic(symbol)) {1033 messages_.Say(1034 "An automatic variable or component must not be initialized"_err_en_US);1035 } else if (IsDummy(symbol)) {1036 messages_.Say("A dummy argument must not be initialized"_err_en_US);1037 } else if (IsFunctionResult(symbol)) {1038 messages_.Say("A function result must not be initialized"_err_en_US);1039 } else if (IsInBlankCommon(symbol)) {1040 Warn(common::LanguageFeature::InitBlankCommon,1041 "A variable in blank COMMON should not be initialized"_port_en_US);1042 }1043 }1044 if (symbol.owner().kind() == Scope::Kind::BlockData) {1045 if (IsAllocatable(symbol)) {1046 messages_.Say(1047 "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);1048 } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {1049 messages_.Say(1050 "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);1051 }1052 }1053 if (derived && InPure() && !InInterface() &&1054 IsAutomaticallyDestroyed(symbol) &&1055 !IsIntentOut(symbol) /*has better messages*/ &&1056 !IsFunctionResult(symbol) /*ditto*/) {1057 // Check automatically deallocated local variables for possible1058 // problems with finalization in PURE.1059 if (auto whyNot{WhyNotDefinable(symbol.name(), symbol.owner(),1060 {DefinabilityFlag::PotentialDeallocation}, symbol)}) {1061 if (auto *msg{messages_.Say(1062 "'%s' may not be a local variable in a pure subprogram"_err_en_US,1063 symbol.name())}) {1064 msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because)));1065 }1066 }1067 }1068 if (symbol.attrs().test(Attr::EXTERNAL)) {1069 SayWithDeclaration(symbol,1070 "'%s' is a data object and may not be EXTERNAL"_err_en_US,1071 symbol.name());1072 }1073 if (symbol.test(Symbol::Flag::CrayPointee)) {1074 // NB, IsSaved was too smart here.1075 if (details.init()) {1076 messages_.Say(1077 "Cray pointee '%s' may not be initialized"_err_en_US, symbol.name());1078 }1079 if (symbol.attrs().test(Attr::SAVE)) {1080 messages_.Say(1081 "Cray pointee '%s' may not have the SAVE attribute"_err_en_US,1082 symbol.name());1083 }1084 }1085 if (derived) {1086 bool isUnsavedLocal{1087 isLocalVariable && !IsAllocatable(symbol) && !IsSaved(symbol)};1088 if (IsFunctionResult(symbol) || IsPointer(symbol) ||1089 evaluate::IsCoarray(symbol) || isUnsavedLocal) {1090 if (auto badPotential{FindCoarrayPotentialComponent(*derived)}) {1091 if (IsFunctionResult(symbol)) { // F'2023 C8251092 SayWithDeclaration(*badPotential,1093 "Function result '%s' may not have a coarray potential component '%s'"_err_en_US,1094 symbol.name(), badPotential.BuildResultDesignatorName());1095 } else if (IsPointer(symbol)) { // F'2023 C8251096 SayWithDeclaration(*badPotential,1097 "Pointer '%s' may not have a coarray potential component '%s'"_err_en_US,1098 symbol.name(), badPotential.BuildResultDesignatorName());1099 } else if (evaluate::IsCoarray(symbol)) { // F'2023 C8251100 SayWithDeclaration(*badPotential,1101 "Coarray '%s' may not have a coarray potential component '%s'"_err_en_US,1102 symbol.name(), badPotential.BuildResultDesignatorName());1103 } else if (isUnsavedLocal) { // F'2023 C8261104 SayWithDeclaration(*badPotential,1105 "Local variable '%s' without the SAVE or ALLOCATABLE attribute may not have a coarray potential subobject component '%s'"_err_en_US,1106 symbol.name(), badPotential.BuildResultDesignatorName());1107 } else {1108 DIE("caught unexpected bad coarray potential component");1109 }1110 }1111 } else if (isComponent && (IsAllocatable(symbol) || symbol.Rank() > 0)) {1112 if (auto badUltimate{FindCoarrayUltimateComponent(*derived)}) {1113 // TODO: still an error in F'2023?1114 SayWithDeclaration(*badUltimate,1115 "Allocatable or array component '%s' may not have a coarray ultimate component '%s'"_err_en_US,1116 symbol.name(), badUltimate.BuildResultDesignatorName());1117 }1118 }1119 }1120 1121 // Check CUDA attributes and special circumstances of being in device1122 // subprograms1123 const Scope &progUnit{GetProgramUnitContaining(symbol)};1124 const auto *subpDetails{!isComponent && progUnit.symbol()1125 ? progUnit.symbol()->detailsIf<SubprogramDetails>()1126 : nullptr};1127 bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};1128 if (inDeviceSubprogram) {1129 if (IsSaved(symbol)) {1130 Warn(common::UsageWarning::CUDAUsage,1131 "'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,1132 symbol.name());1133 }1134 if (IsPointer(symbol)) {1135 Warn(common::UsageWarning::CUDAUsage,1136 "Pointer '%s' may not be associated in a device subprogram"_warn_en_US,1137 symbol.name());1138 }1139 if (details.isDummy() &&1140 details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=1141 common::CUDADataAttr::Device &&1142 details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=1143 common::CUDADataAttr::Managed &&1144 details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=1145 common::CUDADataAttr::Shared) {1146 Warn(common::UsageWarning::CUDAUsage,1147 "Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,1148 symbol.name(),1149 parser::ToUpperCaseLetters(1150 common::EnumToString(*details.cudaDataAttr())));1151 }1152 }1153 if (details.cudaDataAttr()) {1154 if (auto dyType{evaluate::DynamicType::From(symbol)}) {1155 if (dyType->category() != TypeCategory::Derived) {1156 if (!IsCUDAIntrinsicType(*dyType)) {1157 messages_.Say(1158 "'%s' has intrinsic type '%s' that is not available on the device"_err_en_US,1159 symbol.name(), dyType->AsFortran());1160 }1161 }1162 }1163 auto attr{*details.cudaDataAttr()};1164 switch (attr) {1165 case common::CUDADataAttr::Constant:1166 if (subpDetails && !inDeviceSubprogram) {1167 messages_.Say(1168 "Object '%s' with ATTRIBUTES(CONSTANT) may not be declared in a host subprogram"_err_en_US,1169 symbol.name());1170 } else if (IsAllocatableOrPointer(symbol) ||1171 symbol.attrs().test(Attr::TARGET)) {1172 messages_.Say(1173 "Object '%s' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target"_err_en_US,1174 symbol.name());1175 } else if (auto shape{evaluate::GetShape(foldingContext_, symbol)};1176 !shape ||1177 !evaluate::AsConstantExtents(foldingContext_, *shape)) {1178 messages_.Say(1179 "Object '%s' with ATTRIBUTES(CONSTANT) must have constant array bounds"_err_en_US,1180 symbol.name());1181 }1182 break;1183 case common::CUDADataAttr::Device:1184 if (isComponent && !IsAllocatable(symbol) && !IsPointer(symbol)) {1185 messages_.Say(1186 "Component '%s' with ATTRIBUTES(DEVICE) must also be allocatable or pointer"_err_en_US,1187 symbol.name());1188 }1189 break;1190 case common::CUDADataAttr::Managed:1191 if (!IsAutomatic(symbol) && !IsAllocatable(symbol) &&1192 !details.isDummy() && !evaluate::IsExplicitShape(symbol)) {1193 messages_.Say(1194 "Object '%s' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, explicit shape, or a dummy argument"_err_en_US,1195 symbol.name());1196 }1197 break;1198 case common::CUDADataAttr::Pinned:1199 if (inDeviceSubprogram) {1200 Warn(common::UsageWarning::CUDAUsage,1201 "Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,1202 symbol.name());1203 } else if (IsPointer(symbol)) {1204 Warn(common::UsageWarning::CUDAUsage,1205 "Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,1206 symbol.name());1207 } else if (!IsAllocatable(symbol)) {1208 Warn(common::UsageWarning::CUDAUsage,1209 "Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,1210 symbol.name());1211 }1212 break;1213 case common::CUDADataAttr::Shared:1214 if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {1215 messages_.Say(1216 "Object '%s' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target"_err_en_US,1217 symbol.name());1218 } else if (!inDeviceSubprogram) {1219 messages_.Say(1220 "Object '%s' with ATTRIBUTES(SHARED) must be declared in a device subprogram"_err_en_US,1221 symbol.name());1222 }1223 break;1224 case common::CUDADataAttr::Unified:1225 if (((!subpDetails &&1226 symbol.owner().kind() != Scope::Kind::MainProgram) ||1227 inDeviceSubprogram) &&1228 !isComponent) {1229 messages_.Say(1230 "Object '%s' with ATTRIBUTES(UNIFIED) must be declared in a host subprogram"_err_en_US,1231 symbol.name());1232 }1233 break;1234 case common::CUDADataAttr::Texture:1235 messages_.Say(1236 "ATTRIBUTES(TEXTURE) is obsolete and no longer supported"_err_en_US);1237 break;1238 }1239 if (attr != common::CUDADataAttr::Pinned) {1240 if (details.commonBlock()) {1241 messages_.Say(1242 "Object '%s' with ATTRIBUTES(%s) may not be in COMMON"_err_en_US,1243 symbol.name(),1244 parser::ToUpperCaseLetters(common::EnumToString(attr)));1245 } else if (FindEquivalenceSet(symbol)) {1246 messages_.Say(1247 "Object '%s' with ATTRIBUTES(%s) may not be in an equivalence group"_err_en_US,1248 symbol.name(),1249 parser::ToUpperCaseLetters(common::EnumToString(attr)));1250 }1251 }1252 if (subpDetails /* not a module variable */ && IsSaved(symbol) &&1253 !inDeviceSubprogram && !IsAllocatable(symbol) &&1254 attr == common::CUDADataAttr::Device) {1255 messages_.Say(1256 "Saved object '%s' in host code may not have ATTRIBUTES(DEVICE) unless allocatable"_err_en_US,1257 symbol.name(),1258 parser::ToUpperCaseLetters(common::EnumToString(attr)));1259 }1260 if (isComponent) {1261 if (attr == common::CUDADataAttr::Device) {1262 const DeclTypeSpec *type{symbol.GetType()};1263 if (const DerivedTypeSpec *1264 derived{type ? type->AsDerived() : nullptr}) {1265 DirectComponentIterator directs{*derived};1266 if (auto iter{std::find_if(directs.begin(), directs.end(),1267 [](const Symbol &) { return false; })}) {1268 messages_.Say(1269 "Derived type component '%s' may not have ATTRIBUTES(DEVICE) as it has a direct device component '%s'"_err_en_US,1270 symbol.name(), iter.BuildResultDesignatorName());1271 }1272 }1273 } else if (attr == common::CUDADataAttr::Constant ||1274 attr == common::CUDADataAttr::Shared) {1275 messages_.Say(1276 "Derived type component '%s' may not have ATTRIBUTES(%s)"_err_en_US,1277 symbol.name(),1278 parser::ToUpperCaseLetters(common::EnumToString(attr)));1279 }1280 } else if (!subpDetails && symbol.owner().kind() != Scope::Kind::Module &&1281 symbol.owner().kind() != Scope::Kind::MainProgram &&1282 symbol.owner().kind() != Scope::Kind::BlockConstruct &&1283 symbol.owner().kind() != Scope::Kind::OpenACCConstruct) {1284 messages_.Say(1285 "ATTRIBUTES(%s) may apply only to module, host subprogram, block, or device subprogram data"_err_en_US,1286 parser::ToUpperCaseLetters(common::EnumToString(attr)));1287 }1288 }1289 1290 if (derived && derived->IsVectorType()) {1291 CHECK(type);1292 std::string typeName{type->AsFortran()};1293 if (IsAssumedShape(symbol)) {1294 SayWithDeclaration(symbol,1295 "Assumed-shape entity of %s type is not supported"_err_en_US,1296 typeName);1297 } else if (IsDeferredShape(symbol)) {1298 SayWithDeclaration(symbol,1299 "Deferred-shape entity of %s type is not supported"_err_en_US,1300 typeName);1301 } else if (IsAssumedRank(symbol)) {1302 SayWithDeclaration(symbol,1303 "Assumed rank entity of %s type is not supported"_err_en_US,1304 typeName);1305 }1306 }1307}1308 1309void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {1310 if (IsPointer(symbol) && !context_.HasError(symbol) &&1311 !scopeIsUninstantiatedPDT_) {1312 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {1313 if (object->init()) { // C764, C765; C8081314 if (auto designator{evaluate::AsGenericExpr(symbol)}) {1315 auto restorer{messages_.SetLocation(symbol.name())};1316 context_.set_location(symbol.name());1317 CheckInitialDataPointerTarget(1318 context_, *designator, *object->init(), DEREF(scope_));1319 }1320 }1321 } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {1322 if (proc->init() && *proc->init()) {1323 // C1519 - must be nonelemental external or module procedure,1324 // or an unrestricted specific intrinsic function.1325 const Symbol &local{DEREF(*proc->init())};1326 const Symbol &ultimate{local.GetUltimate()};1327 bool checkTarget{true};1328 if (ultimate.attrs().test(Attr::INTRINSIC)) {1329 if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(1330 ultimate.name().ToString())};1331 !intrinsic || intrinsic->isRestrictedSpecific) { // C10301332 context_.Say(1333 "Intrinsic procedure '%s' is not an unrestricted specific "1334 "intrinsic permitted for use as the initializer for procedure "1335 "pointer '%s'"_err_en_US,1336 ultimate.name(), symbol.name());1337 checkTarget = false;1338 }1339 } else if (!(ultimate.attrs().test(Attr::EXTERNAL) ||1340 ultimate.owner().kind() == Scope::Kind::Module ||1341 ultimate.owner().IsTopLevel()) ||1342 IsDummy(ultimate) || IsPointer(ultimate)) {1343 context_.Say(1344 "Procedure pointer '%s' initializer '%s' is neither an external nor a module procedure"_err_en_US,1345 symbol.name(), ultimate.name());1346 checkTarget = false;1347 } else if (IsElementalProcedure(ultimate)) {1348 context_.Say("Procedure pointer '%s' cannot be initialized with the "1349 "elemental procedure '%s'"_err_en_US,1350 symbol.name(), ultimate.name());1351 checkTarget = false;1352 }1353 if (checkTarget) {1354 SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};1355 SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};1356 CheckPointerAssignment(context_, lhs, rhs,1357 GetProgramUnitOrBlockConstructContaining(symbol),1358 /*isBoundsRemapping=*/false, /*isAssumedRank=*/false);1359 }1360 }1361 }1362 }1363}1364 1365// The six different kinds of array-specs:1366// array-spec -> explicit-shape-list | deferred-shape-list1367// | assumed-shape-list | implied-shape-list1368// | assumed-size | assumed-rank1369// explicit-shape -> [ lb : ] ub1370// deferred-shape -> :1371// assumed-shape -> [ lb ] :1372// implied-shape -> [ lb : ] *1373// assumed-size -> [ explicit-shape-list , ] [ lb : ] *1374// assumed-rank -> ..1375// Note:1376// - deferred-shape is also an assumed-shape1377// - A single "*" or "lb:*" might be assumed-size or implied-shape-list1378void CheckHelper::CheckArraySpec(1379 const Symbol &symbol, const ArraySpec &arraySpec) {1380 if (arraySpec.Rank() == 0) {1381 return;1382 }1383 bool isExplicit{arraySpec.IsExplicitShape()};1384 bool canBeDeferred{arraySpec.CanBeDeferredShape()};1385 bool canBeImplied{arraySpec.CanBeImpliedShape()};1386 bool canBeAssumedShape{arraySpec.CanBeAssumedShape()};1387 bool canBeAssumedSize{arraySpec.CanBeAssumedSize()};1388 bool isAssumedRank{arraySpec.IsAssumedRank()};1389 bool isCUDAShared{1390 GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==1391 common::CUDADataAttr::Shared};1392 bool isCrayPointee{symbol.test(Symbol::Flag::CrayPointee)};1393 std::optional<parser::MessageFixedText> msg;1394 if (isCrayPointee && !isExplicit && !canBeAssumedSize) {1395 msg =1396 "Cray pointee '%s' must have explicit shape or assumed size"_err_en_US;1397 } else if (IsAllocatableOrPointer(symbol) && !canBeDeferred &&1398 !isAssumedRank) {1399 if (symbol.owner().IsDerivedType()) { // C7451400 if (IsAllocatable(symbol)) {1401 msg = "Allocatable array component '%s' must have"1402 " deferred shape"_err_en_US;1403 } else {1404 msg = "Array pointer component '%s' must have deferred shape"_err_en_US;1405 }1406 } else {1407 if (IsAllocatable(symbol)) { // C8321408 msg = "Allocatable array '%s' must have deferred shape or"1409 " assumed rank"_err_en_US;1410 } else {1411 msg = "Array pointer '%s' must have deferred shape or"1412 " assumed rank"_err_en_US;1413 }1414 }1415 } else if (IsDummy(symbol)) {1416 if (canBeImplied && !canBeAssumedSize) { // C8361417 msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;1418 }1419 } else if (canBeAssumedShape && !canBeDeferred) {1420 msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;1421 } else if (isAssumedRank) { // C8371422 msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;1423 } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared &&1424 !isCrayPointee) { // C8331425 msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;1426 } else if (canBeImplied) {1427 if (!IsNamedConstant(symbol) && !isCUDAShared &&1428 !isCrayPointee) { // C835, C8361429 msg = "Implied-shape array '%s' must be a named constant or a "1430 "dummy argument"_err_en_US;1431 }1432 } else if (IsNamedConstant(symbol)) {1433 if (!isExplicit && !canBeImplied) {1434 msg = "Named constant '%s' array must have constant or"1435 " implied shape"_err_en_US;1436 }1437 } else if (!isExplicit &&1438 !(IsAllocatableOrPointer(symbol) || isCrayPointee)) {1439 if (symbol.owner().IsDerivedType()) { // C7491440 msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"1441 " have explicit shape"_err_en_US;1442 } else { // C8161443 msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have"1444 " explicit shape"_err_en_US;1445 }1446 }1447 if (msg) {1448 context_.Say(std::move(*msg), symbol.name());1449 }1450}1451 1452void CheckHelper::CheckProcEntity(1453 const Symbol &symbol, const ProcEntityDetails &details) {1454 CheckSymbolType(symbol);1455 const Symbol *interface{details.procInterface()};1456 if (details.isDummy()) {1457 if (!symbol.attrs().test(Attr::POINTER) && // C8431458 symbol.attrs().HasAny(1459 {Attr::INTENT_IN, Attr::INTENT_OUT, Attr::INTENT_INOUT})) {1460 messages_.Say("A dummy procedure without the POINTER attribute"1461 " may not have an INTENT attribute"_err_en_US);1462 }1463 if (InElemental()) { // C151001464 messages_.Say(1465 "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);1466 }1467 if (interface && IsElementalProcedure(*interface)) {1468 // There's no explicit constraint or "shall" that we can find in the1469 // standard for this check, but it seems to be implied in multiple1470 // sites, and ELEMENTAL non-intrinsic actual arguments *are*1471 // explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy"1472 // because it is explicitly legal to *pass* the specific intrinsic1473 // function SIN as an actual argument.1474 if (interface->attrs().test(Attr::INTRINSIC)) {1475 Warn(common::UsageWarning::Portability,1476 "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);1477 } else {1478 messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);1479 }1480 }1481 } else if (IsPointer(symbol)) {1482 CheckPointerInitialization(symbol);1483 if (interface) {1484 if (interface->attrs().test(Attr::INTRINSIC)) {1485 auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(1486 interface->name().ToString())};1487 if (!intrinsic || intrinsic->isRestrictedSpecific) { // C15151488 messages_.Say(1489 "Intrinsic procedure '%s' is not an unrestricted specific "1490 "intrinsic permitted for use as the definition of the interface "1491 "to procedure pointer '%s'"_err_en_US,1492 interface->name(), symbol.name());1493 } else if (IsElementalProcedure(*interface)) {1494 Warn(common::UsageWarning::Portability,1495 "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,1496 symbol.name()); // C15171497 }1498 } else if (IsElementalProcedure(*interface)) {1499 messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,1500 symbol.name()); // C15171501 }1502 }1503 if (symbol.owner().IsDerivedType()) {1504 CheckPassArg(symbol, interface, details);1505 }1506 } else if (symbol.owner().IsDerivedType()) {1507 const auto &name{symbol.name()};1508 messages_.Say(name,1509 "Procedure component '%s' must have POINTER attribute"_err_en_US, name);1510 }1511 CheckExternal(symbol);1512}1513 1514// When a module subprogram has the MODULE prefix the following must match1515// with the corresponding separate module procedure interface body:1516// - C1549: characteristics and dummy argument names1517// - C1550: binding label1518// - C1551: NON_RECURSIVE prefix1519class SubprogramMatchHelper {1520public:1521 explicit SubprogramMatchHelper(CheckHelper &checkHelper)1522 : checkHelper{checkHelper} {}1523 1524 void Check(const Symbol &, const Symbol &);1525 1526private:1527 SemanticsContext &context() { return checkHelper.context(); }1528 void CheckDummyArg(const Symbol &, const Symbol &, const DummyArgument &,1529 const DummyArgument &);1530 void CheckDummyDataObject(const Symbol &, const Symbol &,1531 const DummyDataObject &, const DummyDataObject &);1532 void CheckDummyProcedure(const Symbol &, const Symbol &,1533 const DummyProcedure &, const DummyProcedure &);1534 bool CheckSameIntent(1535 const Symbol &, const Symbol &, common::Intent, common::Intent);1536 template <typename... A>1537 void Say(1538 const Symbol &, const Symbol &, parser::MessageFixedText &&, A &&...);1539 template <typename ATTRS>1540 bool CheckSameAttrs(const Symbol &, const Symbol &, ATTRS, ATTRS);1541 bool ShapesAreCompatible(const DummyDataObject &, const DummyDataObject &);1542 evaluate::Shape FoldShape(const evaluate::Shape &);1543 std::optional<evaluate::Shape> FoldShape(1544 const std::optional<evaluate::Shape> &shape) {1545 if (shape) {1546 return FoldShape(*shape);1547 }1548 return std::nullopt;1549 }1550 std::string AsFortran(DummyDataObject::Attr attr) {1551 return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr));1552 }1553 std::string AsFortran(DummyProcedure::Attr attr) {1554 return parser::ToUpperCaseLetters(DummyProcedure::EnumToString(attr));1555 }1556 1557 CheckHelper &checkHelper;1558};1559 1560// 15.6.2.6 para 3 - can the result of an ENTRY differ from its function?1561bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) {1562 if (result.attrs.test(FunctionResult::Attr::Allocatable) ||1563 result.attrs.test(FunctionResult::Attr::Pointer)) {1564 return false;1565 }1566 const auto *typeAndShape{result.GetTypeAndShape()};1567 if (!typeAndShape || typeAndShape->Rank() != 0) {1568 return false;1569 }1570 auto category{typeAndShape->type().category()};1571 if (category == TypeCategory::Character ||1572 category == TypeCategory::Derived) {1573 return false;1574 }1575 int kind{typeAndShape->type().kind()};1576 return kind == context_.GetDefaultKind(category) ||1577 (category == TypeCategory::Real &&1578 kind == context_.doublePrecisionKind());1579}1580 1581void CheckHelper::CheckSubprogram(1582 const Symbol &symbol, const SubprogramDetails &details) {1583 // Evaluate a procedure definition's characteristics to flush out1584 // any errors that analysis might expose, in case this subprogram hasn't1585 // had any calls in this compilation unit that would have validated them.1586 if (!context_.HasError(symbol) && !details.isDummy() &&1587 !details.isInterface() && !details.stmtFunction()) {1588 if (!Procedure::Characterize(symbol, foldingContext_)) {1589 context_.SetError(symbol);1590 }1591 }1592 if (const Symbol *iface{FindSeparateModuleSubprogramInterface(&symbol)}) {1593 SubprogramMatchHelper{*this}.Check(symbol, *iface);1594 }1595 if (const Scope *entryScope{details.entryScope()}) {1596 // ENTRY F'2023 15.6.2.61597 std::optional<parser::MessageFixedText> error;1598 const Symbol *subprogram{entryScope->symbol()};1599 const SubprogramDetails *subprogramDetails{nullptr};1600 if (subprogram) {1601 subprogramDetails = subprogram->detailsIf<SubprogramDetails>();1602 }1603 if (!(entryScope->parent().IsGlobal() || entryScope->parent().IsModule() ||1604 entryScope->parent().IsSubmodule())) {1605 error = "ENTRY may not appear in an internal subprogram"_err_en_US;1606 } else if (subprogramDetails && details.isFunction() &&1607 subprogramDetails->isFunction() &&1608 !context_.HasError(details.result()) &&1609 !context_.HasError(subprogramDetails->result())) {1610 auto result{FunctionResult::Characterize(1611 details.result(), context_.foldingContext())};1612 auto subpResult{FunctionResult::Characterize(1613 subprogramDetails->result(), context_.foldingContext())};1614 if (result && subpResult && *result != *subpResult &&1615 (!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {1616 error =1617 "Result of ENTRY is not compatible with result of containing function"_err_en_US;1618 }1619 }1620 if (error) {1621 if (auto *msg{messages_.Say(symbol.name(), *error)}) {1622 if (subprogram) {1623 msg->Attach(subprogram->name(), "Containing subprogram"_en_US);1624 }1625 }1626 }1627 }1628 if (details.isFunction() &&1629 details.result().name() != symbol.name()) { // F'2023 C1569 & C15831630 if (auto iter{symbol.owner().find(details.result().name())};1631 iter != symbol.owner().end()) {1632 const Symbol &resNameSym{*iter->second};1633 if (const auto *resNameSubp{resNameSym.detailsIf<SubprogramDetails>()}) {1634 if (const Scope * resNameEntryScope{resNameSubp->entryScope()}) {1635 const Scope *myScope{1636 details.entryScope() ? details.entryScope() : symbol.scope()};1637 if (resNameEntryScope == myScope) {1638 if (auto *msg{messages_.Say(symbol.name(),1639 "Explicit RESULT('%s') of function '%s' cannot have the same name as a distinct ENTRY into the same scope"_err_en_US,1640 details.result().name(), symbol.name())}) {1641 msg->Attach(1642 resNameSym.name(), "ENTRY with conflicting name"_en_US);1643 }1644 }1645 }1646 }1647 }1648 }1649 if (const MaybeExpr & stmtFunction{details.stmtFunction()}) {1650 if (auto msg{evaluate::CheckStatementFunction(1651 symbol, *stmtFunction, context_.foldingContext())}) {1652 SayWithDeclaration(symbol, std::move(*msg));1653 } else if (IsPointer(symbol)) {1654 SayWithDeclaration(symbol,1655 "A statement function must not have the POINTER attribute"_err_en_US);1656 } else if (details.result().flags().test(Symbol::Flag::Implicit)) {1657 // 15.6.4 p2 weird requirement1658 if (const Symbol *1659 host{symbol.owner().parent().FindSymbol(symbol.name())}) {1660 evaluate::AttachDeclaration(1661 Warn(common::LanguageFeature::StatementFunctionExtensions,1662 symbol.name(),1663 "An implicitly typed statement function should not appear when the same symbol is available in its host scope"_port_en_US),1664 *host);1665 }1666 }1667 if (GetProgramUnitOrBlockConstructContaining(symbol).kind() ==1668 Scope::Kind::BlockConstruct) { // C11071669 messages_.Say(symbol.name(),1670 "A statement function definition may not appear in a BLOCK construct"_err_en_US);1671 }1672 }1673 if (IsElementalProcedure(symbol)) {1674 // See comment on the similar check in CheckProcEntity()1675 if (details.isDummy()) {1676 messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);1677 } else {1678 for (const Symbol *dummy : details.dummyArgs()) {1679 if (!dummy) { // C151001680 messages_.Say(1681 "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US);1682 }1683 }1684 }1685 }1686 if (details.isInterface()) {1687 if (!details.isDummy() && details.isFunction() &&1688 IsAssumedLengthCharacter(details.result())) { // C7211689 messages_.Say(details.result().name(),1690 "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);1691 }1692 if (symbol.attrs().test(Attr::ABSTRACT) &&1693 (symbol.name() == "integer" || symbol.name() == "unsigned" ||1694 symbol.name() == "real" || symbol.name() == "complex" ||1695 symbol.name() == "character" ||1696 symbol.name() == "logical")) { // F'2023 C15031697 messages_.Say(1698 "An ABSTRACT interface may not have the same name as an intrinsic type"_err_en_US);1699 }1700 }1701 CheckExternal(symbol);1702 CheckModuleProcedureDef(symbol);1703 auto cudaAttrs{details.cudaSubprogramAttrs()};1704 if (cudaAttrs &&1705 (*cudaAttrs == common::CUDASubprogramAttrs::Global ||1706 *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&1707 details.isFunction()) {1708 messages_.Say(symbol.name(),1709 "A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);1710 }1711 if (cudaAttrs &&1712 (*cudaAttrs == common::CUDASubprogramAttrs::Global ||1713 *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&1714 symbol.attrs().HasAny({Attr::RECURSIVE, Attr::PURE, Attr::ELEMENTAL})) {1715 messages_.Say(symbol.name(),1716 "A kernel subprogram may not be RECURSIVE, PURE, or ELEMENTAL"_err_en_US);1717 }1718 if (cudaAttrs && *cudaAttrs != common::CUDASubprogramAttrs::Host) {1719 // CUDA device subprogram checks1720 if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {1721 messages_.Say(symbol.name(),1722 "A device subprogram may not be an internal subprogram"_err_en_US);1723 }1724 }1725 if ((!details.cudaLaunchBounds().empty() ||1726 !details.cudaClusterDims().empty()) &&1727 !(cudaAttrs &&1728 (*cudaAttrs == common::CUDASubprogramAttrs::Global ||1729 *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global))) {1730 messages_.Say(symbol.name(),1731 "A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);1732 }1733 if (!IsStmtFunction(symbol)) {1734 if (const Scope * outerDevice{FindCUDADeviceContext(&symbol.owner())};1735 outerDevice && outerDevice->symbol()) {1736 if (auto *msg{messages_.Say(symbol.name(),1737 "'%s' may not be an internal procedure of CUDA device subprogram '%s'"_err_en_US,1738 symbol.name(), outerDevice->symbol()->name())}) {1739 msg->Attach(outerDevice->symbol()->name(),1740 "Containing CUDA device subprogram"_en_US);1741 }1742 }1743 }1744}1745 1746void CheckHelper::CheckExternal(const Symbol &symbol) {1747 if (IsExternal(symbol)) {1748 std::string interfaceName{symbol.name().ToString()};1749 if (const auto *bind{symbol.GetBindName()}) {1750 interfaceName = *bind;1751 }1752 if (const Symbol * global{FindGlobal(symbol)};1753 global && global != &symbol) {1754 std::string definitionName{global->name().ToString()};1755 if (const auto *bind{global->GetBindName()}) {1756 definitionName = *bind;1757 }1758 if (interfaceName == definitionName) {1759 parser::Message *msg{nullptr};1760 if (!IsProcedure(*global)) {1761 if ((symbol.flags().test(Symbol::Flag::Function) ||1762 symbol.flags().test(Symbol::Flag::Subroutine))) {1763 msg = Warn(common::UsageWarning::ExternalNameConflict,1764 "The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_warn_en_US,1765 global->name(), symbol.name());1766 }1767 } else if (auto chars{Characterize(symbol)}) {1768 if (auto globalChars{Characterize(*global)}) {1769 if (chars->HasExplicitInterface()) {1770 std::string whyNot;1771 if (!chars->IsCompatibleWith(*globalChars,1772 /*ignoreImplicitVsExplicit=*/false, &whyNot)) {1773 msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,1774 "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,1775 global->name(), whyNot);1776 }1777 } else if (!globalChars->CanBeCalledViaImplicitInterface()) {1778 // TODO: This should be a hard error if the procedure has1779 // actually been called (as opposed to just being used as a1780 // procedure pointer target or passed as an actual argument).1781 msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,1782 "The global subprogram '%s' should not be referenced via the implicit interface '%s'"_warn_en_US,1783 global->name(), symbol.name());1784 }1785 }1786 }1787 if (msg) {1788 if (msg->IsFatal()) {1789 context_.SetError(symbol);1790 }1791 evaluate::AttachDeclaration(msg, *global);1792 evaluate::AttachDeclaration(msg, symbol);1793 }1794 }1795 } else if (auto iter{externalNames_.find(interfaceName)};1796 iter != externalNames_.end()) {1797 const Symbol &previous{*iter->second};1798 if (auto chars{Characterize(symbol)}) {1799 if (auto previousChars{Characterize(previous)}) {1800 std::string whyNot;1801 if (!chars->IsCompatibleWith(*previousChars,1802 /*ignoreImplicitVsExplicit=*/true, &whyNot)) {1803 if (auto *msg{Warn(common::UsageWarning::ExternalInterfaceMismatch,1804 "The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,1805 symbol.name(), whyNot)}) {1806 evaluate::AttachDeclaration(msg, previous);1807 evaluate::AttachDeclaration(msg, symbol);1808 }1809 }1810 }1811 }1812 } else {1813 externalNames_.emplace(interfaceName, symbol);1814 }1815 }1816}1817 1818void CheckHelper::CheckDerivedType(1819 const Symbol &derivedType, const DerivedTypeDetails &details) {1820 if (details.isForwardReferenced() && !context_.HasError(derivedType)) {1821 messages_.Say("The derived type '%s' has not been defined"_err_en_US,1822 derivedType.name());1823 }1824 const Scope *scope{derivedType.scope()};1825 if (!scope) {1826 CHECK(details.isForwardReferenced());1827 return;1828 }1829 CHECK(scope->symbol() == &derivedType);1830 CHECK(scope->IsDerivedType());1831 if (derivedType.attrs().test(Attr::ABSTRACT) && // C7341832 (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {1833 messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);1834 }1835 if (const DeclTypeSpec *parent{FindParentTypeSpec(derivedType)}) {1836 const DerivedTypeSpec *parentDerived{parent->AsDerived()};1837 if (!IsExtensibleType(parentDerived)) { // C7051838 messages_.Say("The parent type is not extensible"_err_en_US);1839 }1840 if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived &&1841 parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {1842 ScopeComponentIterator components{*parentDerived};1843 for (const Symbol &component : components) {1844 if (component.attrs().test(Attr::DEFERRED)) {1845 if (scope->FindComponent(component.name()) == &component) {1846 SayWithDeclaration(component,1847 "Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,1848 parentDerived->typeSymbol().name(), component.name());1849 }1850 }1851 }1852 }1853 DerivedTypeSpec derived{derivedType.name(), derivedType};1854 derived.set_scope(*scope);1855 if (FindCoarrayUltimateComponent(derived) && // C7361856 !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {1857 messages_.Say(1858 "Type '%s' has a coarray ultimate component so the type at the base "1859 "of its type extension chain ('%s') must be a type that has a "1860 "coarray ultimate component"_err_en_US,1861 derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());1862 }1863 if (FindEventOrLockPotentialComponent(derived) && // C7371864 !(FindEventOrLockPotentialComponent(*parentDerived) ||1865 IsEventTypeOrLockType(parentDerived))) {1866 messages_.Say(1867 "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "1868 "at the base of its type extension chain ('%s') must either have an "1869 "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "1870 "LOCK_TYPE"_err_en_US,1871 derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());1872 }1873 }1874 if (HasIntrinsicTypeName(derivedType)) { // C7291875 messages_.Say("A derived type name cannot be the name of an intrinsic"1876 " type"_err_en_US);1877 }1878 std::map<SourceName, SymbolRef> previous;1879 for (const auto &pair : details.finals()) {1880 SourceName source{pair.first};1881 const Symbol &ref{*pair.second};1882 if (CheckFinal(ref, source, derivedType) &&1883 std::all_of(previous.begin(), previous.end(),1884 [&](std::pair<SourceName, SymbolRef> prev) {1885 return CheckDistinguishableFinals(1886 ref, source, *prev.second, prev.first, derivedType);1887 })) {1888 previous.emplace(source, ref);1889 }1890 }1891}1892 1893// C7861894bool CheckHelper::CheckFinal(1895 const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) {1896 if (!IsModuleProcedure(subroutine)) {1897 SayWithDeclaration(subroutine, finalName,1898 "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US,1899 subroutine.name(), derivedType.name());1900 return false;1901 }1902 const Procedure *proc{Characterize(subroutine)};1903 if (!proc) {1904 return false; // error recovery1905 }1906 if (!proc->IsSubroutine()) {1907 SayWithDeclaration(subroutine, finalName,1908 "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US,1909 subroutine.name(), derivedType.name());1910 return false;1911 }1912 if (proc->dummyArguments.size() != 1) {1913 SayWithDeclaration(subroutine, finalName,1914 "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US,1915 subroutine.name(), derivedType.name());1916 return false;1917 }1918 const auto &arg{proc->dummyArguments[0]};1919 const Symbol *errSym{&subroutine};1920 if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {1921 if (!details->dummyArgs().empty()) {1922 if (const Symbol *argSym{details->dummyArgs()[0]}) {1923 errSym = argSym;1924 }1925 }1926 }1927 const auto *ddo{std::get_if<DummyDataObject>(&arg.u)};1928 if (!ddo) {1929 SayWithDeclaration(subroutine, finalName,1930 "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US,1931 subroutine.name(), derivedType.name());1932 return false;1933 }1934 bool ok{true};1935 if (arg.IsOptional()) {1936 SayWithDeclaration(*errSym, finalName,1937 "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US,1938 subroutine.name(), derivedType.name());1939 ok = false;1940 }1941 if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) {1942 SayWithDeclaration(*errSym, finalName,1943 "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US,1944 subroutine.name(), derivedType.name());1945 ok = false;1946 }1947 if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) {1948 SayWithDeclaration(*errSym, finalName,1949 "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US,1950 subroutine.name(), derivedType.name());1951 ok = false;1952 }1953 if (ddo->intent == common::Intent::Out) {1954 SayWithDeclaration(*errSym, finalName,1955 "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US,1956 subroutine.name(), derivedType.name());1957 ok = false;1958 }1959 if (ddo->attrs.test(DummyDataObject::Attr::Value)) {1960 SayWithDeclaration(*errSym, finalName,1961 "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US,1962 subroutine.name(), derivedType.name());1963 ok = false;1964 }1965 if (ddo->type.corank() > 0) {1966 SayWithDeclaration(*errSym, finalName,1967 "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US,1968 subroutine.name(), derivedType.name());1969 ok = false;1970 }1971 if (ddo->type.type().IsPolymorphic()) {1972 SayWithDeclaration(*errSym, finalName,1973 "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US,1974 subroutine.name(), derivedType.name());1975 ok = false;1976 } else if (ddo->type.type().category() != TypeCategory::Derived ||1977 &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) {1978 SayWithDeclaration(*errSym, finalName,1979 "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US,1980 subroutine.name(), derivedType.name(), derivedType.name());1981 ok = false;1982 } else { // check that all LEN type parameters are assumed1983 for (auto ref : OrderParameterDeclarations(derivedType)) {1984 if (IsLenTypeParameter(*ref)) {1985 const auto *value{1986 ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};1987 if (!value || !value->isAssumed()) {1988 SayWithDeclaration(*errSym, finalName,1989 "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,1990 subroutine.name(), derivedType.name(), ref->name());1991 ok = false;1992 }1993 }1994 }1995 }1996 return ok;1997}1998 1999bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,2000 SourceName f1Name, const Symbol &f2, SourceName f2Name,2001 const Symbol &derivedType) {2002 const Procedure *p1{Characterize(f1)};2003 const Procedure *p2{Characterize(f2)};2004 if (p1 && p2) {2005 if (characteristics::Distinguishable(context_.languageFeatures(), *p1, *p2)2006 .value_or(false)) {2007 return true;2008 }2009 if (auto *msg{messages_.Say(f1Name,2010 "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,2011 f1Name, f2Name, derivedType.name())}) {2012 msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())2013 .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)2014 .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);2015 }2016 }2017 return false;2018}2019 2020void CheckHelper::CheckHostAssoc(2021 const Symbol &symbol, const HostAssocDetails &details) {2022 const Symbol &hostSymbol{details.symbol()};2023 if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {2024 if (details.implicitOrSpecExprError) {2025 messages_.Say("Implicitly typed local entity '%s' not allowed in"2026 " specification expression"_err_en_US,2027 symbol.name());2028 } else if (details.implicitOrExplicitTypeError) {2029 messages_.Say(2030 "No explicit type declared for '%s'"_err_en_US, symbol.name());2031 }2032 }2033}2034 2035void CheckHelper::CheckGeneric(2036 const Symbol &symbol, const GenericDetails &details) {2037 CheckSpecifics(symbol, details);2038 common::visit(common::visitors{2039 [&](const common::DefinedIo &io) {2040 CheckDefinedIoProc(symbol, details, io);2041 },2042 [&](const GenericKind::OtherKind &other) {2043 if (other == GenericKind::OtherKind::Name) {2044 CheckGenericVsIntrinsic(symbol, details);2045 }2046 },2047 [](const auto &) {},2048 },2049 details.kind().u);2050 // Ensure that shadowed symbols are checked2051 if (details.specific()) {2052 Check(*details.specific());2053 }2054 if (details.derivedType()) {2055 Check(*details.derivedType());2056 }2057}2058 2059// Check that the specifics of this generic are distinguishable from each other2060void CheckHelper::CollectSpecifics(DistinguishabilityHelper &helper,2061 const Symbol &generic, const GenericDetails &details) {2062 GenericKind kind{details.kind()};2063 for (const Symbol &specific : details.specificProcs()) {2064 if (specific.attrs().test(Attr::ABSTRACT)) {2065 if (auto *msg{messages_.Say(generic.name(),2066 "Generic interface '%s' must not use abstract interface '%s' as a specific procedure"_err_en_US,2067 generic.name(), specific.name())}) {2068 msg->Attach(2069 specific.name(), "Definition of '%s'"_en_US, specific.name());2070 }2071 continue;2072 }2073 if (specific.attrs().test(Attr::INTRINSIC)) {2074 // GNU Fortran allows INTRINSIC procedures in generics.2075 auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(2076 specific.name().ToString())};2077 if (intrinsic && !intrinsic->isRestrictedSpecific) {2078 if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,2079 specific.name(),2080 "Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,2081 specific.name(), generic.name())}) {2082 msg->Attach(2083 generic.name(), "Definition of '%s'"_en_US, generic.name());2084 }2085 } else {2086 if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,2087 specific.name(),2088 "Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,2089 specific.name(), generic.name())}) {2090 msg->Attach(2091 generic.name(), "Definition of '%s'"_en_US, generic.name());2092 }2093 continue;2094 }2095 }2096 if (IsStmtFunction(specific)) {2097 if (auto *msg{messages_.Say(specific.name(),2098 "Specific procedure '%s' of generic interface '%s' may not be a statement function"_err_en_US,2099 specific.name(), generic.name())}) {2100 msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name());2101 }2102 continue;2103 }2104 if (const Procedure *procedure{Characterize(specific)}) {2105 if (procedure->HasExplicitInterface()) {2106 helper.Add(generic, kind, specific, *procedure);2107 } else {2108 if (auto *msg{messages_.Say(specific.name(),2109 "Specific procedure '%s' of generic interface '%s' must have an explicit interface"_err_en_US,2110 specific.name(), generic.name())}) {2111 msg->Attach(2112 generic.name(), "Definition of '%s'"_en_US, generic.name());2113 }2114 }2115 }2116 }2117 if (const Scope * parent{generic.owner().GetDerivedTypeParent()}) {2118 if (const Symbol * inherited{parent->FindComponent(generic.name())}) {2119 if (IsAccessible(*inherited, generic.owner().parent())) {2120 if (const auto *details{inherited->detailsIf<GenericDetails>()}) {2121 // Include specifics of inherited generic of the same name, too2122 CollectSpecifics(helper, *inherited, *details);2123 }2124 }2125 }2126 }2127}2128 2129void CheckHelper::CheckSpecifics(2130 const Symbol &generic, const GenericDetails &details) {2131 DistinguishabilityHelper helper{context_};2132 CollectSpecifics(helper, generic, details);2133 helper.Check(generic.owner());2134}2135 2136static bool CUDAHostDeviceDiffer(2137 const Procedure &proc, const DummyDataObject &arg) {2138 auto procCUDA{2139 proc.cudaSubprogramAttrs.value_or(common::CUDASubprogramAttrs::Host)};2140 bool procIsHostOnly{procCUDA == common::CUDASubprogramAttrs::Host};2141 bool procIsDeviceOnly{2142 !procIsHostOnly && procCUDA != common::CUDASubprogramAttrs::HostDevice};2143 const auto &argCUDA{arg.cudaDataAttr};2144 bool argIsHostOnly{!argCUDA || *argCUDA == common::CUDADataAttr::Pinned};2145 bool argIsDeviceOnly{(!argCUDA && procIsDeviceOnly) ||2146 (argCUDA &&2147 (*argCUDA != common::CUDADataAttr::Managed &&2148 *argCUDA != common::CUDADataAttr::Pinned &&2149 *argCUDA != common::CUDADataAttr::Unified))};2150 return (procIsHostOnly && argIsDeviceOnly) ||2151 (procIsDeviceOnly && argIsHostOnly);2152}2153 2154static bool ConflictsWithIntrinsicAssignment(const Procedure &proc) {2155 const auto &lhsData{std::get<DummyDataObject>(proc.dummyArguments[0].u)};2156 const auto &lhsTnS{lhsData.type};2157 const auto &rhsData{std::get<DummyDataObject>(proc.dummyArguments[1].u)};2158 const auto &rhsTnS{rhsData.type};2159 return !CUDAHostDeviceDiffer(proc, lhsData) &&2160 !CUDAHostDeviceDiffer(proc, rhsData) &&2161 Tristate::No ==2162 IsDefinedAssignment(2163 lhsTnS.type(), lhsTnS.Rank(), rhsTnS.type(), rhsTnS.Rank());2164}2165 2166static bool ConflictsWithIntrinsicOperator(2167 const GenericKind &kind, const Procedure &proc, SemanticsContext &context) {2168 if (!kind.IsIntrinsicOperator()) {2169 return false;2170 }2171 const auto &arg0Data{std::get<DummyDataObject>(proc.dummyArguments[0].u)};2172 if (CUDAHostDeviceDiffer(proc, arg0Data)) {2173 return false;2174 }2175 const auto &arg0TnS{arg0Data.type};2176 auto type0{arg0TnS.type()};2177 if (proc.dummyArguments.size() == 1) { // unary2178 return common::visit(2179 common::visitors{2180 [&](common::NumericOperator) { return IsIntrinsicNumeric(type0); },2181 [&](common::LogicalOperator) { return IsIntrinsicLogical(type0); },2182 [](const auto &) -> bool { DIE("bad generic kind"); },2183 },2184 kind.u);2185 } else { // binary2186 int rank0{arg0TnS.Rank()};2187 const auto &arg1Data{std::get<DummyDataObject>(proc.dummyArguments[1].u)};2188 if (CUDAHostDeviceDiffer(proc, arg1Data)) {2189 return false;2190 }2191 const auto &arg1TnS{arg1Data.type};2192 auto type1{arg1TnS.type()};2193 int rank1{arg1TnS.Rank()};2194 return common::visit(2195 common::visitors{2196 [&](common::NumericOperator) {2197 return IsIntrinsicNumeric(type0, rank0, type1, rank1);2198 },2199 [&](common::LogicalOperator) {2200 return IsIntrinsicLogical(type0, rank0, type1, rank1);2201 },2202 [&](common::RelationalOperator opr) {2203 return IsIntrinsicRelational(opr, type0, rank0, type1, rank1);2204 },2205 [&](GenericKind::OtherKind x) {2206 CHECK(x == GenericKind::OtherKind::Concat);2207 return IsIntrinsicConcat(type0, rank0, type1, rank1);2208 },2209 [](const auto &) -> bool { DIE("bad generic kind"); },2210 },2211 kind.u);2212 }2213}2214 2215// Check if this procedure can be used for defined operators (see 15.4.3.4.2).2216bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,2217 const Symbol &specific, const Procedure &proc) {2218 if (context_.HasError(specific)) {2219 return false;2220 }2221 std::optional<parser::MessageFixedText> msg;2222 auto checkDefinedOperatorArgs{2223 [&](SourceName opName, const Symbol &specific, const Procedure &proc) {2224 bool arg0Defined{CheckDefinedOperatorArg(opName, specific, proc, 0)};2225 bool arg1Defined{CheckDefinedOperatorArg(opName, specific, proc, 1)};2226 return arg0Defined && arg1Defined;2227 }};2228 if (specific.attrs().test(Attr::NOPASS)) { // C7742229 msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US;2230 } else if (!proc.functionResult.has_value()) {2231 msg = "%s procedure '%s' must be a function"_err_en_US;2232 } else if (proc.functionResult->IsAssumedLengthCharacter()) {2233 const auto *subpDetails{specific.detailsIf<SubprogramDetails>()};2234 if (subpDetails && !subpDetails->isDummy() && subpDetails->isInterface()) {2235 // Error is caught by more general test for interfaces with2236 // assumed-length character function results2237 return true;2238 }2239 msg = "%s function '%s' may not have assumed-length CHARACTER(*)"2240 " result"_err_en_US;2241 } else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {2242 if (m->IsFatal()) {2243 msg = *m;2244 } else {2245 evaluate::AttachDeclaration(2246 Warn(common::UsageWarning::DefinedOperatorArgs, specific.name(),2247 std::move(*m), MakeOpName(opName), specific.name()),2248 specific);2249 return true;2250 }2251 } else if (!checkDefinedOperatorArgs(opName, specific, proc)) {2252 return false; // error was reported2253 } else if (ConflictsWithIntrinsicOperator(kind, proc, context_)) {2254 msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;2255 }2256 if (msg) {2257 SayWithDeclaration(2258 specific, std::move(*msg), MakeOpName(opName), specific.name());2259 context_.SetError(specific);2260 return false;2261 }2262 return true;2263}2264 2265// If the number of arguments is wrong for this intrinsic operator, return2266// false and return the error message in msg.2267std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs(2268 const GenericKind &kind, std::size_t nargs) {2269 if (!kind.IsIntrinsicOperator()) {2270 if (nargs < 1 || nargs > 2) {2271 if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {2272 return "%s function '%s' should have 1 or 2 dummy arguments"_warn_en_US;2273 }2274 }2275 return std::nullopt;2276 }2277 std::size_t min{2}, max{2}; // allowed number of args; default is binary2278 common::visit(common::visitors{2279 [&](const common::NumericOperator &x) {2280 if (x == common::NumericOperator::Add ||2281 x == common::NumericOperator::Subtract) {2282 min = 1; // + and - are unary or binary2283 }2284 },2285 [&](const common::LogicalOperator &x) {2286 if (x == common::LogicalOperator::Not) {2287 min = 1; // .NOT. is unary2288 max = 1;2289 }2290 },2291 [](const common::RelationalOperator &) {2292 // all are binary2293 },2294 [](const GenericKind::OtherKind &x) {2295 CHECK(x == GenericKind::OtherKind::Concat);2296 },2297 [](const auto &) { DIE("expected intrinsic operator"); },2298 },2299 kind.u);2300 if (nargs >= min && nargs <= max) {2301 return std::nullopt;2302 } else if (max == 1) {2303 return "%s function '%s' must have one dummy argument"_err_en_US;2304 } else if (min == 2) {2305 return "%s function '%s' must have two dummy arguments"_err_en_US;2306 } else {2307 return "%s function '%s' must have one or two dummy arguments"_err_en_US;2308 }2309}2310 2311bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,2312 const Symbol &symbol, const Procedure &proc, std::size_t pos) {2313 if (pos >= proc.dummyArguments.size()) {2314 return true;2315 }2316 auto &arg{proc.dummyArguments.at(pos)};2317 std::optional<parser::MessageFixedText> msg;2318 if (arg.IsOptional()) {2319 msg =2320 "In %s function '%s', dummy argument '%s' may not be OPTIONAL"_err_en_US;2321 } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};2322 dataObject == nullptr) {2323 msg =2324 "In %s function '%s', dummy argument '%s' must be a data object"_err_en_US;2325 } else if (dataObject->intent == common::Intent::Out) {2326 msg =2327 "In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;2328 } else if (dataObject->intent != common::Intent::In &&2329 !dataObject->attrs.test(DummyDataObject::Attr::Value)) {2330 evaluate::AttachDeclaration(2331 Warn(common::UsageWarning::DefinedOperatorArgs,2332 "In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US,2333 parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),2334 arg.name),2335 symbol);2336 return true;2337 }2338 if (msg) {2339 SayWithDeclaration(symbol, std::move(*msg),2340 parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);2341 return false;2342 }2343 return true;2344}2345 2346// Check if this procedure can be used for defined assignment (see 15.4.3.4.3).2347bool CheckHelper::CheckDefinedAssignment(2348 const Symbol &specific, const Procedure &proc) {2349 if (context_.HasError(specific)) {2350 return false;2351 }2352 std::optional<parser::MessageFixedText> msg;2353 if (specific.attrs().test(Attr::NOPASS)) { // C7742354 msg = "Defined assignment procedure '%s' may not have"2355 " NOPASS attribute"_err_en_US;2356 } else if (!proc.IsSubroutine()) {2357 msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US;2358 } else if (proc.dummyArguments.size() != 2) {2359 msg = "Defined assignment subroutine '%s' must have"2360 " two dummy arguments"_err_en_US;2361 } else {2362 // Check both arguments even if the first has an error.2363 bool ok0{CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0)};2364 bool ok1{CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)};2365 if (!(ok0 && ok1)) {2366 return false; // error was reported2367 } else if (ConflictsWithIntrinsicAssignment(proc)) {2368 msg =2369 "Defined assignment subroutine '%s' conflicts with intrinsic assignment"_err_en_US;2370 } else {2371 return true; // OK2372 }2373 }2374 SayWithDeclaration(specific, std::move(msg.value()), specific.name());2375 context_.SetError(specific);2376 return false;2377}2378 2379bool CheckHelper::CheckDefinedAssignmentArg(2380 const Symbol &symbol, const DummyArgument &arg, int pos) {2381 std::optional<parser::MessageFixedText> msg;2382 if (arg.IsOptional()) {2383 msg = "In defined assignment subroutine '%s', dummy argument '%s'"2384 " may not be OPTIONAL"_err_en_US;2385 } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {2386 if (pos == 0) {2387 if (dataObject->intent == common::Intent::In) {2388 msg = "In defined assignment subroutine '%s', first dummy argument '%s'"2389 " may not have INTENT(IN)"_err_en_US;2390 } else if (dataObject->intent != common::Intent::Out &&2391 dataObject->intent != common::Intent::InOut) {2392 msg =2393 "In defined assignment subroutine '%s', first dummy argument '%s' should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;2394 }2395 } else if (pos == 1) {2396 if (dataObject->intent == common::Intent::Out) {2397 msg = "In defined assignment subroutine '%s', second dummy"2398 " argument '%s' may not have INTENT(OUT)"_err_en_US;2399 } else if (dataObject->intent != common::Intent::In &&2400 !dataObject->attrs.test(DummyDataObject::Attr::Value)) {2401 msg =2402 "In defined assignment subroutine '%s', second dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;2403 } else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {2404 msg =2405 "In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;2406 } else if (dataObject->attrs.test(DummyDataObject::Attr::Allocatable)) {2407 msg =2408 "In defined assignment subroutine '%s', second dummy argument '%s' must not be an allocatable"_err_en_US;2409 }2410 } else {2411 DIE("pos must be 0 or 1");2412 }2413 } else {2414 msg = "In defined assignment subroutine '%s', dummy argument '%s'"2415 " must be a data object"_err_en_US;2416 }2417 if (msg) {2418 if (msg->IsFatal()) {2419 SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);2420 context_.SetError(symbol);2421 return false;2422 } else {2423 evaluate::AttachDeclaration(2424 Warn(common::UsageWarning::DefinedOperatorArgs, std::move(*msg),2425 symbol.name(), arg.name),2426 symbol);2427 }2428 }2429 return true;2430}2431 2432// Report a conflicting attribute error if symbol has both of these attributes2433bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {2434 if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {2435 messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,2436 symbol.name(), AttrToString(a1), AttrToString(a2));2437 return true;2438 } else {2439 return false;2440 }2441}2442 2443void CheckHelper::WarnMissingFinal(const Symbol &symbol) {2444 const auto *object{symbol.detailsIf<ObjectEntityDetails>()};2445 if (!object || object->IsAssumedRank() ||2446 (!IsAutomaticallyDestroyed(symbol) &&2447 symbol.owner().kind() != Scope::Kind::DerivedType)) {2448 return;2449 }2450 const DeclTypeSpec *type{object->type()};2451 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};2452 const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};2453 int rank{object->shape().Rank()};2454 const Symbol *initialDerivedSym{derivedSym};2455 while (const auto *derivedDetails{2456 derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {2457 if (!derivedDetails->finals().empty() &&2458 !derivedDetails->GetFinalForRank(rank)) {2459 if (auto *msg{derivedSym == initialDerivedSym2460 ? Warn(common::UsageWarning::Final, symbol.name(),2461 "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,2462 symbol.name(), derivedSym->name(), rank)2463 : Warn(common::UsageWarning::Final, symbol.name(),2464 "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,2465 symbol.name(), initialDerivedSym->name(),2466 derivedSym->name(), rank)}) {2467 msg->Attach(derivedSym->name(),2468 "Declaration of derived type '%s'"_en_US, derivedSym->name());2469 }2470 return;2471 }2472 derived = derivedSym->GetParentTypeSpec();2473 derivedSym = derived ? &derived->typeSymbol() : nullptr;2474 }2475}2476 2477const Procedure *CheckHelper::Characterize(const Symbol &symbol) {2478 auto it{characterizeCache_.find(symbol)};2479 if (it == characterizeCache_.end()) {2480 auto pair{characterizeCache_.emplace(SymbolRef{symbol},2481 Procedure::Characterize(symbol, context_.foldingContext()))};2482 it = pair.first;2483 }2484 return common::GetPtrFromOptional(it->second);2485}2486 2487void CheckHelper::CheckVolatile(const Symbol &symbol,2488 const DerivedTypeSpec *derived) { // C866 - C8682489 if (IsIntentIn(symbol)) {2490 messages_.Say(2491 "VOLATILE attribute may not apply to an INTENT(IN) argument"_err_en_US);2492 }2493 if (IsProcedure(symbol)) {2494 messages_.Say("VOLATILE attribute may apply only to a variable"_err_en_US);2495 }2496 if (symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()) {2497 const Symbol &ultimate{symbol.GetUltimate()};2498 if (evaluate::IsCoarray(ultimate)) {2499 messages_.Say(2500 "VOLATILE attribute may not apply to a coarray accessed by USE or host association"_err_en_US);2501 }2502 if (derived) {2503 if (FindCoarrayUltimateComponent(*derived)) {2504 messages_.Say(2505 "VOLATILE attribute may not apply to a type with a coarray ultimate component accessed by USE or host association"_err_en_US);2506 }2507 }2508 }2509}2510 2511void CheckHelper::CheckContiguous(const Symbol &symbol) {2512 if (evaluate::IsVariable(symbol) &&2513 ((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||2514 IsAssumedRank(symbol))) {2515 } else {2516 parser::MessageFixedText msg{symbol.owner().IsDerivedType()2517 ? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US2518 : "CONTIGUOUS entity '%s' should be an array pointer, assumed-shape, or assumed-rank"_port_en_US};2519 if (!context_.IsEnabled(common::LanguageFeature::RedundantContiguous)) {2520 msg.set_severity(parser::Severity::Error);2521 messages_.Say(std::move(msg), symbol.name());2522 } else {2523 Warn(common::LanguageFeature::RedundantContiguous, std::move(msg),2524 symbol.name());2525 }2526 }2527}2528 2529void CheckHelper::CheckPointer(const Symbol &symbol) { // C8522530 CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);2531 CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C7512532 CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);2533 // Prohibit constant pointers. The standard does not explicitly prohibit2534 // them, but the PARAMETER attribute requires a entity-decl to have an2535 // initialization that is a constant-expr, and the only form of2536 // initialization that allows a constant-expr is the one that's not a "=>"2537 // pointer initialization. See C811, C807, and section 8.5.13.2538 CheckConflicting(symbol, Attr::POINTER, Attr::PARAMETER);2539 if (symbol.Corank() > 0) {2540 messages_.Say(2541 "'%s' may not have the POINTER attribute because it is a coarray"_err_en_US,2542 symbol.name());2543 }2544}2545 2546// C760 constraints on the passed-object dummy argument2547// C757 constraints on procedure pointer components2548void CheckHelper::CheckPassArg(2549 const Symbol &proc, const Symbol *interface0, const WithPassArg &details) {2550 if (proc.attrs().test(Attr::NOPASS)) {2551 return;2552 }2553 const auto &name{proc.name()};2554 const Symbol *interface {2555 interface0 ? FindInterface(*interface0) : nullptr2556 };2557 if (!interface) {2558 messages_.Say(name,2559 "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,2560 name);2561 return;2562 }2563 const auto *subprogram{interface->detailsIf<SubprogramDetails>()};2564 if (!subprogram) {2565 messages_.Say(name,2566 "Procedure component '%s' has invalid interface '%s'"_err_en_US, name,2567 interface->name());2568 return;2569 }2570 std::optional<SourceName> passName{details.passName()};2571 const auto &dummyArgs{subprogram->dummyArgs()};2572 if (!passName) {2573 if (dummyArgs.empty()) {2574 messages_.Say(name,2575 proc.has<ProcEntityDetails>()2576 ? "Procedure component '%s' with no dummy arguments"2577 " must have NOPASS attribute"_err_en_US2578 : "Procedure binding '%s' with no dummy arguments"2579 " must have NOPASS attribute"_err_en_US,2580 name);2581 context_.SetError(*interface);2582 return;2583 }2584 Symbol *argSym{dummyArgs[0]};2585 if (!argSym) {2586 messages_.Say(interface->name(),2587 "Cannot use an alternate return as the passed-object dummy "2588 "argument"_err_en_US);2589 return;2590 }2591 passName = dummyArgs[0]->name();2592 }2593 std::optional<int> passArgIndex{};2594 for (std::size_t i{0}; i < dummyArgs.size(); ++i) {2595 if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {2596 passArgIndex = i;2597 break;2598 }2599 }2600 if (!passArgIndex) { // C7582601 messages_.Say(*passName,2602 "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,2603 *passName, interface->name());2604 return;2605 }2606 const Symbol &passArg{*dummyArgs[*passArgIndex]};2607 std::optional<parser::MessageFixedText> msg;2608 if (!passArg.has<ObjectEntityDetails>()) {2609 msg = "Passed-object dummy argument '%s' of procedure '%s'"2610 " must be a data object"_err_en_US;2611 } else if (passArg.attrs().test(Attr::POINTER)) {2612 msg = "Passed-object dummy argument '%s' of procedure '%s'"2613 " may not have the POINTER attribute"_err_en_US;2614 } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {2615 msg = "Passed-object dummy argument '%s' of procedure '%s'"2616 " may not have the ALLOCATABLE attribute"_err_en_US;2617 } else if (passArg.attrs().test(Attr::VALUE)) {2618 msg = "Passed-object dummy argument '%s' of procedure '%s'"2619 " may not have the VALUE attribute"_err_en_US;2620 } else if (passArg.Rank() > 0) {2621 msg = "Passed-object dummy argument '%s' of procedure '%s'"2622 " must be scalar"_err_en_US;2623 }2624 if (msg) {2625 messages_.Say(name, std::move(*msg), passName.value(), name);2626 return;2627 }2628 const DeclTypeSpec *type{passArg.GetType()};2629 if (!type) {2630 return; // an error already occurred2631 }2632 const Symbol &typeSymbol{*proc.owner().GetSymbol()};2633 const DerivedTypeSpec *derived{type->AsDerived()};2634 if (!derived || derived->typeSymbol() != typeSymbol) {2635 messages_.Say(name,2636 "Passed-object dummy argument '%s' of procedure '%s'"2637 " must be of type '%s' but is '%s'"_err_en_US,2638 passName.value(), name, typeSymbol.name(), type->AsFortran());2639 return;2640 }2641 if (IsExtensibleType(derived) != type->IsPolymorphic()) {2642 messages_.Say(name,2643 type->IsPolymorphic()2644 ? "Passed-object dummy argument '%s' of procedure '%s'"2645 " may not be polymorphic because '%s' is not extensible"_err_en_US2646 : "Passed-object dummy argument '%s' of procedure '%s'"2647 " must be polymorphic because '%s' is extensible"_err_en_US,2648 passName.value(), name, typeSymbol.name());2649 return;2650 }2651 for (const auto &[paramName, paramValue] : derived->parameters()) {2652 if (paramValue.isLen() && !paramValue.isAssumed()) {2653 messages_.Say(name,2654 "Passed-object dummy argument '%s' of procedure '%s'"2655 " has non-assumed length parameter '%s'"_err_en_US,2656 passName.value(), name, paramName);2657 }2658 }2659}2660 2661void CheckHelper::CheckProcBinding(2662 const Symbol &symbol, const ProcBindingDetails &binding) {2663 const Scope &dtScope{symbol.owner()};2664 CHECK(dtScope.kind() == Scope::Kind::DerivedType);2665 bool isInaccessibleDeferred{false};2666 const Symbol *overridden{2667 FindOverriddenBinding(symbol, isInaccessibleDeferred)};2668 if (symbol.attrs().test(Attr::DEFERRED)) {2669 if (const Symbol *dtSymbol{dtScope.symbol()}) {2670 if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C7332671 SayWithDeclaration(*dtSymbol,2672 "Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,2673 dtSymbol->name());2674 }2675 }2676 if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) {2677 messages_.Say(2678 "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,2679 symbol.name());2680 }2681 if (overridden && !overridden->attrs().test(Attr::DEFERRED)) {2682 SayWithDeclaration(*overridden,2683 "Override of non-DEFERRED '%s' must not be DEFERRED"_err_en_US,2684 symbol.name());2685 }2686 }2687 if (binding.symbol().attrs().test(Attr::INTRINSIC) &&2688 !context_.intrinsics().IsSpecificIntrinsicFunction(2689 binding.symbol().name().ToString())) {2690 messages_.Say(2691 "Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US,2692 binding.symbol().name(), symbol.name());2693 }2694 if (overridden) {2695 if (isInaccessibleDeferred) {2696 evaluate::AttachDeclaration(2697 Warn(common::LanguageFeature::InaccessibleDeferredOverride,2698 symbol.name(),2699 "Override of PRIVATE DEFERRED '%s' should appear in its module"_warn_en_US,2700 symbol.name()),2701 *overridden);2702 }2703 if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {2704 SayWithDeclaration(*overridden,2705 "Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,2706 symbol.name());2707 }2708 if (const auto *overriddenBinding{2709 overridden->detailsIf<ProcBindingDetails>()}) {2710 if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {2711 SayWithDeclaration(*overridden,2712 "An overridden pure type-bound procedure binding must also be pure"_err_en_US);2713 return;2714 }2715 if (!IsElementalProcedure(binding.symbol()) &&2716 IsElementalProcedure(*overridden)) {2717 SayWithDeclaration(*overridden,2718 "A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);2719 return;2720 }2721 bool isNopass{symbol.attrs().test(Attr::NOPASS)};2722 if (isNopass != overridden->attrs().test(Attr::NOPASS)) {2723 SayWithDeclaration(*overridden,2724 isNopass2725 ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US2726 : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);2727 } else {2728 const auto *bindingChars{Characterize(symbol)};2729 const auto *overriddenChars{Characterize(*overridden)};2730 if (bindingChars && overriddenChars) {2731 if (isNopass) {2732 if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {2733 SayWithDeclaration(*overridden,2734 "A NOPASS type-bound procedure and its override must have identical interfaces"_err_en_US);2735 }2736 } else if (!context_.HasError(binding.symbol())) {2737 auto passIndex{bindingChars->FindPassIndex(binding.passName())};2738 auto overriddenPassIndex{2739 overriddenChars->FindPassIndex(overriddenBinding->passName())};2740 if (passIndex && overriddenPassIndex) {2741 if (*passIndex != *overriddenPassIndex) {2742 SayWithDeclaration(*overridden,2743 "A type-bound procedure and its override must use the same PASS argument"_err_en_US);2744 } else if (!bindingChars->CanOverride(2745 *overriddenChars, passIndex)) {2746 SayWithDeclaration(*overridden,2747 "A type-bound procedure and its override must have compatible interfaces"_err_en_US);2748 }2749 }2750 }2751 }2752 }2753 if (symbol.attrs().test(Attr::PRIVATE)) {2754 if (FindModuleContaining(dtScope) ==2755 FindModuleContaining(overridden->owner())) {2756 // types declared in same madule2757 if (!overridden->attrs().test(Attr::PRIVATE)) {2758 SayWithDeclaration(*overridden,2759 "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);2760 }2761 } else { // types declared in distinct madules2762 if (!CheckAccessibleSymbol(dtScope.parent(), *overridden)) {2763 SayWithDeclaration(*overridden,2764 "A PRIVATE procedure may not override an accessible procedure"_err_en_US);2765 }2766 }2767 }2768 } else {2769 SayWithDeclaration(*overridden,2770 "A type-bound procedure binding may not have the same name as a parent component"_err_en_US);2771 }2772 }2773 CheckPassArg(symbol, &binding.symbol(), binding);2774}2775 2776void CheckHelper::Check(const Scope &scope) {2777 scope_ = &scope;2778 common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_};2779 if (const Symbol *symbol{scope.symbol()}) {2780 innermostSymbol_ = symbol;2781 }2782 if (scope.IsParameterizedDerivedTypeInstantiation()) {2783 auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};2784 auto restorer2{context_.foldingContext().messages().SetContext(2785 scope.instantiationContext().get())};2786 for (const auto &pair : scope) {2787 CheckPointerInitialization(*pair.second);2788 }2789 } else {2790 auto restorer{common::ScopedSet(2791 scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};2792 for (const auto &set : scope.equivalenceSets()) {2793 CheckEquivalenceSet(set);2794 }2795 for (const auto &pair : scope) {2796 Check(*pair.second);2797 }2798 if (scope.IsSubmodule() && scope.symbol()) {2799 // Submodule names are not in their parent's scopes2800 Check(*scope.symbol());2801 }2802 for (const auto &pair : scope.commonBlocks()) {2803 CheckCommonBlock(*pair.second);2804 }2805 int mainProgCnt{0};2806 for (const Scope &child : scope.children()) {2807 Check(child);2808 // A program shall consist of exactly one main program (5.2.2).2809 if (child.kind() == Scope::Kind::MainProgram) {2810 ++mainProgCnt;2811 if (mainProgCnt > 1) {2812 messages_.Say(child.sourceRange(),2813 "A source file cannot contain more than one main program"_err_en_US);2814 }2815 }2816 }2817 if (scope.kind() == Scope::Kind::BlockData) {2818 CheckBlockData(scope);2819 }2820 if (auto name{scope.GetName()}) {2821 auto iter{scope.find(*name)};2822 if (iter != scope.end()) {2823 const char *kind{nullptr};2824 switch (scope.kind()) {2825 case Scope::Kind::Module:2826 kind = scope.symbol()->get<ModuleDetails>().isSubmodule()2827 ? "submodule"2828 : "module";2829 break;2830 case Scope::Kind::MainProgram:2831 kind = "main program";2832 break;2833 case Scope::Kind::BlockData:2834 kind = "BLOCK DATA subprogram";2835 break;2836 default:;2837 }2838 if (kind) {2839 Warn(common::LanguageFeature::BenignNameClash, iter->second->name(),2840 "Name '%s' declared in a %s should not have the same name as the %s"_port_en_US,2841 *name, kind, kind);2842 }2843 }2844 }2845 CheckGenericOps(scope);2846 }2847}2848 2849void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {2850 auto iter{2851 std::find_if(set.begin(), set.end(), [](const EquivalenceObject &object) {2852 return FindCommonBlockContaining(object.symbol) != nullptr;2853 })};2854 if (iter != set.end()) {2855 const Symbol &commonBlock{DEREF(FindCommonBlockContaining(iter->symbol))};2856 for (auto &object : set) {2857 if (&object != &*iter) {2858 if (auto *details{object.symbol.detailsIf<ObjectEntityDetails>()}) {2859 if (details->commonBlock()) {2860 if (details->commonBlock() != &commonBlock) { // 8.10.3 paragraph 12861 if (auto *msg{messages_.Say(object.symbol.name(),2862 "Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks"_err_en_US)}) {2863 msg->Attach(iter->symbol.name(),2864 "Other object in EQUIVALENCE set"_en_US)2865 .Attach(details->commonBlock()->name(),2866 "COMMON block containing '%s'"_en_US,2867 object.symbol.name())2868 .Attach(commonBlock.name(),2869 "COMMON block containing '%s'"_en_US,2870 iter->symbol.name());2871 }2872 }2873 } else {2874 // Mark all symbols in the equivalence set with the same COMMON2875 // block to prevent spurious error messages about initialization2876 // in BLOCK DATA outside COMMON2877 details->set_commonBlock(commonBlock);2878 }2879 }2880 }2881 }2882 }2883 for (const EquivalenceObject &object : set) {2884 CheckEquivalenceObject(object);2885 }2886}2887 2888static bool InCommonWithBind(const Symbol &symbol) {2889 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {2890 const Symbol *commonBlock{details->commonBlock()};2891 return commonBlock && commonBlock->attrs().test(Attr::BIND_C);2892 } else {2893 return false;2894 }2895}2896 2897void CheckHelper::CheckEquivalenceObject(const EquivalenceObject &object) {2898 parser::MessageFixedText msg;2899 const Symbol &symbol{object.symbol};2900 if (symbol.owner().IsDerivedType()) {2901 msg =2902 "Derived type component '%s' is not allowed in an equivalence set"_err_en_US;2903 } else if (IsDummy(symbol)) {2904 msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;2905 } else if (symbol.IsFuncResult()) {2906 msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;2907 } else if (IsPointer(symbol)) {2908 msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;2909 } else if (IsAllocatable(symbol)) {2910 msg =2911 "Allocatable variable '%s' is not allowed in an equivalence set"_err_en_US;2912 } else if (symbol.Corank() > 0) {2913 msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;2914 } else if (symbol.has<UseDetails>()) {2915 msg =2916 "Use-associated variable '%s' is not allowed in an equivalence set"_err_en_US;2917 } else if (symbol.attrs().test(Attr::BIND_C)) {2918 msg =2919 "Variable '%s' with BIND attribute is not allowed in an equivalence set"_err_en_US;2920 } else if (symbol.attrs().test(Attr::TARGET)) {2921 msg =2922 "Variable '%s' with TARGET attribute is not allowed in an equivalence set"_err_en_US;2923 } else if (IsNamedConstant(symbol)) {2924 msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;2925 } else if (InCommonWithBind(symbol)) {2926 msg =2927 "Variable '%s' in common block with BIND attribute is not allowed in an equivalence set"_err_en_US;2928 } else if (!symbol.has<ObjectEntityDetails>()) {2929 msg = "'%s' in equivalence set is not a data object"_err_en_US;2930 } else if (const auto *type{symbol.GetType()}) {2931 const auto *derived{type->AsDerived()};2932 if (derived && !derived->IsVectorType()) {2933 if (const auto *comp{2934 FindUltimateComponent(*derived, IsAllocatableOrPointer)}) {2935 msg = IsPointer(*comp)2936 ? "Derived type object '%s' with pointer ultimate component is not allowed in an equivalence set"_err_en_US2937 : "Derived type object '%s' with allocatable ultimate component is not allowed in an equivalence set"_err_en_US;2938 } else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {2939 msg =2940 "Nonsequence derived type object '%s' is not allowed in an equivalence set"_err_en_US;2941 }2942 } else if (IsAutomatic(symbol)) {2943 msg =2944 "Automatic object '%s' is not allowed in an equivalence set"_err_en_US;2945 } else if (symbol.test(Symbol::Flag::CrayPointee)) {2946 messages_.Say(object.symbol.name(),2947 "Cray pointee '%s' may not be a member of an EQUIVALENCE group"_err_en_US,2948 object.symbol.name());2949 }2950 }2951 if (!msg.text().empty()) {2952 context_.Say(object.source, std::move(msg), symbol.name());2953 }2954}2955 2956void CheckHelper::CheckBlockData(const Scope &scope) {2957 // BLOCK DATA subprograms should contain only named common blocks.2958 // C1415 presents a list of statements that shouldn't appear in2959 // BLOCK DATA, but so long as the subprogram contains no executable2960 // code and allocates no storage outside named COMMON, we're happy2961 // (e.g., an ENUM is strictly not allowed).2962 for (const auto &pair : scope) {2963 const Symbol &symbol{*pair.second};2964 if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() ||2965 symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() ||2966 symbol.has<SubprogramDetails>() ||2967 symbol.has<ObjectEntityDetails>() ||2968 (symbol.has<ProcEntityDetails>() &&2969 !symbol.attrs().test(Attr::POINTER)))) {2970 messages_.Say(symbol.name(),2971 "'%s' may not appear in a BLOCK DATA subprogram"_err_en_US,2972 symbol.name());2973 }2974 }2975}2976 2977// Check distinguishability of generic assignment and operators.2978// For these, generics and generic bindings must be considered together.2979void CheckHelper::CheckGenericOps(const Scope &scope) {2980 DistinguishabilityHelper helper{context_};2981 auto addSpecifics{[&](const Symbol &generic) {2982 if (!IsAccessible(generic, scope)) {2983 return;2984 }2985 const auto *details{generic.GetUltimate().detailsIf<GenericDetails>()};2986 if (!details) {2987 // Not a generic; ensure characteristics are defined if a function.2988 auto restorer{messages_.SetLocation(generic.name())};2989 if (IsFunction(generic) && !context_.HasError(generic)) {2990 if (const Symbol *result{FindFunctionResult(generic)};2991 result && !context_.HasError(*result)) {2992 Characterize(generic);2993 }2994 }2995 return;2996 }2997 GenericKind kind{details->kind()};2998 if (!kind.IsAssignment() && !kind.IsOperator()) {2999 return;3000 }3001 const SymbolVector &specifics{details->specificProcs()};3002 const std::vector<SourceName> &bindingNames{details->bindingNames()};3003 for (std::size_t i{0}; i < specifics.size(); ++i) {3004 const Symbol &specific{*specifics[i]};3005 auto restorer{messages_.SetLocation(bindingNames[i])};3006 if (const Procedure *proc{Characterize(specific)}) {3007 if (kind.IsAssignment()) {3008 if (!CheckDefinedAssignment(specific, *proc)) {3009 continue;3010 }3011 } else {3012 if (!CheckDefinedOperator(generic.name(), kind, specific, *proc)) {3013 continue;3014 }3015 }3016 helper.Add(generic, kind, specific, *proc);3017 }3018 }3019 }};3020 for (const auto &pair : scope) {3021 const Symbol &symbol{*pair.second};3022 addSpecifics(symbol);3023 const Symbol &ultimate{symbol.GetUltimate()};3024 if (ultimate.has<DerivedTypeDetails>()) {3025 if (const Scope *typeScope{ultimate.scope()}) {3026 for (const auto &pair2 : *typeScope) {3027 addSpecifics(*pair2.second);3028 }3029 }3030 }3031 }3032 helper.Check(scope);3033}3034 3035static bool IsSubprogramDefinition(const Symbol &symbol) {3036 const auto *subp{symbol.detailsIf<SubprogramDetails>()};3037 return subp && !subp->isInterface() && symbol.scope() &&3038 symbol.scope()->kind() == Scope::Kind::Subprogram;3039}3040 3041static bool IsExternalProcedureDefinition(const Symbol &symbol) {3042 return IsBlockData(symbol) ||3043 ((IsSubprogramDefinition(symbol) || IsAlternateEntry(&symbol)) &&3044 (IsExternal(symbol) || symbol.GetBindName()));3045}3046 3047static std::optional<std::string> DefinesGlobalName(const Symbol &symbol) {3048 if (const auto *module{symbol.detailsIf<ModuleDetails>()}) {3049 if (!module->isSubmodule() && !symbol.owner().IsIntrinsicModules()) {3050 return symbol.name().ToString();3051 }3052 } else if (IsBlockData(symbol)) {3053 return symbol.name().ToString();3054 } else {3055 const std::string *bindC{symbol.GetBindName()};3056 if (symbol.has<CommonBlockDetails>() ||3057 IsExternalProcedureDefinition(symbol) ||3058 (symbol.owner().IsGlobal() && IsExternal(symbol))) {3059 return bindC ? *bindC : symbol.name().ToString();3060 } else if (bindC &&3061 (symbol.has<ObjectEntityDetails>() || IsModuleProcedure(symbol))) {3062 return *bindC;3063 }3064 }3065 return std::nullopt;3066}3067 3068// 19.2 p23069void CheckHelper::CheckGlobalName(const Symbol &symbol) {3070 if (auto global{DefinesGlobalName(symbol)}) {3071 auto pair{globalNames_.emplace(std::move(*global), symbol)};3072 if (!pair.second) {3073 const Symbol &other{*pair.first->second};3074 if (context_.HasError(symbol) || context_.HasError(other)) {3075 // don't pile on3076 } else if (symbol.has<CommonBlockDetails>() &&3077 other.has<CommonBlockDetails>() && symbol.name() == other.name()) {3078 // Two common blocks can have the same global name so long as3079 // they're not in the same scope.3080 } else if ((IsProcedure(symbol) || IsBlockData(symbol)) &&3081 (IsProcedure(other) || IsBlockData(other)) &&3082 (!IsExternalProcedureDefinition(symbol) ||3083 !IsExternalProcedureDefinition(other))) {3084 // both are procedures/BLOCK DATA, not both definitions3085 } else if (AreSameModuleSymbol(symbol, other)) {3086 // Both symbols are the same thing.3087 } else if (symbol.has<ModuleDetails>()) {3088 Warn(common::LanguageFeature::BenignNameClash, symbol.name(),3089 "Module '%s' conflicts with a global name"_port_en_US,3090 pair.first->first);3091 } else if (other.has<ModuleDetails>()) {3092 Warn(common::LanguageFeature::BenignNameClash, symbol.name(),3093 "Global name '%s' conflicts with a module"_port_en_US,3094 pair.first->first);3095 } else if (auto *msg{messages_.Say(symbol.name(),3096 "Two entities have the same global name '%s'"_err_en_US,3097 pair.first->first)}) {3098 msg->Attach(other.name(), "Conflicting declaration"_en_US);3099 context_.SetError(symbol);3100 context_.SetError(other);3101 }3102 }3103 }3104}3105 3106void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {3107 if (!IsProcedure(symbol) || symbol != symbol.GetUltimate())3108 return;3109 const std::string *bindName{symbol.GetBindName()};3110 const bool hasExplicitBindingLabel{3111 symbol.GetIsExplicitBindName() && bindName};3112 if (hasExplicitBindingLabel || IsExternal(symbol)) {3113 const std::string assemblyName{hasExplicitBindingLabel3114 ? *bindName3115 : common::GetExternalAssemblyName(3116 symbol.name().ToString(), context_.underscoring())};3117 auto pair{procedureAssemblyNames_.emplace(std::move(assemblyName), symbol)};3118 if (!pair.second) {3119 const Symbol &other{*pair.first->second};3120 const bool otherHasExplicitBindingLabel{3121 other.GetIsExplicitBindName() && other.GetBindName()};3122 if (otherHasExplicitBindingLabel != hasExplicitBindingLabel) {3123 // The BIND(C,NAME="...") binding label is the same as the name that3124 // will be used in LLVM IR for an external procedure declared without3125 // BIND(C) in the same file. While this is not forbidden by the3126 // standard, this name collision would lead to a crash when producing3127 // the IR.3128 if (auto *msg{messages_.Say(symbol.name(),3129 "%s procedure assembly name conflicts with %s procedure assembly name"_err_en_US,3130 hasExplicitBindingLabel ? "BIND(C)" : "Non BIND(C)",3131 hasExplicitBindingLabel ? "non BIND(C)" : "BIND(C)")}) {3132 msg->Attach(other.name(), "Conflicting declaration"_en_US);3133 }3134 context_.SetError(symbol);3135 context_.SetError(other);3136 }3137 // Otherwise, the global names also match and the conflict is analyzed3138 // by CheckGlobalName.3139 }3140 }3141}3142 3143parser::Messages CheckHelper::WhyNotInteroperableDerivedType(3144 const Symbol &symbol) {3145 parser::Messages msgs;3146 if (examinedByWhyNotInteroperable_.find(symbol) !=3147 examinedByWhyNotInteroperable_.end()) {3148 return msgs;3149 }3150 examinedByWhyNotInteroperable_.insert(symbol);3151 if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {3152 if (derived->sequence()) { // C18013153 msgs.Say(symbol.name(),3154 "An interoperable derived type cannot have the SEQUENCE attribute"_err_en_US);3155 } else if (!derived->paramNameOrder().empty()) { // C18023156 msgs.Say(symbol.name(),3157 "An interoperable derived type cannot have a type parameter"_err_en_US);3158 } else if (const auto *parent{3159 symbol.scope()->GetDerivedTypeParent()}) { // C18033160 if (symbol.attrs().test(Attr::BIND_C)) {3161 msgs.Say(symbol.name(),3162 "A derived type with the BIND attribute cannot be an extended derived type"_err_en_US);3163 } else {3164 bool interoperableParent{true};3165 if (parent->symbol()) {3166 auto bad{WhyNotInteroperableDerivedType(*parent->symbol())};3167 if (bad.AnyFatalError()) {3168 auto &msg{msgs.Say(symbol.name(),3169 "The parent of an interoperable type is not interoperable"_err_en_US)};3170 bad.AttachTo(msg, parser::Severity::None);3171 interoperableParent = false;3172 }3173 }3174 if (interoperableParent) {3175 msgs.Say(symbol.name(),3176 "An interoperable type should not be an extended derived type"_warn_en_US);3177 }3178 }3179 }3180 const Symbol *parentComponent{symbol.scope()3181 ? derived->GetParentComponent(*symbol.scope())3182 : nullptr};3183 for (const auto &pair : *symbol.scope()) {3184 const Symbol &component{*pair.second};3185 if (&component == parentComponent) {3186 continue; // was checked above3187 }3188 if (IsProcedure(component)) { // C18043189 msgs.Say(component.name(),3190 "An interoperable derived type cannot have a type bound procedure"_err_en_US);3191 } else if (IsAllocatableOrPointer(component)) { // C18063192 msgs.Say(component.name(),3193 "An interoperable derived type cannot have a pointer or allocatable component"_err_en_US);3194 } else if (const auto *type{component.GetType()}) {3195 if (const auto *derived{type->AsDerived()}) {3196 auto bad{WhyNotInteroperableDerivedType(derived->typeSymbol())};3197 if (bad.AnyFatalError()) {3198 auto &msg{msgs.Say(component.name(),3199 "Component '%s' of an interoperable derived type must have an interoperable type but does not"_err_en_US,3200 component.name())};3201 bad.AttachTo(msg, parser::Severity::None);3202 } else if (!derived->typeSymbol().GetUltimate().attrs().test(3203 Attr::BIND_C)) {3204 auto &msg{3205 msgs.Say(component.name(),3206 "Derived type of component '%s' of an interoperable derived type should have the BIND attribute"_warn_en_US,3207 component.name())3208 .Attach(derived->typeSymbol().name(),3209 "Non-BIND(C) component type"_en_US)};3210 bad.AttachTo(msg, parser::Severity::None);3211 } else {3212 msgs.Annex(std::move(bad));3213 }3214 } else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&3215 !evaluate::IsInteroperableIntrinsicType(3216 *dyType, &context_.languageFeatures())3217 .value_or(false)) {3218 if (type->category() == DeclTypeSpec::Logical) {3219 context().Warn(msgs, common::UsageWarning::LogicalVsCBool,3220 component.name(),3221 "A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);3222 } else if (type->category() == DeclTypeSpec::Character && dyType &&3223 dyType->kind() == 1) {3224 context().Warn(msgs, common::UsageWarning::BindCCharLength,3225 component.name(),3226 "A CHARACTER component of an interoperable type should have length 1"_port_en_US);3227 } else {3228 msgs.Say(component.name(),3229 "Each component of an interoperable derived type must have an interoperable type"_err_en_US);3230 }3231 }3232 }3233 if (auto extents{3234 evaluate::GetConstantExtents(foldingContext_, &component)};3235 extents && evaluate::GetSize(*extents) == 0) {3236 msgs.Say(component.name(),3237 "An array component of an interoperable type must have at least one element"_err_en_US);3238 }3239 }3240 if (derived->componentNames().empty()) { // F'2023 C18053241 context().Warn(msgs, common::LanguageFeature::EmptyBindCDerivedType,3242 symbol.name(),3243 "A derived type with the BIND attribute should not be empty"_warn_en_US);3244 }3245 }3246 if (msgs.AnyFatalError()) {3247 examinedByWhyNotInteroperable_.erase(symbol);3248 }3249 return msgs;3250}3251 3252parser::Messages CheckHelper::WhyNotInteroperableObject(3253 const Symbol &symbol, bool allowNonInteroperableType, bool forCommonBlock) {3254 parser::Messages msgs;3255 if (!forCommonBlock) {3256 if (examinedByWhyNotInteroperable_.find(symbol) !=3257 examinedByWhyNotInteroperable_.end()) {3258 return msgs;3259 }3260 examinedByWhyNotInteroperable_.insert(symbol);3261 }3262 bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};3263 CHECK(symbol.has<ObjectEntityDetails>());3264 if (isExplicitBindC && !symbol.owner().IsModule()) {3265 msgs.Say(symbol.name(),3266 "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);3267 }3268 auto shape{evaluate::GetShape(foldingContext_, symbol)};3269 if (shape) {3270 if (evaluate::GetRank(*shape) == 0) { // 18.3.43271 if (IsAllocatableOrPointer(symbol) && !IsDummy(symbol)) {3272 msgs.Say(symbol.name(),3273 "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);3274 }3275 } else if (auto extents{3276 evaluate::AsConstantExtents(foldingContext_, *shape)}) {3277 if (evaluate::GetSize(*extents) == 0) {3278 msgs.Say(symbol.name(),3279 "Interoperable array must have at least one element"_err_en_US);3280 }3281 } else if (!evaluate::IsExplicitShape(symbol) &&3282 !IsAssumedSizeArray(symbol) &&3283 !(IsDummy(symbol) && !symbol.attrs().test(Attr::VALUE))) {3284 msgs.Say(symbol.name(),3285 "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);3286 }3287 }3288 if (const auto *type{symbol.GetType()}) {3289 const auto *derived{type->AsDerived()};3290 if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {3291 if (allowNonInteroperableType) { // portability warning only3292 evaluate::AttachDeclaration(3293 Warn(common::UsageWarning::Portability, symbol.name(),3294 "The derived type of this interoperable object should be BIND(C)"_port_en_US),3295 derived->typeSymbol());3296 } else if (!context_.IsEnabled(3297 common::LanguageFeature::NonBindCInteroperability)) {3298 msgs.Say(symbol.name(),3299 "The derived type of an interoperable object must be BIND(C)"_err_en_US)3300 .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);3301 } else if (auto bad{3302 WhyNotInteroperableDerivedType(derived->typeSymbol())};3303 bad.AnyFatalError()) {3304 bad.AttachTo(3305 msgs.Say(symbol.name(),3306 "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)3307 .Attach(derived->typeSymbol().name(),3308 "Non-interoperable type"_en_US),3309 parser::Severity::None);3310 } else {3311 msgs.Say(symbol.name(),3312 "The derived type of an interoperable object should be BIND(C)"_warn_en_US)3313 .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);3314 }3315 }3316 if (type->IsAssumedType()) { // ok3317 } else if (IsAssumedLengthCharacter(symbol) &&3318 !IsAllocatableOrPointer(symbol)) {3319 } else if (IsAllocatableOrPointer(symbol) &&3320 type->category() == DeclTypeSpec::Character &&3321 type->characterTypeSpec().length().isDeferred()) {3322 // ok; F'2023 18.3.7 p2(6)3323 } else if (derived) { // type has been checked3324 } else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&3325 evaluate::IsInteroperableIntrinsicType(3326 *dyType, InModuleFile() ? nullptr : &context_.languageFeatures())3327 .value_or(false)) {3328 // F'2023 18.3.7 p2(4,5)3329 // N.B. Language features are not passed to IsInteroperableIntrinsicType3330 // when processing a module file, since the module file might have been3331 // compiled with CUDA while the client is not.3332 } else if (type->category() == DeclTypeSpec::Logical) {3333 if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {3334 if (IsDummy(symbol)) {3335 Warn(common::UsageWarning::LogicalVsCBool, symbol.name(),3336 "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);3337 } else {3338 Warn(common::UsageWarning::LogicalVsCBool, symbol.name(),3339 "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);3340 }3341 }3342 } else if (symbol.attrs().test(Attr::VALUE)) {3343 msgs.Say(symbol.name(),3344 "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);3345 } else {3346 msgs.Say(symbol.name(),3347 "A BIND(C) object must have an interoperable type"_err_en_US);3348 }3349 }3350 if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {3351 msgs.Say(symbol.name(),3352 "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);3353 }3354 if (IsDescriptor(symbol) && IsPointer(symbol) &&3355 symbol.attrs().test(Attr::CONTIGUOUS)) {3356 msgs.Say(symbol.name(),3357 "An interoperable pointer must not be CONTIGUOUS"_err_en_US);3358 }3359 if (!forCommonBlock && msgs.AnyFatalError()) {3360 examinedByWhyNotInteroperable_.erase(symbol);3361 }3362 return msgs;3363}3364 3365parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(3366 const Symbol &symbol) {3367 parser::Messages msgs;3368 if (IsPointer(symbol) || IsAllocatable(symbol)) {3369 msgs.Say(symbol.name(),3370 "Interoperable function result may not have ALLOCATABLE or POINTER attribute"_err_en_US);3371 }3372 if (const DeclTypeSpec * type{symbol.GetType()};3373 type && type->category() == DeclTypeSpec::Character) {3374 bool isConstOne{false}; // 18.3.1(1)3375 if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {3376 if (auto constLen{evaluate::ToInt64(*len)}) {3377 isConstOne = constLen == 1;3378 }3379 }3380 if (!isConstOne) {3381 msgs.Say(symbol.name(),3382 "Interoperable character function result must have length one"_err_en_US);3383 }3384 }3385 if (symbol.Rank() > 0) {3386 msgs.Say(symbol.name(),3387 "Interoperable function result must be scalar"_err_en_US);3388 }3389 return msgs;3390}3391 3392parser::Messages CheckHelper::WhyNotInteroperableProcedure(3393 const Symbol &symbol, bool isError) {3394 parser::Messages msgs;3395 if (examinedByWhyNotInteroperable_.find(symbol) !=3396 examinedByWhyNotInteroperable_.end()) {3397 return msgs;3398 }3399 isError |= symbol.attrs().test(Attr::BIND_C);3400 examinedByWhyNotInteroperable_.insert(symbol);3401 if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {3402 if (isError) {3403 if (!proc->procInterface() ||3404 !proc->procInterface()->attrs().test(Attr::BIND_C)) {3405 msgs.Say(symbol.name(),3406 "An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration"_err_en_US);3407 }3408 } else if (!proc->procInterface()) {3409 msgs.Say(symbol.name(),3410 "An interoperable procedure should have an interface"_port_en_US);3411 } else if (!proc->procInterface()->attrs().test(Attr::BIND_C)) {3412 auto bad{WhyNotInteroperableProcedure(3413 *proc->procInterface(), /*isError=*/false)};3414 if (bad.AnyFatalError()) {3415 bad.AttachTo(msgs.Say(symbol.name(),3416 "An interoperable procedure must have an interoperable interface"_err_en_US));3417 } else {3418 msgs.Say(symbol.name(),3419 "An interoperable procedure should have an interface with the BIND attribute"_warn_en_US);3420 }3421 }3422 } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {3423 for (const Symbol *dummy : subp->dummyArgs()) {3424 if (dummy) {3425 parser::Messages dummyMsgs;3426 if (dummy->has<ProcEntityDetails>() ||3427 dummy->has<SubprogramDetails>()) {3428 dummyMsgs = WhyNotInteroperableProcedure(*dummy, /*isError=*/false);3429 if (dummyMsgs.empty() && !dummy->attrs().test(Attr::BIND_C)) {3430 dummyMsgs.Say(dummy->name(),3431 "A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);3432 }3433 } else if (dummy->has<ObjectEntityDetails>()) {3434 // Emit only optional portability warnings for non-interoperable3435 // types when the dummy argument is not VALUE and will be implemented3436 // on the C side by either a cdesc_t * or a void *. F'2023 18.3.7 (5)3437 bool allowNonInteroperableType{!dummy->attrs().test(Attr::VALUE) &&3438 (IsDescriptor(*dummy) || IsAssumedType(*dummy))};3439 dummyMsgs = WhyNotInteroperableObject(3440 *dummy, allowNonInteroperableType, /*forCommonBlock=*/false);3441 } else {3442 CheckBindC(*dummy);3443 }3444 msgs.Annex(std::move(dummyMsgs));3445 } else {3446 msgs.Say(symbol.name(),3447 "A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);3448 }3449 }3450 if (subp->isFunction()) {3451 if (subp->result().has<ObjectEntityDetails>()) {3452 msgs.Annex(WhyNotInteroperableFunctionResult(subp->result()));3453 } else {3454 msgs.Say(subp->result().name(),3455 "The result of an interoperable function must be a data object"_err_en_US);3456 }3457 }3458 }3459 if (msgs.AnyFatalError()) {3460 examinedByWhyNotInteroperable_.erase(symbol);3461 }3462 return msgs;3463}3464 3465void CheckHelper::CheckBindC(const Symbol &symbol) {3466 bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};3467 if (isExplicitBindC) {3468 CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);3469 CheckConflicting(symbol, Attr::BIND_C, Attr::INTRINSIC);3470 CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);3471 } else {3472 // symbol must be interoperable (e.g., dummy argument of interoperable3473 // procedure interface) but is not itself BIND(C).3474 }3475 parser::Messages whyNot;3476 if (const std::string * bindName{symbol.GetBindName()};3477 bindName) { // has a binding name3478 if (!bindName->empty()) {3479 bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())};3480 for (char ch : *bindName) {3481 ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch);3482 }3483 if (!ok) {3484 messages_.Say(symbol.name(),3485 "Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US);3486 context_.SetError(symbol);3487 }3488 }3489 }3490 if (symbol.GetIsExplicitBindName()) { // BIND(C,NAME=...); C1552, C15293491 auto defClass{ClassifyProcedure(symbol)};3492 if (IsProcedurePointer(symbol)) {3493 messages_.Say(symbol.name(),3494 "A procedure pointer may not have a BIND attribute with a name"_err_en_US);3495 context_.SetError(symbol);3496 } else if (defClass == ProcedureDefinitionClass::None ||3497 IsExternal(symbol)) {3498 } else if (symbol.attrs().test(Attr::ABSTRACT)) {3499 messages_.Say(symbol.name(),3500 "An ABSTRACT interface may not have a BIND attribute with a name"_err_en_US);3501 context_.SetError(symbol);3502 } else if (defClass == ProcedureDefinitionClass::Internal ||3503 defClass == ProcedureDefinitionClass::Dummy) {3504 messages_.Say(symbol.name(),3505 "An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US);3506 context_.SetError(symbol);3507 }3508 }3509 if (symbol.has<ObjectEntityDetails>()) {3510 whyNot = WhyNotInteroperableObject(symbol);3511 } else if (symbol.has<ProcEntityDetails>() ||3512 symbol.has<SubprogramDetails>()) {3513 whyNot = WhyNotInteroperableProcedure(symbol, /*isError=*/isExplicitBindC);3514 } else if (symbol.has<DerivedTypeDetails>()) {3515 whyNot = WhyNotInteroperableDerivedType(symbol);3516 }3517 if (!whyNot.empty()) {3518 bool anyFatal{whyNot.AnyFatalError()};3519 if (anyFatal ||3520 (!InModuleFile() &&3521 context_.ShouldWarn(3522 common::LanguageFeature::NonBindCInteroperability))) {3523 context_.messages().Annex(std::move(whyNot));3524 }3525 if (anyFatal) {3526 context_.SetError(symbol);3527 }3528 }3529}3530 3531bool CheckHelper::CheckDioDummyIsData(3532 const Symbol &subp, const Symbol *arg, std::size_t position) {3533 if (arg && arg->detailsIf<ObjectEntityDetails>()) {3534 if (IsAssumedRank(*arg)) {3535 messages_.Say(arg->name(),3536 "Dummy argument '%s' may not be assumed-rank"_err_en_US, arg->name());3537 return false;3538 } else {3539 return true;3540 }3541 } else {3542 if (arg) {3543 messages_.Say(arg->name(),3544 "Dummy argument '%s' must be a data object"_err_en_US, arg->name());3545 } else {3546 messages_.Say(subp.name(),3547 "Dummy argument %d of '%s' must be a data object"_err_en_US, position,3548 subp.name());3549 }3550 return false;3551 }3552}3553 3554void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,3555 common::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {3556 // Check for conflict between non-type-bound defined I/O and type-bound3557 // generics. It's okay to have two or more distinct defined I/O procedures for3558 // the same type if they're coming from distinct non-type-bound interfaces.3559 // (The non-type-bound interfaces would have been merged into a single generic3560 // -- with errors where indistinguishable -- when both were visible from the3561 // same scope.)3562 if (generic.owner().IsDerivedType()) {3563 return;3564 }3565 if (const Scope * dtScope{derivedType.scope()}) {3566 if (auto iter{dtScope->find(generic.name())}; iter != dtScope->end() &&3567 IsAccessible(*iter->second, generic.owner())) {3568 for (auto specRef : iter->second->get<GenericDetails>().specificProcs()) {3569 const Symbol *specific{&specRef->get<ProcBindingDetails>().symbol()};3570 if (specific == &proc) {3571 continue; // unambiguous, accept3572 }3573 if (const auto *peDetails{specific->detailsIf<ProcEntityDetails>()}) {3574 specific = peDetails->procInterface();3575 if (!specific) {3576 continue;3577 }3578 }3579 if (const auto *specDT{GetDtvArgDerivedType(*specific)};3580 specDT && evaluate::AreSameDerivedType(derivedType, *specDT)) {3581 SayWithDeclaration(*specRef, proc.name(),3582 "Derived type '%s' has conflicting type-bound input/output procedure '%s'"_err_en_US,3583 derivedType.name(), GenericKind::AsFortran(ioKind));3584 return;3585 }3586 }3587 }3588 }3589}3590 3591void CheckHelper::CheckDioDummyIsDerived(const Symbol &proc, const Symbol &arg,3592 common::DefinedIo ioKind, const Symbol &generic) {3593 if (const DeclTypeSpec *type{arg.GetType()}) {3594 if (const DerivedTypeSpec *derivedType{type->AsDerived()}) {3595 CheckAlreadySeenDefinedIo(*derivedType, ioKind, proc, generic);3596 bool isPolymorphic{type->IsPolymorphic()};3597 if (isPolymorphic != IsExtensibleType(derivedType)) {3598 messages_.Say(arg.name(),3599 "Dummy argument '%s' of a defined input/output procedure must be %s when the derived type is %s"_err_en_US,3600 arg.name(), isPolymorphic ? "TYPE()" : "CLASS()",3601 isPolymorphic ? "not extensible" : "extensible");3602 }3603 } else {3604 messages_.Say(arg.name(),3605 "Dummy argument '%s' of a defined input/output procedure must have a derived type"_err_en_US,3606 arg.name());3607 }3608 }3609}3610 3611void CheckHelper::CheckDioDummyIsDefaultInteger(3612 const Symbol &subp, const Symbol &arg) {3613 if (const DeclTypeSpec *type{arg.GetType()};3614 type && type->IsNumeric(TypeCategory::Integer)) {3615 if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};3616 kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {3617 return;3618 }3619 }3620 messages_.Say(arg.name(),3621 "Dummy argument '%s' of a defined input/output procedure must be an INTEGER of default KIND"_err_en_US,3622 arg.name());3623}3624 3625void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) {3626 if (arg.Rank() > 0) {3627 messages_.Say(arg.name(),3628 "Dummy argument '%s' of a defined input/output procedure must be a scalar"_err_en_US,3629 arg.name());3630 }3631}3632 3633void CheckHelper::CheckDioDtvArg(const Symbol &proc, const Symbol &subp,3634 const Symbol *arg, common::DefinedIo ioKind, const Symbol &generic) {3635 // Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv3636 if (CheckDioDummyIsData(subp, arg, 0)) {3637 CheckDioDummyIsDerived(proc, *arg, ioKind, generic);3638 CheckDioDummyAttrs(subp, *arg,3639 ioKind == common::DefinedIo::ReadFormatted ||3640 ioKind == common::DefinedIo::ReadUnformatted3641 ? Attr::INTENT_INOUT3642 : Attr::INTENT_IN);3643 CheckDioDummyIsScalar(subp, *arg);3644 }3645}3646 3647// If an explicit INTRINSIC name is a function, so must all the specifics be,3648// and similarly for subroutines3649void CheckHelper::CheckGenericVsIntrinsic(3650 const Symbol &symbol, const GenericDetails &generic) {3651 if (symbol.attrs().test(Attr::INTRINSIC)) {3652 const evaluate::IntrinsicProcTable &table{3653 context_.foldingContext().intrinsics()};3654 bool isSubroutine{table.IsIntrinsicSubroutine(symbol.name().ToString())};3655 if (isSubroutine || table.IsIntrinsicFunction(symbol.name().ToString())) {3656 for (const SymbolRef &ref : generic.specificProcs()) {3657 const Symbol &ultimate{ref->GetUltimate()};3658 bool specificFunc{ultimate.test(Symbol::Flag::Function)};3659 bool specificSubr{ultimate.test(Symbol::Flag::Subroutine)};3660 if (!specificFunc && !specificSubr) {3661 if (const auto *proc{ultimate.detailsIf<SubprogramDetails>()}) {3662 if (proc->isFunction()) {3663 specificFunc = true;3664 } else {3665 specificSubr = true;3666 }3667 }3668 }3669 if ((specificFunc || specificSubr) &&3670 isSubroutine != specificSubr) { // C8483671 messages_.Say(symbol.name(),3672 "Generic interface '%s' with explicit intrinsic %s of the same name may not have specific procedure '%s' that is a %s"_err_en_US,3673 symbol.name(), isSubroutine ? "subroutine" : "function",3674 ref->name(), isSubroutine ? "function" : "subroutine");3675 }3676 }3677 }3678 }3679}3680 3681void CheckHelper::CheckDefaultIntegerArg(3682 const Symbol &subp, const Symbol *arg, Attr intent) {3683 // Argument looks like: INTEGER, INTENT(intent) :: arg3684 if (CheckDioDummyIsData(subp, arg, 1)) {3685 CheckDioDummyIsDefaultInteger(subp, *arg);3686 CheckDioDummyIsScalar(subp, *arg);3687 CheckDioDummyAttrs(subp, *arg, intent);3688 }3689}3690 3691void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,3692 const Symbol *arg, std::size_t argPosition, Attr intent) {3693 // Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg)3694 if (CheckDioDummyIsData(subp, arg, argPosition)) {3695 CheckDioDummyAttrs(subp, *arg, intent);3696 const DeclTypeSpec *type{arg ? arg->GetType() : nullptr};3697 const IntrinsicTypeSpec *intrinsic{type ? type->AsIntrinsic() : nullptr};3698 const auto kind{3699 intrinsic ? evaluate::ToInt64(intrinsic->kind()) : std::nullopt};3700 if (!IsAssumedLengthCharacter(*arg) ||3701 (!kind ||3702 *kind !=3703 context_.defaultKinds().GetDefaultKind(3704 TypeCategory::Character))) {3705 messages_.Say(arg->name(),3706 "Dummy argument '%s' of a defined input/output procedure must be assumed-length CHARACTER of default kind"_err_en_US,3707 arg->name());3708 }3709 CheckDioDummyIsScalar(subp, *arg);3710 }3711}3712 3713void CheckHelper::CheckDioVlistArg(3714 const Symbol &subp, const Symbol *arg, std::size_t argPosition) {3715 // Vlist argument looks like: INTEGER, INTENT(IN) :: v_list(:)3716 if (CheckDioDummyIsData(subp, arg, argPosition)) {3717 CheckDioDummyIsDefaultInteger(subp, *arg);3718 CheckDioDummyAttrs(subp, *arg, Attr::INTENT_IN);3719 const auto *objectDetails{arg->detailsIf<ObjectEntityDetails>()};3720 if (!objectDetails || !objectDetails->shape().CanBeAssumedShape() ||3721 objectDetails->shape().Rank() != 1) {3722 messages_.Say(arg->name(),3723 "Dummy argument '%s' of a defined input/output procedure must be assumed shape vector"_err_en_US,3724 arg->name());3725 }3726 }3727}3728 3729void CheckHelper::CheckDioArgCount(3730 const Symbol &subp, common::DefinedIo ioKind, std::size_t argCount) {3731 const std::size_t requiredArgCount{3732 (std::size_t)(ioKind == common::DefinedIo::ReadFormatted ||3733 ioKind == common::DefinedIo::WriteFormatted3734 ? 63735 : 4)};3736 if (argCount != requiredArgCount) {3737 SayWithDeclaration(subp,3738 "Defined input/output procedure '%s' must have %d dummy arguments rather than %d"_err_en_US,3739 subp.name(), requiredArgCount, argCount);3740 context_.SetError(subp);3741 }3742}3743 3744void CheckHelper::CheckDioDummyAttrs(3745 const Symbol &subp, const Symbol &arg, Attr goodIntent) {3746 // Defined I/O procedures can't have attributes other than INTENT3747 Attrs attrs{arg.attrs()};3748 if (!attrs.test(goodIntent)) {3749 messages_.Say(arg.name(),3750 "Dummy argument '%s' of a defined input/output procedure must have intent '%s'"_err_en_US,3751 arg.name(), AttrToString(goodIntent));3752 }3753 attrs = attrs - Attr::INTENT_IN - Attr::INTENT_OUT - Attr::INTENT_INOUT;3754 if (!attrs.empty()) {3755 messages_.Say(arg.name(),3756 "Dummy argument '%s' of a defined input/output procedure may not have any attributes"_err_en_US,3757 arg.name());3758 }3759}3760 3761// Enforce semantics for defined input/output procedures (12.6.4.8.2) and C7773762void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,3763 const GenericDetails &details, common::DefinedIo ioKind) {3764 for (auto ref : details.specificProcs()) {3765 const Symbol &ultimate{ref->GetUltimate()};3766 const auto *binding{ultimate.detailsIf<ProcBindingDetails>()};3767 if (ultimate.attrs().test(Attr::NOPASS)) { // C7743768 messages_.Say(3769 "Defined input/output procedure '%s' may not have NOPASS attribute"_err_en_US,3770 ultimate.name());3771 context_.SetError(ultimate);3772 }3773 const Symbol *specificProc{binding ? &binding->symbol() : &ultimate};3774 const Symbol *specificSubp{specificProc};3775 if (const auto *peDetails{specificSubp->detailsIf<ProcEntityDetails>()}) {3776 specificSubp = peDetails->procInterface();3777 if (!specificSubp) {3778 continue;3779 }3780 }3781 if (const auto *subpDetails{specificSubp->detailsIf<SubprogramDetails>()}) {3782 const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()};3783 CheckDioArgCount(*specificSubp, ioKind, dummyArgs.size());3784 int argCount{0};3785 for (auto *arg : dummyArgs) {3786 if (arg && arg->Corank() > 0) {3787 evaluate::AttachDeclaration(3788 messages_.Say(arg->name(),3789 "Dummy argument '%s' of defined input/output procedure '%s' may not be a coarray"_err_en_US,3790 arg->name(), ultimate.name()),3791 *arg);3792 }3793 switch (argCount++) {3794 case 0:3795 // dtv-type-spec, INTENT(INOUT) :: dtv3796 CheckDioDtvArg(*specificProc, *specificSubp, arg, ioKind, symbol);3797 break;3798 case 1:3799 // INTEGER, INTENT(IN) :: unit3800 CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_IN);3801 break;3802 case 2:3803 if (ioKind == common::DefinedIo::ReadFormatted ||3804 ioKind == common::DefinedIo::WriteFormatted) {3805 // CHARACTER (LEN=*), INTENT(IN) :: iotype3806 CheckDioAssumedLenCharacterArg(3807 *specificSubp, arg, argCount, Attr::INTENT_IN);3808 } else {3809 // INTEGER, INTENT(OUT) :: iostat3810 CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT);3811 }3812 break;3813 case 3:3814 if (ioKind == common::DefinedIo::ReadFormatted ||3815 ioKind == common::DefinedIo::WriteFormatted) {3816 // INTEGER, INTENT(IN) :: v_list(:)3817 CheckDioVlistArg(*specificSubp, arg, argCount);3818 } else {3819 // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg3820 CheckDioAssumedLenCharacterArg(3821 *specificSubp, arg, argCount, Attr::INTENT_INOUT);3822 }3823 break;3824 case 4:3825 // INTEGER, INTENT(OUT) :: iostat3826 CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT);3827 break;3828 case 5:3829 // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg3830 CheckDioAssumedLenCharacterArg(3831 *specificSubp, arg, argCount, Attr::INTENT_INOUT);3832 break;3833 default:;3834 }3835 }3836 }3837 }3838}3839 3840void CheckHelper::CheckSymbolType(const Symbol &symbol) {3841 const Symbol *result{FindFunctionResult(symbol)};3842 const Symbol &relevant{result ? *result : symbol};3843 if (IsAllocatable(relevant)) { // always ok3844 } else if (IsProcedurePointer(symbol) && result && IsPointer(*result)) {3845 // procedure pointer returning allocatable or pointer: ok3846 } else if (IsPointer(relevant) && !IsProcedure(relevant)) {3847 // object pointers are always ok3848 } else if (auto dyType{evaluate::DynamicType::From(relevant)}) {3849 if (dyType->IsPolymorphic() && !dyType->IsAssumedType() &&3850 !(IsDummy(symbol) && !IsProcedure(relevant))) { // C7083851 messages_.Say(3852 "CLASS entity '%s' must be a dummy argument, allocatable, or object pointer"_err_en_US,3853 symbol.name());3854 }3855 if (dyType->HasDeferredTypeParameter()) { // C7023856 messages_.Say(3857 "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,3858 symbol.name(), dyType->AsFortran());3859 }3860 if (!symbol.has<ObjectEntityDetails>()) {3861 if (const DerivedTypeSpec *3862 derived{evaluate::GetDerivedTypeSpec(*dyType)}) {3863 if (IsEventTypeOrLockType(derived)) {3864 messages_.Say(3865 "Entity '%s' with EVENT_TYPE or LOCK_TYPE must be an object"_err_en_US,3866 symbol.name());3867 } else if (auto iter{FindEventOrLockPotentialComponent(*derived)}) {3868 messages_.Say(3869 "Entity '%s' with EVENT_TYPE or LOCK_TYPE potential subobject component '%s' must be an object"_err_en_US,3870 symbol.name(), iter.BuildResultDesignatorName());3871 }3872 }3873 }3874 }3875}3876 3877void CheckHelper::CheckModuleProcedureDef(const Symbol &symbol) {3878 auto procClass{ClassifyProcedure(symbol)};3879 if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};3880 subprogram &&3881 (procClass == ProcedureDefinitionClass::Module &&3882 symbol.attrs().test(Attr::MODULE)) &&3883 !subprogram->bindName() && !subprogram->isInterface()) {3884 const Symbol &interface {3885 subprogram->moduleInterface() ? *subprogram->moduleInterface() : symbol3886 };3887 if (const Symbol *3888 module{interface.owner().kind() == Scope::Kind::Module3889 ? interface.owner().symbol()3890 : nullptr};3891 module && module->has<ModuleDetails>()) {3892 std::pair<SourceName, const Symbol *> key{symbol.name(), module};3893 auto iter{moduleProcs_.find(key)};3894 if (iter == moduleProcs_.end()) {3895 moduleProcs_.emplace(std::move(key), symbol);3896 } else if (3897 auto *msg{messages_.Say(symbol.name(),3898 "Module procedure '%s' in '%s' has multiple definitions"_err_en_US,3899 symbol.name(), GetModuleOrSubmoduleName(*module))}) {3900 msg->Attach(iter->second->name(), "Previous definition of '%s'"_en_US,3901 symbol.name());3902 }3903 }3904 }3905}3906 3907void SubprogramMatchHelper::Check(3908 const Symbol &symbol1, const Symbol &symbol2) {3909 const auto details1{symbol1.get<SubprogramDetails>()};3910 const auto details2{symbol2.get<SubprogramDetails>()};3911 if (details1.isFunction() != details2.isFunction()) {3912 Say(symbol1, symbol2,3913 details1.isFunction()3914 ? "Module function '%s' was declared as a subroutine in the"3915 " corresponding interface body"_err_en_US3916 : "Module subroutine '%s' was declared as a function in the"3917 " corresponding interface body"_err_en_US);3918 return;3919 }3920 const auto &args1{details1.dummyArgs()};3921 const auto &args2{details2.dummyArgs()};3922 int nargs1{static_cast<int>(args1.size())};3923 int nargs2{static_cast<int>(args2.size())};3924 if (nargs1 != nargs2) {3925 Say(symbol1, symbol2,3926 "Module subprogram '%s' has %d args but the corresponding interface"3927 " body has %d"_err_en_US,3928 nargs1, nargs2);3929 return;3930 }3931 bool nonRecursive1{symbol1.attrs().test(Attr::NON_RECURSIVE)};3932 if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C15513933 Say(symbol1, symbol2,3934 nonRecursive13935 ? "Module subprogram '%s' has NON_RECURSIVE prefix but"3936 " the corresponding interface body does not"_err_en_US3937 : "Module subprogram '%s' does not have NON_RECURSIVE prefix but "3938 "the corresponding interface body does"_err_en_US);3939 }3940 const std::string *bindName1{details1.bindName()};3941 const std::string *bindName2{details2.bindName()};3942 if (!bindName1 && !bindName2) {3943 // OK - neither has a binding label3944 } else if (!bindName1) {3945 Say(symbol1, symbol2,3946 "Module subprogram '%s' does not have a binding label but the"3947 " corresponding interface body does"_err_en_US);3948 } else if (!bindName2) {3949 Say(symbol1, symbol2,3950 "Module subprogram '%s' has a binding label but the"3951 " corresponding interface body does not"_err_en_US);3952 } else if (*bindName1 != *bindName2) {3953 Say(symbol1, symbol2,3954 "Module subprogram '%s' has binding label '%s' but the corresponding"3955 " interface body has '%s'"_err_en_US,3956 *details1.bindName(), *details2.bindName());3957 }3958 const Procedure *proc1{checkHelper.Characterize(symbol1)};3959 const Procedure *proc2{checkHelper.Characterize(symbol2)};3960 if (!proc1 || !proc2) {3961 return;3962 }3963 if (proc1->attrs.test(Procedure::Attr::Pure) !=3964 proc2->attrs.test(Procedure::Attr::Pure)) {3965 Say(symbol1, symbol2,3966 "Module subprogram '%s' and its corresponding interface body are not both PURE"_err_en_US);3967 }3968 if (proc1->attrs.test(Procedure::Attr::Elemental) !=3969 proc2->attrs.test(Procedure::Attr::Elemental)) {3970 Say(symbol1, symbol2,3971 "Module subprogram '%s' and its corresponding interface body are not both ELEMENTAL"_err_en_US);3972 }3973 if (proc1->attrs.test(Procedure::Attr::BindC) !=3974 proc2->attrs.test(Procedure::Attr::BindC)) {3975 Say(symbol1, symbol2,3976 "Module subprogram '%s' and its corresponding interface body are not both BIND(C)"_err_en_US);3977 }3978 if (proc1->functionResult && proc2->functionResult) {3979 std::string whyNot;3980 if (!proc1->functionResult->IsCompatibleWith(3981 *proc2->functionResult, &whyNot)) {3982 Say(symbol1, symbol2,3983 "Result of function '%s' is not compatible with the result of the corresponding interface body: %s"_err_en_US,3984 whyNot);3985 }3986 }3987 for (int i{0}; i < nargs1; ++i) {3988 const Symbol *arg1{args1[i]};3989 const Symbol *arg2{args2[i]};3990 if (arg1 && !arg2) {3991 Say(symbol1, symbol2,3992 "Dummy argument %2$d of '%1$s' is not an alternate return indicator"3993 " but the corresponding argument in the interface body is"_err_en_US,3994 i + 1);3995 } else if (!arg1 && arg2) {3996 Say(symbol1, symbol2,3997 "Dummy argument %2$d of '%1$s' is an alternate return indicator but"3998 " the corresponding argument in the interface body is not"_err_en_US,3999 i + 1);4000 } else if (arg1 && arg2) {4001 SourceName name1{arg1->name()};4002 SourceName name2{arg2->name()};4003 if (name1 != name2) {4004 Say(*arg1, *arg2,4005 "Dummy argument name '%s' does not match corresponding name '%s'"4006 " in interface body"_err_en_US,4007 name2);4008 } else {4009 CheckDummyArg(4010 *arg1, *arg2, proc1->dummyArguments[i], proc2->dummyArguments[i]);4011 }4012 }4013 }4014}4015 4016void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1,4017 const Symbol &symbol2, const DummyArgument &arg1,4018 const DummyArgument &arg2) {4019 common::visit(4020 common::visitors{4021 [&](const DummyDataObject &obj1, const DummyDataObject &obj2) {4022 CheckDummyDataObject(symbol1, symbol2, obj1, obj2);4023 },4024 [&](const DummyProcedure &proc1, const DummyProcedure &proc2) {4025 CheckDummyProcedure(symbol1, symbol2, proc1, proc2);4026 },4027 [&](const DummyDataObject &, const auto &) {4028 Say(symbol1, symbol2,4029 "Dummy argument '%s' is a data object; the corresponding"4030 " argument in the interface body is not"_err_en_US);4031 },4032 [&](const DummyProcedure &, const auto &) {4033 Say(symbol1, symbol2,4034 "Dummy argument '%s' is a procedure; the corresponding"4035 " argument in the interface body is not"_err_en_US);4036 },4037 [&](const auto &, const auto &) {4038 llvm_unreachable("Dummy arguments are not data objects or"4039 "procedures");4040 },4041 },4042 arg1.u, arg2.u);4043}4044 4045void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,4046 const Symbol &symbol2, const DummyDataObject &obj1,4047 const DummyDataObject &obj2) {4048 if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {4049 } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {4050 } else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {4051 Say(symbol1, symbol2,4052 "Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,4053 obj1.type.type().AsFortran(), obj2.type.type().AsFortran());4054 } else if (!ShapesAreCompatible(obj1, obj2)) {4055 Say(symbol1, symbol2,4056 "The shape of dummy argument '%s' does not match the shape of the"4057 " corresponding argument in the interface body"_err_en_US);4058 }4059 // TODO: coshape4060}4061 4062void SubprogramMatchHelper::CheckDummyProcedure(const Symbol &symbol1,4063 const Symbol &symbol2, const DummyProcedure &proc1,4064 const DummyProcedure &proc2) {4065 std::string whyNot;4066 if (!CheckSameIntent(symbol1, symbol2, proc1.intent, proc2.intent)) {4067 } else if (!CheckSameAttrs(symbol1, symbol2, proc1.attrs, proc2.attrs)) {4068 } else if (!proc2.IsCompatibleWith(proc1, &whyNot)) {4069 Say(symbol1, symbol2,4070 "Dummy procedure '%s' is not compatible with the corresponding argument in the interface body: %s"_err_en_US,4071 whyNot);4072 } else if (proc1 != proc2) {4073 evaluate::AttachDeclaration(4074 symbol1.owner().context().Warn(4075 common::UsageWarning::MismatchingDummyProcedure,4076 "Dummy procedure '%s' does not exactly match the corresponding argument in the interface body"_warn_en_US,4077 symbol1.name()),4078 symbol2);4079 }4080}4081 4082bool SubprogramMatchHelper::CheckSameIntent(const Symbol &symbol1,4083 const Symbol &symbol2, common::Intent intent1, common::Intent intent2) {4084 if (intent1 == intent2) {4085 return true;4086 } else {4087 Say(symbol1, symbol2,4088 "The intent of dummy argument '%s' does not match the intent"4089 " of the corresponding argument in the interface body"_err_en_US);4090 return false;4091 }4092}4093 4094// Report an error referring to first symbol with declaration of second symbol4095template <typename... A>4096void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2,4097 parser::MessageFixedText &&text, A &&...args) {4098 auto &message{context().Say(symbol1.name(), std::move(text), symbol1.name(),4099 std::forward<A>(args)...)};4100 evaluate::AttachDeclaration(message, symbol2);4101}4102 4103template <typename ATTRS>4104bool SubprogramMatchHelper::CheckSameAttrs(4105 const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) {4106 if (attrs1 == attrs2) {4107 return true;4108 }4109 attrs1.IterateOverMembers([&](auto attr) {4110 if (!attrs2.test(attr)) {4111 Say(symbol1, symbol2,4112 "Dummy argument '%s' has the %s attribute; the corresponding"4113 " argument in the interface body does not"_err_en_US,4114 AsFortran(attr));4115 }4116 });4117 attrs2.IterateOverMembers([&](auto attr) {4118 if (!attrs1.test(attr)) {4119 Say(symbol1, symbol2,4120 "Dummy argument '%s' does not have the %s attribute; the"4121 " corresponding argument in the interface body does"_err_en_US,4122 AsFortran(attr));4123 }4124 });4125 return false;4126}4127 4128bool SubprogramMatchHelper::ShapesAreCompatible(4129 const DummyDataObject &obj1, const DummyDataObject &obj2) {4130 return characteristics::ShapesAreCompatible(4131 FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape()));4132}4133 4134evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {4135 evaluate::Shape result;4136 for (const auto &extent : shape) {4137 result.emplace_back(4138 evaluate::Fold(context().foldingContext(), common::Clone(extent)));4139 }4140 return result;4141}4142 4143void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind,4144 const Symbol &specific, const Procedure &procedure) {4145 const Symbol &ultimate{specific.GetUltimate()};4146 if (!context_.HasError(ultimate)) {4147 nameToSpecifics_[generic.name()].emplace(4148 &ultimate, ProcedureInfo{kind, procedure});4149 }4150}4151 4152void DistinguishabilityHelper::Check(const Scope &scope) {4153 if (FindModuleFileContaining(scope)) {4154 // Distinguishability was checked when the module was created;4155 // don't let optional warnings then become errors now.4156 return;4157 }4158 for (const auto &[name, info] : nameToSpecifics_) {4159 for (auto iter1{info.begin()}; iter1 != info.end(); ++iter1) {4160 const auto &[ultimate, procInfo]{*iter1};4161 const auto &[kind, proc]{procInfo};4162 for (auto iter2{iter1}; ++iter2 != info.end();) {4163 const auto &[ultimate2, procInfo2]{*iter2};4164 if (&*ultimate == &*ultimate2) {4165 continue; // ok, actually the same procedure/binding4166 } else if (const auto *binding1{4167 ultimate->detailsIf<ProcBindingDetails>()}) {4168 if (const auto *binding2{4169 ultimate2->detailsIf<ProcBindingDetails>()}) {4170 if (&binding1->symbol().GetUltimate() ==4171 &binding2->symbol().GetUltimate()) {4172 continue; // ok, (NOPASS) bindings resolve identically4173 } else if (ultimate->name() == ultimate2->name()) {4174 continue; // override, possibly of DEFERRED4175 }4176 }4177 } else if (ultimate->has<ProcBindingDetails>() &&4178 ultimate2->has<ProcBindingDetails>() &&4179 ultimate->name() == ultimate2->name()) {4180 continue; // override, possibly of DEFERRED4181 }4182 auto distinguishable{kind.IsName()4183 ? evaluate::characteristics::Distinguishable4184 : evaluate::characteristics::DistinguishableOpOrAssign};4185 std::optional<bool> distinct{distinguishable(4186 context_.languageFeatures(), proc, procInfo2.procedure)};4187 if (!distinct.value_or(false)) {4188 SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind,4189 *ultimate, *ultimate2, distinct.has_value());4190 }4191 }4192 }4193 }4194}4195 4196void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope,4197 const SourceName &name, GenericKind kind, const Symbol &proc1,4198 const Symbol &proc2, bool isHardConflict) {4199 bool isUseAssociated{!scope.sourceRange().Contains(name)};4200 // The rules for distinguishing specific procedures (F'2023 15.4.3.4.5)4201 // are inadequate for some real-world cases like pFUnit.4202 // When there are optional dummy arguments or unlimited polymorphic4203 // dummy data object arguments, the best that we can do is emit an optional4204 // portability warning. Also, named generics created by USE association4205 // merging shouldn't receive hard errors for ambiguity.4206 // (Non-named generics might be defined I/O procedures or defined4207 // assignments that need to be used by the runtime.)4208 bool isWarning{!isHardConflict || (isUseAssociated && kind.IsName())};4209 if (isWarning &&4210 (!context_.ShouldWarn(4211 common::LanguageFeature::IndistinguishableSpecifics) ||4212 FindModuleFileContaining(scope))) {4213 return;4214 }4215 std::string name1{proc1.name().ToString()};4216 std::string name2{proc2.name().ToString()};4217 if (kind.IsOperator() || kind.IsAssignment()) {4218 // proc1 and proc2 may come from different scopes so qualify their names4219 if (proc1.owner().IsDerivedType()) {4220 name1 = proc1.owner().GetName()->ToString() + '%' + name1;4221 }4222 if (proc2.owner().IsDerivedType()) {4223 name2 = proc2.owner().GetName()->ToString() + '%' + name2;4224 }4225 }4226 parser::Message *msg;4227 if (!isUseAssociated) {4228 CHECK(isWarning == !isHardConflict);4229 msg = &context_.Say(name,4230 isHardConflict4231 ? "Generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US4232 : "Generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,4233 MakeOpName(name), name1, name2);4234 } else {4235 msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(),4236 isHardConflict4237 ? (isWarning4238 ? "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_warn_en_US4239 : "USE-associated generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US)4240 : "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,4241 MakeOpName(name), name1, name2);4242 }4243 AttachDeclaration(*msg, scope, proc1);4244 AttachDeclaration(*msg, scope, proc2);4245}4246 4247// `evaluate::AttachDeclaration` doesn't handle the generic case where `proc`4248// comes from a different module but is not necessarily use-associated.4249void DistinguishabilityHelper::AttachDeclaration(4250 parser::Message &msg, const Scope &scope, const Symbol &proc) {4251 if (proc.owner().IsTopLevel()) {4252 evaluate::AttachDeclaration(msg, proc);4253 } else {4254 const Scope &unit{GetTopLevelUnitContaining(proc)};4255 if (unit == scope) {4256 evaluate::AttachDeclaration(msg, proc);4257 } else {4258 msg.Attach(unit.GetName().value(),4259 "'%s' is USE-associated from module '%s'"_en_US, proc.name(),4260 unit.GetName().value());4261 }4262 }4263}4264 4265void CheckDeclarations(SemanticsContext &context) {4266 CheckHelper{context}.Check();4267}4268} // namespace Fortran::semantics4269