1 //===-- lib/Evaluate/intrinsics.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/intrinsics.h" 10 #include "flang/Common/Fortran.h" 11 #include "flang/Common/enum-set.h" 12 #include "flang/Common/idioms.h" 13 #include "flang/Evaluate/check-expression.h" 14 #include "flang/Evaluate/common.h" 15 #include "flang/Evaluate/expression.h" 16 #include "flang/Evaluate/fold.h" 17 #include "flang/Evaluate/shape.h" 18 #include "flang/Evaluate/tools.h" 19 #include "flang/Evaluate/type.h" 20 #include "flang/Semantics/scope.h" 21 #include "flang/Semantics/tools.h" 22 #include "llvm/Support/raw_ostream.h" 23 #include <algorithm> 24 #include <cmath> 25 #include <map> 26 #include <string> 27 #include <utility> 28 29 using namespace Fortran::parser::literals; 30 31 namespace Fortran::evaluate { 32 33 class FoldingContext; 34 35 // This file defines the supported intrinsic procedures and implements 36 // their recognition and validation. It is largely table-driven. See 37 // docs/intrinsics.md and section 16 of the Fortran 2018 standard 38 // for full details on each of the intrinsics. Be advised, they have 39 // complicated details, and the design of these tables has to accommodate 40 // that complexity. 41 42 // Dummy arguments to generic intrinsic procedures are each specified by 43 // their keyword name (rarely used, but always defined), allowable type 44 // categories, a kind pattern, a rank pattern, and information about 45 // optionality and defaults. The kind and rank patterns are represented 46 // here with code values that are significant to the matching/validation engine. 47 48 // An actual argument to an intrinsic procedure may be a procedure itself 49 // only if the dummy argument is Rank::reduceOperation, 50 // KindCode::addressable, or the special case of NULL(MOLD=procedurePointer). 51 52 // These are small bit-sets of type category enumerators. 53 // Note that typeless (BOZ literal) values don't have a distinct type category. 54 // These typeless arguments are represented in the tables as if they were 55 // INTEGER with a special "typeless" kind code. Arguments of intrinsic types 56 // that can also be typeless values are encoded with an "elementalOrBOZ" 57 // rank pattern. 58 // Assumed-type (TYPE(*)) dummy arguments can be forwarded along to some 59 // intrinsic functions that accept AnyType + Rank::anyOrAssumedRank or 60 // AnyType + Kind::addressable. 61 using CategorySet = common::EnumSet<TypeCategory, 8>; 62 static constexpr CategorySet IntType{TypeCategory::Integer}; 63 static constexpr CategorySet RealType{TypeCategory::Real}; 64 static constexpr CategorySet ComplexType{TypeCategory::Complex}; 65 static constexpr CategorySet CharType{TypeCategory::Character}; 66 static constexpr CategorySet LogicalType{TypeCategory::Logical}; 67 static constexpr CategorySet IntOrRealType{IntType | RealType}; 68 static constexpr CategorySet FloatingType{RealType | ComplexType}; 69 static constexpr CategorySet NumericType{IntType | RealType | ComplexType}; 70 static constexpr CategorySet RelatableType{IntType | RealType | CharType}; 71 static constexpr CategorySet DerivedType{TypeCategory::Derived}; 72 static constexpr CategorySet IntrinsicType{ 73 IntType | RealType | ComplexType | CharType | LogicalType}; 74 static constexpr CategorySet AnyType{IntrinsicType | DerivedType}; 75 76 ENUM_CLASS(KindCode, none, defaultIntegerKind, 77 defaultRealKind, // is also the default COMPLEX kind 78 doublePrecision, defaultCharKind, defaultLogicalKind, 79 any, // matches any kind value; each instance is independent 80 same, // match any kind, but all "same" kinds must be equal 81 operand, // match any kind, with promotion (non-standard) 82 typeless, // BOZ literals are INTEGER with this kind 83 teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays) 84 kindArg, // this argument is KIND= 85 effectiveKind, // for function results: "kindArg" value, possibly defaulted 86 dimArg, // this argument is DIM= 87 likeMultiply, // for DOT_PRODUCT and MATMUL 88 subscript, // address-sized integer 89 size, // default KIND= for SIZE(), UBOUND, &c. 90 addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ 91 nullPointerType, // for ASSOCIATED(NULL()) 92 exactKind, // a single explicit exactKindValue 93 ) 94 95 struct TypePattern { 96 CategorySet categorySet; 97 KindCode kindCode{KindCode::none}; 98 int exactKindValue{0}; // for KindCode::exactBind 99 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 100 }; 101 102 // Abbreviations for argument and result patterns in the intrinsic prototypes: 103 104 // Match specific kinds of intrinsic types 105 static constexpr TypePattern DefaultInt{IntType, KindCode::defaultIntegerKind}; 106 static constexpr TypePattern DefaultReal{RealType, KindCode::defaultRealKind}; 107 static constexpr TypePattern DefaultComplex{ 108 ComplexType, KindCode::defaultRealKind}; 109 static constexpr TypePattern DefaultChar{CharType, KindCode::defaultCharKind}; 110 static constexpr TypePattern DefaultLogical{ 111 LogicalType, KindCode::defaultLogicalKind}; 112 static constexpr TypePattern BOZ{IntType, KindCode::typeless}; 113 static constexpr TypePattern TeamType{DerivedType, KindCode::teamType}; 114 static constexpr TypePattern DoublePrecision{ 115 RealType, KindCode::doublePrecision}; 116 static constexpr TypePattern DoublePrecisionComplex{ 117 ComplexType, KindCode::doublePrecision}; 118 static constexpr TypePattern SubscriptInt{IntType, KindCode::subscript}; 119 120 // Match any kind of some intrinsic or derived types 121 static constexpr TypePattern AnyInt{IntType, KindCode::any}; 122 static constexpr TypePattern AnyReal{RealType, KindCode::any}; 123 static constexpr TypePattern AnyIntOrReal{IntOrRealType, KindCode::any}; 124 static constexpr TypePattern AnyComplex{ComplexType, KindCode::any}; 125 static constexpr TypePattern AnyFloating{FloatingType, KindCode::any}; 126 static constexpr TypePattern AnyNumeric{NumericType, KindCode::any}; 127 static constexpr TypePattern AnyChar{CharType, KindCode::any}; 128 static constexpr TypePattern AnyLogical{LogicalType, KindCode::any}; 129 static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any}; 130 static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any}; 131 static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any}; 132 static constexpr TypePattern AnyData{AnyType, KindCode::any}; 133 134 // Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.) 135 static constexpr TypePattern Addressable{AnyType, KindCode::addressable}; 136 137 // Match some kind of some intrinsic type(s); all "Same" values must match, 138 // even when not in the same category (e.g., SameComplex and SameReal). 139 // Can be used to specify a result so long as at least one argument is 140 // a "Same". 141 static constexpr TypePattern SameInt{IntType, KindCode::same}; 142 static constexpr TypePattern SameReal{RealType, KindCode::same}; 143 static constexpr TypePattern SameIntOrReal{IntOrRealType, KindCode::same}; 144 static constexpr TypePattern SameComplex{ComplexType, KindCode::same}; 145 static constexpr TypePattern SameFloating{FloatingType, KindCode::same}; 146 static constexpr TypePattern SameNumeric{NumericType, KindCode::same}; 147 static constexpr TypePattern SameChar{CharType, KindCode::same}; 148 static constexpr TypePattern SameLogical{LogicalType, KindCode::same}; 149 static constexpr TypePattern SameRelatable{RelatableType, KindCode::same}; 150 static constexpr TypePattern SameIntrinsic{IntrinsicType, KindCode::same}; 151 static constexpr TypePattern SameDerivedType{ 152 CategorySet{TypeCategory::Derived}, KindCode::same}; 153 static constexpr TypePattern SameType{AnyType, KindCode::same}; 154 155 // Match some kind of some INTEGER or REAL type(s); when argument types 156 // &/or kinds differ, their values are converted as if they were operands to 157 // an intrinsic operation like addition. This is a nonstandard but nearly 158 // universal extension feature. 159 static constexpr TypePattern OperandReal{RealType, KindCode::operand}; 160 static constexpr TypePattern OperandIntOrReal{IntOrRealType, KindCode::operand}; 161 162 // For ASSOCIATED, the first argument is a typeless pointer 163 static constexpr TypePattern AnyPointer{AnyType, KindCode::nullPointerType}; 164 165 // For DOT_PRODUCT and MATMUL, the result type depends on the arguments 166 static constexpr TypePattern ResultLogical{LogicalType, KindCode::likeMultiply}; 167 static constexpr TypePattern ResultNumeric{NumericType, KindCode::likeMultiply}; 168 169 // Result types with known category and KIND= 170 static constexpr TypePattern KINDInt{IntType, KindCode::effectiveKind}; 171 static constexpr TypePattern KINDReal{RealType, KindCode::effectiveKind}; 172 static constexpr TypePattern KINDComplex{ComplexType, KindCode::effectiveKind}; 173 static constexpr TypePattern KINDChar{CharType, KindCode::effectiveKind}; 174 static constexpr TypePattern KINDLogical{LogicalType, KindCode::effectiveKind}; 175 176 // The default rank pattern for dummy arguments and function results is 177 // "elemental". 178 ENUM_CLASS(Rank, 179 elemental, // scalar, or array that conforms with other array arguments 180 elementalOrBOZ, // elemental, or typeless BOZ literal scalar 181 scalar, vector, 182 shape, // INTEGER vector of known length and no negative element 183 matrix, 184 array, // not scalar, rank is known and greater than zero 185 coarray, // rank is known and can be scalar; has nonzero corank 186 known, // rank is known and can be scalar 187 anyOrAssumedRank, // rank can be unknown; assumed-type TYPE(*) allowed 188 conformable, // scalar, or array of same rank & shape as "array" argument 189 reduceOperation, // a pure function with constraints for REDUCE 190 dimReduced, // scalar if no DIM= argument, else rank(array)-1 191 dimRemovedOrScalar, // rank(array)-1 (less DIM) or scalar 192 locReduced, // vector(1:rank) if no DIM= argument, else rank(array)-1 193 rankPlus1, // rank(known)+1 194 shaped, // rank is length of SHAPE vector 195 ) 196 197 ENUM_CLASS(Optionality, required, 198 optional, // unless DIM= for SIZE(assumedSize) 199 missing, // for DIM= cases like FINDLOC 200 defaultsToSameKind, // for MatchingDefaultKIND 201 defaultsToDefaultForResult, // for DefaultingKIND 202 defaultsToSizeKind, // for SizeDefaultKIND 203 repeats, // for MAX/MIN and their several variants 204 ) 205 206 struct IntrinsicDummyArgument { 207 const char *keyword{nullptr}; 208 TypePattern typePattern; 209 Rank rank{Rank::elemental}; 210 Optionality optionality{Optionality::required}; 211 common::Intent intent{common::Intent::In}; 212 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 213 }; 214 215 // constexpr abbreviations for popular arguments: 216 // DefaultingKIND is a KIND= argument whose default value is the appropriate 217 // KIND(0), KIND(0.0), KIND(''), &c. value for the function result. 218 static constexpr IntrinsicDummyArgument DefaultingKIND{"kind", 219 {IntType, KindCode::kindArg}, Rank::scalar, 220 Optionality::defaultsToDefaultForResult, common::Intent::In}; 221 // MatchingDefaultKIND is a KIND= argument whose default value is the 222 // kind of any "Same" function argument (viz., the one whose kind pattern is 223 // "same"). 224 static constexpr IntrinsicDummyArgument MatchingDefaultKIND{"kind", 225 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::defaultsToSameKind, 226 common::Intent::In}; 227 // SizeDefaultKind is a KIND= argument whose default value should be 228 // the kind of INTEGER used for address calculations, and can be 229 // set so with a compiler flag; but the standard mandates the 230 // kind of default INTEGER. 231 static constexpr IntrinsicDummyArgument SizeDefaultKIND{"kind", 232 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::defaultsToSizeKind, 233 common::Intent::In}; 234 static constexpr IntrinsicDummyArgument RequiredDIM{"dim", 235 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::required, 236 common::Intent::In}; 237 static constexpr IntrinsicDummyArgument OptionalDIM{"dim", 238 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::optional, 239 common::Intent::In}; 240 static constexpr IntrinsicDummyArgument MissingDIM{"dim", 241 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::missing, 242 common::Intent::In}; 243 static constexpr IntrinsicDummyArgument OptionalMASK{"mask", AnyLogical, 244 Rank::conformable, Optionality::optional, common::Intent::In}; 245 static constexpr IntrinsicDummyArgument OptionalTEAM{ 246 "team", TeamType, Rank::scalar, Optionality::optional, common::Intent::In}; 247 248 struct IntrinsicInterface { 249 static constexpr int maxArguments{7}; // if not a MAX/MIN(...) 250 const char *name{nullptr}; 251 IntrinsicDummyArgument dummy[maxArguments]; 252 TypePattern result; 253 Rank rank{Rank::elemental}; 254 IntrinsicClass intrinsicClass{IntrinsicClass::elementalFunction}; 255 std::optional<SpecificCall> Match(const CallCharacteristics &, 256 const common::IntrinsicTypeDefaultKinds &, ActualArguments &, 257 FoldingContext &context, const semantics::Scope *builtins) const; 258 int CountArguments() const; 259 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 260 }; 261 262 int IntrinsicInterface::CountArguments() const { 263 int n{0}; 264 while (n < maxArguments && dummy[n].keyword) { 265 ++n; 266 } 267 return n; 268 } 269 270 // GENERIC INTRINSIC FUNCTION INTERFACES 271 // Each entry in this table defines a pattern. Some intrinsic 272 // functions have more than one such pattern. Besides the name 273 // of the intrinsic function, each pattern has specifications for 274 // the dummy arguments and for the result of the function. 275 // The dummy argument patterns each have a name (these are from the 276 // standard, but rarely appear in actual code), a type and kind 277 // pattern, allowable ranks, and optionality indicators. 278 // Be advised, the default rank pattern is "elemental". 279 static const IntrinsicInterface genericIntrinsicFunction[]{ 280 {"abs", {{"a", SameIntOrReal}}, SameIntOrReal}, 281 {"abs", {{"a", SameComplex}}, SameReal}, 282 {"achar", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar}, 283 {"acos", {{"x", SameFloating}}, SameFloating}, 284 {"acosd", {{"x", SameFloating}}, SameFloating}, 285 {"acosh", {{"x", SameFloating}}, SameFloating}, 286 {"adjustl", {{"string", SameChar}}, SameChar}, 287 {"adjustr", {{"string", SameChar}}, SameChar}, 288 {"aimag", {{"z", SameComplex}}, SameReal}, 289 {"aint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal}, 290 {"all", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, 291 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 292 {"allocated", {{"array", AnyData, Rank::array}}, DefaultLogical, 293 Rank::elemental, IntrinsicClass::inquiryFunction}, 294 {"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical, 295 Rank::elemental, IntrinsicClass::inquiryFunction}, 296 {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal}, 297 {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, 298 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 299 {"asin", {{"x", SameFloating}}, SameFloating}, 300 {"asind", {{"x", SameFloating}}, SameFloating}, 301 {"asinh", {{"x", SameFloating}}, SameFloating}, 302 {"associated", 303 {{"pointer", AnyPointer, Rank::known}, 304 {"target", Addressable, Rank::known, Optionality::optional}}, 305 DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, 306 {"atan", {{"x", SameFloating}}, SameFloating}, 307 {"atand", {{"x", SameFloating}}, SameFloating}, 308 {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 309 {"atand", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 310 {"atan2", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 311 {"atan2d", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 312 {"atanh", {{"x", SameFloating}}, SameFloating}, 313 {"bessel_j0", {{"x", SameReal}}, SameReal}, 314 {"bessel_j1", {{"x", SameReal}}, SameReal}, 315 {"bessel_jn", {{"n", AnyInt}, {"x", SameReal}}, SameReal}, 316 {"bessel_jn", 317 {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar}, 318 {"x", SameReal, Rank::scalar}}, 319 SameReal, Rank::vector, IntrinsicClass::transformationalFunction}, 320 {"bessel_y0", {{"x", SameReal}}, SameReal}, 321 {"bessel_y1", {{"x", SameReal}}, SameReal}, 322 {"bessel_yn", {{"n", AnyInt}, {"x", SameReal}}, SameReal}, 323 {"bessel_yn", 324 {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar}, 325 {"x", SameReal, Rank::scalar}}, 326 SameReal, Rank::vector, IntrinsicClass::transformationalFunction}, 327 {"bge", 328 {{"i", AnyInt, Rank::elementalOrBOZ}, 329 {"j", AnyInt, Rank::elementalOrBOZ}}, 330 DefaultLogical}, 331 {"bgt", 332 {{"i", AnyInt, Rank::elementalOrBOZ}, 333 {"j", AnyInt, Rank::elementalOrBOZ}}, 334 DefaultLogical}, 335 {"bit_size", {{"i", SameInt, Rank::anyOrAssumedRank}}, SameInt, 336 Rank::scalar, IntrinsicClass::inquiryFunction}, 337 {"ble", 338 {{"i", AnyInt, Rank::elementalOrBOZ}, 339 {"j", AnyInt, Rank::elementalOrBOZ}}, 340 DefaultLogical}, 341 {"blt", 342 {{"i", AnyInt, Rank::elementalOrBOZ}, 343 {"j", AnyInt, Rank::elementalOrBOZ}}, 344 DefaultLogical}, 345 {"btest", {{"i", AnyInt, Rank::elementalOrBOZ}, {"pos", AnyInt}}, 346 DefaultLogical}, 347 {"ceiling", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, 348 {"char", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar}, 349 {"cmplx", {{"x", AnyComplex}, DefaultingKIND}, KINDComplex}, 350 {"cmplx", 351 {{"x", AnyIntOrReal, Rank::elementalOrBOZ}, 352 {"y", AnyIntOrReal, Rank::elementalOrBOZ, Optionality::optional}, 353 DefaultingKIND}, 354 KINDComplex}, 355 {"command_argument_count", {}, DefaultInt, Rank::scalar, 356 IntrinsicClass::transformationalFunction}, 357 {"conjg", {{"z", SameComplex}}, SameComplex}, 358 {"cos", {{"x", SameFloating}}, SameFloating}, 359 {"cosd", {{"x", SameFloating}}, SameFloating}, 360 {"cosh", {{"x", SameFloating}}, SameFloating}, 361 {"count", {{"mask", AnyLogical, Rank::array}, OptionalDIM, DefaultingKIND}, 362 KINDInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, 363 {"cshift", 364 {{"array", SameType, Rank::array}, 365 {"shift", AnyInt, Rank::dimRemovedOrScalar}, OptionalDIM}, 366 SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, 367 {"dble", {{"a", AnyNumeric, Rank::elementalOrBOZ}}, DoublePrecision}, 368 {"digits", {{"x", AnyIntOrReal, Rank::anyOrAssumedRank}}, DefaultInt, 369 Rank::scalar, IntrinsicClass::inquiryFunction}, 370 {"dim", {{"x", OperandIntOrReal}, {"y", OperandIntOrReal}}, 371 OperandIntOrReal}, 372 {"dot_product", 373 {{"vector_a", AnyLogical, Rank::vector}, 374 {"vector_b", AnyLogical, Rank::vector}}, 375 ResultLogical, Rank::scalar, IntrinsicClass::transformationalFunction}, 376 {"dot_product", 377 {{"vector_a", AnyComplex, Rank::vector}, 378 {"vector_b", AnyNumeric, Rank::vector}}, 379 ResultNumeric, Rank::scalar, // conjugates vector_a 380 IntrinsicClass::transformationalFunction}, 381 {"dot_product", 382 {{"vector_a", AnyIntOrReal, Rank::vector}, 383 {"vector_b", AnyNumeric, Rank::vector}}, 384 ResultNumeric, Rank::scalar, IntrinsicClass::transformationalFunction}, 385 {"dprod", {{"x", DefaultReal}, {"y", DefaultReal}}, DoublePrecision}, 386 {"dshiftl", 387 {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}, 388 {"shift", AnyInt}}, 389 SameInt}, 390 {"dshiftl", {{"i", BOZ}, {"j", SameInt}, {"shift", AnyInt}}, SameInt}, 391 {"dshiftr", 392 {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}, 393 {"shift", AnyInt}}, 394 SameInt}, 395 {"dshiftr", {{"i", BOZ}, {"j", SameInt}, {"shift", AnyInt}}, SameInt}, 396 {"eoshift", 397 {{"array", SameIntrinsic, Rank::array}, 398 {"shift", AnyInt, Rank::dimRemovedOrScalar}, 399 {"boundary", SameIntrinsic, Rank::dimRemovedOrScalar, 400 Optionality::optional}, 401 OptionalDIM}, 402 SameIntrinsic, Rank::conformable, 403 IntrinsicClass::transformationalFunction}, 404 {"eoshift", 405 {{"array", SameDerivedType, Rank::array}, 406 {"shift", AnyInt, Rank::dimRemovedOrScalar}, 407 // BOUNDARY= is not optional for derived types 408 {"boundary", SameDerivedType, Rank::dimRemovedOrScalar}, 409 OptionalDIM}, 410 SameDerivedType, Rank::conformable, 411 IntrinsicClass::transformationalFunction}, 412 {"epsilon", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, 413 Rank::scalar, IntrinsicClass::inquiryFunction}, 414 {"erf", {{"x", SameReal}}, SameReal}, 415 {"erfc", {{"x", SameReal}}, SameReal}, 416 {"erfc_scaled", {{"x", SameReal}}, SameReal}, 417 {"exp", {{"x", SameFloating}}, SameFloating}, 418 {"exp", {{"x", SameFloating}}, SameFloating}, 419 {"exponent", {{"x", AnyReal}}, DefaultInt}, 420 {"exp", {{"x", SameFloating}}, SameFloating}, 421 {"extends_type_of", 422 {{"a", ExtensibleDerived, Rank::anyOrAssumedRank}, 423 {"mold", ExtensibleDerived, Rank::anyOrAssumedRank}}, 424 DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, 425 {"failed_images", {OptionalTEAM, SizeDefaultKIND}, KINDInt, Rank::vector, 426 IntrinsicClass::transformationalFunction}, 427 {"findloc", 428 {{"array", AnyNumeric, Rank::array}, 429 {"value", AnyNumeric, Rank::scalar}, RequiredDIM, OptionalMASK, 430 SizeDefaultKIND, 431 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 432 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 433 {"findloc", 434 {{"array", AnyNumeric, Rank::array}, 435 {"value", AnyNumeric, Rank::scalar}, MissingDIM, OptionalMASK, 436 SizeDefaultKIND, 437 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 438 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, 439 {"findloc", 440 {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar}, 441 RequiredDIM, OptionalMASK, SizeDefaultKIND, 442 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 443 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 444 {"findloc", 445 {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar}, 446 MissingDIM, OptionalMASK, SizeDefaultKIND, 447 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 448 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, 449 {"findloc", 450 {{"array", AnyLogical, Rank::array}, 451 {"value", AnyLogical, Rank::scalar}, RequiredDIM, OptionalMASK, 452 SizeDefaultKIND, 453 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 454 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 455 {"findloc", 456 {{"array", AnyLogical, Rank::array}, 457 {"value", AnyLogical, Rank::scalar}, MissingDIM, OptionalMASK, 458 SizeDefaultKIND, 459 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 460 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, 461 {"floor", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, 462 {"fraction", {{"x", SameReal}}, SameReal}, 463 {"gamma", {{"x", SameReal}}, SameReal}, 464 {"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}}, 465 TeamType, Rank::scalar, IntrinsicClass::transformationalFunction}, 466 {"huge", {{"x", SameIntOrReal, Rank::anyOrAssumedRank}}, SameIntOrReal, 467 Rank::scalar, IntrinsicClass::inquiryFunction}, 468 {"hypot", {{"x", OperandReal}, {"y", OperandReal}}, OperandReal}, 469 {"iachar", {{"c", AnyChar}, DefaultingKIND}, KINDInt}, 470 {"iall", {{"array", SameInt, Rank::array}, RequiredDIM, OptionalMASK}, 471 SameInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, 472 {"iall", {{"array", SameInt, Rank::array}, MissingDIM, OptionalMASK}, 473 SameInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 474 {"iany", {{"array", SameInt, Rank::array}, RequiredDIM, OptionalMASK}, 475 SameInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, 476 {"iany", {{"array", SameInt, Rank::array}, MissingDIM, OptionalMASK}, 477 SameInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 478 {"iparity", {{"array", SameInt, Rank::array}, RequiredDIM, OptionalMASK}, 479 SameInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, 480 {"iparity", {{"array", SameInt, Rank::array}, MissingDIM, OptionalMASK}, 481 SameInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 482 {"iand", {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}}, SameInt}, 483 {"iand", {{"i", BOZ}, {"j", SameInt}}, SameInt}, 484 {"ibclr", {{"i", SameInt}, {"pos", AnyInt}}, SameInt}, 485 {"ibits", {{"i", SameInt}, {"pos", AnyInt}, {"len", AnyInt}}, SameInt}, 486 {"ibset", {{"i", SameInt}, {"pos", AnyInt}}, SameInt}, 487 {"ichar", {{"c", AnyChar}, DefaultingKIND}, KINDInt}, 488 {"ieor", {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}}, SameInt}, 489 {"ieor", {{"i", BOZ}, {"j", SameInt}}, SameInt}, 490 {"image_status", {{"image", SameInt}, OptionalTEAM}, DefaultInt}, 491 {"index", 492 {{"string", SameChar}, {"substring", SameChar}, 493 {"back", AnyLogical, Rank::elemental, Optionality::optional}, 494 DefaultingKIND}, 495 KINDInt}, 496 {"int", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND}, KINDInt}, 497 {"int_ptr_kind", {}, DefaultInt, Rank::scalar}, 498 {"ior", {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}}, SameInt}, 499 {"ior", {{"i", BOZ}, {"j", SameInt}}, SameInt}, 500 {"ishft", {{"i", SameInt}, {"shift", AnyInt}}, SameInt}, 501 {"ishftc", 502 {{"i", SameInt}, {"shift", AnyInt}, 503 {"size", AnyInt, Rank::elemental, Optionality::optional}}, 504 SameInt}, 505 {"isnan", {{"a", AnyFloating}}, DefaultLogical}, 506 {"is_contiguous", {{"array", Addressable, Rank::anyOrAssumedRank}}, 507 DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, 508 {"is_iostat_end", {{"i", AnyInt}}, DefaultLogical}, 509 {"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical}, 510 {"kind", {{"x", AnyIntrinsic}}, DefaultInt, Rank::elemental, 511 IntrinsicClass::inquiryFunction}, 512 {"lbound", 513 {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM, 514 SizeDefaultKIND}, 515 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 516 {"lbound", {{"array", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, 517 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, 518 {"leadz", {{"i", AnyInt}}, DefaultInt}, 519 {"len", {{"string", AnyChar, Rank::anyOrAssumedRank}, DefaultingKIND}, 520 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 521 {"len_trim", {{"string", AnyChar}, DefaultingKIND}, KINDInt}, 522 {"lge", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, 523 {"lgt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, 524 {"lle", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, 525 {"llt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, 526 {"loc", {{"loc_argument", Addressable, Rank::anyOrAssumedRank}}, 527 SubscriptInt, Rank::scalar}, 528 {"log", {{"x", SameFloating}}, SameFloating}, 529 {"log10", {{"x", SameReal}}, SameReal}, 530 {"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical}, 531 {"log_gamma", {{"x", SameReal}}, SameReal}, 532 {"matmul", 533 {{"matrix_a", AnyLogical, Rank::vector}, 534 {"matrix_b", AnyLogical, Rank::matrix}}, 535 ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction}, 536 {"matmul", 537 {{"matrix_a", AnyLogical, Rank::matrix}, 538 {"matrix_b", AnyLogical, Rank::vector}}, 539 ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction}, 540 {"matmul", 541 {{"matrix_a", AnyLogical, Rank::matrix}, 542 {"matrix_b", AnyLogical, Rank::matrix}}, 543 ResultLogical, Rank::matrix, IntrinsicClass::transformationalFunction}, 544 {"matmul", 545 {{"matrix_a", AnyNumeric, Rank::vector}, 546 {"matrix_b", AnyNumeric, Rank::matrix}}, 547 ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction}, 548 {"matmul", 549 {{"matrix_a", AnyNumeric, Rank::matrix}, 550 {"matrix_b", AnyNumeric, Rank::vector}}, 551 ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction}, 552 {"matmul", 553 {{"matrix_a", AnyNumeric, Rank::matrix}, 554 {"matrix_b", AnyNumeric, Rank::matrix}}, 555 ResultNumeric, Rank::matrix, IntrinsicClass::transformationalFunction}, 556 {"maskl", {{"i", AnyInt}, DefaultingKIND}, KINDInt}, 557 {"maskr", {{"i", AnyInt}, DefaultingKIND}, KINDInt}, 558 {"max", 559 {{"a1", OperandIntOrReal}, {"a2", OperandIntOrReal}, 560 {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}}, 561 OperandIntOrReal}, 562 {"max", 563 {{"a1", SameChar}, {"a2", SameChar}, 564 {"a3", SameChar, Rank::elemental, Optionality::repeats}}, 565 SameChar}, 566 {"maxexponent", {{"x", AnyReal, Rank::anyOrAssumedRank}}, DefaultInt, 567 Rank::scalar, IntrinsicClass::inquiryFunction}, 568 {"maxloc", 569 {{"array", AnyRelatable, Rank::array}, RequiredDIM, OptionalMASK, 570 SizeDefaultKIND, 571 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 572 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 573 {"maxloc", 574 {{"array", AnyRelatable, Rank::array}, MissingDIM, OptionalMASK, 575 SizeDefaultKIND, 576 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 577 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 578 {"maxval", 579 {{"array", SameRelatable, Rank::array}, RequiredDIM, OptionalMASK}, 580 SameRelatable, Rank::dimReduced, 581 IntrinsicClass::transformationalFunction}, 582 {"maxval", 583 {{"array", SameRelatable, Rank::array}, MissingDIM, OptionalMASK}, 584 SameRelatable, Rank::scalar, IntrinsicClass::transformationalFunction}, 585 {"merge", 586 {{"tsource", SameType}, {"fsource", SameType}, {"mask", AnyLogical}}, 587 SameType}, 588 {"merge_bits", 589 {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}, 590 {"mask", SameInt, Rank::elementalOrBOZ}}, 591 SameInt}, 592 {"merge_bits", 593 {{"i", BOZ}, {"j", SameInt}, {"mask", SameInt, Rank::elementalOrBOZ}}, 594 SameInt}, 595 {"min", 596 {{"a1", OperandIntOrReal}, {"a2", OperandIntOrReal}, 597 {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}}, 598 OperandIntOrReal}, 599 {"min", 600 {{"a1", SameChar}, {"a2", SameChar}, 601 {"a3", SameChar, Rank::elemental, Optionality::repeats}}, 602 SameChar}, 603 {"minexponent", {{"x", AnyReal, Rank::anyOrAssumedRank}}, DefaultInt, 604 Rank::scalar, IntrinsicClass::inquiryFunction}, 605 {"minloc", 606 {{"array", AnyRelatable, Rank::array}, RequiredDIM, OptionalMASK, 607 SizeDefaultKIND, 608 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 609 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 610 {"minloc", 611 {{"array", AnyRelatable, Rank::array}, MissingDIM, OptionalMASK, 612 SizeDefaultKIND, 613 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 614 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 615 {"minval", 616 {{"array", SameRelatable, Rank::array}, RequiredDIM, OptionalMASK}, 617 SameRelatable, Rank::dimReduced, 618 IntrinsicClass::transformationalFunction}, 619 {"minval", 620 {{"array", SameRelatable, Rank::array}, MissingDIM, OptionalMASK}, 621 SameRelatable, Rank::scalar, IntrinsicClass::transformationalFunction}, 622 {"mod", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}}, 623 OperandIntOrReal}, 624 {"modulo", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}}, 625 OperandIntOrReal}, 626 {"nearest", {{"x", SameReal}, {"s", AnyReal}}, SameReal}, 627 {"new_line", {{"x", SameChar, Rank::anyOrAssumedRank}}, SameChar, 628 Rank::scalar, IntrinsicClass::inquiryFunction}, 629 {"nint", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, 630 {"norm2", {{"x", SameReal, Rank::array}, OptionalDIM}, SameReal, 631 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 632 {"not", {{"i", SameInt}}, SameInt}, 633 // NULL() is a special case handled in Probe() below 634 {"num_images", {}, DefaultInt, Rank::scalar, 635 IntrinsicClass::transformationalFunction}, 636 {"num_images", {{"team", TeamType, Rank::scalar}}, DefaultInt, Rank::scalar, 637 IntrinsicClass::transformationalFunction}, 638 {"num_images", {{"team_number", AnyInt, Rank::scalar}}, DefaultInt, 639 Rank::scalar, IntrinsicClass::transformationalFunction}, 640 {"out_of_range", 641 {{"x", AnyIntOrReal}, {"mold", AnyIntOrReal, Rank::scalar}}, 642 DefaultLogical}, 643 {"out_of_range", 644 {{"x", AnyReal}, {"mold", AnyInt, Rank::scalar}, 645 {"round", AnyLogical, Rank::scalar, Optionality::optional}}, 646 DefaultLogical}, 647 {"out_of_range", {{"x", AnyReal}, {"mold", AnyReal}}, DefaultLogical}, 648 {"pack", 649 {{"array", SameType, Rank::array}, 650 {"mask", AnyLogical, Rank::conformable}, 651 {"vector", SameType, Rank::vector, Optionality::optional}}, 652 SameType, Rank::vector, IntrinsicClass::transformationalFunction}, 653 {"parity", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, 654 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 655 {"popcnt", {{"i", AnyInt}}, DefaultInt}, 656 {"poppar", {{"i", AnyInt}}, DefaultInt}, 657 {"product", 658 {{"array", SameNumeric, Rank::array}, RequiredDIM, OptionalMASK}, 659 SameNumeric, Rank::dimReduced, 660 IntrinsicClass::transformationalFunction}, 661 {"product", {{"array", SameNumeric, Rank::array}, MissingDIM, OptionalMASK}, 662 SameNumeric, Rank::scalar, IntrinsicClass::transformationalFunction}, 663 {"precision", {{"x", AnyFloating, Rank::anyOrAssumedRank}}, DefaultInt, 664 Rank::scalar, IntrinsicClass::inquiryFunction}, 665 {"present", {{"a", Addressable, Rank::anyOrAssumedRank}}, DefaultLogical, 666 Rank::scalar, IntrinsicClass::inquiryFunction}, 667 {"radix", {{"x", AnyIntOrReal, Rank::anyOrAssumedRank}}, DefaultInt, 668 Rank::scalar, IntrinsicClass::inquiryFunction}, 669 {"range", {{"x", AnyNumeric, Rank::anyOrAssumedRank}}, DefaultInt, 670 Rank::scalar, IntrinsicClass::inquiryFunction}, 671 {"rank", {{"a", AnyData, Rank::anyOrAssumedRank}}, DefaultInt, Rank::scalar, 672 IntrinsicClass::inquiryFunction}, 673 {"real", {{"a", SameComplex, Rank::elemental}}, 674 SameReal}, // 16.9.160(4)(ii) 675 {"real", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND}, 676 KINDReal}, 677 {"reduce", 678 {{"array", SameType, Rank::array}, 679 {"operation", SameType, Rank::reduceOperation}, RequiredDIM, 680 OptionalMASK, 681 {"identity", SameType, Rank::scalar, Optionality::optional}, 682 {"ordered", AnyLogical, Rank::scalar, Optionality::optional}}, 683 SameType, Rank::dimReduced, IntrinsicClass::transformationalFunction}, 684 {"reduce", 685 {{"array", SameType, Rank::array}, 686 {"operation", SameType, Rank::reduceOperation}, MissingDIM, 687 OptionalMASK, 688 {"identity", SameType, Rank::scalar, Optionality::optional}, 689 {"ordered", AnyLogical, Rank::scalar, Optionality::optional}}, 690 SameType, Rank::scalar, IntrinsicClass::transformationalFunction}, 691 {"repeat", {{"string", SameChar, Rank::scalar}, {"ncopies", AnyInt}}, 692 SameChar, Rank::scalar, IntrinsicClass::transformationalFunction}, 693 {"reshape", 694 {{"source", SameType, Rank::array}, {"shape", AnyInt, Rank::shape}, 695 {"pad", SameType, Rank::array, Optionality::optional}, 696 {"order", AnyInt, Rank::vector, Optionality::optional}}, 697 SameType, Rank::shaped, IntrinsicClass::transformationalFunction}, 698 {"rrspacing", {{"x", SameReal}}, SameReal}, 699 {"same_type_as", 700 {{"a", ExtensibleDerived, Rank::anyOrAssumedRank}, 701 {"b", ExtensibleDerived, Rank::anyOrAssumedRank}}, 702 DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, 703 {"scale", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, // == IEEE_SCALB() 704 {"scan", 705 {{"string", SameChar}, {"set", SameChar}, 706 {"back", AnyLogical, Rank::elemental, Optionality::optional}, 707 DefaultingKIND}, 708 KINDInt}, 709 {"selected_char_kind", {{"name", DefaultChar, Rank::scalar}}, DefaultInt, 710 Rank::scalar, IntrinsicClass::transformationalFunction}, 711 {"selected_int_kind", {{"r", AnyInt, Rank::scalar}}, DefaultInt, 712 Rank::scalar, IntrinsicClass::transformationalFunction}, 713 {"selected_real_kind", 714 {{"p", AnyInt, Rank::scalar}, 715 {"r", AnyInt, Rank::scalar, Optionality::optional}, 716 {"radix", AnyInt, Rank::scalar, Optionality::optional}}, 717 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 718 {"selected_real_kind", 719 {{"p", AnyInt, Rank::scalar, Optionality::optional}, 720 {"r", AnyInt, Rank::scalar}, 721 {"radix", AnyInt, Rank::scalar, Optionality::optional}}, 722 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 723 {"selected_real_kind", 724 {{"p", AnyInt, Rank::scalar, Optionality::optional}, 725 {"r", AnyInt, Rank::scalar, Optionality::optional}, 726 {"radix", AnyInt, Rank::scalar}}, 727 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 728 {"set_exponent", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, 729 {"shape", {{"source", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, 730 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, 731 {"shifta", {{"i", SameInt}, {"shift", AnyInt}}, SameInt}, 732 {"shiftl", {{"i", SameInt}, {"shift", AnyInt}}, SameInt}, 733 {"shiftr", {{"i", SameInt}, {"shift", AnyInt}}, SameInt}, 734 {"sign", {{"a", SameInt}, {"b", AnyInt}}, SameInt}, 735 {"sign", {{"a", SameReal}, {"b", AnyReal}}, SameReal}, 736 {"sin", {{"x", SameFloating}}, SameFloating}, 737 {"sind", {{"x", SameFloating}}, SameFloating}, 738 {"sinh", {{"x", SameFloating}}, SameFloating}, 739 {"size", 740 {{"array", AnyData, Rank::anyOrAssumedRank}, 741 OptionalDIM, // unless array is assumed-size 742 SizeDefaultKIND}, 743 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 744 {"sizeof", {{"a", AnyData, Rank::anyOrAssumedRank}}, SubscriptInt, 745 Rank::scalar, IntrinsicClass::inquiryFunction}, 746 {"spacing", {{"x", SameReal}}, SameReal}, 747 {"spread", 748 {{"source", SameType, Rank::known}, RequiredDIM, 749 {"ncopies", AnyInt, Rank::scalar}}, 750 SameType, Rank::rankPlus1, IntrinsicClass::transformationalFunction}, 751 {"sqrt", {{"x", SameFloating}}, SameFloating}, 752 {"storage_size", {{"a", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, 753 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 754 {"sum", {{"array", SameNumeric, Rank::array}, RequiredDIM, OptionalMASK}, 755 SameNumeric, Rank::dimReduced, 756 IntrinsicClass::transformationalFunction}, 757 {"sum", {{"array", SameNumeric, Rank::array}, MissingDIM, OptionalMASK}, 758 SameNumeric, Rank::scalar, IntrinsicClass::transformationalFunction}, 759 {"tan", {{"x", SameFloating}}, SameFloating}, 760 {"tand", {{"x", SameFloating}}, SameFloating}, 761 {"tanh", {{"x", SameFloating}}, SameFloating}, 762 {"team_number", {OptionalTEAM}, DefaultInt, Rank::scalar, 763 IntrinsicClass::transformationalFunction}, 764 {"this_image", 765 {{"coarray", AnyData, Rank::coarray}, RequiredDIM, OptionalTEAM}, 766 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 767 {"this_image", {{"coarray", AnyData, Rank::coarray}, OptionalTEAM}, 768 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 769 {"this_image", {OptionalTEAM}, DefaultInt, Rank::scalar, 770 IntrinsicClass::transformationalFunction}, 771 {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar, 772 IntrinsicClass::inquiryFunction}, 773 {"trailz", {{"i", AnyInt}}, DefaultInt}, 774 {"transfer", 775 {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::scalar}}, 776 SameType, Rank::scalar, IntrinsicClass::transformationalFunction}, 777 {"transfer", 778 {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::array}}, 779 SameType, Rank::vector, IntrinsicClass::transformationalFunction}, 780 {"transfer", 781 {{"source", AnyData, Rank::anyOrAssumedRank}, 782 {"mold", SameType, Rank::anyOrAssumedRank}, 783 {"size", AnyInt, Rank::scalar}}, 784 SameType, Rank::vector, IntrinsicClass::transformationalFunction}, 785 {"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix, 786 IntrinsicClass::transformationalFunction}, 787 {"trim", {{"string", SameChar, Rank::scalar}}, SameChar, Rank::scalar, 788 IntrinsicClass::transformationalFunction}, 789 {"ubound", 790 {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM, 791 SizeDefaultKIND}, 792 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 793 {"ubound", {{"array", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, 794 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, 795 {"unpack", 796 {{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array}, 797 {"field", SameType, Rank::conformable}}, 798 SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, 799 {"verify", 800 {{"string", SameChar}, {"set", SameChar}, 801 {"back", AnyLogical, Rank::elemental, Optionality::optional}, 802 DefaultingKIND}, 803 KINDInt}, 804 {"__builtin_ieee_is_nan", {{"a", AnyFloating}}, DefaultLogical}, 805 {"__builtin_ieee_is_negative", {{"a", AnyFloating}}, DefaultLogical}, 806 {"__builtin_ieee_is_normal", {{"a", AnyFloating}}, DefaultLogical}, 807 {"__builtin_ieee_next_after", {{"x", SameReal}, {"y", AnyReal}}, SameReal}, 808 {"__builtin_ieee_next_down", {{"x", SameReal}}, SameReal}, 809 {"__builtin_ieee_next_up", {{"x", SameReal}}, SameReal}, 810 {"__builtin_ieee_support_datatype", 811 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 812 DefaultLogical}, 813 {"__builtin_ieee_support_denormal", 814 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 815 DefaultLogical}, 816 {"__builtin_ieee_support_divide", 817 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 818 DefaultLogical}, 819 {"__builtin_ieee_support_inf", 820 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 821 DefaultLogical}, 822 {"__builtin_ieee_support_io", 823 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 824 DefaultLogical}, 825 {"__builtin_ieee_support_nan", 826 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 827 DefaultLogical}, 828 {"__builtin_ieee_support_sqrt", 829 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 830 DefaultLogical}, 831 {"__builtin_ieee_support_standard", 832 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 833 DefaultLogical}, 834 {"__builtin_ieee_support_subnormal", 835 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 836 DefaultLogical}, 837 {"__builtin_ieee_support_underflow_control", 838 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 839 DefaultLogical}, 840 }; 841 842 // TODO: Coarray intrinsic functions 843 // LCOBOUND, UCOBOUND, IMAGE_INDEX, 844 // STOPPED_IMAGES, COSHAPE 845 // TODO: Non-standard intrinsic functions 846 // LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, 847 // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, 848 // QCMPLX, QEXT, QFLOAT, QREAL, DNUM, 849 // INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, 850 // MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR 851 // IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, 852 // EOF, FP_CLASS, INT_PTR_KIND, MALLOC 853 // probably more (these are PGI + Intel, possibly incomplete) 854 // TODO: Optionally warn on use of non-standard intrinsics: 855 // LOC, probably others 856 // TODO: Optionally warn on operand promotion extension 857 858 // Aliases for a few generic intrinsic functions for legacy 859 // compatibility and builtins. 860 static const std::pair<const char *, const char *> genericAlias[]{ 861 {"and", "iand"}, 862 {"or", "ior"}, 863 {"xor", "ieor"}, 864 {"__builtin_ieee_selected_real_kind", "selected_real_kind"}, 865 }; 866 867 // The following table contains the intrinsic functions listed in 868 // Tables 16.2 and 16.3 in Fortran 2018. The "unrestricted" functions 869 // in Table 16.2 can be used as actual arguments, PROCEDURE() interfaces, 870 // and procedure pointer targets. 871 // Note that the restricted conversion functions dcmplx, dreal, float, idint, 872 // ifix, and sngl are extended to accept any argument kind because this is a 873 // common Fortran compilers behavior, and as far as we can tell, is safe and 874 // useful. 875 struct SpecificIntrinsicInterface : public IntrinsicInterface { 876 const char *generic{nullptr}; 877 bool isRestrictedSpecific{false}; 878 // Exact actual/dummy type matching is required by default for specific 879 // intrinsics. If useGenericAndForceResultType is set, then the probing will 880 // also attempt to use the related generic intrinsic and to convert the result 881 // to the specific intrinsic result type if needed. This also prevents 882 // using the generic name so that folding can insert the conversion on the 883 // result and not the arguments. 884 // 885 // This is not enabled on all specific intrinsics because an alternative 886 // is to convert the actual arguments to the required dummy types and this is 887 // not numerically equivalent. 888 // e.g. IABS(INT(i, 4)) not equiv to INT(ABS(i), 4). 889 // This is allowed for restricted min/max specific functions because 890 // the expected behavior is clear from their definitions. A warning is though 891 // always emitted because other compilers' behavior is not ubiquitous here and 892 // the results in case of conversion overflow might not be equivalent. 893 // e.g for MIN0: INT(MIN(2147483647_8, 2*2147483647_8), 4) = 2147483647_4 894 // but: MIN(INT(2147483647_8, 4), INT(2*2147483647_8, 4)) = -2_4 895 // xlf and ifort return the first, and pgfortran the later. f18 will return 896 // the first because this matches more closely the MIN0 definition in 897 // Fortran 2018 table 16.3 (although it is still an extension to allow 898 // non default integer argument in MIN0). 899 bool useGenericAndForceResultType{false}; 900 }; 901 902 static const SpecificIntrinsicInterface specificIntrinsicFunction[]{ 903 {{"abs", {{"a", DefaultReal}}, DefaultReal}}, 904 {{"acos", {{"x", DefaultReal}}, DefaultReal}}, 905 {{"aimag", {{"z", DefaultComplex}}, DefaultReal}}, 906 {{"aint", {{"a", DefaultReal}}, DefaultReal}}, 907 {{"alog", {{"x", DefaultReal}}, DefaultReal}, "log"}, 908 {{"alog10", {{"x", DefaultReal}}, DefaultReal}, "log10"}, 909 {{"amax0", 910 {{"a1", DefaultInt}, {"a2", DefaultInt}, 911 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 912 DefaultReal}, 913 "max", true, true}, 914 {{"amax1", 915 {{"a1", DefaultReal}, {"a2", DefaultReal}, 916 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 917 DefaultReal}, 918 "max", true, true}, 919 {{"amin0", 920 {{"a1", DefaultInt}, {"a2", DefaultInt}, 921 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 922 DefaultReal}, 923 "min", true, true}, 924 {{"amin1", 925 {{"a1", DefaultReal}, {"a2", DefaultReal}, 926 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 927 DefaultReal}, 928 "min", true, true}, 929 {{"amod", {{"a", DefaultReal}, {"p", DefaultReal}}, DefaultReal}, "mod"}, 930 {{"anint", {{"a", DefaultReal}}, DefaultReal}}, 931 {{"asin", {{"x", DefaultReal}}, DefaultReal}}, 932 {{"atan", {{"x", DefaultReal}}, DefaultReal}}, 933 {{"atan2", {{"y", DefaultReal}, {"x", DefaultReal}}, DefaultReal}}, 934 {{"babs", {{"a", TypePattern{IntType, KindCode::exactKind, 1}}}, 935 TypePattern{IntType, KindCode::exactKind, 1}}, 936 "abs"}, 937 {{"cabs", {{"a", DefaultComplex}}, DefaultReal}, "abs"}, 938 {{"ccos", {{"x", DefaultComplex}}, DefaultComplex}, "cos"}, 939 {{"cdabs", {{"a", DoublePrecisionComplex}}, DoublePrecision}, "abs"}, 940 {{"cdcos", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "cos"}, 941 {{"cdexp", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "exp"}, 942 {{"cdlog", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "log"}, 943 {{"cdsin", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "sin"}, 944 {{"cdsqrt", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, 945 "sqrt"}, 946 {{"cexp", {{"x", DefaultComplex}}, DefaultComplex}, "exp"}, 947 {{"clog", {{"x", DefaultComplex}}, DefaultComplex}, "log"}, 948 {{"conjg", {{"z", DefaultComplex}}, DefaultComplex}}, 949 {{"cos", {{"x", DefaultReal}}, DefaultReal}}, 950 {{"cosh", {{"x", DefaultReal}}, DefaultReal}}, 951 {{"csin", {{"x", DefaultComplex}}, DefaultComplex}, "sin"}, 952 {{"csqrt", {{"x", DefaultComplex}}, DefaultComplex}, "sqrt"}, 953 {{"ctan", {{"x", DefaultComplex}}, DefaultComplex}, "tan"}, 954 {{"dabs", {{"a", DoublePrecision}}, DoublePrecision}, "abs"}, 955 {{"dacos", {{"x", DoublePrecision}}, DoublePrecision}, "acos"}, 956 {{"dasin", {{"x", DoublePrecision}}, DoublePrecision}, "asin"}, 957 {{"datan", {{"x", DoublePrecision}}, DoublePrecision}, "atan"}, 958 {{"datan2", {{"y", DoublePrecision}, {"x", DoublePrecision}}, 959 DoublePrecision}, 960 "atan2"}, 961 {{"dcmplx", {{"x", AnyComplex}}, DoublePrecisionComplex}, "cmplx", true}, 962 {{"dcmplx", 963 {{"x", AnyIntOrReal, Rank::elementalOrBOZ}, 964 {"y", AnyIntOrReal, Rank::elementalOrBOZ, Optionality::optional}}, 965 DoublePrecisionComplex}, 966 "cmplx", true}, 967 {{"dconjg", {{"z", DoublePrecisionComplex}}, DoublePrecisionComplex}, 968 "conjg"}, 969 {{"dcos", {{"x", DoublePrecision}}, DoublePrecision}, "cos"}, 970 {{"dcosh", {{"x", DoublePrecision}}, DoublePrecision}, "cosh"}, 971 {{"ddim", {{"x", DoublePrecision}, {"y", DoublePrecision}}, 972 DoublePrecision}, 973 "dim"}, 974 {{"dexp", {{"x", DoublePrecision}}, DoublePrecision}, "exp"}, 975 {{"dfloat", {{"a", AnyInt}}, DoublePrecision}, "real", true}, 976 {{"dim", {{"x", DefaultReal}, {"y", DefaultReal}}, DefaultReal}}, 977 {{"dimag", {{"z", DoublePrecisionComplex}}, DoublePrecision}, "aimag"}, 978 {{"dint", {{"a", DoublePrecision}}, DoublePrecision}, "aint"}, 979 {{"dlog", {{"x", DoublePrecision}}, DoublePrecision}, "log"}, 980 {{"dlog10", {{"x", DoublePrecision}}, DoublePrecision}, "log10"}, 981 {{"dmax1", 982 {{"a1", DoublePrecision}, {"a2", DoublePrecision}, 983 {"a3", DoublePrecision, Rank::elemental, Optionality::repeats}}, 984 DoublePrecision}, 985 "max", true, true}, 986 {{"dmin1", 987 {{"a1", DoublePrecision}, {"a2", DoublePrecision}, 988 {"a3", DoublePrecision, Rank::elemental, Optionality::repeats}}, 989 DoublePrecision}, 990 "min", true, true}, 991 {{"dmod", {{"a", DoublePrecision}, {"p", DoublePrecision}}, 992 DoublePrecision}, 993 "mod"}, 994 {{"dnint", {{"a", DoublePrecision}}, DoublePrecision}, "anint"}, 995 {{"dprod", {{"x", DefaultReal}, {"y", DefaultReal}}, DoublePrecision}}, 996 {{"dreal", {{"a", AnyComplex}}, DoublePrecision}, "real", true}, 997 {{"dsign", {{"a", DoublePrecision}, {"b", DoublePrecision}}, 998 DoublePrecision}, 999 "sign"}, 1000 {{"dsin", {{"x", DoublePrecision}}, DoublePrecision}, "sin"}, 1001 {{"dsinh", {{"x", DoublePrecision}}, DoublePrecision}, "sinh"}, 1002 {{"dsqrt", {{"x", DoublePrecision}}, DoublePrecision}, "sqrt"}, 1003 {{"dtan", {{"x", DoublePrecision}}, DoublePrecision}, "tan"}, 1004 {{"dtanh", {{"x", DoublePrecision}}, DoublePrecision}, "tanh"}, 1005 {{"exp", {{"x", DefaultReal}}, DefaultReal}}, 1006 {{"float", {{"a", AnyInt}}, DefaultReal}, "real", true}, 1007 {{"iabs", {{"a", DefaultInt}}, DefaultInt}, "abs"}, 1008 {{"idim", {{"x", DefaultInt}, {"y", DefaultInt}}, DefaultInt}, "dim"}, 1009 {{"idint", {{"a", AnyReal}}, DefaultInt}, "int", true}, 1010 {{"idnint", {{"a", DoublePrecision}}, DefaultInt}, "nint"}, 1011 {{"ifix", {{"a", AnyReal}}, DefaultInt}, "int", true}, 1012 {{"iiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 2}}}, 1013 TypePattern{IntType, KindCode::exactKind, 2}}, 1014 "abs"}, 1015 {{"index", {{"string", DefaultChar}, {"substring", DefaultChar}}, 1016 DefaultInt}}, 1017 {{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"}, 1018 {{"jiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 4}}}, 1019 TypePattern{IntType, KindCode::exactKind, 4}}, 1020 "abs"}, 1021 {{"kiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 8}}}, 1022 TypePattern{IntType, KindCode::exactKind, 8}}, 1023 "abs"}, 1024 {{"len", {{"string", DefaultChar, Rank::anyOrAssumedRank}}, DefaultInt, 1025 Rank::scalar, IntrinsicClass::inquiryFunction}}, 1026 {{"lge", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1027 DefaultLogical}, 1028 "lge", true}, 1029 {{"lgt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1030 DefaultLogical}, 1031 "lgt", true}, 1032 {{"lle", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1033 DefaultLogical}, 1034 "lle", true}, 1035 {{"llt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1036 DefaultLogical}, 1037 "llt", true}, 1038 {{"log", {{"x", DefaultReal}}, DefaultReal}}, 1039 {{"log10", {{"x", DefaultReal}}, DefaultReal}}, 1040 {{"max0", 1041 {{"a1", DefaultInt}, {"a2", DefaultInt}, 1042 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 1043 DefaultInt}, 1044 "max", true, true}, 1045 {{"max1", 1046 {{"a1", DefaultReal}, {"a2", DefaultReal}, 1047 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 1048 DefaultInt}, 1049 "max", true, true}, 1050 {{"min0", 1051 {{"a1", DefaultInt}, {"a2", DefaultInt}, 1052 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 1053 DefaultInt}, 1054 "min", true, true}, 1055 {{"min1", 1056 {{"a1", DefaultReal}, {"a2", DefaultReal}, 1057 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 1058 DefaultInt}, 1059 "min", true, true}, 1060 {{"mod", {{"a", DefaultInt}, {"p", DefaultInt}}, DefaultInt}}, 1061 {{"nint", {{"a", DefaultReal}}, DefaultInt}}, 1062 {{"sign", {{"a", DefaultReal}, {"b", DefaultReal}}, DefaultReal}}, 1063 {{"sin", {{"x", DefaultReal}}, DefaultReal}}, 1064 {{"sinh", {{"x", DefaultReal}}, DefaultReal}}, 1065 {{"sngl", {{"a", AnyReal}}, DefaultReal}, "real", true}, 1066 {{"sqrt", {{"x", DefaultReal}}, DefaultReal}}, 1067 {{"tan", {{"x", DefaultReal}}, DefaultReal}}, 1068 {{"tanh", {{"x", DefaultReal}}, DefaultReal}}, 1069 {{"zabs", {{"a", TypePattern{ComplexType, KindCode::exactKind, 8}}}, 1070 TypePattern{RealType, KindCode::exactKind, 8}}, 1071 "abs"}, 1072 }; 1073 1074 static const IntrinsicInterface intrinsicSubroutine[]{ 1075 {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1076 {"cpu_time", 1077 {{"time", AnyReal, Rank::scalar, Optionality::required, 1078 common::Intent::Out}}, 1079 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1080 {"date_and_time", 1081 {{"date", DefaultChar, Rank::scalar, Optionality::optional, 1082 common::Intent::Out}, 1083 {"time", DefaultChar, Rank::scalar, Optionality::optional, 1084 common::Intent::Out}, 1085 {"zone", DefaultChar, Rank::scalar, Optionality::optional, 1086 common::Intent::Out}, 1087 {"values", AnyInt, Rank::vector, Optionality::optional, 1088 common::Intent::Out}}, 1089 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1090 {"execute_command_line", 1091 {{"command", DefaultChar, Rank::scalar}, 1092 {"wait", AnyLogical, Rank::scalar, Optionality::optional}, 1093 {"exitstat", AnyInt, Rank::scalar, Optionality::optional, 1094 common::Intent::InOut}, 1095 {"cmdstat", AnyInt, Rank::scalar, Optionality::optional, 1096 common::Intent::Out}, 1097 {"cmdmsg", DefaultChar, Rank::scalar, Optionality::optional, 1098 common::Intent::InOut}}, 1099 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1100 {"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {}, 1101 Rank::elemental, IntrinsicClass::impureSubroutine}, 1102 {"get_command", 1103 {{"command", DefaultChar, Rank::scalar, Optionality::optional, 1104 common::Intent::Out}, 1105 {"length", AnyInt, Rank::scalar, Optionality::optional, 1106 common::Intent::Out}, 1107 {"status", AnyInt, Rank::scalar, Optionality::optional, 1108 common::Intent::Out}, 1109 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1110 common::Intent::InOut}}, 1111 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1112 {"get_command_argument", 1113 {{"number", AnyInt, Rank::scalar}, 1114 {"value", DefaultChar, Rank::scalar, Optionality::optional, 1115 common::Intent::Out}, 1116 {"length", AnyInt, Rank::scalar, Optionality::optional, 1117 common::Intent::Out}, 1118 {"status", AnyInt, Rank::scalar, Optionality::optional, 1119 common::Intent::Out}, 1120 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1121 common::Intent::InOut}}, 1122 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1123 {"get_environment_variable", 1124 {{"name", DefaultChar, Rank::scalar}, 1125 {"value", DefaultChar, Rank::scalar, Optionality::optional, 1126 common::Intent::Out}, 1127 {"length", AnyInt, Rank::scalar, Optionality::optional, 1128 common::Intent::Out}, 1129 {"status", AnyInt, Rank::scalar, Optionality::optional, 1130 common::Intent::Out}, 1131 {"trim_name", AnyLogical, Rank::scalar, Optionality::optional}, 1132 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1133 common::Intent::InOut}}, 1134 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1135 {"move_alloc", 1136 {{"from", SameType, Rank::known, Optionality::required, 1137 common::Intent::InOut}, 1138 {"to", SameType, Rank::known, Optionality::required, 1139 common::Intent::Out}, 1140 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1141 common::Intent::Out}, 1142 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1143 common::Intent::InOut}}, 1144 {}, Rank::elemental, IntrinsicClass::pureSubroutine}, 1145 {"mvbits", 1146 {{"from", SameInt}, {"frompos", AnyInt}, {"len", AnyInt}, 1147 {"to", SameInt, Rank::elemental, Optionality::required, 1148 common::Intent::Out}, 1149 {"topos", AnyInt}}, 1150 {}, Rank::elemental, IntrinsicClass::elementalSubroutine}, // elemental 1151 {"random_init", 1152 {{"repeatable", AnyLogical, Rank::scalar}, 1153 {"image_distinct", AnyLogical, Rank::scalar}}, 1154 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1155 {"random_number", 1156 {{"harvest", AnyReal, Rank::known, Optionality::required, 1157 common::Intent::Out}}, 1158 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1159 {"random_seed", 1160 {{"size", DefaultInt, Rank::scalar, Optionality::optional, 1161 common::Intent::Out}, 1162 {"put", DefaultInt, Rank::vector, Optionality::optional}, 1163 {"get", DefaultInt, Rank::vector, Optionality::optional, 1164 common::Intent::Out}}, 1165 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1166 {"system_clock", 1167 {{"count", AnyInt, Rank::scalar, Optionality::optional, 1168 common::Intent::Out}, 1169 {"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional, 1170 common::Intent::Out}, 1171 {"count_max", AnyInt, Rank::scalar, Optionality::optional, 1172 common::Intent::Out}}, 1173 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1174 }; 1175 1176 // TODO: Intrinsic subroutine EVENT_QUERY 1177 // TODO: Atomic intrinsic subroutines: ATOMIC_ADD &al. 1178 // TODO: Collective intrinsic subroutines: CO_BROADCAST &al. 1179 1180 // Finds a built-in derived type and returns it as a DynamicType. 1181 static DynamicType GetBuiltinDerivedType( 1182 const semantics::Scope *builtinsScope, const char *which) { 1183 if (!builtinsScope) { 1184 common::die("INTERNAL: The __fortran_builtins module was not found, and " 1185 "the type '%s' was required", 1186 which); 1187 } 1188 auto iter{ 1189 builtinsScope->find(semantics::SourceName{which, std::strlen(which)})}; 1190 if (iter == builtinsScope->cend()) { 1191 common::die( 1192 "INTERNAL: The __fortran_builtins module does not define the type '%s'", 1193 which); 1194 } 1195 const semantics::Symbol &symbol{*iter->second}; 1196 const semantics::Scope &scope{DEREF(symbol.scope())}; 1197 const semantics::DerivedTypeSpec &derived{DEREF(scope.derivedTypeSpec())}; 1198 return DynamicType{derived}; 1199 } 1200 1201 // Ensure that the keywords of arguments to MAX/MIN and their variants 1202 // are of the form A123 with no duplicates or leading zeroes. 1203 static bool CheckMaxMinArgument(std::optional<parser::CharBlock> keyword, 1204 std::set<parser::CharBlock> &set, const char *intrinsicName, 1205 parser::ContextualMessages &messages) { 1206 if (keyword) { 1207 std::size_t j{1}; 1208 for (; j < keyword->size(); ++j) { 1209 char ch{(*keyword)[j]}; 1210 if (ch < (j == 1 ? '1' : '0') || ch > '9') { 1211 break; 1212 } 1213 } 1214 if (keyword->size() < 2 || (*keyword)[0] != 'a' || j < keyword->size()) { 1215 messages.Say(*keyword, 1216 "Argument keyword '%s=' is not known in call to '%s'"_err_en_US, 1217 *keyword, intrinsicName); 1218 return false; 1219 } 1220 auto [_, wasInserted]{set.insert(*keyword)}; 1221 if (!wasInserted) { 1222 messages.Say(*keyword, 1223 "Argument keyword '%s=' was repeated in call to '%s'"_err_en_US, 1224 *keyword, intrinsicName); 1225 return false; 1226 } 1227 } 1228 return true; 1229 } 1230 1231 // Intrinsic interface matching against the arguments of a particular 1232 // procedure reference. 1233 std::optional<SpecificCall> IntrinsicInterface::Match( 1234 const CallCharacteristics &call, 1235 const common::IntrinsicTypeDefaultKinds &defaults, 1236 ActualArguments &arguments, FoldingContext &context, 1237 const semantics::Scope *builtinsScope) const { 1238 auto &messages{context.messages()}; 1239 // Attempt to construct a 1-1 correspondence between the dummy arguments in 1240 // a particular intrinsic procedure's generic interface and the actual 1241 // arguments in a procedure reference. 1242 std::size_t dummyArgPatterns{0}; 1243 for (; dummyArgPatterns < maxArguments && dummy[dummyArgPatterns].keyword; 1244 ++dummyArgPatterns) { 1245 } 1246 // MAX and MIN (and others that map to them) allow their last argument to 1247 // be repeated indefinitely. The actualForDummy vector is sized 1248 // and null-initialized to the non-repeated dummy argument count 1249 // for other instrinsics. 1250 bool isMaxMin{dummyArgPatterns > 0 && 1251 dummy[dummyArgPatterns - 1].optionality == Optionality::repeats}; 1252 std::vector<ActualArgument *> actualForDummy( 1253 isMaxMin ? 0 : dummyArgPatterns, nullptr); 1254 int missingActualArguments{0}; 1255 std::set<parser::CharBlock> maxMinKeywords; 1256 for (std::optional<ActualArgument> &arg : arguments) { 1257 if (!arg) { 1258 ++missingActualArguments; 1259 } else if (arg->isAlternateReturn()) { 1260 messages.Say(arg->sourceLocation(), 1261 "alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US, 1262 name); 1263 return std::nullopt; 1264 } else if (isMaxMin) { 1265 if (CheckMaxMinArgument(arg->keyword(), maxMinKeywords, name, messages)) { 1266 actualForDummy.push_back(&*arg); 1267 } else { 1268 return std::nullopt; 1269 } 1270 } else { 1271 bool found{false}; 1272 int slot{missingActualArguments}; 1273 for (std::size_t j{0}; j < dummyArgPatterns && !found; ++j) { 1274 if (dummy[j].optionality == Optionality::missing) { 1275 continue; 1276 } 1277 if (arg->keyword()) { 1278 found = *arg->keyword() == dummy[j].keyword; 1279 if (found) { 1280 if (const auto *previous{actualForDummy[j]}) { 1281 if (previous->keyword()) { 1282 messages.Say(*arg->keyword(), 1283 "repeated keyword argument to intrinsic '%s'"_err_en_US, 1284 name); 1285 } else { 1286 messages.Say(*arg->keyword(), 1287 "keyword argument to intrinsic '%s' was supplied " 1288 "positionally by an earlier actual argument"_err_en_US, 1289 name); 1290 } 1291 return std::nullopt; 1292 } 1293 } 1294 } else { 1295 found = !actualForDummy[j] && slot-- == 0; 1296 } 1297 if (found) { 1298 actualForDummy[j] = &*arg; 1299 } 1300 } 1301 if (!found) { 1302 if (arg->keyword()) { 1303 messages.Say(*arg->keyword(), 1304 "unknown keyword argument to intrinsic '%s'"_err_en_US, name); 1305 } else { 1306 messages.Say( 1307 "too many actual arguments for intrinsic '%s'"_err_en_US, name); 1308 } 1309 return std::nullopt; 1310 } 1311 } 1312 } 1313 1314 std::size_t dummies{actualForDummy.size()}; 1315 1316 // Check types and kinds of the actual arguments against the intrinsic's 1317 // interface. Ensure that two or more arguments that have to have the same 1318 // (or compatible) type and kind do so. Check for missing non-optional 1319 // arguments now, too. 1320 const ActualArgument *sameArg{nullptr}; 1321 const ActualArgument *operandArg{nullptr}; 1322 const IntrinsicDummyArgument *kindDummyArg{nullptr}; 1323 const ActualArgument *kindArg{nullptr}; 1324 bool hasDimArg{false}; 1325 for (std::size_t j{0}; j < dummies; ++j) { 1326 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; 1327 if (d.typePattern.kindCode == KindCode::kindArg) { 1328 CHECK(!kindDummyArg); 1329 kindDummyArg = &d; 1330 } 1331 const ActualArgument *arg{actualForDummy[j]}; 1332 if (!arg) { 1333 if (d.optionality == Optionality::required) { 1334 messages.Say("missing mandatory '%s=' argument"_err_en_US, d.keyword); 1335 return std::nullopt; // missing non-OPTIONAL argument 1336 } else { 1337 continue; 1338 } 1339 } else if (d.optionality == Optionality::missing) { 1340 messages.Say(arg->sourceLocation(), "unexpected '%s=' argument"_err_en_US, 1341 d.keyword); 1342 return std::nullopt; 1343 } 1344 if (arg->GetAssumedTypeDummy()) { 1345 // TYPE(*) assumed-type dummy argument forwarded to intrinsic 1346 if (d.typePattern.categorySet == AnyType && 1347 d.rank == Rank::anyOrAssumedRank && 1348 (d.typePattern.kindCode == KindCode::any || 1349 d.typePattern.kindCode == KindCode::addressable)) { 1350 continue; 1351 } else { 1352 messages.Say(arg->sourceLocation(), 1353 "Assumed type TYPE(*) dummy argument not allowed for '%s=' intrinsic argument"_err_en_US, 1354 d.keyword); 1355 return std::nullopt; 1356 } 1357 } 1358 std::optional<DynamicType> type{arg->GetType()}; 1359 if (!type) { 1360 CHECK(arg->Rank() == 0); 1361 const Expr<SomeType> &expr{DEREF(arg->UnwrapExpr())}; 1362 if (IsBOZLiteral(expr)) { 1363 if (d.typePattern.kindCode == KindCode::typeless || 1364 d.rank == Rank::elementalOrBOZ) { 1365 continue; 1366 } else { 1367 const IntrinsicDummyArgument *nextParam{ 1368 j + 1 < dummies ? &dummy[j + 1] : nullptr}; 1369 if (nextParam && nextParam->rank == Rank::elementalOrBOZ) { 1370 messages.Say(arg->sourceLocation(), 1371 "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109 1372 d.keyword, nextParam->keyword); 1373 } else { 1374 messages.Say(arg->sourceLocation(), 1375 "Typeless (BOZ) not allowed for '%s=' argument"_err_en_US, 1376 d.keyword); 1377 } 1378 } 1379 } else { 1380 // NULL(), procedure, or procedure pointer 1381 CHECK(IsProcedurePointerTarget(expr)); 1382 if (d.typePattern.kindCode == KindCode::addressable || 1383 d.rank == Rank::reduceOperation) { 1384 continue; 1385 } else if (d.typePattern.kindCode == KindCode::nullPointerType) { 1386 continue; 1387 } else { 1388 messages.Say(arg->sourceLocation(), 1389 "Actual argument for '%s=' may not be a procedure"_err_en_US, 1390 d.keyword); 1391 } 1392 } 1393 return std::nullopt; 1394 } else if (!d.typePattern.categorySet.test(type->category())) { 1395 messages.Say(arg->sourceLocation(), 1396 "Actual argument for '%s=' has bad type '%s'"_err_en_US, d.keyword, 1397 type->AsFortran()); 1398 return std::nullopt; // argument has invalid type category 1399 } 1400 bool argOk{false}; 1401 switch (d.typePattern.kindCode) { 1402 case KindCode::none: 1403 case KindCode::typeless: 1404 argOk = false; 1405 break; 1406 case KindCode::teamType: 1407 argOk = !type->IsUnlimitedPolymorphic() && 1408 type->category() == TypeCategory::Derived && 1409 semantics::IsTeamType(&type->GetDerivedTypeSpec()); 1410 break; 1411 case KindCode::defaultIntegerKind: 1412 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Integer); 1413 break; 1414 case KindCode::defaultRealKind: 1415 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Real); 1416 break; 1417 case KindCode::doublePrecision: 1418 argOk = type->kind() == defaults.doublePrecisionKind(); 1419 break; 1420 case KindCode::defaultCharKind: 1421 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Character); 1422 break; 1423 case KindCode::defaultLogicalKind: 1424 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Logical); 1425 break; 1426 case KindCode::any: 1427 argOk = true; 1428 break; 1429 case KindCode::kindArg: 1430 CHECK(type->category() == TypeCategory::Integer); 1431 CHECK(!kindArg); 1432 kindArg = arg; 1433 argOk = true; 1434 break; 1435 case KindCode::dimArg: 1436 CHECK(type->category() == TypeCategory::Integer); 1437 hasDimArg = true; 1438 argOk = true; 1439 break; 1440 case KindCode::same: 1441 if (!sameArg) { 1442 sameArg = arg; 1443 } 1444 argOk = type->IsTkCompatibleWith(sameArg->GetType().value()); 1445 break; 1446 case KindCode::operand: 1447 if (!operandArg) { 1448 operandArg = arg; 1449 } else if (auto prev{operandArg->GetType()}) { 1450 if (type->category() == prev->category()) { 1451 if (type->kind() > prev->kind()) { 1452 operandArg = arg; 1453 } 1454 } else if (prev->category() == TypeCategory::Integer) { 1455 operandArg = arg; 1456 } 1457 } 1458 argOk = true; 1459 break; 1460 case KindCode::effectiveKind: 1461 common::die("INTERNAL: KindCode::effectiveKind appears on argument '%s' " 1462 "for intrinsic '%s'", 1463 d.keyword, name); 1464 break; 1465 case KindCode::addressable: 1466 case KindCode::nullPointerType: 1467 argOk = true; 1468 break; 1469 case KindCode::exactKind: 1470 argOk = type->kind() == d.typePattern.exactKindValue; 1471 break; 1472 default: 1473 CRASH_NO_CASE; 1474 } 1475 if (!argOk) { 1476 messages.Say(arg->sourceLocation(), 1477 "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US, 1478 d.keyword, type->AsFortran()); 1479 return std::nullopt; 1480 } 1481 } 1482 1483 // Check the ranks of the arguments against the intrinsic's interface. 1484 const ActualArgument *arrayArg{nullptr}; 1485 const char *arrayArgName{nullptr}; 1486 const ActualArgument *knownArg{nullptr}; 1487 std::optional<int> shapeArgSize; 1488 int elementalRank{0}; 1489 for (std::size_t j{0}; j < dummies; ++j) { 1490 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; 1491 if (const ActualArgument * arg{actualForDummy[j]}) { 1492 bool isAssumedRank{IsAssumedRank(*arg)}; 1493 if (isAssumedRank && d.rank != Rank::anyOrAssumedRank) { 1494 messages.Say(arg->sourceLocation(), 1495 "Assumed-rank array cannot be forwarded to '%s=' argument"_err_en_US, 1496 d.keyword); 1497 return std::nullopt; 1498 } 1499 int rank{arg->Rank()}; 1500 bool argOk{false}; 1501 switch (d.rank) { 1502 case Rank::elemental: 1503 case Rank::elementalOrBOZ: 1504 if (elementalRank == 0) { 1505 elementalRank = rank; 1506 } 1507 argOk = rank == 0 || rank == elementalRank; 1508 break; 1509 case Rank::scalar: 1510 argOk = rank == 0; 1511 break; 1512 case Rank::vector: 1513 argOk = rank == 1; 1514 break; 1515 case Rank::shape: 1516 CHECK(!shapeArgSize); 1517 if (rank != 1) { 1518 messages.Say(arg->sourceLocation(), 1519 "'shape=' argument must be an array of rank 1"_err_en_US); 1520 return std::nullopt; 1521 } else { 1522 if (auto shape{GetShape(context, *arg)}) { 1523 if (auto constShape{AsConstantShape(context, *shape)}) { 1524 shapeArgSize = constShape->At(ConstantSubscripts{1}).ToInt64(); 1525 CHECK(*shapeArgSize >= 0); 1526 argOk = true; 1527 } 1528 } 1529 } 1530 if (!argOk) { 1531 messages.Say(arg->sourceLocation(), 1532 "'shape=' argument must be a vector of known size"_err_en_US); 1533 return std::nullopt; 1534 } 1535 break; 1536 case Rank::matrix: 1537 argOk = rank == 2; 1538 break; 1539 case Rank::array: 1540 argOk = rank > 0; 1541 if (!arrayArg) { 1542 arrayArg = arg; 1543 arrayArgName = d.keyword; 1544 } 1545 break; 1546 case Rank::coarray: 1547 argOk = IsCoarray(*arg); 1548 if (!argOk) { 1549 messages.Say(arg->sourceLocation(), 1550 "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US, 1551 name); 1552 return std::nullopt; 1553 } 1554 break; 1555 case Rank::known: 1556 if (!knownArg) { 1557 knownArg = arg; 1558 } 1559 argOk = rank == knownArg->Rank(); 1560 break; 1561 case Rank::anyOrAssumedRank: 1562 if (!hasDimArg && rank > 0 && !isAssumedRank && 1563 (std::strcmp(name, "shape") == 0 || 1564 std::strcmp(name, "size") == 0 || 1565 std::strcmp(name, "ubound") == 0)) { 1566 // Check for a whole assumed-size array argument. 1567 // These are disallowed for SHAPE, and require DIM= for 1568 // SIZE and UBOUND. 1569 // (A previous error message for UBOUND will take precedence 1570 // over this one, as this error is caught by the second entry 1571 // for UBOUND.) 1572 if (auto named{ExtractNamedEntity(*arg)}) { 1573 if (semantics::IsAssumedSizeArray(named->GetLastSymbol())) { 1574 if (strcmp(name, "shape") == 0) { 1575 messages.Say(arg->sourceLocation(), 1576 "The '%s=' argument to the intrinsic function '%s' may not be assumed-size"_err_en_US, 1577 d.keyword, name); 1578 } else { 1579 messages.Say(arg->sourceLocation(), 1580 "A dim= argument is required for '%s' when the array is assumed-size"_err_en_US, 1581 name); 1582 } 1583 return std::nullopt; 1584 } 1585 } 1586 } 1587 argOk = true; 1588 break; 1589 case Rank::conformable: // arg must be conformable with previous arrayArg 1590 CHECK(arrayArg); 1591 CHECK(arrayArgName); 1592 if (const std::optional<Shape> &arrayArgShape{ 1593 GetShape(context, *arrayArg)}) { 1594 if (std::optional<Shape> argShape{GetShape(context, *arg)}) { 1595 std::string arrayArgMsg{"'"}; 1596 arrayArgMsg = arrayArgMsg + arrayArgName + "='" + " argument"; 1597 std::string argMsg{"'"}; 1598 argMsg = argMsg + d.keyword + "='" + " argument"; 1599 CheckConformance(context.messages(), *arrayArgShape, *argShape, 1600 CheckConformanceFlags::RightScalarExpandable, 1601 arrayArgMsg.c_str(), argMsg.c_str()); 1602 } 1603 } 1604 argOk = true; // Avoid an additional error message 1605 break; 1606 case Rank::dimReduced: 1607 case Rank::dimRemovedOrScalar: 1608 CHECK(arrayArg); 1609 argOk = rank == 0 || rank + 1 == arrayArg->Rank(); 1610 break; 1611 case Rank::reduceOperation: 1612 // The reduction function is validated in ApplySpecificChecks(). 1613 argOk = true; 1614 break; 1615 case Rank::locReduced: 1616 case Rank::rankPlus1: 1617 case Rank::shaped: 1618 common::die("INTERNAL: result-only rank code appears on argument '%s' " 1619 "for intrinsic '%s'", 1620 d.keyword, name); 1621 } 1622 if (!argOk) { 1623 messages.Say(arg->sourceLocation(), 1624 "'%s=' argument has unacceptable rank %d"_err_en_US, d.keyword, 1625 rank); 1626 return std::nullopt; 1627 } 1628 } 1629 } 1630 1631 // Calculate the characteristics of the function result, if any 1632 std::optional<DynamicType> resultType; 1633 if (auto category{result.categorySet.LeastElement()}) { 1634 // The intrinsic is not a subroutine. 1635 if (call.isSubroutineCall) { 1636 return std::nullopt; 1637 } 1638 switch (result.kindCode) { 1639 case KindCode::defaultIntegerKind: 1640 CHECK(result.categorySet == IntType); 1641 CHECK(*category == TypeCategory::Integer); 1642 resultType = DynamicType{TypeCategory::Integer, 1643 defaults.GetDefaultKind(TypeCategory::Integer)}; 1644 break; 1645 case KindCode::defaultRealKind: 1646 CHECK(result.categorySet == CategorySet{*category}); 1647 CHECK(FloatingType.test(*category)); 1648 resultType = 1649 DynamicType{*category, defaults.GetDefaultKind(TypeCategory::Real)}; 1650 break; 1651 case KindCode::doublePrecision: 1652 CHECK(result.categorySet == CategorySet{*category}); 1653 CHECK(FloatingType.test(*category)); 1654 resultType = DynamicType{*category, defaults.doublePrecisionKind()}; 1655 break; 1656 case KindCode::defaultLogicalKind: 1657 CHECK(result.categorySet == LogicalType); 1658 CHECK(*category == TypeCategory::Logical); 1659 resultType = DynamicType{TypeCategory::Logical, 1660 defaults.GetDefaultKind(TypeCategory::Logical)}; 1661 break; 1662 case KindCode::same: 1663 CHECK(sameArg); 1664 if (std::optional<DynamicType> aType{sameArg->GetType()}) { 1665 if (result.categorySet.test(aType->category())) { 1666 resultType = *aType; 1667 } else { 1668 resultType = DynamicType{*category, aType->kind()}; 1669 } 1670 } 1671 break; 1672 case KindCode::operand: 1673 CHECK(operandArg); 1674 resultType = operandArg->GetType(); 1675 CHECK(!resultType || result.categorySet.test(resultType->category())); 1676 break; 1677 case KindCode::effectiveKind: 1678 CHECK(kindDummyArg); 1679 CHECK(result.categorySet == CategorySet{*category}); 1680 if (kindArg) { 1681 if (auto *expr{kindArg->UnwrapExpr()}) { 1682 CHECK(expr->Rank() == 0); 1683 if (auto code{ToInt64(*expr)}) { 1684 if (context.targetCharacteristics().IsTypeEnabled( 1685 *category, *code)) { 1686 if (*category == TypeCategory::Character) { // ACHAR & CHAR 1687 resultType = DynamicType{static_cast<int>(*code), 1}; 1688 } else { 1689 resultType = DynamicType{*category, static_cast<int>(*code)}; 1690 } 1691 break; 1692 } 1693 } 1694 } 1695 messages.Say("'kind=' argument must be a constant scalar integer " 1696 "whose value is a supported kind for the " 1697 "intrinsic result type"_err_en_US); 1698 return std::nullopt; 1699 } else if (kindDummyArg->optionality == Optionality::defaultsToSameKind) { 1700 CHECK(sameArg); 1701 resultType = *sameArg->GetType(); 1702 } else if (kindDummyArg->optionality == Optionality::defaultsToSizeKind) { 1703 CHECK(*category == TypeCategory::Integer); 1704 resultType = 1705 DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()}; 1706 } else { 1707 CHECK(kindDummyArg->optionality == 1708 Optionality::defaultsToDefaultForResult); 1709 int kind{defaults.GetDefaultKind(*category)}; 1710 if (*category == TypeCategory::Character) { // ACHAR & CHAR 1711 resultType = DynamicType{kind, 1}; 1712 } else { 1713 resultType = DynamicType{*category, kind}; 1714 } 1715 } 1716 break; 1717 case KindCode::likeMultiply: 1718 CHECK(dummies >= 2); 1719 CHECK(actualForDummy[0]); 1720 CHECK(actualForDummy[1]); 1721 resultType = actualForDummy[0]->GetType()->ResultTypeForMultiply( 1722 *actualForDummy[1]->GetType()); 1723 break; 1724 case KindCode::subscript: 1725 CHECK(result.categorySet == IntType); 1726 CHECK(*category == TypeCategory::Integer); 1727 resultType = 1728 DynamicType{TypeCategory::Integer, defaults.subscriptIntegerKind()}; 1729 break; 1730 case KindCode::size: 1731 CHECK(result.categorySet == IntType); 1732 CHECK(*category == TypeCategory::Integer); 1733 resultType = 1734 DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()}; 1735 break; 1736 case KindCode::teamType: 1737 CHECK(result.categorySet == DerivedType); 1738 CHECK(*category == TypeCategory::Derived); 1739 resultType = DynamicType{ 1740 GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")}; 1741 break; 1742 case KindCode::exactKind: 1743 resultType = DynamicType{*category, result.exactKindValue}; 1744 break; 1745 case KindCode::defaultCharKind: 1746 case KindCode::typeless: 1747 case KindCode::any: 1748 case KindCode::kindArg: 1749 case KindCode::dimArg: 1750 common::die( 1751 "INTERNAL: bad KindCode appears on intrinsic '%s' result", name); 1752 break; 1753 default: 1754 CRASH_NO_CASE; 1755 } 1756 } else { 1757 if (!call.isSubroutineCall) { 1758 return std::nullopt; 1759 } 1760 CHECK(result.kindCode == KindCode::none); 1761 } 1762 1763 // At this point, the call is acceptable. 1764 // Determine the rank of the function result. 1765 int resultRank{0}; 1766 switch (rank) { 1767 case Rank::elemental: 1768 resultRank = elementalRank; 1769 break; 1770 case Rank::scalar: 1771 resultRank = 0; 1772 break; 1773 case Rank::vector: 1774 resultRank = 1; 1775 break; 1776 case Rank::matrix: 1777 resultRank = 2; 1778 break; 1779 case Rank::conformable: 1780 CHECK(arrayArg); 1781 resultRank = arrayArg->Rank(); 1782 break; 1783 case Rank::dimReduced: 1784 CHECK(arrayArg); 1785 resultRank = hasDimArg ? arrayArg->Rank() - 1 : 0; 1786 break; 1787 case Rank::locReduced: 1788 CHECK(arrayArg); 1789 resultRank = hasDimArg ? arrayArg->Rank() - 1 : 1; 1790 break; 1791 case Rank::rankPlus1: 1792 CHECK(knownArg); 1793 resultRank = knownArg->Rank() + 1; 1794 break; 1795 case Rank::shaped: 1796 CHECK(shapeArgSize); 1797 resultRank = *shapeArgSize; 1798 break; 1799 case Rank::elementalOrBOZ: 1800 case Rank::shape: 1801 case Rank::array: 1802 case Rank::coarray: 1803 case Rank::known: 1804 case Rank::anyOrAssumedRank: 1805 case Rank::reduceOperation: 1806 case Rank::dimRemovedOrScalar: 1807 common::die("INTERNAL: bad Rank code on intrinsic '%s' result", name); 1808 break; 1809 } 1810 CHECK(resultRank >= 0); 1811 1812 // Rearrange the actual arguments into dummy argument order. 1813 ActualArguments rearranged(dummies); 1814 for (std::size_t j{0}; j < dummies; ++j) { 1815 if (ActualArgument * arg{actualForDummy[j]}) { 1816 rearranged[j] = std::move(*arg); 1817 } 1818 } 1819 1820 // Characterize the specific intrinsic procedure. 1821 characteristics::DummyArguments dummyArgs; 1822 std::optional<int> sameDummyArg; 1823 1824 for (std::size_t j{0}; j < dummies; ++j) { 1825 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; 1826 if (const auto &arg{rearranged[j]}) { 1827 if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) { 1828 std::string kw{d.keyword}; 1829 if (arg->keyword()) { 1830 kw = arg->keyword()->ToString(); 1831 } else if (isMaxMin) { 1832 for (std::size_t k{j + 1};; ++k) { 1833 kw = "a"s + std::to_string(k); 1834 auto iter{std::find_if(dummyArgs.begin(), dummyArgs.end(), 1835 [&kw](const characteristics::DummyArgument &prev) { 1836 return prev.name == kw; 1837 })}; 1838 if (iter == dummyArgs.end()) { 1839 break; 1840 } 1841 } 1842 } 1843 auto dc{characteristics::DummyArgument::FromActual( 1844 std::move(kw), *expr, context)}; 1845 if (!dc) { 1846 common::die("INTERNAL: could not characterize intrinsic function " 1847 "actual argument '%s'", 1848 expr->AsFortran().c_str()); 1849 return std::nullopt; 1850 } 1851 dummyArgs.emplace_back(std::move(*dc)); 1852 if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) { 1853 sameDummyArg = j; 1854 } 1855 } else { 1856 CHECK(arg->GetAssumedTypeDummy()); 1857 dummyArgs.emplace_back(std::string{d.keyword}, 1858 characteristics::DummyDataObject{DynamicType::AssumedType()}); 1859 } 1860 } else { 1861 // optional argument is absent 1862 CHECK(d.optionality != Optionality::required); 1863 if (d.typePattern.kindCode == KindCode::same) { 1864 dummyArgs.emplace_back(dummyArgs[sameDummyArg.value()]); 1865 } else { 1866 auto category{d.typePattern.categorySet.LeastElement().value()}; 1867 if (category == TypeCategory::Derived) { 1868 // TODO: any other built-in derived types used as optional intrinsic 1869 // dummies? 1870 CHECK(d.typePattern.kindCode == KindCode::teamType); 1871 characteristics::TypeAndShape typeAndShape{ 1872 GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")}; 1873 dummyArgs.emplace_back(std::string{d.keyword}, 1874 characteristics::DummyDataObject{std::move(typeAndShape)}); 1875 } else { 1876 characteristics::TypeAndShape typeAndShape{ 1877 DynamicType{category, defaults.GetDefaultKind(category)}}; 1878 dummyArgs.emplace_back(std::string{d.keyword}, 1879 characteristics::DummyDataObject{std::move(typeAndShape)}); 1880 } 1881 } 1882 dummyArgs.back().SetOptional(); 1883 } 1884 dummyArgs.back().SetIntent(d.intent); 1885 } 1886 characteristics::Procedure::Attrs attrs; 1887 if (elementalRank > 0) { 1888 attrs.set(characteristics::Procedure::Attr::Elemental); 1889 } 1890 if (call.isSubroutineCall) { 1891 return SpecificCall{ 1892 SpecificIntrinsic{ 1893 name, characteristics::Procedure{std::move(dummyArgs), attrs}}, 1894 std::move(rearranged)}; 1895 } else { 1896 attrs.set(characteristics::Procedure::Attr::Pure); 1897 characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank}; 1898 characteristics::FunctionResult funcResult{std::move(typeAndShape)}; 1899 characteristics::Procedure chars{ 1900 std::move(funcResult), std::move(dummyArgs), attrs}; 1901 return SpecificCall{ 1902 SpecificIntrinsic{name, std::move(chars)}, std::move(rearranged)}; 1903 } 1904 } 1905 1906 class IntrinsicProcTable::Implementation { 1907 public: 1908 explicit Implementation(const common::IntrinsicTypeDefaultKinds &dfts) 1909 : defaults_{dfts} { 1910 for (const IntrinsicInterface &f : genericIntrinsicFunction) { 1911 genericFuncs_.insert(std::make_pair(std::string{f.name}, &f)); 1912 } 1913 for (const std::pair<const char *, const char *> &a : genericAlias) { 1914 aliases_.insert( 1915 std::make_pair(std::string{a.first}, std::string{a.second})); 1916 } 1917 for (const SpecificIntrinsicInterface &f : specificIntrinsicFunction) { 1918 specificFuncs_.insert(std::make_pair(std::string{f.name}, &f)); 1919 } 1920 for (const IntrinsicInterface &f : intrinsicSubroutine) { 1921 subroutines_.insert(std::make_pair(std::string{f.name}, &f)); 1922 } 1923 } 1924 1925 void SupplyBuiltins(const semantics::Scope &builtins) { 1926 builtinsScope_ = &builtins; 1927 } 1928 1929 bool IsIntrinsic(const std::string &) const; 1930 bool IsIntrinsicFunction(const std::string &) const; 1931 bool IsIntrinsicSubroutine(const std::string &) const; 1932 1933 IntrinsicClass GetIntrinsicClass(const std::string &) const; 1934 std::string GetGenericIntrinsicName(const std::string &) const; 1935 1936 std::optional<SpecificCall> Probe( 1937 const CallCharacteristics &, ActualArguments &, FoldingContext &) const; 1938 1939 std::optional<SpecificIntrinsicFunctionInterface> IsSpecificIntrinsicFunction( 1940 const std::string &) const; 1941 1942 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 1943 1944 private: 1945 DynamicType GetSpecificType(const TypePattern &) const; 1946 SpecificCall HandleNull(ActualArguments &, FoldingContext &) const; 1947 std::optional<SpecificCall> HandleC_F_Pointer( 1948 ActualArguments &, FoldingContext &) const; 1949 const std::string &ResolveAlias(const std::string &name) const { 1950 auto iter{aliases_.find(name)}; 1951 return iter == aliases_.end() ? name : iter->second; 1952 } 1953 1954 common::IntrinsicTypeDefaultKinds defaults_; 1955 std::multimap<std::string, const IntrinsicInterface *> genericFuncs_; 1956 std::multimap<std::string, const SpecificIntrinsicInterface *> specificFuncs_; 1957 std::multimap<std::string, const IntrinsicInterface *> subroutines_; 1958 const semantics::Scope *builtinsScope_{nullptr}; 1959 std::map<std::string, std::string> aliases_; 1960 }; 1961 1962 bool IntrinsicProcTable::Implementation::IsIntrinsicFunction( 1963 const std::string &name0) const { 1964 const std::string &name{ResolveAlias(name0)}; 1965 auto specificRange{specificFuncs_.equal_range(name)}; 1966 if (specificRange.first != specificRange.second) { 1967 return true; 1968 } 1969 auto genericRange{genericFuncs_.equal_range(name)}; 1970 if (genericRange.first != genericRange.second) { 1971 return true; 1972 } 1973 // special cases 1974 return name == "null"; 1975 } 1976 bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine( 1977 const std::string &name) const { 1978 auto subrRange{subroutines_.equal_range(name)}; 1979 if (subrRange.first != subrRange.second) { 1980 return true; 1981 } 1982 // special cases 1983 return name == "__builtin_c_f_pointer"; 1984 } 1985 bool IntrinsicProcTable::Implementation::IsIntrinsic( 1986 const std::string &name) const { 1987 return IsIntrinsicFunction(name) || IsIntrinsicSubroutine(name); 1988 } 1989 1990 IntrinsicClass IntrinsicProcTable::Implementation::GetIntrinsicClass( 1991 const std::string &name) const { 1992 auto specificIntrinsic{specificFuncs_.find(name)}; 1993 if (specificIntrinsic != specificFuncs_.end()) { 1994 return specificIntrinsic->second->intrinsicClass; 1995 } 1996 auto genericIntrinsic{genericFuncs_.find(name)}; 1997 if (genericIntrinsic != genericFuncs_.end()) { 1998 return genericIntrinsic->second->intrinsicClass; 1999 } 2000 auto subrIntrinsic{subroutines_.find(name)}; 2001 if (subrIntrinsic != subroutines_.end()) { 2002 return subrIntrinsic->second->intrinsicClass; 2003 } 2004 return IntrinsicClass::noClass; 2005 } 2006 2007 std::string IntrinsicProcTable::Implementation::GetGenericIntrinsicName( 2008 const std::string &name) const { 2009 auto specificIntrinsic{specificFuncs_.find(name)}; 2010 if (specificIntrinsic != specificFuncs_.end()) { 2011 if (const char *genericName{specificIntrinsic->second->generic}) { 2012 return {genericName}; 2013 } 2014 } 2015 return name; 2016 } 2017 2018 bool CheckAndRearrangeArguments(ActualArguments &arguments, 2019 parser::ContextualMessages &messages, const char *const dummyKeywords[], 2020 std::size_t trailingOptionals) { 2021 std::size_t numDummies{0}; 2022 while (dummyKeywords[numDummies]) { 2023 ++numDummies; 2024 } 2025 CHECK(trailingOptionals <= numDummies); 2026 if (arguments.size() > numDummies) { 2027 messages.Say("Too many actual arguments (%zd > %zd)"_err_en_US, 2028 arguments.size(), numDummies); 2029 return false; 2030 } 2031 ActualArguments rearranged(numDummies); 2032 bool anyKeywords{false}; 2033 std::size_t position{0}; 2034 for (std::optional<ActualArgument> &arg : arguments) { 2035 std::size_t dummyIndex{0}; 2036 if (arg && arg->keyword()) { 2037 anyKeywords = true; 2038 for (; dummyIndex < numDummies; ++dummyIndex) { 2039 if (*arg->keyword() == dummyKeywords[dummyIndex]) { 2040 break; 2041 } 2042 } 2043 if (dummyIndex >= numDummies) { 2044 messages.Say(*arg->keyword(), 2045 "Unknown argument keyword '%s='"_err_en_US, *arg->keyword()); 2046 return false; 2047 } 2048 } else if (anyKeywords) { 2049 messages.Say(arg ? arg->sourceLocation() : messages.at(), 2050 "A positional actual argument may not appear after any keyword arguments"_err_en_US); 2051 return false; 2052 } else { 2053 dummyIndex = position++; 2054 } 2055 if (rearranged[dummyIndex]) { 2056 messages.Say(arg ? arg->sourceLocation() : messages.at(), 2057 "Dummy argument '%s=' appears more than once"_err_en_US, 2058 dummyKeywords[dummyIndex]); 2059 return false; 2060 } 2061 rearranged[dummyIndex] = std::move(arg); 2062 arg.reset(); 2063 } 2064 bool anyMissing{false}; 2065 for (std::size_t j{0}; j < numDummies - trailingOptionals; ++j) { 2066 if (!rearranged[j]) { 2067 messages.Say("Dummy argument '%s=' is absent and not OPTIONAL"_err_en_US, 2068 dummyKeywords[j]); 2069 anyMissing = true; 2070 } 2071 } 2072 arguments = std::move(rearranged); 2073 return !anyMissing; 2074 } 2075 2076 // The NULL() intrinsic is a special case. 2077 SpecificCall IntrinsicProcTable::Implementation::HandleNull( 2078 ActualArguments &arguments, FoldingContext &context) const { 2079 static const char *const keywords[]{"mold", nullptr}; 2080 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) && 2081 arguments[0]) { 2082 if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) { 2083 bool goodProcPointer{true}; 2084 if (IsAllocatableOrPointer(*mold)) { 2085 characteristics::DummyArguments args; 2086 std::optional<characteristics::FunctionResult> fResult; 2087 if (IsProcedurePointerTarget(*mold)) { 2088 // MOLD= procedure pointer 2089 const Symbol *last{GetLastSymbol(*mold)}; 2090 CHECK(last); 2091 auto procPointer{IsProcedure(*last) 2092 ? characteristics::Procedure::Characterize(*last, context) 2093 : std::nullopt}; 2094 // procPointer is null if there was an error with the analysis 2095 // associated with the procedure pointer 2096 if (procPointer) { 2097 args.emplace_back("mold"s, 2098 characteristics::DummyProcedure{common::Clone(*procPointer)}); 2099 fResult.emplace(std::move(*procPointer)); 2100 } else { 2101 goodProcPointer = false; 2102 } 2103 } else if (auto type{mold->GetType()}) { 2104 // MOLD= object pointer 2105 characteristics::TypeAndShape typeAndShape{ 2106 *type, GetShape(context, *mold)}; 2107 args.emplace_back( 2108 "mold"s, characteristics::DummyDataObject{typeAndShape}); 2109 fResult.emplace(std::move(typeAndShape)); 2110 } else { 2111 context.messages().Say(arguments[0]->sourceLocation(), 2112 "MOLD= argument to NULL() lacks type"_err_en_US); 2113 } 2114 if (goodProcPointer) { 2115 fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer); 2116 characteristics::Procedure::Attrs attrs; 2117 attrs.set(characteristics::Procedure::Attr::NullPointer); 2118 characteristics::Procedure chars{ 2119 std::move(*fResult), std::move(args), attrs}; 2120 return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)}, 2121 std::move(arguments)}; 2122 } 2123 } 2124 } 2125 context.messages().Say(arguments[0]->sourceLocation(), 2126 "MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US); 2127 } 2128 characteristics::Procedure::Attrs attrs; 2129 attrs.set(characteristics::Procedure::Attr::NullPointer); 2130 attrs.set(characteristics::Procedure::Attr::Pure); 2131 arguments.clear(); 2132 return SpecificCall{ 2133 SpecificIntrinsic{"null"s, 2134 characteristics::Procedure{characteristics::DummyArguments{}, attrs}}, 2135 std::move(arguments)}; 2136 } 2137 2138 // Subroutine C_F_POINTER(CPTR=,FPTR=[,SHAPE=]) from 2139 // intrinsic module ISO_C_BINDING (18.2.3.3) 2140 std::optional<SpecificCall> 2141 IntrinsicProcTable::Implementation::HandleC_F_Pointer( 2142 ActualArguments &arguments, FoldingContext &context) const { 2143 characteristics::Procedure::Attrs attrs; 2144 attrs.set(characteristics::Procedure::Attr::Subroutine); 2145 static const char *const keywords[]{"cptr", "fptr", "shape", nullptr}; 2146 characteristics::DummyArguments dummies; 2147 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) { 2148 CHECK(arguments.size() == 3); 2149 if (const auto *expr{arguments[0].value().UnwrapExpr()}) { 2150 if (expr->Rank() > 0) { 2151 context.messages().Say(arguments[0]->sourceLocation(), 2152 "CPTR= argument to C_F_POINTER() must be scalar"_err_en_US); 2153 } 2154 if (auto type{expr->GetType()}) { 2155 if (type->category() != TypeCategory::Derived || 2156 type->IsPolymorphic() || 2157 type->GetDerivedTypeSpec().typeSymbol().name() != 2158 "__builtin_c_ptr") { 2159 context.messages().Say(arguments[0]->sourceLocation(), 2160 "CPTR= argument to C_F_POINTER() must be a C_PTR"_err_en_US); 2161 } 2162 characteristics::DummyDataObject cptr{ 2163 characteristics::TypeAndShape{*type}}; 2164 cptr.intent = common::Intent::In; 2165 dummies.emplace_back("cptr"s, std::move(cptr)); 2166 } 2167 } 2168 if (const auto *expr{arguments[1].value().UnwrapExpr()}) { 2169 int fptrRank{expr->Rank()}; 2170 if (auto type{expr->GetType()}) { 2171 if (type->HasDeferredTypeParameter()) { 2172 context.messages().Say(arguments[1]->sourceLocation(), 2173 "FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US); 2174 } 2175 if (ExtractCoarrayRef(*expr)) { 2176 context.messages().Say(arguments[1]->sourceLocation(), 2177 "FPTR= argument to C_F_POINTER() may not be a coindexed object"_err_en_US); 2178 } 2179 characteristics::DummyDataObject fptr{ 2180 characteristics::TypeAndShape{*type, fptrRank}}; 2181 fptr.intent = common::Intent::Out; 2182 fptr.attrs.set(characteristics::DummyDataObject::Attr::Pointer); 2183 dummies.emplace_back("fptr"s, std::move(fptr)); 2184 } else { 2185 context.messages().Say(arguments[1]->sourceLocation(), 2186 "FPTR= argument to C_F_POINTER() must have a type"_err_en_US); 2187 } 2188 if (arguments[2] && fptrRank == 0) { 2189 context.messages().Say(arguments[2]->sourceLocation(), 2190 "SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US); 2191 } else if (!arguments[2] && fptrRank > 0) { 2192 context.messages().Say( 2193 "SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array"_err_en_US); 2194 } 2195 } 2196 } 2197 if (dummies.size() == 2) { 2198 DynamicType shapeType{TypeCategory::Integer, defaults_.sizeIntegerKind()}; 2199 if (arguments[2]) { 2200 if (auto type{arguments[2]->GetType()}) { 2201 if (type->category() == TypeCategory::Integer) { 2202 shapeType = *type; 2203 } 2204 } 2205 } 2206 characteristics::DummyDataObject shape{ 2207 characteristics::TypeAndShape{shapeType, 1}}; 2208 shape.intent = common::Intent::In; 2209 shape.attrs.set(characteristics::DummyDataObject::Attr::Optional); 2210 dummies.emplace_back("shape"s, std::move(shape)); 2211 return SpecificCall{ 2212 SpecificIntrinsic{"__builtin_c_f_pointer"s, 2213 characteristics::Procedure{std::move(dummies), attrs}}, 2214 std::move(arguments)}; 2215 } else { 2216 return std::nullopt; 2217 } 2218 } 2219 2220 static bool CheckAssociated(SpecificCall &call, FoldingContext &context) { 2221 bool ok{true}; 2222 if (const auto &pointerArg{call.arguments[0]}) { 2223 if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) { 2224 if (const Symbol * pointerSymbol{GetLastSymbol(*pointerExpr)}) { 2225 if (!pointerSymbol->attrs().test(semantics::Attr::POINTER)) { 2226 AttachDeclaration(context.messages().Say(pointerArg->sourceLocation(), 2227 "POINTER= argument of ASSOCIATED() must be a " 2228 "POINTER"_err_en_US), 2229 *pointerSymbol); 2230 } else { 2231 if (const auto &targetArg{call.arguments[1]}) { 2232 if (const auto *targetExpr{targetArg->UnwrapExpr()}) { 2233 std::optional<characteristics::Procedure> pointerProc, targetProc; 2234 const Symbol *targetSymbol{GetLastSymbol(*targetExpr)}; 2235 bool isCall{false}; 2236 std::string targetName; 2237 if (const auto *targetProcRef{// target is a function call 2238 std::get_if<ProcedureRef>(&targetExpr->u)}) { 2239 if (auto targetRefedChars{ 2240 characteristics::Procedure::Characterize( 2241 *targetProcRef, context)}) { 2242 targetProc = *targetRefedChars; 2243 targetName = targetProcRef->proc().GetName() + "()"; 2244 isCall = true; 2245 } 2246 } else if (targetSymbol) { 2247 // proc that's not a call 2248 if (IsProcedure(*targetSymbol)) { 2249 targetProc = characteristics::Procedure::Characterize( 2250 *targetSymbol, context); 2251 } 2252 targetName = targetSymbol->name().ToString(); 2253 } 2254 if (IsProcedure(*pointerSymbol)) { 2255 pointerProc = characteristics::Procedure::Characterize( 2256 *pointerSymbol, context); 2257 } 2258 if (pointerProc) { 2259 if (targetProc) { 2260 // procedure pointer and procedure target 2261 std::string whyNot; 2262 if (std::optional<parser::MessageFixedText> msg{ 2263 CheckProcCompatibility( 2264 isCall, pointerProc, &*targetProc, whyNot)}) { 2265 AttachDeclaration( 2266 context.messages().Say(std::move(*msg), 2267 "pointer '" + pointerSymbol->name().ToString() + 2268 "'", 2269 targetName, whyNot), 2270 *pointerSymbol); 2271 } 2272 } else { 2273 // procedure pointer and object target 2274 if (!IsNullPointer(*targetExpr)) { 2275 AttachDeclaration( 2276 context.messages().Say( 2277 "POINTER= argument '%s' is a procedure " 2278 "pointer but the TARGET= argument '%s' is not a " 2279 "procedure or procedure pointer"_err_en_US, 2280 pointerSymbol->name(), targetName), 2281 *pointerSymbol); 2282 } 2283 } 2284 } else if (targetProc) { 2285 // object pointer and procedure target 2286 AttachDeclaration( 2287 context.messages().Say( 2288 "POINTER= argument '%s' is an object pointer " 2289 "but the TARGET= argument '%s' is a " 2290 "procedure designator"_err_en_US, 2291 pointerSymbol->name(), targetName), 2292 *pointerSymbol); 2293 } else if (targetSymbol) { 2294 // object pointer and target 2295 SymbolVector symbols{GetSymbolVector(*targetExpr)}; 2296 CHECK(!symbols.empty()); 2297 if (!GetLastTarget(symbols)) { 2298 parser::Message *msg{context.messages().Say( 2299 targetArg->sourceLocation(), 2300 "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US, 2301 targetExpr->AsFortran())}; 2302 for (SymbolRef ref : symbols) { 2303 msg = AttachDeclaration(msg, *ref); 2304 } 2305 } 2306 if (const auto pointerType{pointerArg->GetType()}) { 2307 if (const auto targetType{targetArg->GetType()}) { 2308 ok = pointerType->IsTkCompatibleWith(*targetType); 2309 } 2310 } 2311 } 2312 } 2313 } 2314 } 2315 } 2316 } 2317 } else { 2318 // No arguments to ASSOCIATED() 2319 ok = false; 2320 } 2321 if (!ok) { 2322 context.messages().Say( 2323 "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US); 2324 } 2325 return ok; 2326 } 2327 2328 static bool CheckForNonPositiveValues(FoldingContext &context, 2329 const ActualArgument &arg, const std::string &procName, 2330 const std::string &argName) { 2331 bool ok{true}; 2332 if (arg.Rank() > 0) { 2333 if (const Expr<SomeType> *expr{arg.UnwrapExpr()}) { 2334 if (const auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) { 2335 std::visit( 2336 [&](const auto &kindExpr) { 2337 using IntType = typename std::decay_t<decltype(kindExpr)>::Result; 2338 if (const auto *constArray{ 2339 UnwrapConstantValue<IntType>(kindExpr)}) { 2340 for (std::size_t j{0}; j < constArray->size(); ++j) { 2341 auto arrayExpr{constArray->values().at(j)}; 2342 if (arrayExpr.IsNegative() || arrayExpr.IsZero()) { 2343 ok = false; 2344 context.messages().Say(arg.sourceLocation(), 2345 "'%s=' argument for intrinsic '%s' must contain all positive values"_err_en_US, 2346 argName, procName); 2347 } 2348 } 2349 } 2350 }, 2351 intExpr->u); 2352 } 2353 } 2354 } else { 2355 if (auto val{ToInt64(arg.UnwrapExpr())}) { 2356 if (*val <= 0) { 2357 ok = false; 2358 context.messages().Say(arg.sourceLocation(), 2359 "'%s=' argument for intrinsic '%s' must be a positive value, but is %jd"_err_en_US, 2360 argName, procName, static_cast<std::intmax_t>(*val)); 2361 } 2362 } 2363 } 2364 return ok; 2365 } 2366 2367 // Applies any semantic checks peculiar to an intrinsic. 2368 static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { 2369 bool ok{true}; 2370 const std::string &name{call.specificIntrinsic.name}; 2371 if (name == "allocated") { 2372 const auto &arg{call.arguments[0]}; 2373 if (arg) { 2374 if (const auto *expr{arg->UnwrapExpr()}) { 2375 ok = evaluate::IsAllocatableDesignator(*expr); 2376 } 2377 } 2378 if (!ok) { 2379 context.messages().Say( 2380 arg ? arg->sourceLocation() : context.messages().at(), 2381 "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US); 2382 } 2383 } else if (name == "associated") { 2384 return CheckAssociated(call, context); 2385 } else if (name == "image_status") { 2386 if (const auto &arg{call.arguments[0]}) { 2387 ok = CheckForNonPositiveValues(context, *arg, name, "image"); 2388 } 2389 } else if (name == "ishftc") { 2390 if (const auto &sizeArg{call.arguments[2]}) { 2391 ok = CheckForNonPositiveValues(context, *sizeArg, name, "size"); 2392 if (ok) { 2393 if (auto sizeVal{ToInt64(sizeArg->UnwrapExpr())}) { 2394 if (const auto &shiftArg{call.arguments[1]}) { 2395 if (auto shiftVal{ToInt64(shiftArg->UnwrapExpr())}) { 2396 if (std::abs(*shiftVal) > *sizeVal) { 2397 ok = false; 2398 context.messages().Say(shiftArg->sourceLocation(), 2399 "The absolute value of the 'shift=' argument for intrinsic '%s' must be less than or equal to the 'size=' argument"_err_en_US, 2400 name); 2401 } 2402 } 2403 } 2404 } 2405 } 2406 } 2407 } else if (name == "loc") { 2408 const auto &arg{call.arguments[0]}; 2409 ok = 2410 arg && (arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr())); 2411 if (!ok) { 2412 context.messages().Say( 2413 arg ? arg->sourceLocation() : context.messages().at(), 2414 "Argument of LOC() must be an object or procedure"_err_en_US); 2415 } 2416 } else if (name == "present") { 2417 const auto &arg{call.arguments[0]}; 2418 if (arg) { 2419 if (const auto *expr{arg->UnwrapExpr()}) { 2420 if (const Symbol * symbol{UnwrapWholeSymbolDataRef(*expr)}) { 2421 ok = symbol->attrs().test(semantics::Attr::OPTIONAL); 2422 } 2423 } 2424 } 2425 if (!ok) { 2426 context.messages().Say( 2427 arg ? arg->sourceLocation() : context.messages().at(), 2428 "Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US); 2429 } 2430 } else if (name == "reduce") { // 16.9.161 2431 std::optional<DynamicType> arrayType; 2432 if (const auto &array{call.arguments[0]}) { 2433 arrayType = array->GetType(); 2434 } 2435 std::optional<characteristics::Procedure> procChars; 2436 parser::CharBlock at{context.messages().at()}; 2437 if (const auto &operation{call.arguments[1]}) { 2438 if (const auto *expr{operation->UnwrapExpr()}) { 2439 if (const auto *designator{ 2440 std::get_if<ProcedureDesignator>(&expr->u)}) { 2441 procChars = 2442 characteristics::Procedure::Characterize(*designator, context); 2443 } else if (const auto *ref{std::get_if<ProcedureRef>(&expr->u)}) { 2444 procChars = characteristics::Procedure::Characterize(*ref, context); 2445 } 2446 } 2447 if (auto operationAt{operation->sourceLocation()}) { 2448 at = *operationAt; 2449 } 2450 } 2451 if (!arrayType || !procChars) { 2452 ok = false; // error recovery 2453 } else { 2454 const auto *result{procChars->functionResult->GetTypeAndShape()}; 2455 if (!procChars->IsPure() || procChars->dummyArguments.size() != 2 || 2456 !procChars->functionResult) { 2457 ok = false; 2458 context.messages().Say(at, 2459 "OPERATION= argument of REDUCE() must be a pure function of two data arguments"_err_en_US); 2460 } else if (!result || result->Rank() != 0) { 2461 ok = false; 2462 context.messages().Say(at, 2463 "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US); 2464 } else if (result->type().IsPolymorphic() || 2465 !arrayType->IsTkCompatibleWith(result->type())) { 2466 ok = false; 2467 context.messages().Say(at, 2468 "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US); 2469 } else { 2470 const characteristics::DummyDataObject *data[2]{}; 2471 for (int j{0}; j < 2; ++j) { 2472 const auto &dummy{procChars->dummyArguments.at(j)}; 2473 data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u); 2474 ok = ok && data[j]; 2475 } 2476 if (!ok) { 2477 context.messages().Say(at, 2478 "OPERATION= argument of REDUCE() may not have dummy procedure arguments"_err_en_US); 2479 } else { 2480 for (int j{0}; j < 2; ++j) { 2481 ok = ok && 2482 !data[j]->attrs.test( 2483 characteristics::DummyDataObject::Attr::Optional) && 2484 !data[j]->attrs.test( 2485 characteristics::DummyDataObject::Attr::Allocatable) && 2486 !data[j]->attrs.test( 2487 characteristics::DummyDataObject::Attr::Pointer) && 2488 data[j]->type.Rank() == 0 && 2489 !data[j]->type.type().IsPolymorphic() && 2490 data[j]->type.type().IsTkCompatibleWith(*arrayType); 2491 } 2492 if (!ok) { 2493 context.messages().Say(at, 2494 "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional"_err_en_US); 2495 } else if (data[0]->attrs.test(characteristics::DummyDataObject:: 2496 Attr::Asynchronous) != 2497 data[1]->attrs.test( 2498 characteristics::DummyDataObject::Attr::Asynchronous) || 2499 data[0]->attrs.test( 2500 characteristics::DummyDataObject::Attr::Volatile) != 2501 data[1]->attrs.test( 2502 characteristics::DummyDataObject::Attr::Volatile) || 2503 data[0]->attrs.test( 2504 characteristics::DummyDataObject::Attr::Target) != 2505 data[1]->attrs.test( 2506 characteristics::DummyDataObject::Attr::Target)) { 2507 ok = false; 2508 context.messages().Say(at, 2509 "If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute"_err_en_US); 2510 } 2511 } 2512 } 2513 } 2514 } 2515 return ok; 2516 } 2517 2518 static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface, 2519 const common::IntrinsicTypeDefaultKinds &defaults) { 2520 TypeCategory category{TypeCategory::Integer}; 2521 switch (interface.result.kindCode) { 2522 case KindCode::defaultIntegerKind: 2523 break; 2524 case KindCode::doublePrecision: 2525 case KindCode::defaultRealKind: 2526 category = TypeCategory::Real; 2527 break; 2528 default: 2529 CRASH_NO_CASE; 2530 } 2531 int kind{interface.result.kindCode == KindCode::doublePrecision 2532 ? defaults.doublePrecisionKind() 2533 : defaults.GetDefaultKind(category)}; 2534 return DynamicType{category, kind}; 2535 } 2536 2537 // Probe the configured intrinsic procedure pattern tables in search of a 2538 // match for a given procedure reference. 2539 std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe( 2540 const CallCharacteristics &call, ActualArguments &arguments, 2541 FoldingContext &context) const { 2542 2543 // All special cases handled here before the table probes below must 2544 // also be recognized as special names in IsIntrinsicSubroutine(). 2545 if (call.isSubroutineCall) { 2546 if (call.name == "__builtin_c_f_pointer") { 2547 return HandleC_F_Pointer(arguments, context); 2548 } else if (call.name == "random_seed") { 2549 if (arguments.size() != 0 && arguments.size() != 1) { 2550 context.messages().Say( 2551 "RANDOM_SEED must have either 1 or no arguments"_err_en_US); 2552 } 2553 } 2554 } else if (call.name == "null") { 2555 return HandleNull(arguments, context); 2556 } 2557 2558 if (call.isSubroutineCall) { 2559 auto subrRange{subroutines_.equal_range(call.name)}; 2560 for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) { 2561 if (auto specificCall{iter->second->Match( 2562 call, defaults_, arguments, context, builtinsScope_)}) { 2563 return specificCall; 2564 } 2565 } 2566 if (IsIntrinsicFunction(call.name)) { 2567 context.messages().Say( 2568 "Cannot use intrinsic function '%s' as a subroutine"_err_en_US, 2569 call.name); 2570 } 2571 return std::nullopt; 2572 } 2573 2574 // Helper to avoid emitting errors before it is sure there is no match 2575 parser::Messages localBuffer; 2576 parser::Messages *finalBuffer{context.messages().messages()}; 2577 parser::ContextualMessages localMessages{ 2578 context.messages().at(), finalBuffer ? &localBuffer : nullptr}; 2579 FoldingContext localContext{context, localMessages}; 2580 auto matchOrBufferMessages{ 2581 [&](const IntrinsicInterface &intrinsic, 2582 parser::Messages &buffer) -> std::optional<SpecificCall> { 2583 if (auto specificCall{intrinsic.Match( 2584 call, defaults_, arguments, localContext, builtinsScope_)}) { 2585 if (finalBuffer) { 2586 finalBuffer->Annex(std::move(localBuffer)); 2587 } 2588 return specificCall; 2589 } else if (buffer.empty()) { 2590 buffer.Annex(std::move(localBuffer)); 2591 } else { 2592 localBuffer.clear(); 2593 } 2594 return std::nullopt; 2595 }}; 2596 2597 // Probe the generic intrinsic function table first; allow for 2598 // the use of a legacy alias. 2599 parser::Messages genericBuffer; 2600 const std::string &name{ResolveAlias(call.name)}; 2601 auto genericRange{genericFuncs_.equal_range(name)}; 2602 for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) { 2603 if (auto specificCall{ 2604 matchOrBufferMessages(*iter->second, genericBuffer)}) { 2605 ApplySpecificChecks(*specificCall, context); 2606 return specificCall; 2607 } 2608 } 2609 2610 // Probe the specific intrinsic function table next. 2611 parser::Messages specificBuffer; 2612 auto specificRange{specificFuncs_.equal_range(call.name)}; 2613 for (auto specIter{specificRange.first}; specIter != specificRange.second; 2614 ++specIter) { 2615 // We only need to check the cases with distinct generic names. 2616 if (const char *genericName{specIter->second->generic}) { 2617 if (auto specificCall{ 2618 matchOrBufferMessages(*specIter->second, specificBuffer)}) { 2619 if (!specIter->second->useGenericAndForceResultType) { 2620 specificCall->specificIntrinsic.name = genericName; 2621 } 2622 specificCall->specificIntrinsic.isRestrictedSpecific = 2623 specIter->second->isRestrictedSpecific; 2624 // TODO test feature AdditionalIntrinsics, warn on nonstandard 2625 // specifics with DoublePrecisionComplex arguments. 2626 return specificCall; 2627 } 2628 } 2629 } 2630 2631 // If there was no exact match with a specific, try to match the related 2632 // generic and convert the result to the specific required type. 2633 for (auto specIter{specificRange.first}; specIter != specificRange.second; 2634 ++specIter) { 2635 // We only need to check the cases with distinct generic names. 2636 if (const char *genericName{specIter->second->generic}) { 2637 if (specIter->second->useGenericAndForceResultType) { 2638 auto genericRange{genericFuncs_.equal_range(genericName)}; 2639 for (auto genIter{genericRange.first}; genIter != genericRange.second; 2640 ++genIter) { 2641 if (auto specificCall{ 2642 matchOrBufferMessages(*genIter->second, specificBuffer)}) { 2643 // Force the call result type to the specific intrinsic result type 2644 DynamicType newType{GetReturnType(*specIter->second, defaults_)}; 2645 context.messages().Say( 2646 "argument types do not match specific intrinsic '%s' " 2647 "requirements; using '%s' generic instead and converting the " 2648 "result to %s if needed"_port_en_US, 2649 call.name, genericName, newType.AsFortran()); 2650 specificCall->specificIntrinsic.name = call.name; 2651 specificCall->specificIntrinsic.characteristics.value() 2652 .functionResult.value() 2653 .SetType(newType); 2654 return specificCall; 2655 } 2656 } 2657 } 2658 } 2659 } 2660 2661 if (specificBuffer.empty() && genericBuffer.empty() && 2662 IsIntrinsicSubroutine(call.name)) { 2663 context.messages().Say( 2664 "Cannot use intrinsic subroutine '%s' as a function"_err_en_US, 2665 call.name); 2666 } 2667 2668 // No match; report the right errors, if any 2669 if (finalBuffer) { 2670 if (specificBuffer.empty()) { 2671 finalBuffer->Annex(std::move(genericBuffer)); 2672 } else { 2673 finalBuffer->Annex(std::move(specificBuffer)); 2674 } 2675 } 2676 return std::nullopt; 2677 } 2678 2679 std::optional<SpecificIntrinsicFunctionInterface> 2680 IntrinsicProcTable::Implementation::IsSpecificIntrinsicFunction( 2681 const std::string &name) const { 2682 auto specificRange{specificFuncs_.equal_range(name)}; 2683 for (auto iter{specificRange.first}; iter != specificRange.second; ++iter) { 2684 const SpecificIntrinsicInterface &specific{*iter->second}; 2685 std::string genericName{name}; 2686 if (specific.generic) { 2687 genericName = std::string(specific.generic); 2688 } 2689 characteristics::FunctionResult fResult{GetSpecificType(specific.result)}; 2690 characteristics::DummyArguments args; 2691 int dummies{specific.CountArguments()}; 2692 for (int j{0}; j < dummies; ++j) { 2693 characteristics::DummyDataObject dummy{ 2694 GetSpecificType(specific.dummy[j].typePattern)}; 2695 dummy.intent = specific.dummy[j].intent; 2696 args.emplace_back( 2697 std::string{specific.dummy[j].keyword}, std::move(dummy)); 2698 } 2699 characteristics::Procedure::Attrs attrs; 2700 attrs.set(characteristics::Procedure::Attr::Pure) 2701 .set(characteristics::Procedure::Attr::Elemental); 2702 characteristics::Procedure chars{ 2703 std::move(fResult), std::move(args), attrs}; 2704 return SpecificIntrinsicFunctionInterface{ 2705 std::move(chars), genericName, specific.isRestrictedSpecific}; 2706 } 2707 return std::nullopt; 2708 } 2709 2710 DynamicType IntrinsicProcTable::Implementation::GetSpecificType( 2711 const TypePattern &pattern) const { 2712 const CategorySet &set{pattern.categorySet}; 2713 CHECK(set.count() == 1); 2714 TypeCategory category{set.LeastElement().value()}; 2715 if (pattern.kindCode == KindCode::doublePrecision) { 2716 return DynamicType{category, defaults_.doublePrecisionKind()}; 2717 } else { 2718 return DynamicType{category, defaults_.GetDefaultKind(category)}; 2719 } 2720 } 2721 2722 IntrinsicProcTable::~IntrinsicProcTable() = default; 2723 2724 IntrinsicProcTable IntrinsicProcTable::Configure( 2725 const common::IntrinsicTypeDefaultKinds &defaults) { 2726 IntrinsicProcTable result; 2727 result.impl_ = std::make_unique<IntrinsicProcTable::Implementation>(defaults); 2728 return result; 2729 } 2730 2731 void IntrinsicProcTable::SupplyBuiltins( 2732 const semantics::Scope &builtins) const { 2733 DEREF(impl_.get()).SupplyBuiltins(builtins); 2734 } 2735 2736 bool IntrinsicProcTable::IsIntrinsic(const std::string &name) const { 2737 return DEREF(impl_.get()).IsIntrinsic(name); 2738 } 2739 bool IntrinsicProcTable::IsIntrinsicFunction(const std::string &name) const { 2740 return DEREF(impl_.get()).IsIntrinsicFunction(name); 2741 } 2742 bool IntrinsicProcTable::IsIntrinsicSubroutine(const std::string &name) const { 2743 return DEREF(impl_.get()).IsIntrinsicSubroutine(name); 2744 } 2745 2746 IntrinsicClass IntrinsicProcTable::GetIntrinsicClass( 2747 const std::string &name) const { 2748 return DEREF(impl_.get()).GetIntrinsicClass(name); 2749 } 2750 2751 std::string IntrinsicProcTable::GetGenericIntrinsicName( 2752 const std::string &name) const { 2753 return DEREF(impl_.get()).GetGenericIntrinsicName(name); 2754 } 2755 2756 std::optional<SpecificCall> IntrinsicProcTable::Probe( 2757 const CallCharacteristics &call, ActualArguments &arguments, 2758 FoldingContext &context) const { 2759 return DEREF(impl_.get()).Probe(call, arguments, context); 2760 } 2761 2762 std::optional<SpecificIntrinsicFunctionInterface> 2763 IntrinsicProcTable::IsSpecificIntrinsicFunction(const std::string &name) const { 2764 return DEREF(impl_.get()).IsSpecificIntrinsicFunction(name); 2765 } 2766 2767 llvm::raw_ostream &TypePattern::Dump(llvm::raw_ostream &o) const { 2768 if (categorySet == AnyType) { 2769 o << "any type"; 2770 } else { 2771 const char *sep = ""; 2772 auto set{categorySet}; 2773 while (auto least{set.LeastElement()}) { 2774 o << sep << EnumToString(*least); 2775 sep = " or "; 2776 set.reset(*least); 2777 } 2778 } 2779 o << '(' << EnumToString(kindCode) << ')'; 2780 return o; 2781 } 2782 2783 llvm::raw_ostream &IntrinsicDummyArgument::Dump(llvm::raw_ostream &o) const { 2784 if (keyword) { 2785 o << keyword << '='; 2786 } 2787 return typePattern.Dump(o) 2788 << ' ' << EnumToString(rank) << ' ' << EnumToString(optionality) 2789 << EnumToString(intent); 2790 } 2791 2792 llvm::raw_ostream &IntrinsicInterface::Dump(llvm::raw_ostream &o) const { 2793 o << name; 2794 char sep{'('}; 2795 for (const auto &d : dummy) { 2796 if (d.typePattern.kindCode == KindCode::none) { 2797 break; 2798 } 2799 d.Dump(o << sep); 2800 sep = ','; 2801 } 2802 if (sep == '(') { 2803 o << "()"; 2804 } 2805 return result.Dump(o << " -> ") << ' ' << EnumToString(rank); 2806 } 2807 2808 llvm::raw_ostream &IntrinsicProcTable::Implementation::Dump( 2809 llvm::raw_ostream &o) const { 2810 o << "generic intrinsic functions:\n"; 2811 for (const auto &iter : genericFuncs_) { 2812 iter.second->Dump(o << iter.first << ": ") << '\n'; 2813 } 2814 o << "specific intrinsic functions:\n"; 2815 for (const auto &iter : specificFuncs_) { 2816 iter.second->Dump(o << iter.first << ": "); 2817 if (const char *g{iter.second->generic}) { 2818 o << " -> " << g; 2819 } 2820 o << '\n'; 2821 } 2822 o << "subroutines:\n"; 2823 for (const auto &iter : subroutines_) { 2824 iter.second->Dump(o << iter.first << ": ") << '\n'; 2825 } 2826 return o; 2827 } 2828 2829 llvm::raw_ostream &IntrinsicProcTable::Dump(llvm::raw_ostream &o) const { 2830 return DEREF(impl_.get()).Dump(o); 2831 } 2832 2833 // In general C846 prohibits allocatable coarrays to be passed to INTENT(OUT) 2834 // dummy arguments. This rule does not apply to intrinsics in general. 2835 // Some intrinsic explicitly allow coarray allocatable in their description. 2836 // It is assumed that unless explicitly allowed for an intrinsic, 2837 // this is forbidden. 2838 // Since there are very few intrinsic identified that allow this, they are 2839 // listed here instead of adding a field in the table. 2840 bool AcceptsIntentOutAllocatableCoarray(const std::string &intrinsic) { 2841 return intrinsic == "move_alloc"; 2842 } 2843 } // namespace Fortran::evaluate 2844