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

source code of flang/lib/Evaluate/intrinsics.cpp