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