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, 60 // AnyType + Rank::arrayOrAssumedRank, or AnyType + Kind::addressable. 61 using CategorySet = common::EnumSet<TypeCategory, 8>; 62 static constexpr CategorySet IntType{TypeCategory::Integer}; 63 static constexpr CategorySet UnsignedType{TypeCategory::Unsigned}; 64 static constexpr CategorySet RealType{TypeCategory::Real}; 65 static constexpr CategorySet ComplexType{TypeCategory::Complex}; 66 static constexpr CategorySet CharType{TypeCategory::Character}; 67 static constexpr CategorySet LogicalType{TypeCategory::Logical}; 68 static constexpr CategorySet IntOrUnsignedType{IntType | UnsignedType}; 69 static constexpr CategorySet IntOrRealType{IntType | RealType}; 70 static constexpr CategorySet IntUnsignedOrRealType{ 71 IntType | UnsignedType | RealType}; 72 static constexpr CategorySet IntOrRealOrCharType{IntType | RealType | CharType}; 73 static constexpr CategorySet IntOrLogicalType{IntType | LogicalType}; 74 static constexpr CategorySet FloatingType{RealType | ComplexType}; 75 static constexpr CategorySet NumericType{ 76 IntType | UnsignedType | RealType | ComplexType}; 77 static constexpr CategorySet RelatableType{ 78 IntType | UnsignedType | RealType | CharType}; 79 static constexpr CategorySet DerivedType{TypeCategory::Derived}; 80 static constexpr CategorySet IntrinsicType{ 81 IntType | UnsignedType | RealType | ComplexType | CharType | LogicalType}; 82 static constexpr CategorySet AnyType{IntrinsicType | DerivedType}; 83 84 ENUM_CLASS(KindCode, none, defaultIntegerKind, 85 defaultRealKind, // is also the default COMPLEX kind 86 doublePrecision, defaultCharKind, defaultLogicalKind, 87 greaterOrEqualToKind, // match kind value greater than or equal to a single 88 // explicit kind value 89 any, // matches any kind value; each instance is independent 90 // match any kind, but all "same" kinds must be equal. For characters, also 91 // implies that lengths must be equal. 92 same, 93 // for characters that only require the same kind, not length 94 sameKind, 95 operand, // match any kind, with promotion (non-standard) 96 typeless, // BOZ literals are INTEGER with this kind 97 ieeeFlagType, // IEEE_FLAG_TYPE from ISO_FORTRAN_EXCEPTION 98 ieeeRoundType, // IEEE_ROUND_TYPE from ISO_FORTRAN_ARITHMETIC 99 eventType, // EVENT_TYPE from module ISO_FORTRAN_ENV (for coarrays) 100 teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays) 101 kindArg, // this argument is KIND= 102 effectiveKind, // for function results: "kindArg" value, possibly defaulted 103 dimArg, // this argument is DIM= 104 likeMultiply, // for DOT_PRODUCT and MATMUL 105 subscript, // address-sized integer 106 size, // default KIND= for SIZE(), UBOUND, &c. 107 addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ 108 nullPointerType, // for ASSOCIATED(NULL()) 109 exactKind, // a single explicit exactKindValue 110 atomicIntKind, // atomic_int_kind from iso_fortran_env 111 atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind 112 sameAtom, // same type and kind as atom 113 ) 114 115 struct TypePattern { 116 CategorySet categorySet; 117 KindCode kindCode{KindCode::none}; 118 int kindValue{0}; // for KindCode::exactKind and greaterOrEqualToKind 119 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 120 }; 121 122 // Abbreviations for argument and result patterns in the intrinsic prototypes: 123 124 // Match specific kinds of intrinsic types 125 static constexpr TypePattern DefaultInt{IntType, KindCode::defaultIntegerKind}; 126 static constexpr TypePattern DefaultReal{RealType, KindCode::defaultRealKind}; 127 static constexpr TypePattern DefaultComplex{ 128 ComplexType, KindCode::defaultRealKind}; 129 static constexpr TypePattern DefaultChar{CharType, KindCode::defaultCharKind}; 130 static constexpr TypePattern DefaultLogical{ 131 LogicalType, KindCode::defaultLogicalKind}; 132 static constexpr TypePattern BOZ{IntType, KindCode::typeless}; 133 static constexpr TypePattern EventType{DerivedType, KindCode::eventType}; 134 static constexpr TypePattern IeeeFlagType{DerivedType, KindCode::ieeeFlagType}; 135 static constexpr TypePattern IeeeRoundType{ 136 DerivedType, KindCode::ieeeRoundType}; 137 static constexpr TypePattern TeamType{DerivedType, KindCode::teamType}; 138 static constexpr TypePattern DoublePrecision{ 139 RealType, KindCode::doublePrecision}; 140 static constexpr TypePattern DoublePrecisionComplex{ 141 ComplexType, KindCode::doublePrecision}; 142 static constexpr TypePattern SubscriptInt{IntType, KindCode::subscript}; 143 144 // Match any kind of some intrinsic or derived types 145 static constexpr TypePattern AnyInt{IntType, KindCode::any}; 146 static constexpr TypePattern AnyIntOrUnsigned{IntOrUnsignedType, KindCode::any}; 147 static constexpr TypePattern AnyReal{RealType, KindCode::any}; 148 static constexpr TypePattern AnyIntOrReal{IntOrRealType, KindCode::any}; 149 static constexpr TypePattern AnyIntUnsignedOrReal{ 150 IntUnsignedOrRealType, KindCode::any}; 151 static constexpr TypePattern AnyIntOrRealOrChar{ 152 IntOrRealOrCharType, KindCode::any}; 153 static constexpr TypePattern AnyIntOrLogical{IntOrLogicalType, KindCode::any}; 154 static constexpr TypePattern AnyComplex{ComplexType, KindCode::any}; 155 static constexpr TypePattern AnyFloating{FloatingType, KindCode::any}; 156 static constexpr TypePattern AnyNumeric{NumericType, KindCode::any}; 157 static constexpr TypePattern AnyChar{CharType, KindCode::any}; 158 static constexpr TypePattern AnyLogical{LogicalType, KindCode::any}; 159 static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any}; 160 static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any}; 161 static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any}; 162 static constexpr TypePattern AnyData{AnyType, KindCode::any}; 163 164 // Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.) 165 static constexpr TypePattern Addressable{AnyType, KindCode::addressable}; 166 167 // Match some kind of some intrinsic type(s); all "Same" values must match, 168 // even when not in the same category (e.g., SameComplex and SameReal). 169 // Can be used to specify a result so long as at least one argument is 170 // a "Same". 171 static constexpr TypePattern SameInt{IntType, KindCode::same}; 172 static constexpr TypePattern SameIntOrUnsigned{ 173 IntOrUnsignedType, KindCode::same}; 174 static constexpr TypePattern SameReal{RealType, KindCode::same}; 175 static constexpr TypePattern SameIntOrReal{IntOrRealType, KindCode::same}; 176 static constexpr TypePattern SameIntUnsignedOrReal{ 177 IntUnsignedOrRealType, KindCode::same}; 178 static constexpr TypePattern SameComplex{ComplexType, KindCode::same}; 179 static constexpr TypePattern SameFloating{FloatingType, KindCode::same}; 180 static constexpr TypePattern SameNumeric{NumericType, KindCode::same}; 181 static constexpr TypePattern SameChar{CharType, KindCode::same}; 182 static constexpr TypePattern SameCharNoLen{CharType, KindCode::sameKind}; 183 static constexpr TypePattern SameLogical{LogicalType, KindCode::same}; 184 static constexpr TypePattern SameRelatable{RelatableType, KindCode::same}; 185 static constexpr TypePattern SameIntrinsic{IntrinsicType, KindCode::same}; 186 static constexpr TypePattern SameType{AnyType, KindCode::same}; 187 188 // Match some kind of some INTEGER or REAL type(s); when argument types 189 // &/or kinds differ, their values are converted as if they were operands to 190 // an intrinsic operation like addition. This is a nonstandard but nearly 191 // universal extension feature. 192 static constexpr TypePattern OperandInt{IntType, KindCode::operand}; 193 static constexpr TypePattern OperandReal{RealType, KindCode::operand}; 194 static constexpr TypePattern OperandIntOrReal{IntOrRealType, KindCode::operand}; 195 196 static constexpr TypePattern OperandUnsigned{UnsignedType, KindCode::operand}; 197 198 // For ASSOCIATED, the first argument is a typeless pointer 199 static constexpr TypePattern AnyPointer{AnyType, KindCode::nullPointerType}; 200 201 // For DOT_PRODUCT and MATMUL, the result type depends on the arguments 202 static constexpr TypePattern ResultLogical{LogicalType, KindCode::likeMultiply}; 203 static constexpr TypePattern ResultNumeric{NumericType, KindCode::likeMultiply}; 204 205 // Result types with known category and KIND= 206 static constexpr TypePattern KINDInt{IntType, KindCode::effectiveKind}; 207 static constexpr TypePattern KINDUnsigned{ 208 UnsignedType, KindCode::effectiveKind}; 209 static constexpr TypePattern KINDReal{RealType, KindCode::effectiveKind}; 210 static constexpr TypePattern KINDComplex{ComplexType, KindCode::effectiveKind}; 211 static constexpr TypePattern KINDChar{CharType, KindCode::effectiveKind}; 212 static constexpr TypePattern KINDLogical{LogicalType, KindCode::effectiveKind}; 213 214 static constexpr TypePattern AtomicInt{IntType, KindCode::atomicIntKind}; 215 static constexpr TypePattern AtomicIntOrLogical{ 216 IntOrLogicalType, KindCode::atomicIntOrLogicalKind}; 217 static constexpr TypePattern SameAtom{IntOrLogicalType, KindCode::sameAtom}; 218 219 // The default rank pattern for dummy arguments and function results is 220 // "elemental". 221 ENUM_CLASS(Rank, 222 elemental, // scalar, or array that conforms with other array arguments 223 elementalOrBOZ, // elemental, or typeless BOZ literal scalar 224 scalar, vector, 225 shape, // INTEGER vector of known length and no negative element 226 matrix, 227 array, // not scalar, rank is known and greater than zero 228 coarray, // rank is known and can be scalar; has nonzero corank 229 atom, // is scalar and has nonzero corank or is coindexed 230 known, // rank is known and can be scalar 231 anyOrAssumedRank, // any rank, or assumed; assumed-type TYPE(*) allowed 232 arrayOrAssumedRank, // rank >= 1 or assumed; assumed-type TYPE(*) allowed 233 conformable, // scalar, or array of same rank & shape as "array" argument 234 reduceOperation, // a pure function with constraints for REDUCE 235 dimReduced, // scalar if no DIM= argument, else rank(array)-1 236 dimRemovedOrScalar, // rank(array)-1 (less DIM) or scalar 237 scalarIfDim, // scalar if DIM= argument is present, else rank one array 238 locReduced, // vector(1:rank) if no DIM= argument, else rank(array)-1 239 rankPlus1, // rank(known)+1 240 shaped, // rank is length of SHAPE vector 241 ) 242 243 ENUM_CLASS(Optionality, required, 244 optional, // unless DIM= for SIZE(assumedSize) 245 missing, // for DIM= cases like FINDLOC 246 repeats, // for MAX/MIN and their several variants 247 ) 248 249 ENUM_CLASS(ArgFlag, none, 250 canBeNull, // actual argument can be NULL(with or without MOLD=) 251 canBeMoldNull, // actual argument can be NULL(with MOLD=) 252 defaultsToSameKind, // for MatchingDefaultKIND 253 defaultsToSizeKind, // for SizeDefaultKIND 254 defaultsToDefaultForResult, // for DefaultingKIND 255 notAssumedSize) 256 257 struct IntrinsicDummyArgument { 258 const char *keyword{nullptr}; 259 TypePattern typePattern; 260 Rank rank{Rank::elemental}; 261 Optionality optionality{Optionality::required}; 262 common::Intent intent{common::Intent::In}; 263 common::EnumSet<ArgFlag, 32> flags{}; 264 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 265 }; 266 267 // constexpr abbreviations for popular arguments: 268 // DefaultingKIND is a KIND= argument whose default value is the appropriate 269 // KIND(0), KIND(0.0), KIND(''), &c. value for the function result. 270 static constexpr IntrinsicDummyArgument DefaultingKIND{"kind", 271 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::optional, 272 common::Intent::In, {ArgFlag::defaultsToDefaultForResult}}; 273 // MatchingDefaultKIND is a KIND= argument whose default value is the 274 // kind of any "Same" function argument (viz., the one whose kind pattern is 275 // "same"). 276 static constexpr IntrinsicDummyArgument MatchingDefaultKIND{"kind", 277 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::optional, 278 common::Intent::In, {ArgFlag::defaultsToSameKind}}; 279 // SizeDefaultKind is a KIND= argument whose default value should be 280 // the kind of INTEGER used for address calculations, and can be 281 // set so with a compiler flag; but the standard mandates the 282 // kind of default INTEGER. 283 static constexpr IntrinsicDummyArgument SizeDefaultKIND{"kind", 284 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::optional, 285 common::Intent::In, {ArgFlag::defaultsToSizeKind}}; 286 static constexpr IntrinsicDummyArgument RequiredDIM{"dim", 287 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::required, 288 common::Intent::In}; 289 static constexpr IntrinsicDummyArgument OptionalDIM{"dim", 290 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::optional, 291 common::Intent::In}; 292 static constexpr IntrinsicDummyArgument MissingDIM{"dim", 293 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::missing, 294 common::Intent::In}; 295 static constexpr IntrinsicDummyArgument OptionalMASK{"mask", AnyLogical, 296 Rank::conformable, Optionality::optional, common::Intent::In}; 297 static constexpr IntrinsicDummyArgument OptionalTEAM{ 298 "team", TeamType, Rank::scalar, Optionality::optional, common::Intent::In}; 299 300 struct IntrinsicInterface { 301 static constexpr int maxArguments{7}; // if not a MAX/MIN(...) 302 const char *name{nullptr}; 303 IntrinsicDummyArgument dummy[maxArguments]; 304 TypePattern result; 305 Rank rank{Rank::elemental}; 306 IntrinsicClass intrinsicClass{IntrinsicClass::elementalFunction}; 307 std::optional<SpecificCall> Match(const CallCharacteristics &, 308 const common::IntrinsicTypeDefaultKinds &, ActualArguments &, 309 FoldingContext &context, const semantics::Scope *builtins) const; 310 int CountArguments() const; 311 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 312 }; 313 314 int IntrinsicInterface::CountArguments() const { 315 int n{0}; 316 while (n < maxArguments && dummy[n].keyword) { 317 ++n; 318 } 319 return n; 320 } 321 322 // GENERIC INTRINSIC FUNCTION INTERFACES 323 // Each entry in this table defines a pattern. Some intrinsic 324 // functions have more than one such pattern. Besides the name 325 // of the intrinsic function, each pattern has specifications for 326 // the dummy arguments and for the result of the function. 327 // The dummy argument patterns each have a name (these are from the 328 // standard, but rarely appear in actual code), a type and kind 329 // pattern, allowable ranks, and optionality indicators. 330 // Be advised, the default rank pattern is "elemental". 331 static const IntrinsicInterface genericIntrinsicFunction[]{ 332 {"abs", {{"a", SameIntOrReal}}, SameIntOrReal}, 333 {"abs", {{"a", SameComplex}}, SameReal}, 334 {"achar", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar}, 335 {"acos", {{"x", SameFloating}}, SameFloating}, 336 {"acosd", {{"x", SameFloating}}, SameFloating}, 337 {"acosh", {{"x", SameFloating}}, SameFloating}, 338 {"adjustl", {{"string", SameChar}}, SameChar}, 339 {"adjustr", {{"string", SameChar}}, SameChar}, 340 {"aimag", {{"z", SameComplex}}, SameReal}, 341 {"aint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal}, 342 {"all", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, 343 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 344 {"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical, 345 Rank::elemental, IntrinsicClass::inquiryFunction}, 346 {"allocated", {{"array", AnyData, Rank::anyOrAssumedRank}}, DefaultLogical, 347 Rank::elemental, IntrinsicClass::inquiryFunction}, 348 {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal}, 349 {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, 350 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 351 {"asin", {{"x", SameFloating}}, SameFloating}, 352 {"asind", {{"x", SameFloating}}, SameFloating}, 353 {"asinh", {{"x", SameFloating}}, SameFloating}, 354 {"associated", 355 {{"pointer", AnyPointer, Rank::anyOrAssumedRank, Optionality::required, 356 common::Intent::In, {ArgFlag::canBeNull}}, 357 {"target", Addressable, Rank::anyOrAssumedRank, 358 Optionality::optional, common::Intent::In, 359 {ArgFlag::canBeNull}}}, 360 DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, 361 {"atan", {{"x", SameFloating}}, SameFloating}, 362 {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 363 {"atand", {{"x", SameFloating}}, SameFloating}, 364 {"atand", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 365 {"atan2", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 366 {"atan2d", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 367 {"atanpi", {{"x", SameFloating}}, SameFloating}, 368 {"atanpi", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 369 {"atan2pi", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, 370 {"atanh", {{"x", SameFloating}}, SameFloating}, 371 {"bessel_j0", {{"x", SameReal}}, SameReal}, 372 {"bessel_j1", {{"x", SameReal}}, SameReal}, 373 {"bessel_jn", {{"n", AnyInt}, {"x", SameReal}}, SameReal}, 374 {"bessel_jn", 375 {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar}, 376 {"x", SameReal, Rank::scalar}}, 377 SameReal, Rank::vector, IntrinsicClass::transformationalFunction}, 378 {"bessel_y0", {{"x", SameReal}}, SameReal}, 379 {"bessel_y1", {{"x", SameReal}}, SameReal}, 380 {"bessel_yn", {{"n", AnyInt}, {"x", SameReal}}, SameReal}, 381 {"bessel_yn", 382 {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar}, 383 {"x", SameReal, Rank::scalar}}, 384 SameReal, Rank::vector, IntrinsicClass::transformationalFunction}, 385 {"bge", 386 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ}, 387 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}}, 388 DefaultLogical}, 389 {"bgt", 390 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ}, 391 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}}, 392 DefaultLogical}, 393 {"bit_size", 394 {{"i", SameIntOrUnsigned, Rank::anyOrAssumedRank, Optionality::required, 395 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 396 SameInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 397 {"ble", 398 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ}, 399 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}}, 400 DefaultLogical}, 401 {"blt", 402 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ}, 403 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}}, 404 DefaultLogical}, 405 {"btest", {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ}, {"pos", AnyInt}}, 406 DefaultLogical}, 407 {"ceiling", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, 408 {"char", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar}, 409 {"chdir", {{"name", DefaultChar, Rank::scalar, Optionality::required}}, 410 DefaultInt}, 411 {"cmplx", {{"x", AnyComplex}, DefaultingKIND}, KINDComplex}, 412 {"cmplx", 413 {{"x", AnyIntUnsignedOrReal, Rank::elementalOrBOZ}, 414 {"y", AnyIntUnsignedOrReal, Rank::elementalOrBOZ, 415 Optionality::optional}, 416 DefaultingKIND}, 417 KINDComplex}, 418 {"command_argument_count", {}, DefaultInt, Rank::scalar, 419 IntrinsicClass::transformationalFunction}, 420 {"conjg", {{"z", SameComplex}}, SameComplex}, 421 {"cos", {{"x", SameFloating}}, SameFloating}, 422 {"cosd", {{"x", SameFloating}}, SameFloating}, 423 {"cosh", {{"x", SameFloating}}, SameFloating}, 424 {"count", {{"mask", AnyLogical, Rank::array}, OptionalDIM, DefaultingKIND}, 425 KINDInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, 426 {"cshift", 427 {{"array", SameType, Rank::array}, 428 {"shift", AnyInt, Rank::dimRemovedOrScalar}, OptionalDIM}, 429 SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, 430 {"dble", {{"a", AnyNumeric, Rank::elementalOrBOZ}}, DoublePrecision}, 431 {"digits", 432 {{"x", AnyIntUnsignedOrReal, Rank::anyOrAssumedRank, 433 Optionality::required, common::Intent::In, 434 {ArgFlag::canBeMoldNull}}}, 435 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 436 {"dim", {{"x", OperandIntOrReal}, {"y", OperandIntOrReal}}, 437 OperandIntOrReal}, 438 {"dot_product", 439 {{"vector_a", AnyLogical, Rank::vector}, 440 {"vector_b", AnyLogical, Rank::vector}}, 441 ResultLogical, Rank::scalar, IntrinsicClass::transformationalFunction}, 442 {"dot_product", 443 {{"vector_a", AnyComplex, Rank::vector}, 444 {"vector_b", AnyNumeric, Rank::vector}}, 445 ResultNumeric, Rank::scalar, // conjugates vector_a 446 IntrinsicClass::transformationalFunction}, 447 {"dot_product", 448 {{"vector_a", AnyIntUnsignedOrReal, Rank::vector}, 449 {"vector_b", AnyNumeric, Rank::vector}}, 450 ResultNumeric, Rank::scalar, IntrinsicClass::transformationalFunction}, 451 {"dprod", {{"x", DefaultReal}, {"y", DefaultReal}}, DoublePrecision}, 452 {"dshiftl", 453 {{"i", SameIntOrUnsigned}, 454 {"j", SameIntOrUnsigned, Rank::elementalOrBOZ}, {"shift", AnyInt}}, 455 SameIntOrUnsigned}, 456 {"dshiftl", {{"i", BOZ}, {"j", SameIntOrUnsigned}, {"shift", AnyInt}}, 457 SameIntOrUnsigned}, 458 {"dshiftr", 459 {{"i", SameIntOrUnsigned}, 460 {"j", SameIntOrUnsigned, Rank::elementalOrBOZ}, {"shift", AnyInt}}, 461 SameIntOrUnsigned}, 462 {"dshiftr", {{"i", BOZ}, {"j", SameIntOrUnsigned}, {"shift", AnyInt}}, 463 SameIntOrUnsigned}, 464 {"eoshift", 465 {{"array", SameType, Rank::array}, 466 {"shift", AnyInt, Rank::dimRemovedOrScalar}, 467 // BOUNDARY= is not optional for non-intrinsic types 468 {"boundary", SameType, Rank::dimRemovedOrScalar}, OptionalDIM}, 469 SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, 470 {"eoshift", 471 {{"array", SameIntrinsic, Rank::array}, 472 {"shift", AnyInt, Rank::dimRemovedOrScalar}, 473 {"boundary", SameIntrinsic, Rank::dimRemovedOrScalar, 474 Optionality::optional}, 475 OptionalDIM}, 476 SameIntrinsic, Rank::conformable, 477 IntrinsicClass::transformationalFunction}, 478 {"epsilon", 479 {{"x", SameReal, Rank::anyOrAssumedRank, Optionality::required, 480 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 481 SameReal, Rank::scalar, IntrinsicClass::inquiryFunction}, 482 {"erf", {{"x", SameReal}}, SameReal}, 483 {"erfc", {{"x", SameReal}}, SameReal}, 484 {"erfc_scaled", {{"x", SameReal}}, SameReal}, 485 {"etime", 486 {{"values", TypePattern{RealType, KindCode::exactKind, 4}, Rank::vector, 487 Optionality::required, common::Intent::Out}}, 488 TypePattern{RealType, KindCode::exactKind, 4}}, 489 {"exp", {{"x", SameFloating}}, SameFloating}, 490 {"exp", {{"x", SameFloating}}, SameFloating}, 491 {"exponent", {{"x", AnyReal}}, DefaultInt}, 492 {"exp", {{"x", SameFloating}}, SameFloating}, 493 {"extends_type_of", 494 {{"a", ExtensibleDerived, Rank::anyOrAssumedRank, Optionality::required, 495 common::Intent::In, {ArgFlag::canBeMoldNull}}, 496 {"mold", ExtensibleDerived, Rank::anyOrAssumedRank, 497 Optionality::required, common::Intent::In, 498 {ArgFlag::canBeMoldNull}}}, 499 DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, 500 {"failed_images", {OptionalTEAM, SizeDefaultKIND}, KINDInt, Rank::vector, 501 IntrinsicClass::transformationalFunction}, 502 {"findloc", 503 {{"array", AnyNumeric, Rank::array}, 504 {"value", AnyNumeric, Rank::scalar}, RequiredDIM, OptionalMASK, 505 SizeDefaultKIND, 506 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 507 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 508 {"findloc", 509 {{"array", AnyNumeric, Rank::array}, 510 {"value", AnyNumeric, Rank::scalar}, MissingDIM, OptionalMASK, 511 SizeDefaultKIND, 512 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 513 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, 514 {"findloc", 515 {{"array", SameCharNoLen, Rank::array}, 516 {"value", SameCharNoLen, Rank::scalar}, RequiredDIM, OptionalMASK, 517 SizeDefaultKIND, 518 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 519 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 520 {"findloc", 521 {{"array", SameCharNoLen, Rank::array}, 522 {"value", SameCharNoLen, Rank::scalar}, MissingDIM, OptionalMASK, 523 SizeDefaultKIND, 524 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 525 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, 526 {"findloc", 527 {{"array", AnyLogical, Rank::array}, 528 {"value", AnyLogical, Rank::scalar}, RequiredDIM, OptionalMASK, 529 SizeDefaultKIND, 530 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 531 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 532 {"findloc", 533 {{"array", AnyLogical, Rank::array}, 534 {"value", AnyLogical, Rank::scalar}, MissingDIM, OptionalMASK, 535 SizeDefaultKIND, 536 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 537 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, 538 {"floor", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, 539 {"fraction", {{"x", SameReal}}, SameReal}, 540 {"gamma", {{"x", SameReal}}, SameReal}, 541 {"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}}, 542 TeamType, Rank::scalar, IntrinsicClass::transformationalFunction}, 543 {"getcwd", 544 {{"c", DefaultChar, Rank::scalar, Optionality::required, 545 common::Intent::Out}}, 546 TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}}, 547 {"getgid", {}, DefaultInt}, 548 {"getpid", {}, DefaultInt}, 549 {"getuid", {}, DefaultInt}, 550 {"huge", 551 {{"x", SameIntUnsignedOrReal, Rank::anyOrAssumedRank, 552 Optionality::required, common::Intent::In, 553 {ArgFlag::canBeMoldNull}}}, 554 SameIntUnsignedOrReal, Rank::scalar, IntrinsicClass::inquiryFunction}, 555 {"hypot", {{"x", OperandReal}, {"y", OperandReal}}, OperandReal}, 556 {"iachar", {{"c", AnyChar}, DefaultingKIND}, KINDInt}, 557 {"iall", 558 {{"array", SameIntOrUnsigned, Rank::array}, RequiredDIM, OptionalMASK}, 559 SameIntOrUnsigned, Rank::dimReduced, 560 IntrinsicClass::transformationalFunction}, 561 {"iall", 562 {{"array", SameIntOrUnsigned, Rank::array}, MissingDIM, OptionalMASK}, 563 SameIntOrUnsigned, Rank::scalar, 564 IntrinsicClass::transformationalFunction}, 565 {"iany", 566 {{"array", SameIntOrUnsigned, Rank::array}, RequiredDIM, OptionalMASK}, 567 SameIntOrUnsigned, Rank::dimReduced, 568 IntrinsicClass::transformationalFunction}, 569 {"iany", 570 {{"array", SameIntOrUnsigned, Rank::array}, MissingDIM, OptionalMASK}, 571 SameIntOrUnsigned, Rank::scalar, 572 IntrinsicClass::transformationalFunction}, 573 {"iparity", 574 {{"array", SameIntOrUnsigned, Rank::array}, RequiredDIM, OptionalMASK}, 575 SameIntOrUnsigned, Rank::dimReduced, 576 IntrinsicClass::transformationalFunction}, 577 {"iparity", 578 {{"array", SameIntOrUnsigned, Rank::array}, MissingDIM, OptionalMASK}, 579 SameIntOrUnsigned, Rank::scalar, 580 IntrinsicClass::transformationalFunction}, 581 {"iand", {{"i", OperandInt}, {"j", OperandInt, Rank::elementalOrBOZ}}, 582 OperandInt}, 583 {"iand", 584 {{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}}, 585 OperandUnsigned}, 586 {"iand", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned}, 587 {"ibclr", {{"i", SameIntOrUnsigned}, {"pos", AnyInt}}, SameIntOrUnsigned}, 588 {"ibits", {{"i", SameIntOrUnsigned}, {"pos", AnyInt}, {"len", AnyInt}}, 589 SameIntOrUnsigned}, 590 {"ibset", {{"i", SameIntOrUnsigned}, {"pos", AnyInt}}, SameIntOrUnsigned}, 591 {"ichar", {{"c", AnyChar}, DefaultingKIND}, KINDInt}, 592 {"ieor", {{"i", OperandInt}, {"j", OperandInt, Rank::elementalOrBOZ}}, 593 OperandInt}, 594 {"ieor", 595 {{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}}, 596 OperandUnsigned}, 597 {"ieor", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned}, 598 {"image_index", 599 {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector}}, 600 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 601 {"image_index", 602 {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector}, 603 {"team", TeamType, Rank::scalar}}, 604 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 605 {"image_index", 606 {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector}, 607 {"team_number", AnyInt, Rank::scalar}}, 608 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 609 {"image_status", {{"image", SameInt}, OptionalTEAM}, DefaultInt}, 610 {"index", 611 {{"string", SameCharNoLen}, {"substring", SameCharNoLen}, 612 {"back", AnyLogical, Rank::elemental, Optionality::optional}, 613 DefaultingKIND}, 614 KINDInt}, 615 {"int", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND}, KINDInt}, 616 {"int2", {{"a", AnyNumeric, Rank::elementalOrBOZ}}, 617 TypePattern{IntType, KindCode::exactKind, 2}}, 618 {"int8", {{"a", AnyNumeric, Rank::elementalOrBOZ}}, 619 TypePattern{IntType, KindCode::exactKind, 8}}, 620 {"int_ptr_kind", {}, DefaultInt, Rank::scalar}, 621 {"ior", {{"i", OperandInt}, {"j", OperandInt, Rank::elementalOrBOZ}}, 622 OperandInt}, 623 {"ior", 624 {{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}}, 625 OperandUnsigned}, 626 {"ior", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned}, 627 {"ishft", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}}, SameIntOrUnsigned}, 628 {"ishftc", 629 {{"i", SameIntOrUnsigned}, {"shift", AnyInt}, 630 {"size", AnyInt, Rank::elemental, Optionality::optional}}, 631 SameIntOrUnsigned}, 632 {"isnan", {{"a", AnyFloating}}, DefaultLogical}, 633 {"is_contiguous", {{"array", Addressable, Rank::anyOrAssumedRank}}, 634 DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, 635 {"is_iostat_end", {{"i", AnyInt}}, DefaultLogical}, 636 {"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical}, 637 {"izext", {{"i", AnyInt}}, TypePattern{IntType, KindCode::exactKind, 2}}, 638 {"jzext", {{"i", AnyInt}}, DefaultInt}, 639 {"kind", 640 {{"x", AnyIntrinsic, Rank::anyOrAssumedRank, Optionality::required, 641 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 642 DefaultInt, Rank::elemental, IntrinsicClass::inquiryFunction}, 643 {"lbound", 644 {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM, 645 SizeDefaultKIND}, 646 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 647 {"lbound", {{"array", AnyData, Rank::arrayOrAssumedRank}, SizeDefaultKIND}, 648 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, 649 {"lcobound", 650 {{"coarray", AnyData, Rank::coarray}, OptionalDIM, SizeDefaultKIND}, 651 KINDInt, Rank::scalarIfDim, IntrinsicClass::inquiryFunction}, 652 {"leadz", {{"i", AnyInt}}, DefaultInt}, 653 {"len", 654 {{"string", AnyChar, Rank::anyOrAssumedRank, Optionality::required, 655 common::Intent::In, {ArgFlag::canBeMoldNull}}, 656 DefaultingKIND}, 657 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 658 {"len_trim", {{"string", AnyChar}, DefaultingKIND}, KINDInt}, 659 {"lge", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, 660 DefaultLogical}, 661 {"lgt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, 662 DefaultLogical}, 663 {"lle", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, 664 DefaultLogical}, 665 {"llt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, 666 DefaultLogical}, 667 {"lnblnk", {{"string", AnyChar}}, DefaultInt}, 668 {"loc", {{"x", Addressable, Rank::anyOrAssumedRank}}, SubscriptInt, 669 Rank::scalar}, 670 {"log", {{"x", SameFloating}}, SameFloating}, 671 {"log10", {{"x", SameReal}}, SameReal}, 672 {"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical}, 673 {"log_gamma", {{"x", SameReal}}, SameReal}, 674 {"malloc", {{"size", AnyInt}}, SubscriptInt}, 675 {"matmul", 676 {{"matrix_a", AnyLogical, Rank::vector}, 677 {"matrix_b", AnyLogical, Rank::matrix}}, 678 ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction}, 679 {"matmul", 680 {{"matrix_a", AnyLogical, Rank::matrix}, 681 {"matrix_b", AnyLogical, Rank::vector}}, 682 ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction}, 683 {"matmul", 684 {{"matrix_a", AnyLogical, Rank::matrix}, 685 {"matrix_b", AnyLogical, Rank::matrix}}, 686 ResultLogical, Rank::matrix, IntrinsicClass::transformationalFunction}, 687 {"matmul", 688 {{"matrix_a", AnyNumeric, Rank::vector}, 689 {"matrix_b", AnyNumeric, Rank::matrix}}, 690 ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction}, 691 {"matmul", 692 {{"matrix_a", AnyNumeric, Rank::matrix}, 693 {"matrix_b", AnyNumeric, Rank::vector}}, 694 ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction}, 695 {"matmul", 696 {{"matrix_a", AnyNumeric, Rank::matrix}, 697 {"matrix_b", AnyNumeric, Rank::matrix}}, 698 ResultNumeric, Rank::matrix, IntrinsicClass::transformationalFunction}, 699 {"maskl", {{"i", AnyInt}, DefaultingKIND}, KINDInt}, 700 {"maskr", {{"i", AnyInt}, DefaultingKIND}, KINDInt}, 701 {"max", 702 {{"a1", OperandIntOrReal}, {"a2", OperandIntOrReal}, 703 {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}}, 704 OperandIntOrReal}, 705 {"max", 706 {{"a1", OperandUnsigned}, {"a2", OperandUnsigned}, 707 {"a3", OperandUnsigned, Rank::elemental, Optionality::repeats}}, 708 OperandUnsigned}, 709 {"max", 710 {{"a1", SameCharNoLen}, {"a2", SameCharNoLen}, 711 {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}}, 712 SameCharNoLen}, 713 {"maxexponent", 714 {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required, 715 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 716 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 717 {"maxloc", 718 {{"array", AnyRelatable, Rank::array}, RequiredDIM, OptionalMASK, 719 SizeDefaultKIND, 720 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 721 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 722 {"maxloc", 723 {{"array", AnyRelatable, Rank::array}, MissingDIM, OptionalMASK, 724 SizeDefaultKIND, 725 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 726 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 727 {"maxval", 728 {{"array", SameRelatable, Rank::array}, RequiredDIM, OptionalMASK}, 729 SameRelatable, Rank::dimReduced, 730 IntrinsicClass::transformationalFunction}, 731 {"maxval", 732 {{"array", SameRelatable, Rank::array}, MissingDIM, OptionalMASK}, 733 SameRelatable, Rank::scalar, IntrinsicClass::transformationalFunction}, 734 {"merge", 735 {{"tsource", SameType}, {"fsource", SameType}, {"mask", AnyLogical}}, 736 SameType}, 737 {"merge_bits", 738 {{"i", SameIntOrUnsigned}, 739 {"j", SameIntOrUnsigned, Rank::elementalOrBOZ}, 740 {"mask", SameIntOrUnsigned, Rank::elementalOrBOZ}}, 741 SameIntOrUnsigned}, 742 {"merge_bits", 743 {{"i", BOZ}, {"j", SameIntOrUnsigned}, 744 {"mask", SameIntOrUnsigned, Rank::elementalOrBOZ}}, 745 SameIntOrUnsigned}, 746 {"min", 747 {{"a1", OperandIntOrReal}, {"a2", OperandIntOrReal}, 748 {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}}, 749 OperandIntOrReal}, 750 {"min", 751 {{"a1", OperandUnsigned}, {"a2", OperandUnsigned}, 752 {"a3", OperandUnsigned, Rank::elemental, Optionality::repeats}}, 753 OperandUnsigned}, 754 {"min", 755 {{"a1", SameCharNoLen}, {"a2", SameCharNoLen}, 756 {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}}, 757 SameCharNoLen}, 758 {"minexponent", 759 {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required, 760 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 761 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 762 {"minloc", 763 {{"array", AnyRelatable, Rank::array}, RequiredDIM, OptionalMASK, 764 SizeDefaultKIND, 765 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 766 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 767 {"minloc", 768 {{"array", AnyRelatable, Rank::array}, MissingDIM, OptionalMASK, 769 SizeDefaultKIND, 770 {"back", AnyLogical, Rank::scalar, Optionality::optional}}, 771 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, 772 {"minval", 773 {{"array", SameRelatable, Rank::array}, RequiredDIM, OptionalMASK}, 774 SameRelatable, Rank::dimReduced, 775 IntrinsicClass::transformationalFunction}, 776 {"minval", 777 {{"array", SameRelatable, Rank::array}, MissingDIM, OptionalMASK}, 778 SameRelatable, Rank::scalar, IntrinsicClass::transformationalFunction}, 779 {"mod", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}}, 780 OperandIntOrReal}, 781 {"mod", {{"a", OperandUnsigned}, {"p", OperandUnsigned}}, OperandUnsigned}, 782 {"modulo", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}}, 783 OperandIntOrReal}, 784 {"modulo", {{"a", OperandUnsigned}, {"p", OperandUnsigned}}, 785 OperandUnsigned}, 786 {"nearest", {{"x", SameReal}, {"s", AnyReal}}, SameReal}, 787 {"new_line", 788 {{"a", SameCharNoLen, Rank::anyOrAssumedRank, Optionality::required, 789 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 790 SameCharNoLen, Rank::scalar, IntrinsicClass::inquiryFunction}, 791 {"nint", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, 792 {"norm2", {{"x", SameReal, Rank::array}, RequiredDIM}, SameReal, 793 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 794 {"norm2", {{"x", SameReal, Rank::array}, MissingDIM}, SameReal, 795 Rank::scalar, IntrinsicClass::transformationalFunction}, 796 {"not", {{"i", SameIntOrUnsigned}}, SameIntOrUnsigned}, 797 // NULL() is a special case handled in Probe() below 798 {"num_images", {}, DefaultInt, Rank::scalar, 799 IntrinsicClass::transformationalFunction}, 800 {"num_images", {{"team", TeamType, Rank::scalar}}, DefaultInt, Rank::scalar, 801 IntrinsicClass::transformationalFunction}, 802 {"num_images", {{"team_number", AnyInt, Rank::scalar}}, DefaultInt, 803 Rank::scalar, IntrinsicClass::transformationalFunction}, 804 {"out_of_range", 805 {{"x", AnyIntOrReal}, {"mold", AnyIntOrReal, Rank::scalar}}, 806 DefaultLogical}, 807 {"out_of_range", 808 {{"x", AnyReal}, {"mold", AnyInt, Rank::scalar}, 809 {"round", AnyLogical, Rank::scalar, Optionality::optional}}, 810 DefaultLogical}, 811 {"out_of_range", {{"x", AnyReal}, {"mold", AnyReal}}, DefaultLogical}, 812 {"pack", 813 {{"array", SameType, Rank::array}, 814 {"mask", AnyLogical, Rank::conformable}, 815 {"vector", SameType, Rank::vector, Optionality::optional}}, 816 SameType, Rank::vector, IntrinsicClass::transformationalFunction}, 817 {"parity", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, 818 Rank::dimReduced, IntrinsicClass::transformationalFunction}, 819 {"popcnt", {{"i", AnyInt}}, DefaultInt}, 820 {"poppar", {{"i", AnyInt}}, DefaultInt}, 821 {"product", 822 {{"array", SameNumeric, Rank::array}, RequiredDIM, OptionalMASK}, 823 SameNumeric, Rank::dimReduced, 824 IntrinsicClass::transformationalFunction}, 825 {"product", {{"array", SameNumeric, Rank::array}, MissingDIM, OptionalMASK}, 826 SameNumeric, Rank::scalar, IntrinsicClass::transformationalFunction}, 827 {"precision", 828 {{"x", AnyFloating, Rank::anyOrAssumedRank, Optionality::required, 829 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 830 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 831 {"present", {{"a", Addressable, Rank::anyOrAssumedRank}}, DefaultLogical, 832 Rank::scalar, IntrinsicClass::inquiryFunction}, 833 {"radix", 834 {{"x", AnyIntOrReal, Rank::anyOrAssumedRank, Optionality::required, 835 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 836 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 837 {"range", 838 {{"x", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required, 839 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 840 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 841 {"rank", 842 {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required, 843 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 844 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 845 {"real", {{"a", SameComplex, Rank::elemental}}, 846 SameReal}, // 16.9.160(4)(ii) 847 {"real", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND}, 848 KINDReal}, 849 {"reduce", 850 {{"array", SameType, Rank::array}, 851 {"operation", SameType, Rank::reduceOperation}, RequiredDIM, 852 OptionalMASK, 853 {"identity", SameType, Rank::scalar, Optionality::optional}, 854 {"ordered", AnyLogical, Rank::scalar, Optionality::optional}}, 855 SameType, Rank::dimReduced, IntrinsicClass::transformationalFunction}, 856 {"reduce", 857 {{"array", SameType, Rank::array}, 858 {"operation", SameType, Rank::reduceOperation}, MissingDIM, 859 OptionalMASK, 860 {"identity", SameType, Rank::scalar, Optionality::optional}, 861 {"ordered", AnyLogical, Rank::scalar, Optionality::optional}}, 862 SameType, Rank::scalar, IntrinsicClass::transformationalFunction}, 863 {"rename", 864 {{"path1", DefaultChar, Rank::scalar}, 865 {"path2", DefaultChar, Rank::scalar}}, 866 DefaultInt, Rank::scalar}, 867 {"repeat", 868 {{"string", SameCharNoLen, Rank::scalar}, 869 {"ncopies", AnyInt, Rank::scalar}}, 870 SameCharNoLen, Rank::scalar, IntrinsicClass::transformationalFunction}, 871 {"reshape", 872 {{"source", SameType, Rank::array}, {"shape", AnyInt, Rank::shape}, 873 {"pad", SameType, Rank::array, Optionality::optional}, 874 {"order", AnyInt, Rank::vector, Optionality::optional}}, 875 SameType, Rank::shaped, IntrinsicClass::transformationalFunction}, 876 {"rrspacing", {{"x", SameReal}}, SameReal}, 877 {"same_type_as", 878 {{"a", ExtensibleDerived, Rank::anyOrAssumedRank, Optionality::required, 879 common::Intent::In, {ArgFlag::canBeMoldNull}}, 880 {"b", ExtensibleDerived, Rank::anyOrAssumedRank, 881 Optionality::required, common::Intent::In, 882 {ArgFlag::canBeMoldNull}}}, 883 DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, 884 {"scale", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, // == IEEE_SCALB() 885 {"scan", 886 {{"string", SameCharNoLen}, {"set", SameCharNoLen}, 887 {"back", AnyLogical, Rank::elemental, Optionality::optional}, 888 DefaultingKIND}, 889 KINDInt}, 890 {"second", {}, DefaultReal, Rank::scalar}, 891 {"selected_char_kind", {{"name", DefaultChar, Rank::scalar}}, DefaultInt, 892 Rank::scalar, IntrinsicClass::transformationalFunction}, 893 {"selected_int_kind", {{"r", AnyInt, Rank::scalar}}, DefaultInt, 894 Rank::scalar, IntrinsicClass::transformationalFunction}, 895 {"selected_logical_kind", {{"bits", AnyInt, Rank::scalar}}, DefaultInt, 896 Rank::scalar, IntrinsicClass::transformationalFunction}, 897 {"selected_real_kind", 898 {{"p", AnyInt, Rank::scalar}, 899 {"r", AnyInt, Rank::scalar, Optionality::optional}, 900 {"radix", AnyInt, Rank::scalar, Optionality::optional}}, 901 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 902 {"selected_real_kind", 903 {{"p", AnyInt, Rank::scalar, Optionality::optional}, 904 {"r", AnyInt, Rank::scalar}, 905 {"radix", AnyInt, Rank::scalar, Optionality::optional}}, 906 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 907 {"selected_real_kind", 908 {{"p", AnyInt, Rank::scalar, Optionality::optional}, 909 {"r", AnyInt, Rank::scalar, Optionality::optional}, 910 {"radix", AnyInt, Rank::scalar}}, 911 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 912 {"selected_unsigned_kind", {{"r", AnyInt, Rank::scalar}}, DefaultInt, 913 Rank::scalar, IntrinsicClass::transformationalFunction}, 914 {"set_exponent", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, 915 {"shape", {{"source", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, 916 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, 917 {"shifta", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}}, 918 SameIntOrUnsigned}, 919 {"shiftl", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}}, 920 SameIntOrUnsigned}, 921 {"shiftr", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}}, 922 SameIntOrUnsigned}, 923 {"sign", {{"a", SameInt}, {"b", AnyInt}}, SameInt}, 924 {"sign", {{"a", SameReal}, {"b", AnyReal}}, SameReal}, 925 {"sin", {{"x", SameFloating}}, SameFloating}, 926 {"sind", {{"x", SameFloating}}, SameFloating}, 927 {"sinh", {{"x", SameFloating}}, SameFloating}, 928 {"size", 929 {{"array", AnyData, Rank::arrayOrAssumedRank}, 930 OptionalDIM, // unless array is assumed-size 931 SizeDefaultKIND}, 932 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 933 {"sizeof", {{"a", AnyData, Rank::anyOrAssumedRank}}, SubscriptInt, 934 Rank::scalar, IntrinsicClass::inquiryFunction}, 935 {"spacing", {{"x", SameReal}}, SameReal}, 936 {"spread", 937 {{"source", SameType, Rank::known, Optionality::required, 938 common::Intent::In, {ArgFlag::notAssumedSize}}, 939 RequiredDIM, {"ncopies", AnyInt, Rank::scalar}}, 940 SameType, Rank::rankPlus1, IntrinsicClass::transformationalFunction}, 941 {"sqrt", {{"x", SameFloating}}, SameFloating}, 942 {"stopped_images", {OptionalTEAM, SizeDefaultKIND}, KINDInt, Rank::vector, 943 IntrinsicClass::transformationalFunction}, 944 {"storage_size", 945 {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required, 946 common::Intent::In, {ArgFlag::canBeMoldNull}}, 947 SizeDefaultKIND}, 948 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 949 {"sum", {{"array", SameNumeric, Rank::array}, RequiredDIM, OptionalMASK}, 950 SameNumeric, Rank::dimReduced, 951 IntrinsicClass::transformationalFunction}, 952 {"sum", {{"array", SameNumeric, Rank::array}, MissingDIM, OptionalMASK}, 953 SameNumeric, Rank::scalar, IntrinsicClass::transformationalFunction}, 954 {"system", {{"command", DefaultChar, Rank::scalar}}, DefaultInt, 955 Rank::scalar}, 956 {"tan", {{"x", SameFloating}}, SameFloating}, 957 {"tand", {{"x", SameFloating}}, SameFloating}, 958 {"tanh", {{"x", SameFloating}}, SameFloating}, 959 {"team_number", {OptionalTEAM}, DefaultInt, Rank::scalar, 960 IntrinsicClass::transformationalFunction}, 961 {"this_image", 962 {{"coarray", AnyData, Rank::coarray}, RequiredDIM, OptionalTEAM}, 963 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, 964 {"this_image", {{"coarray", AnyData, Rank::coarray}, OptionalTEAM}, 965 DefaultInt, Rank::vector, IntrinsicClass::transformationalFunction}, 966 {"this_image", {OptionalTEAM}, DefaultInt, Rank::scalar, 967 IntrinsicClass::transformationalFunction}, 968 {"tiny", 969 {{"x", SameReal, Rank::anyOrAssumedRank, Optionality::required, 970 common::Intent::In, {ArgFlag::canBeMoldNull}}}, 971 SameReal, Rank::scalar, IntrinsicClass::inquiryFunction}, 972 {"trailz", {{"i", AnyInt}}, DefaultInt}, 973 {"transfer", 974 {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::scalar}}, 975 SameType, Rank::scalar, IntrinsicClass::transformationalFunction}, 976 {"transfer", 977 {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::array}}, 978 SameType, Rank::vector, IntrinsicClass::transformationalFunction}, 979 {"transfer", 980 {{"source", AnyData, Rank::anyOrAssumedRank}, 981 {"mold", SameType, Rank::anyOrAssumedRank}, 982 {"size", AnyInt, Rank::scalar}}, 983 SameType, Rank::vector, IntrinsicClass::transformationalFunction}, 984 {"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix, 985 IntrinsicClass::transformationalFunction}, 986 {"trim", {{"string", SameCharNoLen, Rank::scalar}}, SameCharNoLen, 987 Rank::scalar, IntrinsicClass::transformationalFunction}, 988 {"ubound", 989 {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM, 990 SizeDefaultKIND}, 991 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, 992 {"ubound", {{"array", AnyData, Rank::arrayOrAssumedRank}, SizeDefaultKIND}, 993 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, 994 {"ucobound", 995 {{"coarray", AnyData, Rank::coarray}, OptionalDIM, SizeDefaultKIND}, 996 KINDInt, Rank::scalarIfDim, IntrinsicClass::inquiryFunction}, 997 {"uint", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND}, 998 KINDUnsigned}, 999 {"umaskl", {{"i", AnyInt}, DefaultingKIND}, KINDUnsigned}, 1000 {"umaskr", {{"i", AnyInt}, DefaultingKIND}, KINDUnsigned}, 1001 {"unpack", 1002 {{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array}, 1003 {"field", SameType, Rank::conformable}}, 1004 SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, 1005 {"verify", 1006 {{"string", SameCharNoLen}, {"set", SameCharNoLen}, 1007 {"back", AnyLogical, Rank::elemental, Optionality::optional}, 1008 DefaultingKIND}, 1009 KINDInt}, 1010 {"__builtin_compiler_options", {}, DefaultChar}, 1011 {"__builtin_compiler_version", {}, DefaultChar}, 1012 {"__builtin_fma", {{"f1", SameReal}, {"f2", SameReal}, {"f3", SameReal}}, 1013 SameReal}, 1014 {"__builtin_ieee_int", 1015 {{"a", AnyFloating}, {"round", IeeeRoundType}, DefaultingKIND}, 1016 KINDInt}, 1017 {"__builtin_ieee_is_nan", {{"a", AnyFloating}}, DefaultLogical}, 1018 {"__builtin_ieee_is_negative", {{"a", AnyFloating}}, DefaultLogical}, 1019 {"__builtin_ieee_is_normal", {{"a", AnyFloating}}, DefaultLogical}, 1020 {"__builtin_ieee_next_after", {{"x", SameReal}, {"y", AnyReal}}, SameReal}, 1021 {"__builtin_ieee_next_down", {{"x", SameReal}}, SameReal}, 1022 {"__builtin_ieee_next_up", {{"x", SameReal}}, SameReal}, 1023 {"__builtin_ieee_real", {{"a", AnyIntOrReal}, DefaultingKIND}, KINDReal}, 1024 {"__builtin_ieee_support_datatype", 1025 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1026 DefaultLogical}, 1027 {"__builtin_ieee_support_denormal", 1028 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1029 DefaultLogical}, 1030 {"__builtin_ieee_support_divide", 1031 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1032 DefaultLogical}, 1033 {"__builtin_ieee_support_flag", 1034 {{"flag", IeeeFlagType, Rank::scalar}, 1035 {"x", AnyReal, Rank::elemental, Optionality::optional}}, 1036 DefaultLogical}, 1037 {"__builtin_ieee_support_halting", {{"flag", IeeeFlagType, Rank::scalar}}, 1038 DefaultLogical}, 1039 {"__builtin_ieee_support_inf", 1040 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1041 DefaultLogical}, 1042 {"__builtin_ieee_support_io", 1043 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1044 DefaultLogical}, 1045 {"__builtin_ieee_support_nan", 1046 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1047 DefaultLogical}, 1048 {"__builtin_ieee_support_rounding", 1049 {{"round_value", IeeeRoundType, Rank::scalar}, 1050 {"x", AnyReal, Rank::elemental, Optionality::optional}}, 1051 DefaultLogical}, 1052 {"__builtin_ieee_support_sqrt", 1053 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1054 DefaultLogical}, 1055 {"__builtin_ieee_support_standard", 1056 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1057 DefaultLogical}, 1058 {"__builtin_ieee_support_subnormal", 1059 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1060 DefaultLogical}, 1061 {"__builtin_ieee_support_underflow_control", 1062 {{"x", AnyReal, Rank::elemental, Optionality::optional}}, 1063 DefaultLogical}, 1064 {"__builtin_numeric_storage_size", {}, DefaultInt}, 1065 }; 1066 1067 // TODO: Coarray intrinsic functions 1068 // COSHAPE 1069 // TODO: Non-standard intrinsic functions 1070 // SHIFT, 1071 // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, 1072 // QCMPLX, QEXT, QFLOAT, QREAL, DNUM, 1073 // INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, 1074 // MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR 1075 // IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, 1076 // EOF, FP_CLASS, INT_PTR_KIND, MALLOC 1077 // probably more (these are PGI + Intel, possibly incomplete) 1078 // TODO: Optionally warn on use of non-standard intrinsics: 1079 // LOC, probably others 1080 // TODO: Optionally warn on operand promotion extension 1081 1082 // Aliases for a few generic intrinsic functions for legacy 1083 // compatibility and builtins. 1084 static const std::pair<const char *, const char *> genericAlias[]{ 1085 {"and", "iand"}, 1086 {"getenv", "get_environment_variable"}, 1087 {"imag", "aimag"}, 1088 {"lshift", "shiftl"}, 1089 {"or", "ior"}, 1090 {"rshift", "shifta"}, 1091 {"unsigned", "uint"}, // Sun vs gfortran names 1092 {"xor", "ieor"}, 1093 {"__builtin_ieee_selected_real_kind", "selected_real_kind"}, 1094 }; 1095 1096 // The following table contains the intrinsic functions listed in 1097 // Tables 16.2 and 16.3 in Fortran 2018. The "unrestricted" functions 1098 // in Table 16.2 can be used as actual arguments, PROCEDURE() interfaces, 1099 // and procedure pointer targets. 1100 // Note that the restricted conversion functions dcmplx, dreal, float, idint, 1101 // ifix, and sngl are extended to accept any argument kind because this is a 1102 // common Fortran compilers behavior, and as far as we can tell, is safe and 1103 // useful. 1104 struct SpecificIntrinsicInterface : public IntrinsicInterface { 1105 const char *generic{nullptr}; 1106 bool isRestrictedSpecific{false}; 1107 // Exact actual/dummy type matching is required by default for specific 1108 // intrinsics. If useGenericAndForceResultType is set, then the probing will 1109 // also attempt to use the related generic intrinsic and to convert the result 1110 // to the specific intrinsic result type if needed. This also prevents 1111 // using the generic name so that folding can insert the conversion on the 1112 // result and not the arguments. 1113 // 1114 // This is not enabled on all specific intrinsics because an alternative 1115 // is to convert the actual arguments to the required dummy types and this is 1116 // not numerically equivalent. 1117 // e.g. IABS(INT(i, 4)) not equiv to INT(ABS(i), 4). 1118 // This is allowed for restricted min/max specific functions because 1119 // the expected behavior is clear from their definitions. A warning is though 1120 // always emitted because other compilers' behavior is not ubiquitous here and 1121 // the results in case of conversion overflow might not be equivalent. 1122 // e.g for MIN0: INT(MIN(2147483647_8, 2*2147483647_8), 4) = 2147483647_4 1123 // but: MIN(INT(2147483647_8, 4), INT(2*2147483647_8, 4)) = -2_4 1124 // xlf and ifort return the first, and pgfortran the later. f18 will return 1125 // the first because this matches more closely the MIN0 definition in 1126 // Fortran 2018 table 16.3 (although it is still an extension to allow 1127 // non default integer argument in MIN0). 1128 bool useGenericAndForceResultType{false}; 1129 }; 1130 1131 static const SpecificIntrinsicInterface specificIntrinsicFunction[]{ 1132 {{"abs", {{"a", DefaultReal}}, DefaultReal}}, 1133 {{"acos", {{"x", DefaultReal}}, DefaultReal}}, 1134 {{"aimag", {{"z", DefaultComplex}}, DefaultReal}}, 1135 {{"aint", {{"a", DefaultReal}}, DefaultReal}}, 1136 {{"alog", {{"x", DefaultReal}}, DefaultReal}, "log"}, 1137 {{"alog10", {{"x", DefaultReal}}, DefaultReal}, "log10"}, 1138 {{"amax0", 1139 {{"a1", DefaultInt}, {"a2", DefaultInt}, 1140 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 1141 DefaultReal}, 1142 "max", true, true}, 1143 {{"amax1", 1144 {{"a1", DefaultReal}, {"a2", DefaultReal}, 1145 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 1146 DefaultReal}, 1147 "max", true, true}, 1148 {{"amin0", 1149 {{"a1", DefaultInt}, {"a2", DefaultInt}, 1150 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 1151 DefaultReal}, 1152 "min", true, true}, 1153 {{"amin1", 1154 {{"a1", DefaultReal}, {"a2", DefaultReal}, 1155 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 1156 DefaultReal}, 1157 "min", true, true}, 1158 {{"amod", {{"a", DefaultReal}, {"p", DefaultReal}}, DefaultReal}, "mod"}, 1159 {{"anint", {{"a", DefaultReal}}, DefaultReal}}, 1160 {{"asin", {{"x", DefaultReal}}, DefaultReal}}, 1161 {{"atan", {{"x", DefaultReal}}, DefaultReal}}, 1162 {{"atan2", {{"y", DefaultReal}, {"x", DefaultReal}}, DefaultReal}}, 1163 {{"babs", {{"a", TypePattern{IntType, KindCode::exactKind, 1}}}, 1164 TypePattern{IntType, KindCode::exactKind, 1}}, 1165 "abs"}, 1166 {{"cabs", {{"a", DefaultComplex}}, DefaultReal}, "abs"}, 1167 {{"ccos", {{"x", DefaultComplex}}, DefaultComplex}, "cos"}, 1168 {{"cdabs", {{"a", DoublePrecisionComplex}}, DoublePrecision}, "abs"}, 1169 {{"cdcos", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "cos"}, 1170 {{"cdexp", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "exp"}, 1171 {{"cdlog", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "log"}, 1172 {{"cdsin", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "sin"}, 1173 {{"cdsqrt", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, 1174 "sqrt"}, 1175 {{"cexp", {{"x", DefaultComplex}}, DefaultComplex}, "exp"}, 1176 {{"clog", {{"x", DefaultComplex}}, DefaultComplex}, "log"}, 1177 {{"conjg", {{"z", DefaultComplex}}, DefaultComplex}}, 1178 {{"cos", {{"x", DefaultReal}}, DefaultReal}}, 1179 {{"cosh", {{"x", DefaultReal}}, DefaultReal}}, 1180 {{"csin", {{"x", DefaultComplex}}, DefaultComplex}, "sin"}, 1181 {{"csqrt", {{"x", DefaultComplex}}, DefaultComplex}, "sqrt"}, 1182 {{"ctan", {{"x", DefaultComplex}}, DefaultComplex}, "tan"}, 1183 {{"dabs", {{"a", DoublePrecision}}, DoublePrecision}, "abs"}, 1184 {{"dacos", {{"x", DoublePrecision}}, DoublePrecision}, "acos"}, 1185 {{"dasin", {{"x", DoublePrecision}}, DoublePrecision}, "asin"}, 1186 {{"datan", {{"x", DoublePrecision}}, DoublePrecision}, "atan"}, 1187 {{"datan2", {{"y", DoublePrecision}, {"x", DoublePrecision}}, 1188 DoublePrecision}, 1189 "atan2"}, 1190 {{"dcmplx", {{"x", AnyComplex}}, DoublePrecisionComplex}, "cmplx", true}, 1191 {{"dcmplx", 1192 {{"x", AnyIntOrReal, Rank::elementalOrBOZ}, 1193 {"y", AnyIntOrReal, Rank::elementalOrBOZ, Optionality::optional}}, 1194 DoublePrecisionComplex}, 1195 "cmplx", true}, 1196 {{"dconjg", {{"z", DoublePrecisionComplex}}, DoublePrecisionComplex}, 1197 "conjg"}, 1198 {{"dcos", {{"x", DoublePrecision}}, DoublePrecision}, "cos"}, 1199 {{"dcosh", {{"x", DoublePrecision}}, DoublePrecision}, "cosh"}, 1200 {{"ddim", {{"x", DoublePrecision}, {"y", DoublePrecision}}, 1201 DoublePrecision}, 1202 "dim"}, 1203 {{"derf", {{"x", DoublePrecision}}, DoublePrecision}, "erf"}, 1204 {{"dexp", {{"x", DoublePrecision}}, DoublePrecision}, "exp"}, 1205 {{"dfloat", {{"a", AnyInt}}, DoublePrecision}, "real", true}, 1206 {{"dim", {{"x", DefaultReal}, {"y", DefaultReal}}, DefaultReal}}, 1207 {{"dimag", {{"z", DoublePrecisionComplex}}, DoublePrecision}, "aimag"}, 1208 {{"dint", {{"a", DoublePrecision}}, DoublePrecision}, "aint"}, 1209 {{"dlog", {{"x", DoublePrecision}}, DoublePrecision}, "log"}, 1210 {{"dlog10", {{"x", DoublePrecision}}, DoublePrecision}, "log10"}, 1211 {{"dmax1", 1212 {{"a1", DoublePrecision}, {"a2", DoublePrecision}, 1213 {"a3", DoublePrecision, Rank::elemental, Optionality::repeats}}, 1214 DoublePrecision}, 1215 "max", true, true}, 1216 {{"dmin1", 1217 {{"a1", DoublePrecision}, {"a2", DoublePrecision}, 1218 {"a3", DoublePrecision, Rank::elemental, Optionality::repeats}}, 1219 DoublePrecision}, 1220 "min", true, true}, 1221 {{"dmod", {{"a", DoublePrecision}, {"p", DoublePrecision}}, 1222 DoublePrecision}, 1223 "mod"}, 1224 {{"dnint", {{"a", DoublePrecision}}, DoublePrecision}, "anint"}, 1225 {{"dprod", {{"x", DefaultReal}, {"y", DefaultReal}}, DoublePrecision}}, 1226 {{"dreal", {{"a", AnyComplex}}, DoublePrecision}, "real", true}, 1227 {{"dsign", {{"a", DoublePrecision}, {"b", DoublePrecision}}, 1228 DoublePrecision}, 1229 "sign"}, 1230 {{"dsin", {{"x", DoublePrecision}}, DoublePrecision}, "sin"}, 1231 {{"dsinh", {{"x", DoublePrecision}}, DoublePrecision}, "sinh"}, 1232 {{"dsqrt", {{"x", DoublePrecision}}, DoublePrecision}, "sqrt"}, 1233 {{"dtan", {{"x", DoublePrecision}}, DoublePrecision}, "tan"}, 1234 {{"dtanh", {{"x", DoublePrecision}}, DoublePrecision}, "tanh"}, 1235 {{"exp", {{"x", DefaultReal}}, DefaultReal}}, 1236 {{"float", {{"a", AnyInt}}, DefaultReal}, "real", true}, 1237 {{"iabs", {{"a", DefaultInt}}, DefaultInt}, "abs"}, 1238 {{"idim", {{"x", DefaultInt}, {"y", DefaultInt}}, DefaultInt}, "dim"}, 1239 {{"idint", {{"a", AnyReal}}, DefaultInt}, "int", true}, 1240 {{"idnint", {{"a", DoublePrecision}}, DefaultInt}, "nint"}, 1241 {{"ifix", {{"a", AnyReal}}, DefaultInt}, "int", true}, 1242 {{"iiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 2}}}, 1243 TypePattern{IntType, KindCode::exactKind, 2}}, 1244 "abs"}, 1245 // The definition of the unrestricted specific intrinsic function INDEX 1246 // in F'77 and F'90 has only two arguments; later standards omit the 1247 // argument information for all unrestricted specific intrinsic 1248 // procedures. No compiler supports an implementation that allows 1249 // INDEX with BACK= to work when associated as an actual procedure or 1250 // procedure pointer target. 1251 {{"index", {{"string", DefaultChar}, {"substring", DefaultChar}}, 1252 DefaultInt}}, 1253 {{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"}, 1254 {{"jiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 4}}}, 1255 TypePattern{IntType, KindCode::exactKind, 4}}, 1256 "abs"}, 1257 {{"kiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 8}}}, 1258 TypePattern{IntType, KindCode::exactKind, 8}}, 1259 "abs"}, 1260 {{"kidnnt", {{"a", DoublePrecision}}, 1261 TypePattern{IntType, KindCode::exactKind, 8}}, 1262 "nint"}, 1263 {{"knint", {{"a", DefaultReal}}, 1264 TypePattern{IntType, KindCode::exactKind, 8}}, 1265 "nint"}, 1266 {{"len", {{"string", DefaultChar, Rank::anyOrAssumedRank}}, DefaultInt, 1267 Rank::scalar, IntrinsicClass::inquiryFunction}}, 1268 {{"lge", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1269 DefaultLogical}, 1270 "lge", true}, 1271 {{"lgt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1272 DefaultLogical}, 1273 "lgt", true}, 1274 {{"lle", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1275 DefaultLogical}, 1276 "lle", true}, 1277 {{"llt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}}, 1278 DefaultLogical}, 1279 "llt", true}, 1280 {{"log", {{"x", DefaultReal}}, DefaultReal}}, 1281 {{"log10", {{"x", DefaultReal}}, DefaultReal}}, 1282 {{"max0", 1283 {{"a1", DefaultInt}, {"a2", DefaultInt}, 1284 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 1285 DefaultInt}, 1286 "max", true, true}, 1287 {{"max1", 1288 {{"a1", DefaultReal}, {"a2", DefaultReal}, 1289 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 1290 DefaultInt}, 1291 "max", true, true}, 1292 {{"min0", 1293 {{"a1", DefaultInt}, {"a2", DefaultInt}, 1294 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}}, 1295 DefaultInt}, 1296 "min", true, true}, 1297 {{"min1", 1298 {{"a1", DefaultReal}, {"a2", DefaultReal}, 1299 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}}, 1300 DefaultInt}, 1301 "min", true, true}, 1302 {{"mod", {{"a", DefaultInt}, {"p", DefaultInt}}, DefaultInt}}, 1303 {{"nint", {{"a", DefaultReal}}, DefaultInt}}, 1304 {{"sign", {{"a", DefaultReal}, {"b", DefaultReal}}, DefaultReal}}, 1305 {{"sin", {{"x", DefaultReal}}, DefaultReal}}, 1306 {{"sinh", {{"x", DefaultReal}}, DefaultReal}}, 1307 {{"sngl", {{"a", AnyReal}}, DefaultReal}, "real", true}, 1308 {{"sqrt", {{"x", DefaultReal}}, DefaultReal}}, 1309 {{"tan", {{"x", DefaultReal}}, DefaultReal}}, 1310 {{"tanh", {{"x", DefaultReal}}, DefaultReal}}, 1311 {{"zabs", {{"a", TypePattern{ComplexType, KindCode::exactKind, 8}}}, 1312 TypePattern{RealType, KindCode::exactKind, 8}}, 1313 "abs"}, 1314 }; 1315 1316 static const IntrinsicInterface intrinsicSubroutine[]{ 1317 {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1318 {"atomic_add", 1319 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1320 common::Intent::InOut}, 1321 {"value", AnyInt, Rank::scalar, Optionality::required, 1322 common::Intent::In}, 1323 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1324 common::Intent::Out}}, 1325 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1326 {"atomic_and", 1327 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1328 common::Intent::InOut}, 1329 {"value", AnyInt, Rank::scalar, Optionality::required, 1330 common::Intent::In}, 1331 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1332 common::Intent::Out}}, 1333 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1334 {"atomic_cas", 1335 {{"atom", SameAtom, Rank::atom, Optionality::required, 1336 common::Intent::InOut}, 1337 {"old", SameAtom, Rank::scalar, Optionality::required, 1338 common::Intent::Out}, 1339 {"compare", SameAtom, Rank::scalar, Optionality::required, 1340 common::Intent::In}, 1341 {"new", SameAtom, Rank::scalar, Optionality::required, 1342 common::Intent::In}, 1343 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1344 common::Intent::Out}}, 1345 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1346 {"atomic_define", 1347 {{"atom", AtomicIntOrLogical, Rank::atom, Optionality::required, 1348 common::Intent::Out}, 1349 {"value", AnyIntOrLogical, Rank::scalar, Optionality::required, 1350 common::Intent::In}, 1351 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1352 common::Intent::Out}}, 1353 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1354 {"atomic_fetch_add", 1355 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1356 common::Intent::InOut}, 1357 {"value", AnyInt, Rank::scalar, Optionality::required, 1358 common::Intent::In}, 1359 {"old", AtomicInt, Rank::scalar, Optionality::required, 1360 common::Intent::Out}, 1361 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1362 common::Intent::Out}}, 1363 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1364 {"atomic_fetch_and", 1365 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1366 common::Intent::InOut}, 1367 {"value", AnyInt, Rank::scalar, Optionality::required, 1368 common::Intent::In}, 1369 {"old", AtomicInt, Rank::scalar, Optionality::required, 1370 common::Intent::Out}, 1371 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1372 common::Intent::Out}}, 1373 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1374 {"atomic_fetch_or", 1375 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1376 common::Intent::InOut}, 1377 {"value", AnyInt, Rank::scalar, Optionality::required, 1378 common::Intent::In}, 1379 {"old", AtomicInt, Rank::scalar, Optionality::required, 1380 common::Intent::Out}, 1381 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1382 common::Intent::Out}}, 1383 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1384 {"atomic_fetch_xor", 1385 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1386 common::Intent::InOut}, 1387 {"value", AnyInt, Rank::scalar, Optionality::required, 1388 common::Intent::In}, 1389 {"old", AtomicInt, Rank::scalar, Optionality::required, 1390 common::Intent::Out}, 1391 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1392 common::Intent::Out}}, 1393 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1394 {"atomic_or", 1395 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1396 common::Intent::InOut}, 1397 {"value", AnyInt, Rank::scalar, Optionality::required, 1398 common::Intent::In}, 1399 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1400 common::Intent::Out}}, 1401 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1402 {"atomic_ref", 1403 {{"value", AnyIntOrLogical, Rank::scalar, Optionality::required, 1404 common::Intent::Out}, 1405 {"atom", AtomicIntOrLogical, Rank::atom, Optionality::required, 1406 common::Intent::In}, 1407 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1408 common::Intent::Out}}, 1409 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1410 {"atomic_xor", 1411 {{"atom", AtomicInt, Rank::atom, Optionality::required, 1412 common::Intent::InOut}, 1413 {"value", AnyInt, Rank::scalar, Optionality::required, 1414 common::Intent::In}, 1415 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1416 common::Intent::Out}}, 1417 {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, 1418 {"chdir", 1419 {{"name", DefaultChar, Rank::scalar, Optionality::required}, 1420 {"status", AnyInt, Rank::scalar, Optionality::optional, 1421 common::Intent::Out}}, 1422 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1423 {"co_broadcast", 1424 {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required, 1425 common::Intent::InOut}, 1426 {"source_image", AnyInt, Rank::scalar, Optionality::required, 1427 common::Intent::In}, 1428 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1429 common::Intent::Out}, 1430 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1431 common::Intent::InOut}}, 1432 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, 1433 {"co_max", 1434 {{"a", AnyIntOrRealOrChar, Rank::anyOrAssumedRank, 1435 Optionality::required, common::Intent::InOut}, 1436 {"result_image", AnyInt, Rank::scalar, Optionality::optional, 1437 common::Intent::In}, 1438 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1439 common::Intent::Out}, 1440 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1441 common::Intent::InOut}}, 1442 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, 1443 {"co_min", 1444 {{"a", AnyIntOrRealOrChar, Rank::anyOrAssumedRank, 1445 Optionality::required, common::Intent::InOut}, 1446 {"result_image", AnyInt, Rank::scalar, Optionality::optional, 1447 common::Intent::In}, 1448 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1449 common::Intent::Out}, 1450 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1451 common::Intent::InOut}}, 1452 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, 1453 {"co_sum", 1454 {{"a", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required, 1455 common::Intent::InOut}, 1456 {"result_image", AnyInt, Rank::scalar, Optionality::optional, 1457 common::Intent::In}, 1458 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1459 common::Intent::Out}, 1460 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1461 common::Intent::InOut}}, 1462 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, 1463 {"cpu_time", 1464 {{"time", AnyReal, Rank::scalar, Optionality::required, 1465 common::Intent::Out}}, 1466 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1467 {"date_and_time", 1468 {{"date", DefaultChar, Rank::scalar, Optionality::optional, 1469 common::Intent::Out}, 1470 {"time", DefaultChar, Rank::scalar, Optionality::optional, 1471 common::Intent::Out}, 1472 {"zone", DefaultChar, Rank::scalar, Optionality::optional, 1473 common::Intent::Out}, 1474 {"values", AnyInt, Rank::vector, Optionality::optional, 1475 common::Intent::Out}}, 1476 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1477 {"etime", 1478 {{"values", TypePattern{RealType, KindCode::exactKind, 4}, Rank::vector, 1479 Optionality::required, common::Intent::Out}, 1480 {"time", TypePattern{RealType, KindCode::exactKind, 4}, 1481 Rank::scalar, Optionality::required, common::Intent::Out}}, 1482 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1483 {"event_query", 1484 {{"event", EventType, Rank::scalar}, 1485 {"count", AnyInt, Rank::scalar, Optionality::required, 1486 common::Intent::Out}, 1487 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1488 common::Intent::Out}}, 1489 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1490 {"execute_command_line", 1491 {{"command", DefaultChar, Rank::scalar}, 1492 {"wait", AnyLogical, Rank::scalar, Optionality::optional}, 1493 {"exitstat", 1494 TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}, 1495 Rank::scalar, Optionality::optional, common::Intent::InOut}, 1496 {"cmdstat", TypePattern{IntType, KindCode::greaterOrEqualToKind, 2}, 1497 Rank::scalar, Optionality::optional, common::Intent::Out}, 1498 {"cmdmsg", DefaultChar, Rank::scalar, Optionality::optional, 1499 common::Intent::InOut}}, 1500 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1501 {"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {}, 1502 Rank::elemental, IntrinsicClass::impureSubroutine}, 1503 {"free", {{"ptr", Addressable}}, {}}, 1504 {"get_command", 1505 {{"command", DefaultChar, Rank::scalar, Optionality::optional, 1506 common::Intent::Out}, 1507 {"length", AnyInt, Rank::scalar, Optionality::optional, 1508 common::Intent::Out}, 1509 {"status", AnyInt, Rank::scalar, Optionality::optional, 1510 common::Intent::Out}, 1511 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1512 common::Intent::InOut}}, 1513 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1514 {"get_command_argument", 1515 {{"number", AnyInt, Rank::scalar}, 1516 {"value", DefaultChar, Rank::scalar, Optionality::optional, 1517 common::Intent::Out}, 1518 {"length", AnyInt, Rank::scalar, Optionality::optional, 1519 common::Intent::Out}, 1520 {"status", AnyInt, Rank::scalar, Optionality::optional, 1521 common::Intent::Out}, 1522 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1523 common::Intent::InOut}}, 1524 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1525 {"get_environment_variable", 1526 {{"name", DefaultChar, Rank::scalar}, 1527 {"value", DefaultChar, Rank::scalar, Optionality::optional, 1528 common::Intent::Out}, 1529 {"length", AnyInt, Rank::scalar, Optionality::optional, 1530 common::Intent::Out}, 1531 {"status", AnyInt, Rank::scalar, Optionality::optional, 1532 common::Intent::Out}, 1533 {"trim_name", AnyLogical, Rank::scalar, Optionality::optional}, 1534 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1535 common::Intent::InOut}}, 1536 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1537 {"getcwd", 1538 {{"c", DefaultChar, Rank::scalar, Optionality::required, 1539 common::Intent::Out}, 1540 {"status", TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}, 1541 Rank::scalar, Optionality::optional, common::Intent::Out}}, 1542 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1543 {"move_alloc", 1544 {{"from", SameType, Rank::known, Optionality::required, 1545 common::Intent::InOut}, 1546 {"to", SameType, Rank::known, Optionality::required, 1547 common::Intent::Out}, 1548 {"stat", AnyInt, Rank::scalar, Optionality::optional, 1549 common::Intent::Out}, 1550 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, 1551 common::Intent::InOut}}, 1552 {}, Rank::elemental, IntrinsicClass::pureSubroutine}, 1553 {"mvbits", 1554 {{"from", SameIntOrUnsigned}, {"frompos", AnyInt}, {"len", AnyInt}, 1555 {"to", SameIntOrUnsigned, Rank::elemental, Optionality::required, 1556 common::Intent::Out}, 1557 {"topos", AnyInt}}, 1558 {}, Rank::elemental, IntrinsicClass::elementalSubroutine}, // elemental 1559 {"random_init", 1560 {{"repeatable", AnyLogical, Rank::scalar}, 1561 {"image_distinct", AnyLogical, Rank::scalar}}, 1562 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1563 {"random_number", 1564 {{"harvest", {RealType | UnsignedType, KindCode::any}, Rank::known, 1565 Optionality::required, common::Intent::Out, 1566 {ArgFlag::notAssumedSize}}}, 1567 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1568 {"random_seed", 1569 {{"size", DefaultInt, Rank::scalar, Optionality::optional, 1570 common::Intent::Out}, 1571 {"put", DefaultInt, Rank::vector, Optionality::optional}, 1572 {"get", DefaultInt, Rank::vector, Optionality::optional, 1573 common::Intent::Out}}, 1574 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1575 {"rename", 1576 {{"path1", DefaultChar, Rank::scalar}, 1577 {"path2", DefaultChar, Rank::scalar}, 1578 {"status", DefaultInt, Rank::scalar, Optionality::optional, 1579 common::Intent::Out}}, 1580 {}, Rank::scalar, IntrinsicClass::impureSubroutine}, 1581 {"second", {{"time", DefaultReal, Rank::scalar}}, {}, Rank::scalar, 1582 IntrinsicClass::impureSubroutine}, 1583 {"system", 1584 {{"command", DefaultChar, Rank::scalar}, 1585 {"exitstat", DefaultInt, Rank::scalar, Optionality::optional, 1586 common::Intent::Out}}, 1587 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1588 {"system_clock", 1589 {{"count", AnyInt, Rank::scalar, Optionality::optional, 1590 common::Intent::Out}, 1591 {"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional, 1592 common::Intent::Out}, 1593 {"count_max", AnyInt, Rank::scalar, Optionality::optional, 1594 common::Intent::Out}}, 1595 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1596 {"signal", 1597 {{"number", AnyInt, Rank::scalar, Optionality::required, 1598 common::Intent::In}, 1599 // note: any pointer also accepts AnyInt 1600 {"handler", AnyPointer, Rank::scalar, Optionality::required, 1601 common::Intent::In}, 1602 {"status", AnyInt, Rank::scalar, Optionality::optional, 1603 common::Intent::Out}}, 1604 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1605 {"sleep", 1606 {{"seconds", AnyInt, Rank::scalar, Optionality::required, 1607 common::Intent::In}}, 1608 {}, Rank::elemental, IntrinsicClass::impureSubroutine}, 1609 }; 1610 1611 // TODO: Collective intrinsic subroutines: co_reduce 1612 1613 // Finds a built-in derived type and returns it as a DynamicType. 1614 static DynamicType GetBuiltinDerivedType( 1615 const semantics::Scope *builtinsScope, const char *which) { 1616 if (!builtinsScope) { 1617 common::die("INTERNAL: The __fortran_builtins module was not found, and " 1618 "the type '%s' was required", 1619 which); 1620 } 1621 auto iter{ 1622 builtinsScope->find(semantics::SourceName{which, std::strlen(which)})}; 1623 if (iter == builtinsScope->cend()) { 1624 // keep the string all together 1625 // clang-format off 1626 common::die( 1627 "INTERNAL: The __fortran_builtins module does not define the type '%s'", 1628 which); 1629 // clang-format on 1630 } 1631 const semantics::Symbol &symbol{*iter->second}; 1632 const semantics::Scope &scope{DEREF(symbol.scope())}; 1633 const semantics::DerivedTypeSpec &derived{DEREF(scope.derivedTypeSpec())}; 1634 return DynamicType{derived}; 1635 } 1636 1637 static std::int64_t GetBuiltinKind( 1638 const semantics::Scope *builtinsScope, const char *which) { 1639 if (!builtinsScope) { 1640 common::die("INTERNAL: The __fortran_builtins module was not found, and " 1641 "the kind '%s' was required", 1642 which); 1643 } 1644 auto iter{ 1645 builtinsScope->find(semantics::SourceName{which, std::strlen(which)})}; 1646 if (iter == builtinsScope->cend()) { 1647 common::die( 1648 "INTERNAL: The __fortran_builtins module does not define the kind '%s'", 1649 which); 1650 } 1651 const semantics::Symbol &symbol{*iter->second}; 1652 const auto &details{ 1653 DEREF(symbol.detailsIf<semantics::ObjectEntityDetails>())}; 1654 if (const auto kind{ToInt64(details.init())}) { 1655 return *kind; 1656 } else { 1657 common::die( 1658 "INTERNAL: The __fortran_builtins module does not define the kind '%s'", 1659 which); 1660 return -1; 1661 } 1662 } 1663 1664 // Ensure that the keywords of arguments to MAX/MIN and their variants 1665 // are of the form A123 with no duplicates or leading zeroes. 1666 static bool CheckMaxMinArgument(parser::CharBlock keyword, 1667 std::set<parser::CharBlock> &set, const char *intrinsicName, 1668 parser::ContextualMessages &messages) { 1669 std::size_t j{1}; 1670 for (; j < keyword.size(); ++j) { 1671 char ch{(keyword)[j]}; 1672 if (ch < (j == 1 ? '1' : '0') || ch > '9') { 1673 break; 1674 } 1675 } 1676 if (keyword.size() < 2 || (keyword)[0] != 'a' || j < keyword.size()) { 1677 messages.Say(keyword, 1678 "argument keyword '%s=' is not known in call to '%s'"_err_en_US, 1679 keyword, intrinsicName); 1680 return false; 1681 } 1682 if (!set.insert(keyword).second) { 1683 messages.Say(keyword, 1684 "argument keyword '%s=' was repeated in call to '%s'"_err_en_US, 1685 keyword, intrinsicName); 1686 return false; 1687 } 1688 return true; 1689 } 1690 1691 // Validate the keyword, if any, and ensure that A1 and A2 are always placed in 1692 // first and second position in actualForDummy. A1 and A2 are special since they 1693 // are not optional. The rest of the arguments are not sorted, there are no 1694 // differences between them. 1695 static bool CheckAndPushMinMaxArgument(ActualArgument &arg, 1696 std::vector<ActualArgument *> &actualForDummy, 1697 std::set<parser::CharBlock> &set, const char *intrinsicName, 1698 parser::ContextualMessages &messages) { 1699 if (std::optional<parser::CharBlock> keyword{arg.keyword()}) { 1700 if (!CheckMaxMinArgument(*keyword, set, intrinsicName, messages)) { 1701 return false; 1702 } 1703 const bool isA1{*keyword == parser::CharBlock{"a1", 2}}; 1704 if (isA1 && !actualForDummy[0]) { 1705 actualForDummy[0] = &arg; 1706 return true; 1707 } 1708 const bool isA2{*keyword == parser::CharBlock{"a2", 2}}; 1709 if (isA2 && !actualForDummy[1]) { 1710 actualForDummy[1] = &arg; 1711 return true; 1712 } 1713 if (isA1 || isA2) { 1714 // Note that for arguments other than a1 and a2, this error will be caught 1715 // later in check-call.cpp. 1716 messages.Say(*keyword, 1717 "keyword argument '%s=' to intrinsic '%s' was supplied " 1718 "positionally by an earlier actual argument"_err_en_US, 1719 *keyword, intrinsicName); 1720 return false; 1721 } 1722 } else { 1723 if (actualForDummy.size() == 2) { 1724 if (!actualForDummy[0] && !actualForDummy[1]) { 1725 actualForDummy[0] = &arg; 1726 return true; 1727 } else if (!actualForDummy[1]) { 1728 actualForDummy[1] = &arg; 1729 return true; 1730 } 1731 } 1732 } 1733 actualForDummy.push_back(&arg); 1734 return true; 1735 } 1736 1737 static bool CheckAtomicKind(const ActualArgument &arg, 1738 const semantics::Scope *builtinsScope, parser::ContextualMessages &messages, 1739 const char *keyword) { 1740 std::string atomicKindStr; 1741 std::optional<DynamicType> type{arg.GetType()}; 1742 1743 if (type->category() == TypeCategory::Integer) { 1744 atomicKindStr = "atomic_int_kind"; 1745 } else if (type->category() == TypeCategory::Logical) { 1746 atomicKindStr = "atomic_logical_kind"; 1747 } else { 1748 common::die("atomic_int_kind or atomic_logical_kind from iso_fortran_env " 1749 "must be used with IntType or LogicalType"); 1750 } 1751 1752 bool argOk{type->kind() == 1753 GetBuiltinKind(builtinsScope, ("__builtin_" + atomicKindStr).c_str())}; 1754 if (!argOk) { 1755 messages.Say(arg.sourceLocation(), 1756 "Actual argument for '%s=' must have kind=atomic_%s_kind, but is '%s'"_err_en_US, 1757 keyword, type->category() == TypeCategory::Integer ? "int" : "logical", 1758 type->AsFortran()); 1759 } 1760 return argOk; 1761 } 1762 1763 // Intrinsic interface matching against the arguments of a particular 1764 // procedure reference. 1765 std::optional<SpecificCall> IntrinsicInterface::Match( 1766 const CallCharacteristics &call, 1767 const common::IntrinsicTypeDefaultKinds &defaults, 1768 ActualArguments &arguments, FoldingContext &context, 1769 const semantics::Scope *builtinsScope) const { 1770 auto &messages{context.messages()}; 1771 // Attempt to construct a 1-1 correspondence between the dummy arguments in 1772 // a particular intrinsic procedure's generic interface and the actual 1773 // arguments in a procedure reference. 1774 std::size_t dummyArgPatterns{0}; 1775 for (; dummyArgPatterns < maxArguments && dummy[dummyArgPatterns].keyword; 1776 ++dummyArgPatterns) { 1777 } 1778 // MAX and MIN (and others that map to them) allow their last argument to 1779 // be repeated indefinitely. The actualForDummy vector is sized 1780 // and null-initialized to the non-repeated dummy argument count 1781 // for other intrinsics. 1782 bool isMaxMin{dummyArgPatterns > 0 && 1783 dummy[dummyArgPatterns - 1].optionality == Optionality::repeats}; 1784 std::vector<ActualArgument *> actualForDummy( 1785 isMaxMin ? 2 : dummyArgPatterns, nullptr); 1786 bool anyMissingActualArgument{false}; 1787 std::set<parser::CharBlock> maxMinKeywords; 1788 bool anyKeyword{false}; 1789 int which{0}; 1790 for (std::optional<ActualArgument> &arg : arguments) { 1791 ++which; 1792 if (arg) { 1793 if (arg->isAlternateReturn()) { 1794 messages.Say(arg->sourceLocation(), 1795 "alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US, 1796 name); 1797 return std::nullopt; 1798 } 1799 if (arg->keyword()) { 1800 anyKeyword = true; 1801 } else if (anyKeyword) { 1802 messages.Say(arg ? arg->sourceLocation() : std::nullopt, 1803 "actual argument #%d without a keyword may not follow an actual argument with a keyword"_err_en_US, 1804 which); 1805 return std::nullopt; 1806 } 1807 } else { 1808 anyMissingActualArgument = true; 1809 continue; 1810 } 1811 if (isMaxMin) { 1812 if (!CheckAndPushMinMaxArgument( 1813 *arg, actualForDummy, maxMinKeywords, name, messages)) { 1814 return std::nullopt; 1815 } 1816 } else { 1817 bool found{false}; 1818 for (std::size_t j{0}; j < dummyArgPatterns && !found; ++j) { 1819 if (dummy[j].optionality == Optionality::missing) { 1820 continue; 1821 } 1822 if (arg->keyword()) { 1823 found = *arg->keyword() == dummy[j].keyword; 1824 if (found) { 1825 if (const auto *previous{actualForDummy[j]}) { 1826 if (previous->keyword()) { 1827 messages.Say(*arg->keyword(), 1828 "repeated keyword argument to intrinsic '%s'"_err_en_US, 1829 name); 1830 } else { 1831 messages.Say(*arg->keyword(), 1832 "keyword argument to intrinsic '%s' was supplied " 1833 "positionally by an earlier actual argument"_err_en_US, 1834 name); 1835 } 1836 return std::nullopt; 1837 } 1838 } 1839 } else { 1840 found = !actualForDummy[j] && !anyMissingActualArgument; 1841 } 1842 if (found) { 1843 actualForDummy[j] = &*arg; 1844 } 1845 } 1846 if (!found) { 1847 if (arg->keyword()) { 1848 messages.Say(*arg->keyword(), 1849 "unknown keyword argument to intrinsic '%s'"_err_en_US, name); 1850 } else { 1851 messages.Say( 1852 "too many actual arguments for intrinsic '%s'"_err_en_US, name); 1853 } 1854 return std::nullopt; 1855 } 1856 } 1857 } 1858 1859 std::size_t dummies{actualForDummy.size()}; 1860 1861 // Check types and kinds of the actual arguments against the intrinsic's 1862 // interface. Ensure that two or more arguments that have to have the same 1863 // (or compatible) type and kind do so. Check for missing non-optional 1864 // arguments now, too. 1865 const ActualArgument *sameArg{nullptr}; 1866 const ActualArgument *operandArg{nullptr}; 1867 const IntrinsicDummyArgument *kindDummyArg{nullptr}; 1868 const ActualArgument *kindArg{nullptr}; 1869 std::optional<int> dimArg; 1870 for (std::size_t j{0}; j < dummies; ++j) { 1871 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; 1872 if (d.typePattern.kindCode == KindCode::kindArg) { 1873 CHECK(!kindDummyArg); 1874 kindDummyArg = &d; 1875 } 1876 const ActualArgument *arg{actualForDummy[j]}; 1877 if (!arg) { 1878 if (d.optionality == Optionality::required) { 1879 std::string kw{d.keyword}; 1880 if (isMaxMin && !actualForDummy[0] && !actualForDummy[1]) { 1881 messages.Say("missing mandatory 'a1=' and 'a2=' arguments"_err_en_US); 1882 } else { 1883 messages.Say( 1884 "missing mandatory '%s=' argument"_err_en_US, kw.c_str()); 1885 } 1886 return std::nullopt; // missing non-OPTIONAL argument 1887 } else { 1888 continue; 1889 } 1890 } 1891 if (d.optionality == Optionality::missing) { 1892 messages.Say(arg->sourceLocation(), "unexpected '%s=' argument"_err_en_US, 1893 d.keyword); 1894 return std::nullopt; 1895 } 1896 if (!d.flags.test(ArgFlag::canBeNull)) { 1897 if (const auto *expr{arg->UnwrapExpr()}; expr && IsNullPointer(*expr)) { 1898 if (!IsBareNullPointer(expr) && IsNullObjectPointer(*expr) && 1899 d.flags.test(ArgFlag::canBeMoldNull)) { 1900 // ok 1901 } else { 1902 messages.Say(arg->sourceLocation(), 1903 "A NULL() pointer is not allowed for '%s=' intrinsic argument"_err_en_US, 1904 d.keyword); 1905 return std::nullopt; 1906 } 1907 } 1908 } 1909 if (d.flags.test(ArgFlag::notAssumedSize)) { 1910 if (auto named{ExtractNamedEntity(*arg)}) { 1911 if (semantics::IsAssumedSizeArray(named->GetLastSymbol())) { 1912 messages.Say(arg->sourceLocation(), 1913 "The '%s=' argument to the intrinsic procedure '%s' may not be assumed-size"_err_en_US, 1914 d.keyword, name); 1915 return std::nullopt; 1916 } 1917 } 1918 } 1919 if (arg->GetAssumedTypeDummy()) { 1920 // TYPE(*) assumed-type dummy argument forwarded to intrinsic 1921 if (d.typePattern.categorySet == AnyType && 1922 (d.rank == Rank::anyOrAssumedRank || 1923 d.rank == Rank::arrayOrAssumedRank) && 1924 (d.typePattern.kindCode == KindCode::any || 1925 d.typePattern.kindCode == KindCode::addressable)) { 1926 continue; 1927 } else { 1928 messages.Say(arg->sourceLocation(), 1929 "Assumed type TYPE(*) dummy argument not allowed for '%s=' intrinsic argument"_err_en_US, 1930 d.keyword); 1931 return std::nullopt; 1932 } 1933 } 1934 std::optional<DynamicType> type{arg->GetType()}; 1935 if (!type) { 1936 CHECK(arg->Rank() == 0); 1937 const Expr<SomeType> &expr{DEREF(arg->UnwrapExpr())}; 1938 if (IsBOZLiteral(expr)) { 1939 if (d.typePattern.kindCode == KindCode::typeless || 1940 d.rank == Rank::elementalOrBOZ) { 1941 continue; 1942 } else { 1943 const IntrinsicDummyArgument *nextParam{ 1944 j + 1 < dummies ? &dummy[j + 1] : nullptr}; 1945 if (nextParam && nextParam->rank == Rank::elementalOrBOZ) { 1946 messages.Say(arg->sourceLocation(), 1947 "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109 1948 d.keyword, nextParam->keyword); 1949 } else { 1950 messages.Say(arg->sourceLocation(), 1951 "Typeless (BOZ) not allowed for '%s=' argument"_err_en_US, 1952 d.keyword); 1953 } 1954 } 1955 } else { 1956 // NULL(no MOLD=), procedure, or procedure pointer 1957 CHECK(IsProcedurePointerTarget(expr)); 1958 if (d.typePattern.kindCode == KindCode::addressable || 1959 d.rank == Rank::reduceOperation) { 1960 continue; 1961 } else if (d.typePattern.kindCode == KindCode::nullPointerType) { 1962 continue; 1963 } else if (IsBareNullPointer(&expr)) { 1964 // checked elsewhere 1965 continue; 1966 } else { 1967 CHECK(IsProcedure(expr) || IsProcedurePointer(expr)); 1968 messages.Say(arg->sourceLocation(), 1969 "Actual argument for '%s=' may not be a procedure"_err_en_US, 1970 d.keyword); 1971 } 1972 } 1973 return std::nullopt; 1974 } else if (!d.typePattern.categorySet.test(type->category())) { 1975 messages.Say(arg->sourceLocation(), 1976 "Actual argument for '%s=' has bad type '%s'"_err_en_US, d.keyword, 1977 type->AsFortran()); 1978 return std::nullopt; // argument has invalid type category 1979 } 1980 bool argOk{false}; 1981 switch (d.typePattern.kindCode) { 1982 case KindCode::none: 1983 case KindCode::typeless: 1984 argOk = false; 1985 break; 1986 case KindCode::eventType: 1987 argOk = !type->IsUnlimitedPolymorphic() && 1988 type->category() == TypeCategory::Derived && 1989 semantics::IsEventType(&type->GetDerivedTypeSpec()); 1990 break; 1991 case KindCode::ieeeFlagType: 1992 argOk = !type->IsUnlimitedPolymorphic() && 1993 type->category() == TypeCategory::Derived && 1994 semantics::IsIeeeFlagType(&type->GetDerivedTypeSpec()); 1995 break; 1996 case KindCode::ieeeRoundType: 1997 argOk = !type->IsUnlimitedPolymorphic() && 1998 type->category() == TypeCategory::Derived && 1999 semantics::IsIeeeRoundType(&type->GetDerivedTypeSpec()); 2000 break; 2001 case KindCode::teamType: 2002 argOk = !type->IsUnlimitedPolymorphic() && 2003 type->category() == TypeCategory::Derived && 2004 semantics::IsTeamType(&type->GetDerivedTypeSpec()); 2005 break; 2006 case KindCode::defaultIntegerKind: 2007 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Integer); 2008 break; 2009 case KindCode::defaultRealKind: 2010 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Real); 2011 break; 2012 case KindCode::doublePrecision: 2013 argOk = type->kind() == defaults.doublePrecisionKind(); 2014 break; 2015 case KindCode::defaultCharKind: 2016 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Character); 2017 break; 2018 case KindCode::defaultLogicalKind: 2019 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Logical); 2020 break; 2021 case KindCode::any: 2022 argOk = true; 2023 break; 2024 case KindCode::kindArg: 2025 CHECK(type->category() == TypeCategory::Integer); 2026 CHECK(!kindArg); 2027 kindArg = arg; 2028 argOk = true; 2029 break; 2030 case KindCode::dimArg: 2031 CHECK(type->category() == TypeCategory::Integer); 2032 dimArg = j; 2033 argOk = true; 2034 break; 2035 case KindCode::same: { 2036 if (!sameArg) { 2037 sameArg = arg; 2038 } 2039 // Check both ways so that a CLASS(*) actuals to 2040 // MOVE_ALLOC and EOSHIFT both work. 2041 auto sameType{sameArg->GetType().value()}; 2042 argOk = sameType.IsTkLenCompatibleWith(*type) || 2043 type->IsTkLenCompatibleWith(sameType); 2044 } break; 2045 case KindCode::sameKind: 2046 if (!sameArg) { 2047 sameArg = arg; 2048 } 2049 argOk = type->IsTkCompatibleWith(sameArg->GetType().value()); 2050 break; 2051 case KindCode::operand: 2052 if (!operandArg) { 2053 operandArg = arg; 2054 } else if (auto prev{operandArg->GetType()}) { 2055 if (type->category() == prev->category()) { 2056 if (type->kind() > prev->kind()) { 2057 operandArg = arg; 2058 } 2059 } else if (prev->category() == TypeCategory::Integer) { 2060 operandArg = arg; 2061 } 2062 } 2063 argOk = true; 2064 break; 2065 case KindCode::effectiveKind: 2066 common::die("INTERNAL: KindCode::effectiveKind appears on argument '%s' " 2067 "for intrinsic '%s'", 2068 d.keyword, name); 2069 break; 2070 case KindCode::addressable: 2071 case KindCode::nullPointerType: 2072 argOk = true; 2073 break; 2074 case KindCode::exactKind: 2075 argOk = type->kind() == d.typePattern.kindValue; 2076 break; 2077 case KindCode::greaterOrEqualToKind: 2078 argOk = type->kind() >= d.typePattern.kindValue; 2079 break; 2080 case KindCode::sameAtom: 2081 if (!sameArg) { 2082 sameArg = arg; 2083 argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword); 2084 } else { 2085 argOk = type->IsTkCompatibleWith(sameArg->GetType().value()); 2086 if (!argOk) { 2087 messages.Say(arg->sourceLocation(), 2088 "Actual argument for '%s=' must have same type and kind as 'atom=', but is '%s'"_err_en_US, 2089 d.keyword, type->AsFortran()); 2090 } 2091 } 2092 if (!argOk) { 2093 return std::nullopt; 2094 } 2095 break; 2096 case KindCode::atomicIntKind: 2097 argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword); 2098 if (!argOk) { 2099 return std::nullopt; 2100 } 2101 break; 2102 case KindCode::atomicIntOrLogicalKind: 2103 argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword); 2104 if (!argOk) { 2105 return std::nullopt; 2106 } 2107 break; 2108 default: 2109 CRASH_NO_CASE; 2110 } 2111 if (!argOk) { 2112 messages.Say(arg->sourceLocation(), 2113 "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US, 2114 d.keyword, type->AsFortran()); 2115 return std::nullopt; 2116 } 2117 } 2118 2119 // Check the ranks of the arguments against the intrinsic's interface. 2120 const ActualArgument *arrayArg{nullptr}; 2121 const char *arrayArgName{nullptr}; 2122 const ActualArgument *knownArg{nullptr}; 2123 std::optional<std::int64_t> shapeArgSize; 2124 int elementalRank{0}; 2125 for (std::size_t j{0}; j < dummies; ++j) { 2126 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; 2127 if (const ActualArgument *arg{actualForDummy[j]}) { 2128 bool isAssumedRank{IsAssumedRank(*arg)}; 2129 if (isAssumedRank && d.rank != Rank::anyOrAssumedRank && 2130 d.rank != Rank::arrayOrAssumedRank) { 2131 messages.Say(arg->sourceLocation(), 2132 "Assumed-rank array cannot be forwarded to '%s=' argument"_err_en_US, 2133 d.keyword); 2134 return std::nullopt; 2135 } 2136 int rank{arg->Rank()}; 2137 bool argOk{false}; 2138 switch (d.rank) { 2139 case Rank::elemental: 2140 case Rank::elementalOrBOZ: 2141 if (elementalRank == 0) { 2142 elementalRank = rank; 2143 } 2144 argOk = rank == 0 || rank == elementalRank; 2145 break; 2146 case Rank::scalar: 2147 argOk = rank == 0; 2148 break; 2149 case Rank::vector: 2150 argOk = rank == 1; 2151 break; 2152 case Rank::shape: 2153 CHECK(!shapeArgSize); 2154 if (rank != 1) { 2155 messages.Say(arg->sourceLocation(), 2156 "'shape=' argument must be an array of rank 1"_err_en_US); 2157 return std::nullopt; 2158 } else { 2159 if (auto shape{GetShape(context, *arg)}) { 2160 if (auto constShape{AsConstantShape(context, *shape)}) { 2161 shapeArgSize = constShape->At(ConstantSubscripts{1}).ToInt64(); 2162 CHECK(shapeArgSize.value() >= 0); 2163 argOk = *shapeArgSize <= common::maxRank; 2164 } 2165 } 2166 } 2167 if (!argOk) { 2168 if (shapeArgSize.value_or(0) > common::maxRank) { 2169 messages.Say(arg->sourceLocation(), 2170 "'shape=' argument must be a vector of at most %d elements (has %jd)"_err_en_US, 2171 common::maxRank, std::intmax_t{*shapeArgSize}); 2172 } else { 2173 messages.Say(arg->sourceLocation(), 2174 "'shape=' argument must be a vector of known size"_err_en_US); 2175 } 2176 return std::nullopt; 2177 } 2178 break; 2179 case Rank::matrix: 2180 argOk = rank == 2; 2181 break; 2182 case Rank::array: 2183 argOk = rank > 0; 2184 if (!arrayArg) { 2185 arrayArg = arg; 2186 arrayArgName = d.keyword; 2187 } 2188 break; 2189 case Rank::coarray: 2190 argOk = IsCoarray(*arg); 2191 if (!argOk) { 2192 messages.Say(arg->sourceLocation(), 2193 "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US, 2194 name); 2195 return std::nullopt; 2196 } 2197 break; 2198 case Rank::atom: 2199 argOk = rank == 0 && (IsCoarray(*arg) || ExtractCoarrayRef(*arg)); 2200 if (!argOk) { 2201 messages.Say(arg->sourceLocation(), 2202 "'%s=' argument must be a scalar coarray or coindexed object for intrinsic '%s'"_err_en_US, 2203 d.keyword, name); 2204 return std::nullopt; 2205 } 2206 break; 2207 case Rank::known: 2208 if (!knownArg) { 2209 knownArg = arg; 2210 } 2211 argOk = !isAssumedRank && rank == knownArg->Rank(); 2212 break; 2213 case Rank::anyOrAssumedRank: 2214 case Rank::arrayOrAssumedRank: 2215 if (isAssumedRank) { 2216 argOk = true; 2217 break; 2218 } 2219 if (d.rank == Rank::arrayOrAssumedRank && rank == 0) { 2220 argOk = false; 2221 break; 2222 } 2223 if (!knownArg) { 2224 knownArg = arg; 2225 } 2226 if (!dimArg && rank > 0 && 2227 (std::strcmp(name, "shape") == 0 || 2228 std::strcmp(name, "size") == 0 || 2229 std::strcmp(name, "ubound") == 0)) { 2230 // Check for a whole assumed-size array argument. 2231 // These are disallowed for SHAPE, and require DIM= for 2232 // SIZE and UBOUND. 2233 // (A previous error message for UBOUND will take precedence 2234 // over this one, as this error is caught by the second entry 2235 // for UBOUND.) 2236 if (auto named{ExtractNamedEntity(*arg)}) { 2237 if (semantics::IsAssumedSizeArray(named->GetLastSymbol())) { 2238 if (strcmp(name, "shape") == 0) { 2239 messages.Say(arg->sourceLocation(), 2240 "The 'source=' argument to the intrinsic function 'shape' may not be assumed-size"_err_en_US); 2241 } else { 2242 messages.Say(arg->sourceLocation(), 2243 "A dim= argument is required for '%s' when the array is assumed-size"_err_en_US, 2244 name); 2245 } 2246 return std::nullopt; 2247 } 2248 } 2249 } 2250 argOk = true; 2251 break; 2252 case Rank::conformable: // arg must be conformable with previous arrayArg 2253 CHECK(arrayArg); 2254 CHECK(arrayArgName); 2255 if (const std::optional<Shape> &arrayArgShape{ 2256 GetShape(context, *arrayArg)}) { 2257 if (std::optional<Shape> argShape{GetShape(context, *arg)}) { 2258 std::string arrayArgMsg{"'"}; 2259 arrayArgMsg = arrayArgMsg + arrayArgName + "='" + " argument"; 2260 std::string argMsg{"'"}; 2261 argMsg = argMsg + d.keyword + "='" + " argument"; 2262 CheckConformance(context.messages(), *arrayArgShape, *argShape, 2263 CheckConformanceFlags::RightScalarExpandable, 2264 arrayArgMsg.c_str(), argMsg.c_str()); 2265 } 2266 } 2267 argOk = true; // Avoid an additional error message 2268 break; 2269 case Rank::dimReduced: 2270 case Rank::dimRemovedOrScalar: 2271 CHECK(arrayArg); 2272 argOk = rank == 0 || rank + 1 == arrayArg->Rank(); 2273 break; 2274 case Rank::reduceOperation: 2275 // The reduction function is validated in ApplySpecificChecks(). 2276 argOk = true; 2277 break; 2278 case Rank::scalarIfDim: 2279 case Rank::locReduced: 2280 case Rank::rankPlus1: 2281 case Rank::shaped: 2282 common::die("INTERNAL: result-only rank code appears on argument '%s' " 2283 "for intrinsic '%s'", 2284 d.keyword, name); 2285 } 2286 if (!argOk) { 2287 messages.Say(arg->sourceLocation(), 2288 "'%s=' argument has unacceptable rank %d"_err_en_US, d.keyword, 2289 rank); 2290 return std::nullopt; 2291 } 2292 } 2293 } 2294 2295 // Calculate the characteristics of the function result, if any 2296 std::optional<DynamicType> resultType; 2297 if (auto category{result.categorySet.LeastElement()}) { 2298 // The intrinsic is not a subroutine. 2299 if (call.isSubroutineCall) { 2300 return std::nullopt; 2301 } 2302 switch (result.kindCode) { 2303 case KindCode::defaultIntegerKind: 2304 CHECK(result.categorySet == IntType); 2305 CHECK(*category == TypeCategory::Integer); 2306 resultType = DynamicType{TypeCategory::Integer, 2307 defaults.GetDefaultKind(TypeCategory::Integer)}; 2308 break; 2309 case KindCode::defaultRealKind: 2310 CHECK(result.categorySet == CategorySet{*category}); 2311 CHECK(FloatingType.test(*category)); 2312 resultType = 2313 DynamicType{*category, defaults.GetDefaultKind(TypeCategory::Real)}; 2314 break; 2315 case KindCode::doublePrecision: 2316 CHECK(result.categorySet == CategorySet{*category}); 2317 CHECK(FloatingType.test(*category)); 2318 resultType = DynamicType{*category, defaults.doublePrecisionKind()}; 2319 break; 2320 case KindCode::defaultLogicalKind: 2321 CHECK(result.categorySet == LogicalType); 2322 CHECK(*category == TypeCategory::Logical); 2323 resultType = DynamicType{TypeCategory::Logical, 2324 defaults.GetDefaultKind(TypeCategory::Logical)}; 2325 break; 2326 case KindCode::defaultCharKind: 2327 CHECK(result.categorySet == CharType); 2328 CHECK(*category == TypeCategory::Character); 2329 resultType = DynamicType{TypeCategory::Character, 2330 defaults.GetDefaultKind(TypeCategory::Character)}; 2331 break; 2332 case KindCode::same: 2333 CHECK(sameArg); 2334 if (std::optional<DynamicType> aType{sameArg->GetType()}) { 2335 if (result.categorySet.test(aType->category())) { 2336 if (const auto *sameChar{UnwrapExpr<Expr<SomeCharacter>>(*sameArg)}) { 2337 if (auto len{ToInt64(Fold(context, sameChar->LEN()))}) { 2338 resultType = DynamicType{aType->kind(), *len}; 2339 } else { 2340 resultType = *aType; 2341 } 2342 } else { 2343 resultType = *aType; 2344 } 2345 } else { 2346 resultType = DynamicType{*category, aType->kind()}; 2347 } 2348 } 2349 break; 2350 case KindCode::sameKind: 2351 CHECK(sameArg); 2352 if (std::optional<DynamicType> aType{sameArg->GetType()}) { 2353 resultType = DynamicType{*category, aType->kind()}; 2354 } 2355 break; 2356 case KindCode::operand: 2357 CHECK(operandArg); 2358 resultType = operandArg->GetType(); 2359 CHECK(!resultType || result.categorySet.test(resultType->category())); 2360 break; 2361 case KindCode::effectiveKind: 2362 CHECK(kindDummyArg); 2363 CHECK(result.categorySet == CategorySet{*category}); 2364 if (kindArg) { 2365 if (auto *expr{kindArg->UnwrapExpr()}) { 2366 CHECK(expr->Rank() == 0); 2367 if (auto code{ToInt64(*expr)}) { 2368 if (context.targetCharacteristics().IsTypeEnabled( 2369 *category, *code)) { 2370 if (*category == TypeCategory::Character) { // ACHAR & CHAR 2371 resultType = DynamicType{static_cast<int>(*code), 1}; 2372 } else { 2373 resultType = DynamicType{*category, static_cast<int>(*code)}; 2374 } 2375 break; 2376 } 2377 } 2378 } 2379 messages.Say("'kind=' argument must be a constant scalar integer " 2380 "whose value is a supported kind for the " 2381 "intrinsic result type"_err_en_US); 2382 // use default kind below for error recovery 2383 } else if (kindDummyArg->flags.test(ArgFlag::defaultsToSameKind)) { 2384 CHECK(sameArg); 2385 resultType = *sameArg->GetType(); 2386 } else if (kindDummyArg->flags.test(ArgFlag::defaultsToSizeKind)) { 2387 CHECK(*category == TypeCategory::Integer); 2388 resultType = 2389 DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()}; 2390 } else { 2391 CHECK(kindDummyArg->flags.test(ArgFlag::defaultsToDefaultForResult)); 2392 } 2393 if (!resultType) { 2394 int kind{defaults.GetDefaultKind(*category)}; 2395 if (*category == TypeCategory::Character) { // ACHAR & CHAR 2396 resultType = DynamicType{kind, 1}; 2397 } else { 2398 resultType = DynamicType{*category, kind}; 2399 } 2400 } 2401 break; 2402 case KindCode::likeMultiply: 2403 CHECK(dummies >= 2); 2404 CHECK(actualForDummy[0]); 2405 CHECK(actualForDummy[1]); 2406 resultType = actualForDummy[0]->GetType()->ResultTypeForMultiply( 2407 *actualForDummy[1]->GetType()); 2408 break; 2409 case KindCode::subscript: 2410 CHECK(result.categorySet == IntType); 2411 CHECK(*category == TypeCategory::Integer); 2412 resultType = 2413 DynamicType{TypeCategory::Integer, defaults.subscriptIntegerKind()}; 2414 break; 2415 case KindCode::size: 2416 CHECK(result.categorySet == IntType); 2417 CHECK(*category == TypeCategory::Integer); 2418 resultType = 2419 DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()}; 2420 break; 2421 case KindCode::teamType: 2422 CHECK(result.categorySet == DerivedType); 2423 CHECK(*category == TypeCategory::Derived); 2424 resultType = DynamicType{ 2425 GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")}; 2426 break; 2427 case KindCode::greaterOrEqualToKind: 2428 case KindCode::exactKind: 2429 resultType = DynamicType{*category, result.kindValue}; 2430 break; 2431 case KindCode::typeless: 2432 case KindCode::any: 2433 case KindCode::kindArg: 2434 case KindCode::dimArg: 2435 common::die( 2436 "INTERNAL: bad KindCode appears on intrinsic '%s' result", name); 2437 break; 2438 default: 2439 CRASH_NO_CASE; 2440 } 2441 } else { 2442 if (!call.isSubroutineCall) { 2443 return std::nullopt; 2444 } 2445 CHECK(result.kindCode == KindCode::none); 2446 } 2447 2448 // Emit warnings when the syntactic presence of a DIM= argument determines 2449 // the semantics of the call but the associated actual argument may not be 2450 // present at execution time. 2451 if (dimArg) { 2452 std::optional<int> arrayRank; 2453 if (arrayArg) { 2454 arrayRank = arrayArg->Rank(); 2455 if (auto dimVal{ToInt64(actualForDummy[*dimArg])}) { 2456 if (*dimVal < 1) { 2457 messages.Say( 2458 "The value of DIM= (%jd) may not be less than 1"_err_en_US, 2459 static_cast<std::intmax_t>(*dimVal)); 2460 } else if (*dimVal > *arrayRank) { 2461 messages.Say( 2462 "The value of DIM= (%jd) may not be greater than %d"_err_en_US, 2463 static_cast<std::intmax_t>(*dimVal), *arrayRank); 2464 } 2465 } 2466 } 2467 switch (rank) { 2468 case Rank::dimReduced: 2469 case Rank::dimRemovedOrScalar: 2470 case Rank::locReduced: 2471 case Rank::scalarIfDim: 2472 if (dummy[*dimArg].optionality == Optionality::required) { 2473 if (const Symbol *whole{ 2474 UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) { 2475 if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) { 2476 if (context.languageFeatures().ShouldWarn( 2477 common::UsageWarning::OptionalMustBePresent)) { 2478 if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) { 2479 messages.Say(common::UsageWarning::OptionalMustBePresent, 2480 "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_warn_en_US); 2481 } else { 2482 messages.Say(common::UsageWarning::OptionalMustBePresent, 2483 "The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning"_warn_en_US); 2484 } 2485 } 2486 } 2487 } 2488 } 2489 break; 2490 default:; 2491 } 2492 } 2493 2494 // At this point, the call is acceptable. 2495 // Determine the rank of the function result. 2496 int resultRank{0}; 2497 switch (rank) { 2498 case Rank::elemental: 2499 resultRank = elementalRank; 2500 break; 2501 case Rank::scalar: 2502 resultRank = 0; 2503 break; 2504 case Rank::vector: 2505 resultRank = 1; 2506 break; 2507 case Rank::matrix: 2508 resultRank = 2; 2509 break; 2510 case Rank::conformable: 2511 CHECK(arrayArg); 2512 resultRank = arrayArg->Rank(); 2513 break; 2514 case Rank::dimReduced: 2515 CHECK(arrayArg); 2516 resultRank = dimArg ? arrayArg->Rank() - 1 : 0; 2517 break; 2518 case Rank::locReduced: 2519 CHECK(arrayArg); 2520 resultRank = dimArg ? arrayArg->Rank() - 1 : 1; 2521 break; 2522 case Rank::rankPlus1: 2523 CHECK(knownArg); 2524 resultRank = knownArg->Rank() + 1; 2525 break; 2526 case Rank::shaped: 2527 CHECK(shapeArgSize); 2528 resultRank = *shapeArgSize; 2529 break; 2530 case Rank::scalarIfDim: 2531 resultRank = dimArg ? 0 : 1; 2532 break; 2533 case Rank::elementalOrBOZ: 2534 case Rank::shape: 2535 case Rank::array: 2536 case Rank::coarray: 2537 case Rank::atom: 2538 case Rank::known: 2539 case Rank::anyOrAssumedRank: 2540 case Rank::arrayOrAssumedRank: 2541 case Rank::reduceOperation: 2542 case Rank::dimRemovedOrScalar: 2543 common::die("INTERNAL: bad Rank code on intrinsic '%s' result", name); 2544 break; 2545 } 2546 CHECK(resultRank >= 0); 2547 2548 // Rearrange the actual arguments into dummy argument order. 2549 ActualArguments rearranged(dummies); 2550 for (std::size_t j{0}; j < dummies; ++j) { 2551 if (ActualArgument *arg{actualForDummy[j]}) { 2552 rearranged[j] = std::move(*arg); 2553 } 2554 } 2555 2556 // Characterize the specific intrinsic procedure. 2557 characteristics::DummyArguments dummyArgs; 2558 std::optional<int> sameDummyArg; 2559 2560 for (std::size_t j{0}; j < dummies; ++j) { 2561 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; 2562 if (const auto &arg{rearranged[j]}) { 2563 if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) { 2564 std::string kw{d.keyword}; 2565 if (arg->keyword()) { 2566 kw = arg->keyword()->ToString(); 2567 } else if (isMaxMin) { 2568 for (std::size_t k{j + 1};; ++k) { 2569 kw = "a"s + std::to_string(k); 2570 auto iter{std::find_if(dummyArgs.begin(), dummyArgs.end(), 2571 [&kw](const characteristics::DummyArgument &prev) { 2572 return prev.name == kw; 2573 })}; 2574 if (iter == dummyArgs.end()) { 2575 break; 2576 } 2577 } 2578 } 2579 if (auto dc{characteristics::DummyArgument::FromActual(std::move(kw), 2580 *expr, context, /*forImplicitInterface=*/false)}) { 2581 if (auto *dummyProc{ 2582 std::get_if<characteristics::DummyProcedure>(&dc->u)}) { 2583 // Dummy procedures are never elemental. 2584 dummyProc->procedure.value().attrs.reset( 2585 characteristics::Procedure::Attr::Elemental); 2586 } else if (auto *dummyObject{ 2587 std::get_if<characteristics::DummyDataObject>( 2588 &dc->u)}) { 2589 dummyObject->type.set_corank(0); 2590 } 2591 dummyArgs.emplace_back(std::move(*dc)); 2592 if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) { 2593 sameDummyArg = j; 2594 } 2595 } else { // error recovery 2596 messages.Say( 2597 "Could not characterize intrinsic function actual argument '%s'"_err_en_US, 2598 expr->AsFortran().c_str()); 2599 return std::nullopt; 2600 } 2601 } else { 2602 CHECK(arg->GetAssumedTypeDummy()); 2603 dummyArgs.emplace_back(std::string{d.keyword}, 2604 characteristics::DummyDataObject{DynamicType::AssumedType()}); 2605 } 2606 } else { 2607 // optional argument is absent 2608 CHECK(d.optionality != Optionality::required); 2609 if (d.typePattern.kindCode == KindCode::same) { 2610 dummyArgs.emplace_back(dummyArgs[sameDummyArg.value()]); 2611 } else { 2612 auto category{d.typePattern.categorySet.LeastElement().value()}; 2613 if (category == TypeCategory::Derived) { 2614 // TODO: any other built-in derived types used as optional intrinsic 2615 // dummies? 2616 CHECK(d.typePattern.kindCode == KindCode::teamType); 2617 characteristics::TypeAndShape typeAndShape{ 2618 GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")}; 2619 dummyArgs.emplace_back(std::string{d.keyword}, 2620 characteristics::DummyDataObject{std::move(typeAndShape)}); 2621 } else { 2622 characteristics::TypeAndShape typeAndShape{ 2623 DynamicType{category, defaults.GetDefaultKind(category)}}; 2624 dummyArgs.emplace_back(std::string{d.keyword}, 2625 characteristics::DummyDataObject{std::move(typeAndShape)}); 2626 } 2627 } 2628 dummyArgs.back().SetOptional(); 2629 } 2630 dummyArgs.back().SetIntent(d.intent); 2631 } 2632 characteristics::Procedure::Attrs attrs; 2633 if (elementalRank > 0) { 2634 attrs.set(characteristics::Procedure::Attr::Elemental); 2635 } 2636 if (call.isSubroutineCall) { 2637 if (intrinsicClass == IntrinsicClass::pureSubroutine /* MOVE_ALLOC */ || 2638 intrinsicClass == IntrinsicClass::elementalSubroutine /* MVBITS */) { 2639 attrs.set(characteristics::Procedure::Attr::Pure); 2640 } 2641 return SpecificCall{ 2642 SpecificIntrinsic{ 2643 name, characteristics::Procedure{std::move(dummyArgs), attrs}}, 2644 std::move(rearranged)}; 2645 } else { 2646 attrs.set(characteristics::Procedure::Attr::Pure); 2647 characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank}; 2648 characteristics::FunctionResult funcResult{std::move(typeAndShape)}; 2649 characteristics::Procedure chars{ 2650 std::move(funcResult), std::move(dummyArgs), attrs}; 2651 return SpecificCall{ 2652 SpecificIntrinsic{name, std::move(chars)}, std::move(rearranged)}; 2653 } 2654 } 2655 2656 class IntrinsicProcTable::Implementation { 2657 public: 2658 explicit Implementation(const common::IntrinsicTypeDefaultKinds &dfts) 2659 : defaults_{dfts} { 2660 for (const IntrinsicInterface &f : genericIntrinsicFunction) { 2661 genericFuncs_.insert(std::make_pair(std::string{f.name}, &f)); 2662 } 2663 for (const std::pair<const char *, const char *> &a : genericAlias) { 2664 aliases_.insert( 2665 std::make_pair(std::string{a.first}, std::string{a.second})); 2666 } 2667 for (const SpecificIntrinsicInterface &f : specificIntrinsicFunction) { 2668 specificFuncs_.insert(std::make_pair(std::string{f.name}, &f)); 2669 } 2670 for (const IntrinsicInterface &f : intrinsicSubroutine) { 2671 subroutines_.insert(std::make_pair(std::string{f.name}, &f)); 2672 } 2673 } 2674 2675 void SupplyBuiltins(const semantics::Scope &builtins) { 2676 builtinsScope_ = &builtins; 2677 } 2678 2679 bool IsIntrinsic(const std::string &) const; 2680 bool IsIntrinsicFunction(const std::string &) const; 2681 bool IsIntrinsicSubroutine(const std::string &) const; 2682 bool IsDualIntrinsic(const std::string &) const; 2683 2684 IntrinsicClass GetIntrinsicClass(const std::string &) const; 2685 std::string GetGenericIntrinsicName(const std::string &) const; 2686 2687 std::optional<SpecificCall> Probe( 2688 const CallCharacteristics &, ActualArguments &, FoldingContext &) const; 2689 2690 std::optional<SpecificIntrinsicFunctionInterface> IsSpecificIntrinsicFunction( 2691 const std::string &) const; 2692 2693 llvm::raw_ostream &Dump(llvm::raw_ostream &) const; 2694 2695 private: 2696 DynamicType GetSpecificType(const TypePattern &) const; 2697 SpecificCall HandleNull(ActualArguments &, FoldingContext &) const; 2698 std::optional<SpecificCall> HandleC_F_Pointer( 2699 ActualArguments &, FoldingContext &) const; 2700 std::optional<SpecificCall> HandleC_Loc( 2701 ActualArguments &, FoldingContext &) const; 2702 std::optional<SpecificCall> HandleC_Devloc( 2703 ActualArguments &, FoldingContext &) const; 2704 const std::string &ResolveAlias(const std::string &name) const { 2705 auto iter{aliases_.find(name)}; 2706 return iter == aliases_.end() ? name : iter->second; 2707 } 2708 2709 common::IntrinsicTypeDefaultKinds defaults_; 2710 std::multimap<std::string, const IntrinsicInterface *> genericFuncs_; 2711 std::multimap<std::string, const SpecificIntrinsicInterface *> specificFuncs_; 2712 std::multimap<std::string, const IntrinsicInterface *> subroutines_; 2713 const semantics::Scope *builtinsScope_{nullptr}; 2714 std::map<std::string, std::string> aliases_; 2715 semantics::ParamValue assumedLen_{ 2716 semantics::ParamValue::Assumed(common::TypeParamAttr::Len)}; 2717 }; 2718 2719 bool IntrinsicProcTable::Implementation::IsIntrinsicFunction( 2720 const std::string &name0) const { 2721 const std::string &name{ResolveAlias(name0)}; 2722 auto specificRange{specificFuncs_.equal_range(name)}; 2723 if (specificRange.first != specificRange.second) { 2724 return true; 2725 } 2726 auto genericRange{genericFuncs_.equal_range(name)}; 2727 if (genericRange.first != genericRange.second) { 2728 return true; 2729 } 2730 // special cases 2731 return name == "__builtin_c_loc" || name == "__builtin_c_devloc" || 2732 name == "null"; 2733 } 2734 bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine( 2735 const std::string &name0) const { 2736 const std::string &name{ResolveAlias(name0)}; 2737 auto subrRange{subroutines_.equal_range(name)}; 2738 if (subrRange.first != subrRange.second) { 2739 return true; 2740 } 2741 // special cases 2742 return name == "__builtin_c_f_pointer"; 2743 } 2744 bool IntrinsicProcTable::Implementation::IsIntrinsic( 2745 const std::string &name) const { 2746 return IsIntrinsicFunction(name) || IsIntrinsicSubroutine(name); 2747 } 2748 bool IntrinsicProcTable::Implementation::IsDualIntrinsic( 2749 const std::string &name) const { 2750 // Collection for some intrinsics with function and subroutine form, 2751 // in order to pass the semantic check. 2752 static const std::string dualIntrinsic[]{{"chdir"s}, {"etime"s}, {"getcwd"s}, 2753 {"rename"s}, {"second"s}, {"system"s}}; 2754 2755 return llvm::is_contained(dualIntrinsic, name); 2756 } 2757 2758 IntrinsicClass IntrinsicProcTable::Implementation::GetIntrinsicClass( 2759 const std::string &name) const { 2760 auto specificIntrinsic{specificFuncs_.find(name)}; 2761 if (specificIntrinsic != specificFuncs_.end()) { 2762 return specificIntrinsic->second->intrinsicClass; 2763 } 2764 auto genericIntrinsic{genericFuncs_.find(name)}; 2765 if (genericIntrinsic != genericFuncs_.end()) { 2766 return genericIntrinsic->second->intrinsicClass; 2767 } 2768 auto subrIntrinsic{subroutines_.find(name)}; 2769 if (subrIntrinsic != subroutines_.end()) { 2770 return subrIntrinsic->second->intrinsicClass; 2771 } 2772 return IntrinsicClass::noClass; 2773 } 2774 2775 std::string IntrinsicProcTable::Implementation::GetGenericIntrinsicName( 2776 const std::string &name) const { 2777 auto specificIntrinsic{specificFuncs_.find(name)}; 2778 if (specificIntrinsic != specificFuncs_.end()) { 2779 if (const char *genericName{specificIntrinsic->second->generic}) { 2780 return {genericName}; 2781 } 2782 } 2783 return name; 2784 } 2785 2786 bool CheckAndRearrangeArguments(ActualArguments &arguments, 2787 parser::ContextualMessages &messages, const char *const dummyKeywords[], 2788 std::size_t trailingOptionals) { 2789 std::size_t numDummies{0}; 2790 while (dummyKeywords[numDummies]) { 2791 ++numDummies; 2792 } 2793 CHECK(trailingOptionals <= numDummies); 2794 if (arguments.size() > numDummies) { 2795 messages.Say("Too many actual arguments (%zd > %zd)"_err_en_US, 2796 arguments.size(), numDummies); 2797 return false; 2798 } 2799 ActualArguments rearranged(numDummies); 2800 bool anyKeywords{false}; 2801 std::size_t position{0}; 2802 for (std::optional<ActualArgument> &arg : arguments) { 2803 std::size_t dummyIndex{0}; 2804 if (arg && arg->keyword()) { 2805 anyKeywords = true; 2806 for (; dummyIndex < numDummies; ++dummyIndex) { 2807 if (*arg->keyword() == dummyKeywords[dummyIndex]) { 2808 break; 2809 } 2810 } 2811 if (dummyIndex >= numDummies) { 2812 messages.Say(*arg->keyword(), 2813 "Unknown argument keyword '%s='"_err_en_US, *arg->keyword()); 2814 return false; 2815 } 2816 } else if (anyKeywords) { 2817 messages.Say(arg ? arg->sourceLocation() : messages.at(), 2818 "A positional actual argument may not appear after any keyword arguments"_err_en_US); 2819 return false; 2820 } else { 2821 dummyIndex = position++; 2822 } 2823 if (rearranged[dummyIndex]) { 2824 messages.Say(arg ? arg->sourceLocation() : messages.at(), 2825 "Dummy argument '%s=' appears more than once"_err_en_US, 2826 dummyKeywords[dummyIndex]); 2827 return false; 2828 } 2829 rearranged[dummyIndex] = std::move(arg); 2830 arg.reset(); 2831 } 2832 bool anyMissing{false}; 2833 for (std::size_t j{0}; j < numDummies - trailingOptionals; ++j) { 2834 if (!rearranged[j]) { 2835 messages.Say("Dummy argument '%s=' is absent and not OPTIONAL"_err_en_US, 2836 dummyKeywords[j]); 2837 anyMissing = true; 2838 } 2839 } 2840 arguments = std::move(rearranged); 2841 return !anyMissing; 2842 } 2843 2844 // The NULL() intrinsic is a special case. 2845 SpecificCall IntrinsicProcTable::Implementation::HandleNull( 2846 ActualArguments &arguments, FoldingContext &context) const { 2847 static const char *const keywords[]{"mold", nullptr}; 2848 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) && 2849 arguments[0]) { 2850 Expr<SomeType> *mold{arguments[0]->UnwrapExpr()}; 2851 bool isBareNull{IsBareNullPointer(mold)}; 2852 if (isBareNull) { 2853 // NULL(NULL()), NULL(NULL(NULL())), &c. are all just NULL() 2854 mold = nullptr; 2855 } 2856 if (mold) { 2857 if (IsAssumedRank(*arguments[0])) { 2858 context.messages().Say(arguments[0]->sourceLocation(), 2859 "MOLD= argument to NULL() must not be assumed-rank"_err_en_US); 2860 } 2861 bool isProcPtrTarget{ 2862 IsProcedurePointerTarget(*mold) && !IsNullObjectPointer(*mold)}; 2863 if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold)) { 2864 characteristics::DummyArguments args; 2865 std::optional<characteristics::FunctionResult> fResult; 2866 if (isProcPtrTarget) { 2867 // MOLD= procedure pointer 2868 std::optional<characteristics::Procedure> procPointer; 2869 if (IsNullProcedurePointer(*mold)) { 2870 procPointer = 2871 characteristics::Procedure::Characterize(*mold, context); 2872 } else { 2873 const Symbol *last{GetLastSymbol(*mold)}; 2874 procPointer = 2875 characteristics::Procedure::Characterize(DEREF(last), context); 2876 } 2877 // procPointer is vacant if there was an error with the analysis 2878 // associated with the procedure pointer 2879 if (procPointer) { 2880 args.emplace_back("mold"s, 2881 characteristics::DummyProcedure{common::Clone(*procPointer)}); 2882 fResult.emplace(std::move(*procPointer)); 2883 } 2884 } else if (auto type{mold->GetType()}) { 2885 // MOLD= object pointer 2886 characteristics::TypeAndShape typeAndShape{ 2887 *type, GetShape(context, *mold)}; 2888 args.emplace_back( 2889 "mold"s, characteristics::DummyDataObject{typeAndShape}); 2890 fResult.emplace(std::move(typeAndShape)); 2891 } else { 2892 context.messages().Say(arguments[0]->sourceLocation(), 2893 "MOLD= argument to NULL() lacks type"_err_en_US); 2894 } 2895 if (fResult) { 2896 fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer); 2897 characteristics::Procedure::Attrs attrs; 2898 attrs.set(characteristics::Procedure::Attr::NullPointer); 2899 characteristics::Procedure chars{ 2900 std::move(*fResult), std::move(args), attrs}; 2901 return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)}, 2902 std::move(arguments)}; 2903 } 2904 } 2905 } 2906 if (!isBareNull) { 2907 context.messages().Say(arguments[0]->sourceLocation(), 2908 "MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US); 2909 } 2910 } 2911 characteristics::Procedure::Attrs attrs; 2912 attrs.set(characteristics::Procedure::Attr::NullPointer); 2913 attrs.set(characteristics::Procedure::Attr::Pure); 2914 arguments.clear(); 2915 return SpecificCall{ 2916 SpecificIntrinsic{"null"s, 2917 characteristics::Procedure{characteristics::DummyArguments{}, attrs}}, 2918 std::move(arguments)}; 2919 } 2920 2921 // Subroutine C_F_POINTER(CPTR=,FPTR=[,SHAPE=]) from 2922 // intrinsic module ISO_C_BINDING (18.2.3.3) 2923 std::optional<SpecificCall> 2924 IntrinsicProcTable::Implementation::HandleC_F_Pointer( 2925 ActualArguments &arguments, FoldingContext &context) const { 2926 characteristics::Procedure::Attrs attrs; 2927 attrs.set(characteristics::Procedure::Attr::Subroutine); 2928 static const char *const keywords[]{"cptr", "fptr", "shape", nullptr}; 2929 characteristics::DummyArguments dummies; 2930 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) { 2931 CHECK(arguments.size() == 3); 2932 if (const auto *expr{arguments[0].value().UnwrapExpr()}) { 2933 // General semantic checks will catch an actual argument that's not 2934 // scalar. 2935 if (auto type{expr->GetType()}) { 2936 if (type->category() != TypeCategory::Derived || 2937 type->IsPolymorphic() || 2938 (type->GetDerivedTypeSpec().typeSymbol().name() != 2939 "__builtin_c_ptr" && 2940 type->GetDerivedTypeSpec().typeSymbol().name() != 2941 "__builtin_c_devptr")) { 2942 context.messages().Say(arguments[0]->sourceLocation(), 2943 "CPTR= argument to C_F_POINTER() must be a C_PTR"_err_en_US); 2944 } 2945 characteristics::DummyDataObject cptr{ 2946 characteristics::TypeAndShape{*type}}; 2947 cptr.intent = common::Intent::In; 2948 dummies.emplace_back("cptr"s, std::move(cptr)); 2949 } 2950 } 2951 if (const auto *expr{arguments[1].value().UnwrapExpr()}) { 2952 int fptrRank{expr->Rank()}; 2953 auto at{arguments[1]->sourceLocation()}; 2954 if (auto type{expr->GetType()}) { 2955 if (type->HasDeferredTypeParameter()) { 2956 context.messages().Say(at, 2957 "FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US); 2958 } else if (type->category() == TypeCategory::Derived) { 2959 if (context.languageFeatures().ShouldWarn( 2960 common::UsageWarning::Interoperability) && 2961 type->IsUnlimitedPolymorphic()) { 2962 context.messages().Say(common::UsageWarning::Interoperability, at, 2963 "FPTR= argument to C_F_POINTER() should not be unlimited polymorphic"_warn_en_US); 2964 } else if (!type->GetDerivedTypeSpec().typeSymbol().attrs().test( 2965 semantics::Attr::BIND_C) && 2966 context.languageFeatures().ShouldWarn( 2967 common::UsageWarning::Portability)) { 2968 context.messages().Say(common::UsageWarning::Portability, at, 2969 "FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)"_port_en_US); 2970 } 2971 } else if (!IsInteroperableIntrinsicType( 2972 *type, &context.languageFeatures()) 2973 .value_or(true)) { 2974 if (type->category() == TypeCategory::Character && 2975 type->kind() == 1) { 2976 if (context.languageFeatures().ShouldWarn( 2977 common::UsageWarning::CharacterInteroperability)) { 2978 context.messages().Say( 2979 common::UsageWarning::CharacterInteroperability, at, 2980 "FPTR= argument to C_F_POINTER() should not have the non-interoperable character length %s"_warn_en_US, 2981 type->AsFortran()); 2982 } 2983 } else if (context.languageFeatures().ShouldWarn( 2984 common::UsageWarning::Interoperability)) { 2985 context.messages().Say(common::UsageWarning::Interoperability, at, 2986 "FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind %s"_warn_en_US, 2987 type->AsFortran()); 2988 } 2989 } 2990 if (ExtractCoarrayRef(*expr)) { 2991 context.messages().Say(at, 2992 "FPTR= argument to C_F_POINTER() may not be a coindexed object"_err_en_US); 2993 } 2994 characteristics::DummyDataObject fptr{ 2995 characteristics::TypeAndShape{*type, fptrRank}}; 2996 fptr.intent = common::Intent::Out; 2997 fptr.attrs.set(characteristics::DummyDataObject::Attr::Pointer); 2998 dummies.emplace_back("fptr"s, std::move(fptr)); 2999 } else { 3000 context.messages().Say( 3001 at, "FPTR= argument to C_F_POINTER() must have a type"_err_en_US); 3002 } 3003 if (arguments[2] && fptrRank == 0) { 3004 context.messages().Say(arguments[2]->sourceLocation(), 3005 "SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US); 3006 } else if (!arguments[2] && fptrRank > 0) { 3007 context.messages().Say( 3008 "SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array"_err_en_US); 3009 } else if (arguments[2]) { 3010 if (const auto *argExpr{arguments[2].value().UnwrapExpr()}) { 3011 if (argExpr->Rank() > 1) { 3012 context.messages().Say(arguments[2]->sourceLocation(), 3013 "SHAPE= argument to C_F_POINTER() must be a rank-one array."_err_en_US); 3014 } else if (argExpr->Rank() == 1) { 3015 if (auto constShape{GetConstantShape(context, *argExpr)}) { 3016 if (constShape->At(ConstantSubscripts{1}).ToInt64() != fptrRank) { 3017 context.messages().Say(arguments[2]->sourceLocation(), 3018 "SHAPE= argument to C_F_POINTER() must have size equal to the rank of FPTR="_err_en_US); 3019 } 3020 } 3021 } 3022 } 3023 } 3024 } 3025 } 3026 if (dummies.size() == 2) { 3027 DynamicType shapeType{TypeCategory::Integer, defaults_.sizeIntegerKind()}; 3028 if (arguments[2]) { 3029 if (auto type{arguments[2]->GetType()}) { 3030 if (type->category() == TypeCategory::Integer) { 3031 shapeType = *type; 3032 } 3033 } 3034 } 3035 characteristics::DummyDataObject shape{ 3036 characteristics::TypeAndShape{shapeType, 1}}; 3037 shape.intent = common::Intent::In; 3038 shape.attrs.set(characteristics::DummyDataObject::Attr::Optional); 3039 dummies.emplace_back("shape"s, std::move(shape)); 3040 return SpecificCall{ 3041 SpecificIntrinsic{"__builtin_c_f_pointer"s, 3042 characteristics::Procedure{std::move(dummies), attrs}}, 3043 std::move(arguments)}; 3044 } else { 3045 return std::nullopt; 3046 } 3047 } 3048 3049 // Function C_LOC(X) from intrinsic module ISO_C_BINDING (18.2.3.6) 3050 std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc( 3051 ActualArguments &arguments, FoldingContext &context) const { 3052 static const char *const keywords[]{"x", nullptr}; 3053 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords)) { 3054 CHECK(arguments.size() == 1); 3055 CheckForCoindexedObject(context.messages(), arguments[0], "c_loc", "x"); 3056 const auto *expr{arguments[0].value().UnwrapExpr()}; 3057 if (expr && 3058 !(IsObjectPointer(*expr) || 3059 (IsVariable(*expr) && GetLastTarget(GetSymbolVector(*expr))))) { 3060 context.messages().Say(arguments[0]->sourceLocation(), 3061 "C_LOC() argument must be a data pointer or target"_err_en_US); 3062 } 3063 if (auto typeAndShape{characteristics::TypeAndShape::Characterize( 3064 arguments[0], context)}) { 3065 if (expr && !IsContiguous(*expr, context).value_or(true)) { 3066 context.messages().Say(arguments[0]->sourceLocation(), 3067 "C_LOC() argument must be contiguous"_err_en_US); 3068 } 3069 if (auto constExtents{AsConstantExtents(context, typeAndShape->shape())}; 3070 constExtents && GetSize(*constExtents) == 0) { 3071 context.messages().Say(arguments[0]->sourceLocation(), 3072 "C_LOC() argument may not be a zero-sized array"_err_en_US); 3073 } 3074 if (!(typeAndShape->type().category() != TypeCategory::Derived || 3075 typeAndShape->type().IsAssumedType() || 3076 (!typeAndShape->type().IsPolymorphic() && 3077 CountNonConstantLenParameters( 3078 typeAndShape->type().GetDerivedTypeSpec()) == 0))) { 3079 context.messages().Say(arguments[0]->sourceLocation(), 3080 "C_LOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter"_err_en_US); 3081 } else if (typeAndShape->type().knownLength().value_or(1) == 0) { 3082 context.messages().Say(arguments[0]->sourceLocation(), 3083 "C_LOC() argument may not be zero-length character"_err_en_US); 3084 } else if (typeAndShape->type().category() != TypeCategory::Derived && 3085 !IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true)) { 3086 if (typeAndShape->type().category() == TypeCategory::Character && 3087 typeAndShape->type().kind() == 1) { 3088 // Default character kind, but length is not known to be 1 3089 if (context.languageFeatures().ShouldWarn( 3090 common::UsageWarning::CharacterInteroperability)) { 3091 context.messages().Say( 3092 common::UsageWarning::CharacterInteroperability, 3093 arguments[0]->sourceLocation(), 3094 "C_LOC() argument has non-interoperable character length"_warn_en_US); 3095 } 3096 } else if (context.languageFeatures().ShouldWarn( 3097 common::UsageWarning::Interoperability)) { 3098 context.messages().Say(common::UsageWarning::Interoperability, 3099 arguments[0]->sourceLocation(), 3100 "C_LOC() argument has non-interoperable intrinsic type or kind"_warn_en_US); 3101 } 3102 } 3103 3104 characteristics::DummyDataObject ddo{std::move(*typeAndShape)}; 3105 ddo.intent = common::Intent::In; 3106 return SpecificCall{ 3107 SpecificIntrinsic{"__builtin_c_loc"s, 3108 characteristics::Procedure{ 3109 characteristics::FunctionResult{ 3110 DynamicType{GetBuiltinDerivedType( 3111 builtinsScope_, "__builtin_c_ptr")}}, 3112 characteristics::DummyArguments{ 3113 characteristics::DummyArgument{"x"s, std::move(ddo)}}, 3114 characteristics::Procedure::Attrs{ 3115 characteristics::Procedure::Attr::Pure}}}, 3116 std::move(arguments)}; 3117 } 3118 } 3119 return std::nullopt; 3120 } 3121 3122 // CUDA Fortran C_DEVLOC(x) 3123 std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Devloc( 3124 ActualArguments &arguments, FoldingContext &context) const { 3125 static const char *const keywords[]{"cptr", nullptr}; 3126 3127 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords)) { 3128 CHECK(arguments.size() == 1); 3129 const auto *expr{arguments[0].value().UnwrapExpr()}; 3130 if (auto typeAndShape{characteristics::TypeAndShape::Characterize( 3131 arguments[0], context)}) { 3132 if (expr && !IsContiguous(*expr, context).value_or(true)) { 3133 context.messages().Say(arguments[0]->sourceLocation(), 3134 "C_DEVLOC() argument must be contiguous"_err_en_US); 3135 } 3136 if (auto constExtents{AsConstantExtents(context, typeAndShape->shape())}; 3137 constExtents && GetSize(*constExtents) == 0) { 3138 context.messages().Say(arguments[0]->sourceLocation(), 3139 "C_DEVLOC() argument may not be a zero-sized array"_err_en_US); 3140 } 3141 if (!(typeAndShape->type().category() != TypeCategory::Derived || 3142 typeAndShape->type().IsAssumedType() || 3143 (!typeAndShape->type().IsPolymorphic() && 3144 CountNonConstantLenParameters( 3145 typeAndShape->type().GetDerivedTypeSpec()) == 0))) { 3146 context.messages().Say(arguments[0]->sourceLocation(), 3147 "C_DEVLOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter"_err_en_US); 3148 } else if (typeAndShape->type().knownLength().value_or(1) == 0) { 3149 context.messages().Say(arguments[0]->sourceLocation(), 3150 "C_DEVLOC() argument may not be zero-length character"_err_en_US); 3151 } else if (typeAndShape->type().category() != TypeCategory::Derived && 3152 !IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true)) { 3153 if (typeAndShape->type().category() == TypeCategory::Character && 3154 typeAndShape->type().kind() == 1) { 3155 // Default character kind, but length is not known to be 1 3156 if (context.languageFeatures().ShouldWarn( 3157 common::UsageWarning::CharacterInteroperability)) { 3158 context.messages().Say( 3159 common::UsageWarning::CharacterInteroperability, 3160 arguments[0]->sourceLocation(), 3161 "C_DEVLOC() argument has non-interoperable character length"_warn_en_US); 3162 } 3163 } else if (context.languageFeatures().ShouldWarn( 3164 common::UsageWarning::Interoperability)) { 3165 context.messages().Say(common::UsageWarning::Interoperability, 3166 arguments[0]->sourceLocation(), 3167 "C_DEVLOC() argument has non-interoperable intrinsic type or kind"_warn_en_US); 3168 } 3169 } 3170 3171 characteristics::DummyDataObject ddo{std::move(*typeAndShape)}; 3172 ddo.intent = common::Intent::In; 3173 return SpecificCall{ 3174 SpecificIntrinsic{"__builtin_c_devloc"s, 3175 characteristics::Procedure{ 3176 characteristics::FunctionResult{ 3177 DynamicType{GetBuiltinDerivedType( 3178 builtinsScope_, "__builtin_c_devptr")}}, 3179 characteristics::DummyArguments{ 3180 characteristics::DummyArgument{"cptr"s, std::move(ddo)}}, 3181 characteristics::Procedure::Attrs{ 3182 characteristics::Procedure::Attr::Pure}}}, 3183 std::move(arguments)}; 3184 } 3185 } 3186 return std::nullopt; 3187 } 3188 3189 static bool CheckForNonPositiveValues(FoldingContext &context, 3190 const ActualArgument &arg, const std::string &procName, 3191 const std::string &argName) { 3192 bool ok{true}; 3193 if (arg.Rank() > 0) { 3194 if (const Expr<SomeType> *expr{arg.UnwrapExpr()}) { 3195 if (const auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) { 3196 Fortran::common::visit( 3197 [&](const auto &kindExpr) { 3198 using IntType = typename std::decay_t<decltype(kindExpr)>::Result; 3199 if (const auto *constArray{ 3200 UnwrapConstantValue<IntType>(kindExpr)}) { 3201 for (std::size_t j{0}; j < constArray->size(); ++j) { 3202 auto arrayExpr{constArray->values().at(j)}; 3203 if (arrayExpr.IsNegative() || arrayExpr.IsZero()) { 3204 ok = false; 3205 context.messages().Say(arg.sourceLocation(), 3206 "'%s=' argument for intrinsic '%s' must contain all positive values"_err_en_US, 3207 argName, procName); 3208 } 3209 } 3210 } 3211 }, 3212 intExpr->u); 3213 } 3214 } 3215 } else { 3216 if (auto val{ToInt64(arg.UnwrapExpr())}) { 3217 if (*val <= 0) { 3218 ok = false; 3219 context.messages().Say(arg.sourceLocation(), 3220 "'%s=' argument for intrinsic '%s' must be a positive value, but is %jd"_err_en_US, 3221 argName, procName, static_cast<std::intmax_t>(*val)); 3222 } 3223 } 3224 } 3225 return ok; 3226 } 3227 3228 static bool CheckAtomicDefineAndRef(FoldingContext &context, 3229 const std::optional<ActualArgument> &atomArg, 3230 const std::optional<ActualArgument> &valueArg, 3231 const std::optional<ActualArgument> &statArg, const std::string &procName) { 3232 bool sameType{true}; 3233 if (valueArg && atomArg) { 3234 // for atomic_define and atomic_ref, 'value' arg must be the same type as 3235 // 'atom', but it doesn't have to be the same kind 3236 if (valueArg->GetType()->category() != atomArg->GetType()->category()) { 3237 sameType = false; 3238 context.messages().Say(valueArg->sourceLocation(), 3239 "'value=' argument to '%s' must have same type as 'atom=', but is '%s'"_err_en_US, 3240 procName, valueArg->GetType()->AsFortran()); 3241 } 3242 } 3243 3244 return sameType && 3245 CheckForCoindexedObject(context.messages(), statArg, procName, "stat"); 3246 } 3247 3248 // Applies any semantic checks peculiar to an intrinsic. 3249 // TODO: Move the rest of these checks to Semantics/check-call.cpp. 3250 static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { 3251 bool ok{true}; 3252 const std::string &name{call.specificIntrinsic.name}; 3253 if (name == "allocated") { 3254 const auto &arg{call.arguments[0]}; 3255 if (arg) { 3256 if (const auto *expr{arg->UnwrapExpr()}) { 3257 ok = evaluate::IsAllocatableDesignator(*expr); 3258 } 3259 } 3260 if (!ok) { 3261 context.messages().Say( 3262 arg ? arg->sourceLocation() : context.messages().at(), 3263 "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US); 3264 } 3265 } else if (name == "atomic_add" || name == "atomic_and" || 3266 name == "atomic_or" || name == "atomic_xor" || name == "event_query") { 3267 return CheckForCoindexedObject( 3268 context.messages(), call.arguments[2], name, "stat"); 3269 } else if (name == "atomic_cas") { 3270 return CheckForCoindexedObject( 3271 context.messages(), call.arguments[4], name, "stat"); 3272 } else if (name == "atomic_define") { 3273 return CheckAtomicDefineAndRef( 3274 context, call.arguments[0], call.arguments[1], call.arguments[2], name); 3275 } else if (name == "atomic_fetch_add" || name == "atomic_fetch_and" || 3276 name == "atomic_fetch_or" || name == "atomic_fetch_xor") { 3277 return CheckForCoindexedObject( 3278 context.messages(), call.arguments[3], name, "stat"); 3279 } else if (name == "atomic_ref") { 3280 return CheckAtomicDefineAndRef( 3281 context, call.arguments[1], call.arguments[0], call.arguments[2], name); 3282 } else if (name == "co_broadcast" || name == "co_max" || name == "co_min" || 3283 name == "co_sum") { 3284 bool aOk{CheckForCoindexedObject( 3285 context.messages(), call.arguments[0], name, "a")}; 3286 bool statOk{CheckForCoindexedObject( 3287 context.messages(), call.arguments[2], name, "stat")}; 3288 bool errmsgOk{CheckForCoindexedObject( 3289 context.messages(), call.arguments[3], name, "errmsg")}; 3290 ok = aOk && statOk && errmsgOk; 3291 } else if (name == "image_status") { 3292 if (const auto &arg{call.arguments[0]}) { 3293 ok = CheckForNonPositiveValues(context, *arg, name, "image"); 3294 } 3295 } else if (name == "loc") { 3296 const auto &arg{call.arguments[0]}; 3297 ok = 3298 arg && (arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr())); 3299 if (!ok) { 3300 context.messages().Say( 3301 arg ? arg->sourceLocation() : context.messages().at(), 3302 "Argument of LOC() must be an object or procedure"_err_en_US); 3303 } 3304 } 3305 return ok; 3306 } 3307 3308 static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface, 3309 const common::IntrinsicTypeDefaultKinds &defaults) { 3310 TypeCategory category{TypeCategory::Integer}; 3311 switch (interface.result.kindCode) { 3312 case KindCode::defaultIntegerKind: 3313 break; 3314 case KindCode::doublePrecision: 3315 case KindCode::defaultRealKind: 3316 category = TypeCategory::Real; 3317 break; 3318 default: 3319 CRASH_NO_CASE; 3320 } 3321 int kind{interface.result.kindCode == KindCode::doublePrecision 3322 ? defaults.doublePrecisionKind() 3323 : defaults.GetDefaultKind(category)}; 3324 return DynamicType{category, kind}; 3325 } 3326 3327 // Probe the configured intrinsic procedure pattern tables in search of a 3328 // match for a given procedure reference. 3329 std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe( 3330 const CallCharacteristics &call, ActualArguments &arguments, 3331 FoldingContext &context) const { 3332 3333 // All special cases handled here before the table probes below must 3334 // also be recognized as special names in IsIntrinsicSubroutine(). 3335 if (call.isSubroutineCall) { 3336 if (call.name == "__builtin_c_f_pointer") { 3337 return HandleC_F_Pointer(arguments, context); 3338 } else if (call.name == "random_seed") { 3339 int optionalCount{0}; 3340 for (const auto &arg : arguments) { 3341 if (const auto *expr{arg->UnwrapExpr()}) { 3342 optionalCount += 3343 Fortran::evaluate::MayBePassedAsAbsentOptional(*expr); 3344 } 3345 } 3346 if (arguments.size() - optionalCount > 1) { 3347 context.messages().Say( 3348 "RANDOM_SEED must have either 1 or no arguments"_err_en_US); 3349 } 3350 } 3351 } else { // function 3352 if (call.name == "__builtin_c_loc") { 3353 return HandleC_Loc(arguments, context); 3354 } else if (call.name == "__builtin_c_devloc") { 3355 return HandleC_Devloc(arguments, context); 3356 } else if (call.name == "null") { 3357 return HandleNull(arguments, context); 3358 } 3359 } 3360 3361 if (call.isSubroutineCall) { 3362 const std::string &name{ResolveAlias(call.name)}; 3363 auto subrRange{subroutines_.equal_range(name)}; 3364 for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) { 3365 if (auto specificCall{iter->second->Match( 3366 call, defaults_, arguments, context, builtinsScope_)}) { 3367 ApplySpecificChecks(*specificCall, context); 3368 return specificCall; 3369 } 3370 } 3371 if (IsIntrinsicFunction(call.name) && !IsDualIntrinsic(call.name)) { 3372 context.messages().Say( 3373 "Cannot use intrinsic function '%s' as a subroutine"_err_en_US, 3374 call.name); 3375 } 3376 return std::nullopt; 3377 } 3378 3379 // Helper to avoid emitting errors before it is sure there is no match 3380 parser::Messages localBuffer; 3381 parser::Messages *finalBuffer{context.messages().messages()}; 3382 parser::ContextualMessages localMessages{ 3383 context.messages().at(), finalBuffer ? &localBuffer : nullptr}; 3384 FoldingContext localContext{context, localMessages}; 3385 auto matchOrBufferMessages{ 3386 [&](const IntrinsicInterface &intrinsic, 3387 parser::Messages &buffer) -> std::optional<SpecificCall> { 3388 if (auto specificCall{intrinsic.Match( 3389 call, defaults_, arguments, localContext, builtinsScope_)}) { 3390 if (finalBuffer) { 3391 finalBuffer->Annex(std::move(localBuffer)); 3392 } 3393 return specificCall; 3394 } else if (buffer.empty()) { 3395 buffer.Annex(std::move(localBuffer)); 3396 } else { 3397 // When there are multiple entries in the table for an 3398 // intrinsic that has multiple forms depending on the 3399 // presence of DIM=, use messages from a later entry if 3400 // the messages from an earlier entry complain about the 3401 // DIM= argument and it wasn't specified with a keyword. 3402 for (const auto &m : buffer.messages()) { 3403 if (m.ToString().find("'dim='") != std::string::npos) { 3404 bool hadDimKeyword{false}; 3405 for (const auto &a : arguments) { 3406 if (a) { 3407 if (auto kw{a->keyword()}; kw && kw == "dim") { 3408 hadDimKeyword = true; 3409 break; 3410 } 3411 } 3412 } 3413 if (!hadDimKeyword) { 3414 buffer = std::move(localBuffer); 3415 } 3416 break; 3417 } 3418 } 3419 localBuffer.clear(); 3420 } 3421 return std::nullopt; 3422 }}; 3423 3424 // Probe the generic intrinsic function table first; allow for 3425 // the use of a legacy alias. 3426 parser::Messages genericBuffer; 3427 const std::string &name{ResolveAlias(call.name)}; 3428 auto genericRange{genericFuncs_.equal_range(name)}; 3429 for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) { 3430 if (auto specificCall{ 3431 matchOrBufferMessages(*iter->second, genericBuffer)}) { 3432 ApplySpecificChecks(*specificCall, context); 3433 return specificCall; 3434 } 3435 } 3436 3437 // Probe the specific intrinsic function table next. 3438 parser::Messages specificBuffer; 3439 auto specificRange{specificFuncs_.equal_range(call.name)}; 3440 for (auto specIter{specificRange.first}; specIter != specificRange.second; 3441 ++specIter) { 3442 // We only need to check the cases with distinct generic names. 3443 if (const char *genericName{specIter->second->generic}) { 3444 if (auto specificCall{ 3445 matchOrBufferMessages(*specIter->second, specificBuffer)}) { 3446 if (!specIter->second->useGenericAndForceResultType) { 3447 specificCall->specificIntrinsic.name = genericName; 3448 } 3449 specificCall->specificIntrinsic.isRestrictedSpecific = 3450 specIter->second->isRestrictedSpecific; 3451 // TODO test feature AdditionalIntrinsics, warn on nonstandard 3452 // specifics with DoublePrecisionComplex arguments. 3453 return specificCall; 3454 } 3455 } 3456 } 3457 3458 // If there was no exact match with a specific, try to match the related 3459 // generic and convert the result to the specific required type. 3460 if (context.languageFeatures().IsEnabled(common::LanguageFeature:: 3461 UseGenericIntrinsicWhenSpecificDoesntMatch)) { 3462 for (auto specIter{specificRange.first}; specIter != specificRange.second; 3463 ++specIter) { 3464 // We only need to check the cases with distinct generic names. 3465 if (const char *genericName{specIter->second->generic}) { 3466 if (specIter->second->useGenericAndForceResultType) { 3467 auto genericRange{genericFuncs_.equal_range(genericName)}; 3468 for (auto genIter{genericRange.first}; genIter != genericRange.second; 3469 ++genIter) { 3470 if (auto specificCall{ 3471 matchOrBufferMessages(*genIter->second, specificBuffer)}) { 3472 // Force the call result type to the specific intrinsic result 3473 // type, if possible. 3474 DynamicType genericType{ 3475 DEREF(specificCall->specificIntrinsic.characteristics.value() 3476 .functionResult.value() 3477 .GetTypeAndShape()) 3478 .type()}; 3479 DynamicType newType{GetReturnType(*specIter->second, defaults_)}; 3480 if (genericType.category() == newType.category() || 3481 ((genericType.category() == TypeCategory::Integer || 3482 genericType.category() == TypeCategory::Real) && 3483 (newType.category() == TypeCategory::Integer || 3484 newType.category() == TypeCategory::Real))) { 3485 if (context.languageFeatures().ShouldWarn( 3486 common::LanguageFeature:: 3487 UseGenericIntrinsicWhenSpecificDoesntMatch)) { 3488 context.messages().Say( 3489 common::LanguageFeature:: 3490 UseGenericIntrinsicWhenSpecificDoesntMatch, 3491 "Argument types do not match specific intrinsic '%s' requirements; using '%s' generic instead and converting the result to %s if needed"_port_en_US, 3492 call.name, genericName, newType.AsFortran()); 3493 } 3494 specificCall->specificIntrinsic.name = call.name; 3495 specificCall->specificIntrinsic.characteristics.value() 3496 .functionResult.value() 3497 .SetType(newType); 3498 return specificCall; 3499 } 3500 } 3501 } 3502 } 3503 } 3504 } 3505 } 3506 3507 if (specificBuffer.empty() && genericBuffer.empty() && 3508 IsIntrinsicSubroutine(call.name) && !IsDualIntrinsic(call.name)) { 3509 context.messages().Say( 3510 "Cannot use intrinsic subroutine '%s' as a function"_err_en_US, 3511 call.name); 3512 } 3513 3514 // No match; report the right errors, if any 3515 if (finalBuffer) { 3516 if (specificBuffer.empty()) { 3517 finalBuffer->Annex(std::move(genericBuffer)); 3518 } else { 3519 finalBuffer->Annex(std::move(specificBuffer)); 3520 } 3521 } 3522 return std::nullopt; 3523 } 3524 3525 std::optional<SpecificIntrinsicFunctionInterface> 3526 IntrinsicProcTable::Implementation::IsSpecificIntrinsicFunction( 3527 const std::string &name) const { 3528 auto specificRange{specificFuncs_.equal_range(name)}; 3529 for (auto iter{specificRange.first}; iter != specificRange.second; ++iter) { 3530 const SpecificIntrinsicInterface &specific{*iter->second}; 3531 std::string genericName{name}; 3532 if (specific.generic) { 3533 genericName = std::string(specific.generic); 3534 } 3535 characteristics::FunctionResult fResult{GetSpecificType(specific.result)}; 3536 characteristics::DummyArguments args; 3537 int dummies{specific.CountArguments()}; 3538 for (int j{0}; j < dummies; ++j) { 3539 characteristics::DummyDataObject dummy{ 3540 GetSpecificType(specific.dummy[j].typePattern)}; 3541 dummy.intent = specific.dummy[j].intent; 3542 args.emplace_back( 3543 std::string{specific.dummy[j].keyword}, std::move(dummy)); 3544 } 3545 characteristics::Procedure::Attrs attrs; 3546 attrs.set(characteristics::Procedure::Attr::Pure) 3547 .set(characteristics::Procedure::Attr::Elemental); 3548 characteristics::Procedure chars{ 3549 std::move(fResult), std::move(args), attrs}; 3550 return SpecificIntrinsicFunctionInterface{ 3551 std::move(chars), genericName, specific.isRestrictedSpecific}; 3552 } 3553 return std::nullopt; 3554 } 3555 3556 DynamicType IntrinsicProcTable::Implementation::GetSpecificType( 3557 const TypePattern &pattern) const { 3558 const CategorySet &set{pattern.categorySet}; 3559 CHECK(set.count() == 1); 3560 TypeCategory category{set.LeastElement().value()}; 3561 if (pattern.kindCode == KindCode::doublePrecision) { 3562 return DynamicType{category, defaults_.doublePrecisionKind()}; 3563 } else if (category == TypeCategory::Character) { 3564 // All character arguments to specific intrinsic functions are 3565 // assumed-length. 3566 return DynamicType{defaults_.GetDefaultKind(category), assumedLen_}; 3567 } else { 3568 return DynamicType{category, defaults_.GetDefaultKind(category)}; 3569 } 3570 } 3571 3572 IntrinsicProcTable::~IntrinsicProcTable() = default; 3573 3574 IntrinsicProcTable IntrinsicProcTable::Configure( 3575 const common::IntrinsicTypeDefaultKinds &defaults) { 3576 IntrinsicProcTable result; 3577 result.impl_ = std::make_unique<IntrinsicProcTable::Implementation>(defaults); 3578 return result; 3579 } 3580 3581 void IntrinsicProcTable::SupplyBuiltins( 3582 const semantics::Scope &builtins) const { 3583 DEREF(impl_.get()).SupplyBuiltins(builtins); 3584 } 3585 3586 bool IntrinsicProcTable::IsIntrinsic(const std::string &name) const { 3587 return DEREF(impl_.get()).IsIntrinsic(name); 3588 } 3589 bool IntrinsicProcTable::IsIntrinsicFunction(const std::string &name) const { 3590 return DEREF(impl_.get()).IsIntrinsicFunction(name); 3591 } 3592 bool IntrinsicProcTable::IsIntrinsicSubroutine(const std::string &name) const { 3593 return DEREF(impl_.get()).IsIntrinsicSubroutine(name); 3594 } 3595 3596 IntrinsicClass IntrinsicProcTable::GetIntrinsicClass( 3597 const std::string &name) const { 3598 return DEREF(impl_.get()).GetIntrinsicClass(name); 3599 } 3600 3601 std::string IntrinsicProcTable::GetGenericIntrinsicName( 3602 const std::string &name) const { 3603 return DEREF(impl_.get()).GetGenericIntrinsicName(name); 3604 } 3605 3606 std::optional<SpecificCall> IntrinsicProcTable::Probe( 3607 const CallCharacteristics &call, ActualArguments &arguments, 3608 FoldingContext &context) const { 3609 return DEREF(impl_.get()).Probe(call, arguments, context); 3610 } 3611 3612 std::optional<SpecificIntrinsicFunctionInterface> 3613 IntrinsicProcTable::IsSpecificIntrinsicFunction(const std::string &name) const { 3614 return DEREF(impl_.get()).IsSpecificIntrinsicFunction(name); 3615 } 3616 3617 llvm::raw_ostream &TypePattern::Dump(llvm::raw_ostream &o) const { 3618 if (categorySet == AnyType) { 3619 o << "any type"; 3620 } else { 3621 const char *sep = ""; 3622 auto set{categorySet}; 3623 while (auto least{set.LeastElement()}) { 3624 o << sep << EnumToString(*least); 3625 sep = " or "; 3626 set.reset(*least); 3627 } 3628 } 3629 o << '(' << EnumToString(kindCode) << ')'; 3630 return o; 3631 } 3632 3633 llvm::raw_ostream &IntrinsicDummyArgument::Dump(llvm::raw_ostream &o) const { 3634 if (keyword) { 3635 o << keyword << '='; 3636 } 3637 return typePattern.Dump(o) 3638 << ' ' << EnumToString(rank) << ' ' << EnumToString(optionality) 3639 << EnumToString(intent); 3640 } 3641 3642 llvm::raw_ostream &IntrinsicInterface::Dump(llvm::raw_ostream &o) const { 3643 o << name; 3644 char sep{'('}; 3645 for (const auto &d : dummy) { 3646 if (d.typePattern.kindCode == KindCode::none) { 3647 break; 3648 } 3649 d.Dump(o << sep); 3650 sep = ','; 3651 } 3652 if (sep == '(') { 3653 o << "()"; 3654 } 3655 return result.Dump(o << " -> ") << ' ' << EnumToString(rank); 3656 } 3657 3658 llvm::raw_ostream &IntrinsicProcTable::Implementation::Dump( 3659 llvm::raw_ostream &o) const { 3660 o << "generic intrinsic functions:\n"; 3661 for (const auto &iter : genericFuncs_) { 3662 iter.second->Dump(o << iter.first << ": ") << '\n'; 3663 } 3664 o << "specific intrinsic functions:\n"; 3665 for (const auto &iter : specificFuncs_) { 3666 iter.second->Dump(o << iter.first << ": "); 3667 if (const char *g{iter.second->generic}) { 3668 o << " -> " << g; 3669 } 3670 o << '\n'; 3671 } 3672 o << "subroutines:\n"; 3673 for (const auto &iter : subroutines_) { 3674 iter.second->Dump(o << iter.first << ": ") << '\n'; 3675 } 3676 return o; 3677 } 3678 3679 llvm::raw_ostream &IntrinsicProcTable::Dump(llvm::raw_ostream &o) const { 3680 return DEREF(impl_.get()).Dump(o); 3681 } 3682 3683 // In general C846 prohibits allocatable coarrays to be passed to INTENT(OUT) 3684 // dummy arguments. This rule does not apply to intrinsics in general. 3685 // Some intrinsic explicitly allow coarray allocatable in their description. 3686 // It is assumed that unless explicitly allowed for an intrinsic, 3687 // this is forbidden. 3688 // Since there are very few intrinsic identified that allow this, they are 3689 // listed here instead of adding a field in the table. 3690 bool AcceptsIntentOutAllocatableCoarray(const std::string &intrinsic) { 3691 return intrinsic == "move_alloc"; 3692 } 3693 } // namespace Fortran::evaluate 3694