1 //===-- lib/Evaluate/characteristics.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-exception 6 // 7 //===----------------------------------------------------------------------===// 8 9 #include "flang/Evaluate/characteristics.h" 10 #include "flang/Common/indirection.h" 11 #include "flang/Evaluate/check-expression.h" 12 #include "flang/Evaluate/fold.h" 13 #include "flang/Evaluate/intrinsics.h" 14 #include "flang/Evaluate/tools.h" 15 #include "flang/Evaluate/type.h" 16 #include "flang/Parser/message.h" 17 #include "flang/Semantics/scope.h" 18 #include "flang/Semantics/symbol.h" 19 #include <initializer_list> 20 #include <ostream> 21 22 using namespace Fortran::parser::literals; 23 24 namespace Fortran::evaluate::characteristics { 25 26 // Copy attributes from a symbol to dst based on the mapping in pairs. 27 template<typename A, typename B> 28 static void CopyAttrs(const semantics::Symbol &src, A &dst, 29 const std::initializer_list<std::pair<semantics::Attr, B>> &pairs) { 30 for (const auto &pair : pairs) { 31 if (src.attrs().test(pair.first)) { 32 dst.attrs.set(pair.second); 33 } 34 } 35 } 36 37 // Shapes of function results and dummy arguments have to have 38 // the same rank, the same deferred dimensions, and the same 39 // values for explicit dimensions when constant. 40 static bool ShapesAreCompatible(const Shape &x, const Shape &y) { 41 if (x.size() != y.size()) { 42 return false; 43 } 44 auto yIter{y.begin()}; 45 for (const auto &xDim : x) { 46 const auto &yDim{*yIter++}; 47 if (xDim) { 48 if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) { 49 return false; 50 } 51 } else if (yDim) { 52 return false; 53 } 54 } 55 return true; 56 } 57 58 bool TypeAndShape::operator==(const TypeAndShape &that) const { 59 return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) && 60 attrs_ == that.attrs_ && corank_ == that.corank_; 61 } 62 63 std::optional<TypeAndShape> TypeAndShape::Characterize( 64 const semantics::Symbol &symbol, FoldingContext &context) { 65 return std::visit( 66 common::visitors{ 67 [&](const semantics::ObjectEntityDetails &object) { 68 return Characterize(object); 69 }, 70 [&](const semantics::ProcEntityDetails &proc) { 71 const semantics::ProcInterface &interface{proc.interface()}; 72 if (interface.type()) { 73 return Characterize(*interface.type()); 74 } else if (interface.symbol()) { 75 return Characterize(*interface.symbol(), context); 76 } else { 77 return std::optional<TypeAndShape>{}; 78 } 79 }, 80 [&](const semantics::UseDetails &use) { 81 return Characterize(use.symbol(), context); 82 }, 83 [&](const semantics::HostAssocDetails &assoc) { 84 return Characterize(assoc.symbol(), context); 85 }, 86 [&](const semantics::AssocEntityDetails &assoc) { 87 return Characterize(assoc, context); 88 }, 89 [](const auto &) { return std::optional<TypeAndShape>{}; }, 90 }, 91 symbol.details()); 92 } 93 94 std::optional<TypeAndShape> TypeAndShape::Characterize( 95 const semantics::ObjectEntityDetails &object) { 96 if (auto type{DynamicType::From(object.type())}) { 97 TypeAndShape result{std::move(*type)}; 98 result.AcquireShape(object); 99 return result; 100 } else { 101 return std::nullopt; 102 } 103 } 104 105 std::optional<TypeAndShape> TypeAndShape::Characterize( 106 const semantics::AssocEntityDetails &assoc, FoldingContext &context) { 107 if (auto type{DynamicType::From(assoc.type())}) { 108 if (auto shape{GetShape(context, assoc.expr())}) { 109 return TypeAndShape{std::move(*type), std::move(*shape)}; 110 } 111 } 112 return std::nullopt; 113 } 114 115 std::optional<TypeAndShape> TypeAndShape::Characterize( 116 const semantics::DeclTypeSpec &spec) { 117 if (auto type{DynamicType::From(spec)}) { 118 return TypeAndShape{std::move(*type)}; 119 } else { 120 return std::nullopt; 121 } 122 } 123 124 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, 125 const TypeAndShape &that, const char *thisIs, const char *thatIs, 126 bool isElemental) const { 127 const auto &len{that.LEN()}; 128 if (!type_.IsTypeCompatibleWith(that.type_)) { 129 messages.Say( 130 "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US, 131 thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs, 132 type_.AsFortran()); 133 return false; 134 } 135 return isElemental || 136 CheckConformance(messages, shape_, that.shape_, thisIs, thatIs); 137 } 138 139 void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) { 140 CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank)); 141 corank_ = object.coshape().Rank(); 142 if (object.IsAssumedRank()) { 143 attrs_.set(Attr::AssumedRank); 144 return; 145 } 146 if (object.IsAssumedShape()) { 147 attrs_.set(Attr::AssumedShape); 148 } 149 if (object.IsAssumedSize()) { 150 attrs_.set(Attr::AssumedSize); 151 } 152 if (object.IsDeferredShape()) { 153 attrs_.set(Attr::DeferredShape); 154 } 155 if (object.IsCoarray()) { 156 attrs_.set(Attr::Coarray); 157 } 158 for (const semantics::ShapeSpec &dim : object.shape()) { 159 if (dim.ubound().GetExplicit()) { 160 Expr<SubscriptInteger> extent{*dim.ubound().GetExplicit()}; 161 if (dim.lbound().GetExplicit()) { 162 extent = std::move(extent) + 163 common::Clone(*dim.lbound().GetExplicit()) - 164 Expr<SubscriptInteger>{1}; 165 } 166 shape_.emplace_back(std::move(extent)); 167 } else { 168 shape_.push_back(std::nullopt); 169 } 170 } 171 } 172 173 void TypeAndShape::AcquireLEN() { 174 if (type_.category() == TypeCategory::Character) { 175 if (const auto *param{type_.charLength()}) { 176 if (const auto &intExpr{param->GetExplicit()}) { 177 LEN_ = *intExpr; 178 } 179 } 180 } 181 } 182 183 std::ostream &TypeAndShape::Dump(std::ostream &o) const { 184 o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""); 185 attrs_.Dump(o, EnumToString); 186 if (!shape_.empty()) { 187 o << " dimension("; 188 char sep{'('}; 189 for (const auto &expr : shape_) { 190 o << sep; 191 sep = ','; 192 if (expr) { 193 expr->AsFortran(o); 194 } else { 195 o << ':'; 196 } 197 } 198 o << ')'; 199 } 200 return o; 201 } 202 203 bool DummyDataObject::operator==(const DummyDataObject &that) const { 204 return type == that.type && attrs == that.attrs && intent == that.intent && 205 coshape == that.coshape; 206 } 207 208 static common::Intent GetIntent(const semantics::Attrs &attrs) { 209 if (attrs.test(semantics::Attr::INTENT_IN)) { 210 return common::Intent::In; 211 } else if (attrs.test(semantics::Attr::INTENT_OUT)) { 212 return common::Intent::Out; 213 } else if (attrs.test(semantics::Attr::INTENT_INOUT)) { 214 return common::Intent::InOut; 215 } else { 216 return common::Intent::Default; 217 } 218 } 219 220 std::optional<DummyDataObject> DummyDataObject::Characterize( 221 const semantics::Symbol &symbol) { 222 if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) { 223 if (auto type{TypeAndShape::Characterize(*obj)}) { 224 std::optional<DummyDataObject> result{std::move(*type)}; 225 using semantics::Attr; 226 CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result, 227 { 228 {Attr::OPTIONAL, DummyDataObject::Attr::Optional}, 229 {Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable}, 230 {Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous}, 231 {Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous}, 232 {Attr::VALUE, DummyDataObject::Attr::Value}, 233 {Attr::VOLATILE, DummyDataObject::Attr::Volatile}, 234 {Attr::POINTER, DummyDataObject::Attr::Pointer}, 235 {Attr::TARGET, DummyDataObject::Attr::Target}, 236 }); 237 result->intent = GetIntent(symbol.attrs()); 238 return result; 239 } 240 } 241 return std::nullopt; 242 } 243 244 bool DummyDataObject::CanBePassedViaImplicitInterface() const { 245 if ((attrs & 246 Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional, 247 Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile}) 248 .any()) { 249 return false; // 15.4.2.2(3)(a) 250 } else if ((type.attrs() & 251 TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape, 252 TypeAndShape::Attr::AssumedRank, 253 TypeAndShape::Attr::Coarray}) 254 .any()) { 255 return false; // 15.4.2.2(3)(b-d) 256 } else if (type.type().IsPolymorphic()) { 257 return false; // 15.4.2.2(3)(f) 258 } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) { 259 return derived->parameters().empty(); // 15.4.2.2(3)(e) 260 } else { 261 return true; 262 } 263 } 264 265 std::ostream &DummyDataObject::Dump(std::ostream &o) const { 266 attrs.Dump(o, EnumToString); 267 if (intent != common::Intent::Default) { 268 o << "INTENT(" << common::EnumToString(intent) << ')'; 269 } 270 type.Dump(o); 271 if (!coshape.empty()) { 272 char sep{'['}; 273 for (const auto &expr : coshape) { 274 expr.AsFortran(o << sep); 275 sep = ','; 276 } 277 } 278 return o; 279 } 280 281 DummyProcedure::DummyProcedure(Procedure &&p) 282 : procedure{new Procedure{std::move(p)}} {} 283 284 bool DummyProcedure::operator==(const DummyProcedure &that) const { 285 return attrs == that.attrs && intent == that.intent && 286 procedure.value() == that.procedure.value(); 287 } 288 289 std::optional<DummyProcedure> DummyProcedure::Characterize( 290 const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) { 291 if (auto procedure{Procedure::Characterize(symbol, intrinsics)}) { 292 // Dummy procedures may not be elemental. Elemental dummy procedure 293 // interfaces are errors when the interface is not intrinsic, and that 294 // error is caught elsewhere. Elemental intrinsic interfaces are 295 // made non-elemental. 296 procedure->attrs.reset(Procedure::Attr::Elemental); 297 DummyProcedure result{std::move(procedure.value())}; 298 CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result, 299 { 300 {semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional}, 301 {semantics::Attr::POINTER, DummyProcedure::Attr::Pointer}, 302 }); 303 result.intent = GetIntent(symbol.attrs()); 304 return result; 305 } else { 306 return std::nullopt; 307 } 308 } 309 310 std::ostream &DummyProcedure::Dump(std::ostream &o) const { 311 attrs.Dump(o, EnumToString); 312 if (intent != common::Intent::Default) { 313 o << "INTENT(" << common::EnumToString(intent) << ')'; 314 } 315 procedure.value().Dump(o); 316 return o; 317 } 318 319 std::ostream &AlternateReturn::Dump(std::ostream &o) const { return o << '*'; } 320 321 DummyArgument::~DummyArgument() {} 322 323 bool DummyArgument::operator==(const DummyArgument &that) const { 324 return u == that.u; // name and passed-object usage are not characteristics 325 } 326 327 std::optional<DummyArgument> DummyArgument::Characterize( 328 const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) { 329 auto name{symbol.name().ToString()}; 330 if (symbol.has<semantics::ObjectEntityDetails>()) { 331 if (auto obj{DummyDataObject::Characterize(symbol)}) { 332 return DummyArgument{std::move(name), std::move(obj.value())}; 333 } 334 } else if (auto proc{DummyProcedure::Characterize(symbol, intrinsics)}) { 335 return DummyArgument{std::move(name), std::move(proc.value())}; 336 } 337 return std::nullopt; 338 } 339 340 std::optional<DummyArgument> DummyArgument::FromActual( 341 std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) { 342 return std::visit( 343 common::visitors{ 344 [&](const BOZLiteralConstant &) { 345 return std::make_optional<DummyArgument>(std::move(name), 346 DummyDataObject{ 347 TypeAndShape{DynamicType::TypelessIntrinsicArgument()}}); 348 }, 349 [](const NullPointer &) { return std::optional<DummyArgument>{}; }, 350 [&](const ProcedureDesignator &designator) { 351 if (auto proc{Procedure::Characterize( 352 designator, context.intrinsics())}) { 353 return std::make_optional<DummyArgument>( 354 std::move(name), DummyProcedure{std::move(*proc)}); 355 } else { 356 return std::optional<DummyArgument>{}; 357 } 358 }, 359 [&](const ProcedureRef &call) { 360 if (auto proc{ 361 Procedure::Characterize(call, context.intrinsics())}) { 362 return std::make_optional<DummyArgument>( 363 std::move(name), DummyProcedure{std::move(*proc)}); 364 } else { 365 return std::optional<DummyArgument>{}; 366 } 367 }, 368 [&](const auto &) { 369 if (auto type{expr.GetType()}) { 370 if (auto shape{GetShape(context, expr)}) { 371 return std::make_optional<DummyArgument>(std::move(name), 372 DummyDataObject{TypeAndShape{*type, std::move(*shape)}}); 373 } else { 374 return std::make_optional<DummyArgument>( 375 std::move(name), DummyDataObject{TypeAndShape{*type}}); 376 } 377 } else { 378 return std::optional<DummyArgument>{}; 379 } 380 }, 381 }, 382 expr.u); 383 } 384 385 bool DummyArgument::IsOptional() const { 386 return std::visit( 387 common::visitors{ 388 [](const DummyDataObject &data) { 389 return data.attrs.test(DummyDataObject::Attr::Optional); 390 }, 391 [](const DummyProcedure &proc) { 392 return proc.attrs.test(DummyProcedure::Attr::Optional); 393 }, 394 [](const AlternateReturn &) { return false; }, 395 }, 396 u); 397 } 398 399 void DummyArgument::SetOptional(bool value) { 400 std::visit( 401 common::visitors{ 402 [value](DummyDataObject &data) { 403 data.attrs.set(DummyDataObject::Attr::Optional, value); 404 }, 405 [value](DummyProcedure &proc) { 406 proc.attrs.set(DummyProcedure::Attr::Optional, value); 407 }, 408 [](AlternateReturn &) { DIE("cannot set optional"); }, 409 }, 410 u); 411 } 412 413 bool DummyArgument::CanBePassedViaImplicitInterface() const { 414 if (const auto *object{std::get_if<DummyDataObject>(&u)}) { 415 return object->CanBePassedViaImplicitInterface(); 416 } else { 417 return true; 418 } 419 } 420 421 std::ostream &DummyArgument::Dump(std::ostream &o) const { 422 if (!name.empty()) { 423 o << name << '='; 424 } 425 if (pass) { 426 o << " PASS"; 427 } 428 std::visit([&](const auto &x) { x.Dump(o); }, u); 429 return o; 430 } 431 432 FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {} 433 FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {} 434 FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {} 435 FunctionResult::~FunctionResult() {} 436 437 bool FunctionResult::operator==(const FunctionResult &that) const { 438 return attrs == that.attrs && u == that.u; 439 } 440 441 std::optional<FunctionResult> FunctionResult::Characterize( 442 const Symbol &symbol, const IntrinsicProcTable &intrinsics) { 443 if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) { 444 if (auto type{TypeAndShape::Characterize(*obj)}) { 445 FunctionResult result{std::move(*type)}; 446 CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result, 447 { 448 {semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable}, 449 {semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous}, 450 {semantics::Attr::POINTER, FunctionResult::Attr::Pointer}, 451 }); 452 return result; 453 } 454 } else if (auto maybeProc{Procedure::Characterize(symbol, intrinsics)}) { 455 FunctionResult result{std::move(*maybeProc)}; 456 result.attrs.set(FunctionResult::Attr::Pointer); 457 return result; 458 } 459 return std::nullopt; 460 } 461 462 bool FunctionResult::IsAssumedLengthCharacter() const { 463 if (const auto *ts{std::get_if<TypeAndShape>(&u)}) { 464 return ts->type().IsAssumedLengthCharacter(); 465 } else { 466 return false; 467 } 468 } 469 470 bool FunctionResult::CanBeReturnedViaImplicitInterface() const { 471 if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) { 472 return false; // 15.4.2.2(4)(b) 473 } else if (const auto *typeAndShape{GetTypeAndShape()}) { 474 if (typeAndShape->Rank() > 0) { 475 return false; // 15.4.2.2(4)(a) 476 } else { 477 const DynamicType &type{typeAndShape->type()}; 478 switch (type.category()) { 479 case TypeCategory::Character: 480 if (const auto *param{type.charLength()}) { 481 if (const auto &expr{param->GetExplicit()}) { 482 return IsConstantExpr(*expr); // 15.4.2.2(4)(c) 483 } 484 } 485 return false; 486 case TypeCategory::Derived: 487 if (!type.IsPolymorphic()) { 488 const auto &spec{type.GetDerivedTypeSpec()}; 489 for (const auto &pair : spec.parameters()) { 490 if (const auto &expr{pair.second.GetExplicit()}) { 491 if (!IsConstantExpr(*expr)) { 492 return false; // 15.4.2.2(4)(c) 493 } 494 } 495 } 496 return true; 497 } 498 return false; 499 default: return true; 500 } 501 } 502 } else { 503 return false; // 15.4.2.2(4)(b) - procedure pointer 504 } 505 } 506 507 std::ostream &FunctionResult::Dump(std::ostream &o) const { 508 attrs.Dump(o, EnumToString); 509 std::visit( 510 common::visitors{ 511 [&](const TypeAndShape &ts) { ts.Dump(o); }, 512 [&](const CopyableIndirection<Procedure> &p) { 513 p.value().Dump(o << " procedure(") << ')'; 514 }, 515 }, 516 u); 517 return o; 518 } 519 520 Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a) 521 : functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {} 522 Procedure::Procedure(DummyArguments &&args, Attrs a) 523 : dummyArguments{std::move(args)}, attrs{a} {} 524 Procedure::~Procedure() {} 525 526 bool Procedure::operator==(const Procedure &that) const { 527 return attrs == that.attrs && functionResult == that.functionResult && 528 dummyArguments == that.dummyArguments; 529 } 530 531 int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const { 532 int argCount{static_cast<int>(dummyArguments.size())}; 533 int index{0}; 534 if (name) { 535 while (index < argCount && *name != dummyArguments[index].name.c_str()) { 536 ++index; 537 } 538 } 539 CHECK(index < argCount); 540 return index; 541 } 542 543 bool Procedure::CanOverride( 544 const Procedure &that, std::optional<int> passIndex) const { 545 // A pure procedure may override an impure one (7.5.7.3(2)) 546 if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) || 547 that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) || 548 functionResult != that.functionResult) { 549 return false; 550 } 551 int argCount{static_cast<int>(dummyArguments.size())}; 552 if (argCount != static_cast<int>(that.dummyArguments.size())) { 553 return false; 554 } 555 for (int j{0}; j < argCount; ++j) { 556 if ((!passIndex || j != *passIndex) && 557 dummyArguments[j] != that.dummyArguments[j]) { 558 return false; 559 } 560 } 561 return true; 562 } 563 564 std::optional<Procedure> Procedure::Characterize( 565 const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) { 566 Procedure result; 567 CopyAttrs<Procedure, Procedure::Attr>(symbol, result, 568 { 569 {semantics::Attr::PURE, Procedure::Attr::Pure}, 570 {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental}, 571 {semantics::Attr::BIND_C, Procedure::Attr::BindC}, 572 }); 573 if (result.attrs.test(Attr::Elemental) && 574 !symbol.attrs().test(semantics::Attr::IMPURE)) { 575 result.attrs.set(Attr::Pure); // explicitly flag pure procedures 576 } 577 return std::visit( 578 common::visitors{ 579 [&](const semantics::SubprogramDetails &subp) 580 -> std::optional<Procedure> { 581 if (subp.isFunction()) { 582 if (auto fr{FunctionResult::Characterize( 583 subp.result(), intrinsics)}) { 584 result.functionResult = std::move(fr); 585 } else { 586 return std::nullopt; 587 } 588 } else { 589 result.attrs.set(Attr::Subroutine); 590 } 591 for (const semantics::Symbol *arg : subp.dummyArgs()) { 592 if (!arg) { 593 result.dummyArguments.emplace_back(AlternateReturn{}); 594 } else if (auto argCharacteristics{ 595 DummyArgument::Characterize(*arg, intrinsics)}) { 596 result.dummyArguments.emplace_back( 597 std::move(argCharacteristics.value())); 598 } else { 599 return std::nullopt; 600 } 601 } 602 return result; 603 }, 604 [&](const semantics::ProcEntityDetails &proc) 605 -> std::optional<Procedure> { 606 if (symbol.attrs().test(semantics::Attr::INTRINSIC)) { 607 return intrinsics.IsSpecificIntrinsicFunction( 608 symbol.name().ToString()); 609 } 610 const semantics::ProcInterface &interface{proc.interface()}; 611 if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) { 612 return Characterize(*interfaceSymbol, intrinsics); 613 } else { 614 result.attrs.set(Attr::ImplicitInterface); 615 const semantics::DeclTypeSpec *type{interface.type()}; 616 if (symbol.test(semantics::Symbol::Flag::Subroutine)) { 617 // ignore any implicit typing 618 result.attrs.set(Attr::Subroutine); 619 } else if (type) { 620 if (auto resultType{DynamicType::From(*type)}) { 621 result.functionResult = FunctionResult{*resultType}; 622 } else { 623 return std::nullopt; 624 } 625 } else if (symbol.test(semantics::Symbol::Flag::Function)) { 626 return std::nullopt; 627 } 628 // The PASS name, if any, is not a characteristic. 629 return result; 630 } 631 }, 632 [&](const semantics::ProcBindingDetails &binding) { 633 if (auto result{Characterize(binding.symbol(), intrinsics)}) { 634 if (!symbol.attrs().test(semantics::Attr::NOPASS)) { 635 auto passName{binding.passName()}; 636 for (auto &dummy : result->dummyArguments) { 637 if (!passName || dummy.name.c_str() == *passName) { 638 dummy.pass = true; 639 return result; 640 } 641 } 642 DIE("PASS argument missing"); 643 } 644 return result; 645 } else { 646 return std::optional<Procedure>{}; 647 } 648 }, 649 [&](const semantics::UseDetails &use) { 650 return Characterize(use.symbol(), intrinsics); 651 }, 652 [&](const semantics::HostAssocDetails &assoc) { 653 return Characterize(assoc.symbol(), intrinsics); 654 }, 655 [](const auto &) { return std::optional<Procedure>{}; }, 656 }, 657 symbol.details()); 658 } 659 660 std::optional<Procedure> Procedure::Characterize( 661 const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) { 662 if (const auto *symbol{proc.GetSymbol()}) { 663 if (auto result{characteristics::Procedure::Characterize( 664 ResolveAssociations(*symbol), intrinsics)}) { 665 return result; 666 } 667 } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) { 668 return intrinsic->characteristics.value(); 669 } 670 return std::nullopt; 671 } 672 673 std::optional<Procedure> Procedure::Characterize( 674 const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) { 675 if (auto callee{Characterize(ref.proc(), intrinsics)}) { 676 if (callee->functionResult) { 677 if (const Procedure * 678 proc{callee->functionResult->IsProcedurePointer()}) { 679 return {*proc}; 680 } 681 } 682 } 683 return std::nullopt; 684 } 685 686 bool Procedure::CanBeCalledViaImplicitInterface() const { 687 if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) { 688 return false; // 15.4.2.2(5,6) 689 } else if (IsFunction() && 690 !functionResult->CanBeReturnedViaImplicitInterface()) { 691 return false; 692 } else { 693 for (const DummyArgument &arg : dummyArguments) { 694 if (!arg.CanBePassedViaImplicitInterface()) { 695 return false; 696 } 697 } 698 return true; 699 } 700 } 701 702 std::ostream &Procedure::Dump(std::ostream &o) const { 703 attrs.Dump(o, EnumToString); 704 if (functionResult) { 705 functionResult->Dump(o << "TYPE(") << ") FUNCTION"; 706 } else { 707 o << "SUBROUTINE"; 708 } 709 char sep{'('}; 710 for (const auto &dummy : dummyArguments) { 711 dummy.Dump(o << sep); 712 sep = ','; 713 } 714 return o << (sep == '(' ? "()" : ")"); 715 } 716 717 // Utility class to determine if Procedures, etc. are distinguishable 718 class DistinguishUtils { 719 public: 720 // Are these procedures distinguishable for a generic name? 721 static bool Distinguishable(const Procedure &, const Procedure &); 722 // Are these procedures distinguishable for a generic operator or assignment? 723 static bool DistinguishableOpOrAssign(const Procedure &, const Procedure &); 724 725 private: 726 struct CountDummyProcedures { 727 CountDummyProcedures(const DummyArguments &args) { 728 for (const DummyArgument &arg : args) { 729 if (std::holds_alternative<DummyProcedure>(arg.u)) { 730 total += 1; 731 notOptional += !arg.IsOptional(); 732 } 733 } 734 } 735 int total{0}; 736 int notOptional{0}; 737 }; 738 739 static bool Rule3Distinguishable(const Procedure &, const Procedure &); 740 static const DummyArgument *Rule1DistinguishingArg( 741 const DummyArguments &, const DummyArguments &); 742 static int FindFirstToDistinguishByPosition( 743 const DummyArguments &, const DummyArguments &); 744 static int FindLastToDistinguishByName( 745 const DummyArguments &, const DummyArguments &); 746 static int CountCompatibleWith(const DummyArgument &, const DummyArguments &); 747 static int CountNotDistinguishableFrom( 748 const DummyArgument &, const DummyArguments &); 749 static bool Distinguishable(const DummyArgument &, const DummyArgument &); 750 static bool Distinguishable(const DummyDataObject &, const DummyDataObject &); 751 static bool Distinguishable(const DummyProcedure &, const DummyProcedure &); 752 static bool Distinguishable(const FunctionResult &, const FunctionResult &); 753 static bool Distinguishable(const TypeAndShape &, const TypeAndShape &); 754 static bool IsTkrCompatible(const DummyArgument &, const DummyArgument &); 755 static bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &); 756 static const DummyArgument *GetAtEffectivePosition( 757 const DummyArguments &, int); 758 static const DummyArgument *GetPassArg(const Procedure &); 759 }; 760 761 // Simpler distinguishability rules for operators and assignment 762 bool DistinguishUtils::DistinguishableOpOrAssign( 763 const Procedure &proc1, const Procedure &proc2) { 764 auto &args1{proc1.dummyArguments}; 765 auto &args2{proc2.dummyArguments}; 766 if (args1.size() != args2.size()) { 767 return true; // C1511: distinguishable based on number of arguments 768 } 769 for (std::size_t i{0}; i < args1.size(); ++i) { 770 if (Distinguishable(args1[i], args2[i])) { 771 return true; // C1511, C1512: distinguishable based on this arg 772 } 773 } 774 return false; 775 } 776 777 bool DistinguishUtils::Distinguishable( 778 const Procedure &proc1, const Procedure &proc2) { 779 auto &args1{proc1.dummyArguments}; 780 auto &args2{proc2.dummyArguments}; 781 auto count1{CountDummyProcedures(args1)}; 782 auto count2{CountDummyProcedures(args2)}; 783 if (count1.notOptional > count2.total || count2.notOptional > count1.total) { 784 return true; // distinguishable based on C1514 rule 2 785 } 786 if (Rule3Distinguishable(proc1, proc2)) { 787 return true; // distinguishable based on C1514 rule 3 788 } 789 if (Rule1DistinguishingArg(args1, args2)) { 790 return true; // distinguishable based on C1514 rule 1 791 } 792 int pos1{FindFirstToDistinguishByPosition(args1, args2)}; 793 int name1{FindLastToDistinguishByName(args1, args2)}; 794 if (pos1 >= 0 && pos1 <= name1) { 795 return true; // distinguishable based on C1514 rule 4 796 } 797 int pos2{FindFirstToDistinguishByPosition(args2, args1)}; 798 int name2{FindLastToDistinguishByName(args2, args1)}; 799 if (pos2 >= 0 && pos2 <= name2) { 800 return true; // distinguishable based on C1514 rule 4 801 } 802 return false; 803 } 804 805 // C1514 rule 3: Procedures are distinguishable if both have a passed-object 806 // dummy argument and those are distinguishable. 807 bool DistinguishUtils::Rule3Distinguishable( 808 const Procedure &proc1, const Procedure &proc2) { 809 const DummyArgument *pass1{GetPassArg(proc1)}; 810 const DummyArgument *pass2{GetPassArg(proc2)}; 811 return pass1 && pass2 && Distinguishable(*pass1, *pass2); 812 } 813 814 // Find a non-passed-object dummy data object in one of the argument lists 815 // that satisfies C1514 rule 1. I.e. x such that: 816 // - m is the number of dummy data objects in one that are nonoptional, 817 // are not passed-object, that x is TKR compatible with 818 // - n is the number of non-passed-object dummy data objects, in the other 819 // that are not distinguishable from x 820 // - m is greater than n 821 const DummyArgument *DistinguishUtils::Rule1DistinguishingArg( 822 const DummyArguments &args1, const DummyArguments &args2) { 823 auto size1{args1.size()}; 824 auto size2{args2.size()}; 825 for (std::size_t i{0}; i < size1 + size2; ++i) { 826 const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]}; 827 if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) { 828 if (CountCompatibleWith(x, args1) > 829 CountNotDistinguishableFrom(x, args2) || 830 CountCompatibleWith(x, args2) > 831 CountNotDistinguishableFrom(x, args1)) { 832 return &x; 833 } 834 } 835 } 836 return nullptr; 837 } 838 839 // Find the index of the first nonoptional non-passed-object dummy argument 840 // in args1 at an effective position such that either: 841 // - args2 has no dummy argument at that effective position 842 // - the dummy argument at that position is distinguishable from it 843 int DistinguishUtils::FindFirstToDistinguishByPosition( 844 const DummyArguments &args1, const DummyArguments &args2) { 845 int effective{0}; // position of arg1 in list, ignoring passed arg 846 for (std::size_t i{0}; i < args1.size(); ++i) { 847 const DummyArgument &arg1{args1.at(i)}; 848 if (!arg1.pass && !arg1.IsOptional()) { 849 const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)}; 850 if (!arg2 || Distinguishable(arg1, *arg2)) { 851 return i; 852 } 853 } 854 effective += !arg1.pass; 855 } 856 return -1; 857 } 858 859 // Find the index of the last nonoptional non-passed-object dummy argument 860 // in args1 whose name is such that either: 861 // - args2 has no dummy argument with that name 862 // - the dummy argument with that name is distinguishable from it 863 int DistinguishUtils::FindLastToDistinguishByName( 864 const DummyArguments &args1, const DummyArguments &args2) { 865 std::map<std::string, const DummyArgument *> nameToArg; 866 for (const auto &arg2 : args2) { 867 nameToArg.emplace(arg2.name, &arg2); 868 } 869 for (int i = args1.size() - 1; i >= 0; --i) { 870 const DummyArgument &arg1{args1.at(i)}; 871 if (!arg1.pass && !arg1.IsOptional()) { 872 auto it{nameToArg.find(arg1.name)}; 873 if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) { 874 return i; 875 } 876 } 877 } 878 return -1; 879 } 880 881 // Count the dummy data objects in args that are nonoptional, are not 882 // passed-object, and that x is TKR compatible with 883 int DistinguishUtils::CountCompatibleWith( 884 const DummyArgument &x, const DummyArguments &args) { 885 return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) { 886 return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y); 887 }); 888 } 889 890 // Return the number of dummy data objects in args that are not 891 // distinguishable from x and not passed-object. 892 int DistinguishUtils::CountNotDistinguishableFrom( 893 const DummyArgument &x, const DummyArguments &args) { 894 return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) { 895 return !y.pass && std::holds_alternative<DummyDataObject>(y.u) && 896 !Distinguishable(y, x); 897 }); 898 } 899 900 bool DistinguishUtils::Distinguishable( 901 const DummyArgument &x, const DummyArgument &y) { 902 if (x.u.index() != y.u.index()) { 903 return true; // different kind: data/proc/alt-return 904 } 905 return std::visit( 906 common::visitors{ 907 [&](const DummyDataObject &z) { 908 return Distinguishable(z, std::get<DummyDataObject>(y.u)); 909 }, 910 [&](const DummyProcedure &z) { 911 return Distinguishable(z, std::get<DummyProcedure>(y.u)); 912 }, 913 [&](const AlternateReturn &) { return false; }, 914 }, 915 x.u); 916 } 917 918 bool DistinguishUtils::Distinguishable( 919 const DummyDataObject &x, const DummyDataObject &y) { 920 using Attr = DummyDataObject::Attr; 921 if (Distinguishable(x.type, y.type)) { 922 return true; 923 } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) && 924 y.intent != common::Intent::In) { 925 return true; 926 } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) && 927 x.intent != common::Intent::In) { 928 return true; 929 } else { 930 return false; 931 } 932 } 933 934 bool DistinguishUtils::Distinguishable( 935 const DummyProcedure &x, const DummyProcedure &y) { 936 const Procedure &xProc{x.procedure.value()}; 937 const Procedure &yProc{y.procedure.value()}; 938 if (Distinguishable(xProc, yProc)) { 939 return true; 940 } else { 941 const std::optional<FunctionResult> &xResult{xProc.functionResult}; 942 const std::optional<FunctionResult> &yResult{yProc.functionResult}; 943 return xResult ? !yResult || Distinguishable(*xResult, *yResult) 944 : yResult.has_value(); 945 } 946 } 947 948 bool DistinguishUtils::Distinguishable( 949 const FunctionResult &x, const FunctionResult &y) { 950 if (x.u.index() != y.u.index()) { 951 return true; // one is data object, one is procedure 952 } 953 return std::visit( 954 common::visitors{ 955 [&](const TypeAndShape &z) { 956 return Distinguishable(z, std::get<TypeAndShape>(y.u)); 957 }, 958 [&](const CopyableIndirection<Procedure> &z) { 959 return Distinguishable(z.value(), 960 std::get<CopyableIndirection<Procedure>>(y.u).value()); 961 }, 962 }, 963 x.u); 964 } 965 966 bool DistinguishUtils::Distinguishable( 967 const TypeAndShape &x, const TypeAndShape &y) { 968 return !IsTkrCompatible(x, y) && !IsTkrCompatible(y, x); 969 } 970 971 // Compatibility based on type, kind, and rank 972 bool DistinguishUtils::IsTkrCompatible( 973 const DummyArgument &x, const DummyArgument &y) { 974 const auto *obj1{std::get_if<DummyDataObject>(&x.u)}; 975 const auto *obj2{std::get_if<DummyDataObject>(&y.u)}; 976 return obj1 && obj2 && IsTkrCompatible(obj1->type, obj2->type); 977 } 978 bool DistinguishUtils::IsTkrCompatible( 979 const TypeAndShape &x, const TypeAndShape &y) { 980 return x.type().IsTkCompatibleWith(y.type()) && 981 (x.attrs().test(TypeAndShape::Attr::AssumedRank) || 982 y.attrs().test(TypeAndShape::Attr::AssumedRank) || 983 x.Rank() == y.Rank()); 984 } 985 986 // Return the argument at the given index, ignoring the passed arg 987 const DummyArgument *DistinguishUtils::GetAtEffectivePosition( 988 const DummyArguments &args, int index) { 989 for (const DummyArgument &arg : args) { 990 if (!arg.pass) { 991 if (index == 0) { 992 return &arg; 993 } 994 --index; 995 } 996 } 997 return nullptr; 998 } 999 1000 // Return the passed-object dummy argument of this procedure, if any 1001 const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) { 1002 for (const auto &arg : proc.dummyArguments) { 1003 if (arg.pass) { 1004 return &arg; 1005 } 1006 } 1007 return nullptr; 1008 } 1009 1010 bool Distinguishable(const Procedure &x, const Procedure &y) { 1011 return DistinguishUtils::Distinguishable(x, y); 1012 } 1013 1014 bool DistinguishableOpOrAssign(const Procedure &x, const Procedure &y) { 1015 return DistinguishUtils::DistinguishableOpOrAssign(x, y); 1016 } 1017 1018 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument) 1019 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure) 1020 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult) 1021 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure) 1022 } 1023 1024 template class Fortran::common::Indirection< 1025 Fortran::evaluate::characteristics::Procedure, true>; 1026