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