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