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