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