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