1 //===-- lib/Evaluate/intrinsics.cpp ---------------------------------------===//
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
7 //===----------------------------------------------------------------------===//
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"
29 using namespace Fortran::parser::literals
;
31 namespace Fortran::evaluate
{
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
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.
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).
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"
58 // Assumed-type (TYPE(*)) dummy arguments can be forwarded along to some
59 // intrinsic functions that accept AnyType + Rank::anyOrAssumedRank,
60 // AnyType + Rank::arrayOrAssumedRank, or AnyType + Kind::addressable.
61 using CategorySet
= common::EnumSet
<TypeCategory
, 8>;
62 static constexpr CategorySet IntType
{TypeCategory::Integer
};
63 static constexpr CategorySet UnsignedType
{TypeCategory::Unsigned
};
64 static constexpr CategorySet RealType
{TypeCategory::Real
};
65 static constexpr CategorySet ComplexType
{TypeCategory::Complex
};
66 static constexpr CategorySet CharType
{TypeCategory::Character
};
67 static constexpr CategorySet LogicalType
{TypeCategory::Logical
};
68 static constexpr CategorySet IntOrUnsignedType
{IntType
| UnsignedType
};
69 static constexpr CategorySet IntOrRealType
{IntType
| RealType
};
70 static constexpr CategorySet IntUnsignedOrRealType
{
71 IntType
| UnsignedType
| RealType
};
72 static constexpr CategorySet IntOrRealOrCharType
{IntType
| RealType
| CharType
};
73 static constexpr CategorySet IntOrLogicalType
{IntType
| LogicalType
};
74 static constexpr CategorySet FloatingType
{RealType
| ComplexType
};
75 static constexpr CategorySet NumericType
{
76 IntType
| UnsignedType
| RealType
| ComplexType
};
77 static constexpr CategorySet RelatableType
{
78 IntType
| UnsignedType
| RealType
| CharType
};
79 static constexpr CategorySet DerivedType
{TypeCategory::Derived
};
80 static constexpr CategorySet IntrinsicType
{
81 IntType
| UnsignedType
| RealType
| ComplexType
| CharType
| LogicalType
};
82 static constexpr CategorySet AnyType
{IntrinsicType
| DerivedType
};
84 ENUM_CLASS(KindCode
, none
, defaultIntegerKind
,
85 defaultRealKind
, // is also the default COMPLEX kind
86 doublePrecision
, defaultCharKind
, defaultLogicalKind
,
87 greaterOrEqualToKind
, // match kind value greater than or equal to a single
88 // explicit kind value
89 any
, // matches any kind value; each instance is independent
90 // match any kind, but all "same" kinds must be equal. For characters, also
91 // implies that lengths must be equal.
93 // for characters that only require the same kind, not length
95 operand
, // match any kind, with promotion (non-standard)
96 typeless
, // BOZ literals are INTEGER with this kind
97 ieeeFlagType
, // IEEE_FLAG_TYPE from ISO_FORTRAN_EXCEPTION
98 ieeeRoundType
, // IEEE_ROUND_TYPE from ISO_FORTRAN_ARITHMETIC
99 eventType
, // EVENT_TYPE from module ISO_FORTRAN_ENV (for coarrays)
100 teamType
, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays)
101 kindArg
, // this argument is KIND=
102 effectiveKind
, // for function results: "kindArg" value, possibly defaulted
103 dimArg
, // this argument is DIM=
104 likeMultiply
, // for DOT_PRODUCT and MATMUL
105 subscript
, // address-sized integer
106 size
, // default KIND= for SIZE(), UBOUND, &c.
107 addressable
, // for PRESENT(), &c.; anything (incl. procedure) but BOZ
108 nullPointerType
, // for ASSOCIATED(NULL())
109 exactKind
, // a single explicit exactKindValue
110 atomicIntKind
, // atomic_int_kind from iso_fortran_env
111 atomicIntOrLogicalKind
, // atomic_int_kind or atomic_logical_kind
112 sameAtom
, // same type and kind as atom
116 CategorySet categorySet
;
117 KindCode kindCode
{KindCode::none
};
118 int kindValue
{0}; // for KindCode::exactKind and greaterOrEqualToKind
119 llvm::raw_ostream
&Dump(llvm::raw_ostream
&) const;
122 // Abbreviations for argument and result patterns in the intrinsic prototypes:
124 // Match specific kinds of intrinsic types
125 static constexpr TypePattern DefaultInt
{IntType
, KindCode::defaultIntegerKind
};
126 static constexpr TypePattern DefaultReal
{RealType
, KindCode::defaultRealKind
};
127 static constexpr TypePattern DefaultComplex
{
128 ComplexType
, KindCode::defaultRealKind
};
129 static constexpr TypePattern DefaultChar
{CharType
, KindCode::defaultCharKind
};
130 static constexpr TypePattern DefaultLogical
{
131 LogicalType
, KindCode::defaultLogicalKind
};
132 static constexpr TypePattern BOZ
{IntType
, KindCode::typeless
};
133 static constexpr TypePattern EventType
{DerivedType
, KindCode::eventType
};
134 static constexpr TypePattern IeeeFlagType
{DerivedType
, KindCode::ieeeFlagType
};
135 static constexpr TypePattern IeeeRoundType
{
136 DerivedType
, KindCode::ieeeRoundType
};
137 static constexpr TypePattern TeamType
{DerivedType
, KindCode::teamType
};
138 static constexpr TypePattern DoublePrecision
{
139 RealType
, KindCode::doublePrecision
};
140 static constexpr TypePattern DoublePrecisionComplex
{
141 ComplexType
, KindCode::doublePrecision
};
142 static constexpr TypePattern SubscriptInt
{IntType
, KindCode::subscript
};
144 // Match any kind of some intrinsic or derived types
145 static constexpr TypePattern AnyInt
{IntType
, KindCode::any
};
146 static constexpr TypePattern AnyIntOrUnsigned
{IntOrUnsignedType
, KindCode::any
};
147 static constexpr TypePattern AnyReal
{RealType
, KindCode::any
};
148 static constexpr TypePattern AnyIntOrReal
{IntOrRealType
, KindCode::any
};
149 static constexpr TypePattern AnyIntUnsignedOrReal
{
150 IntUnsignedOrRealType
, KindCode::any
};
151 static constexpr TypePattern AnyIntOrRealOrChar
{
152 IntOrRealOrCharType
, KindCode::any
};
153 static constexpr TypePattern AnyIntOrLogical
{IntOrLogicalType
, KindCode::any
};
154 static constexpr TypePattern AnyComplex
{ComplexType
, KindCode::any
};
155 static constexpr TypePattern AnyFloating
{FloatingType
, KindCode::any
};
156 static constexpr TypePattern AnyNumeric
{NumericType
, KindCode::any
};
157 static constexpr TypePattern AnyChar
{CharType
, KindCode::any
};
158 static constexpr TypePattern AnyLogical
{LogicalType
, KindCode::any
};
159 static constexpr TypePattern AnyRelatable
{RelatableType
, KindCode::any
};
160 static constexpr TypePattern AnyIntrinsic
{IntrinsicType
, KindCode::any
};
161 static constexpr TypePattern ExtensibleDerived
{DerivedType
, KindCode::any
};
162 static constexpr TypePattern AnyData
{AnyType
, KindCode::any
};
164 // Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.)
165 static constexpr TypePattern Addressable
{AnyType
, KindCode::addressable
};
167 // Match some kind of some intrinsic type(s); all "Same" values must match,
168 // even when not in the same category (e.g., SameComplex and SameReal).
169 // Can be used to specify a result so long as at least one argument is
171 static constexpr TypePattern SameInt
{IntType
, KindCode::same
};
172 static constexpr TypePattern SameIntOrUnsigned
{
173 IntOrUnsignedType
, KindCode::same
};
174 static constexpr TypePattern SameReal
{RealType
, KindCode::same
};
175 static constexpr TypePattern SameIntOrReal
{IntOrRealType
, KindCode::same
};
176 static constexpr TypePattern SameIntUnsignedOrReal
{
177 IntUnsignedOrRealType
, KindCode::same
};
178 static constexpr TypePattern SameComplex
{ComplexType
, KindCode::same
};
179 static constexpr TypePattern SameFloating
{FloatingType
, KindCode::same
};
180 static constexpr TypePattern SameNumeric
{NumericType
, KindCode::same
};
181 static constexpr TypePattern SameChar
{CharType
, KindCode::same
};
182 static constexpr TypePattern SameCharNoLen
{CharType
, KindCode::sameKind
};
183 static constexpr TypePattern SameLogical
{LogicalType
, KindCode::same
};
184 static constexpr TypePattern SameRelatable
{RelatableType
, KindCode::same
};
185 static constexpr TypePattern SameIntrinsic
{IntrinsicType
, KindCode::same
};
186 static constexpr TypePattern SameType
{AnyType
, KindCode::same
};
188 // Match some kind of some INTEGER or REAL type(s); when argument types
189 // &/or kinds differ, their values are converted as if they were operands to
190 // an intrinsic operation like addition. This is a nonstandard but nearly
191 // universal extension feature.
192 static constexpr TypePattern OperandInt
{IntType
, KindCode::operand
};
193 static constexpr TypePattern OperandReal
{RealType
, KindCode::operand
};
194 static constexpr TypePattern OperandIntOrReal
{IntOrRealType
, KindCode::operand
};
196 static constexpr TypePattern OperandUnsigned
{UnsignedType
, KindCode::operand
};
198 // For ASSOCIATED, the first argument is a typeless pointer
199 static constexpr TypePattern AnyPointer
{AnyType
, KindCode::nullPointerType
};
201 // For DOT_PRODUCT and MATMUL, the result type depends on the arguments
202 static constexpr TypePattern ResultLogical
{LogicalType
, KindCode::likeMultiply
};
203 static constexpr TypePattern ResultNumeric
{NumericType
, KindCode::likeMultiply
};
205 // Result types with known category and KIND=
206 static constexpr TypePattern KINDInt
{IntType
, KindCode::effectiveKind
};
207 static constexpr TypePattern KINDUnsigned
{
208 UnsignedType
, KindCode::effectiveKind
};
209 static constexpr TypePattern KINDReal
{RealType
, KindCode::effectiveKind
};
210 static constexpr TypePattern KINDComplex
{ComplexType
, KindCode::effectiveKind
};
211 static constexpr TypePattern KINDChar
{CharType
, KindCode::effectiveKind
};
212 static constexpr TypePattern KINDLogical
{LogicalType
, KindCode::effectiveKind
};
214 static constexpr TypePattern AtomicInt
{IntType
, KindCode::atomicIntKind
};
215 static constexpr TypePattern AtomicIntOrLogical
{
216 IntOrLogicalType
, KindCode::atomicIntOrLogicalKind
};
217 static constexpr TypePattern SameAtom
{IntOrLogicalType
, KindCode::sameAtom
};
219 // The default rank pattern for dummy arguments and function results is
222 elemental
, // scalar, or array that conforms with other array arguments
223 elementalOrBOZ
, // elemental, or typeless BOZ literal scalar
225 shape
, // INTEGER vector of known length and no negative element
227 array
, // not scalar, rank is known and greater than zero
228 coarray
, // rank is known and can be scalar; has nonzero corank
229 atom
, // is scalar and has nonzero corank or is coindexed
230 known
, // rank is known and can be scalar
231 anyOrAssumedRank
, // any rank, or assumed; assumed-type TYPE(*) allowed
232 arrayOrAssumedRank
, // rank >= 1 or assumed; assumed-type TYPE(*) allowed
233 conformable
, // scalar, or array of same rank & shape as "array" argument
234 reduceOperation
, // a pure function with constraints for REDUCE
235 dimReduced
, // scalar if no DIM= argument, else rank(array)-1
236 dimRemovedOrScalar
, // rank(array)-1 (less DIM) or scalar
237 scalarIfDim
, // scalar if DIM= argument is present, else rank one array
238 locReduced
, // vector(1:rank) if no DIM= argument, else rank(array)-1
239 rankPlus1
, // rank(known)+1
240 shaped
, // rank is length of SHAPE vector
243 ENUM_CLASS(Optionality
, required
,
244 optional
, // unless DIM= for SIZE(assumedSize)
245 missing
, // for DIM= cases like FINDLOC
246 repeats
, // for MAX/MIN and their several variants
249 ENUM_CLASS(ArgFlag
, none
,
250 canBeNull
, // actual argument can be NULL(with or without MOLD=)
251 canBeMoldNull
, // actual argument can be NULL(with MOLD=)
252 defaultsToSameKind
, // for MatchingDefaultKIND
253 defaultsToSizeKind
, // for SizeDefaultKIND
254 defaultsToDefaultForResult
, // for DefaultingKIND
257 struct IntrinsicDummyArgument
{
258 const char *keyword
{nullptr};
259 TypePattern typePattern
;
260 Rank rank
{Rank::elemental
};
261 Optionality optionality
{Optionality::required
};
262 common::Intent intent
{common::Intent::In
};
263 common::EnumSet
<ArgFlag
, 32> flags
{};
264 llvm::raw_ostream
&Dump(llvm::raw_ostream
&) const;
267 // constexpr abbreviations for popular arguments:
268 // DefaultingKIND is a KIND= argument whose default value is the appropriate
269 // KIND(0), KIND(0.0), KIND(''), &c. value for the function result.
270 static constexpr IntrinsicDummyArgument DefaultingKIND
{"kind",
271 {IntType
, KindCode::kindArg
}, Rank::scalar
, Optionality::optional
,
272 common::Intent::In
, {ArgFlag::defaultsToDefaultForResult
}};
273 // MatchingDefaultKIND is a KIND= argument whose default value is the
274 // kind of any "Same" function argument (viz., the one whose kind pattern is
276 static constexpr IntrinsicDummyArgument MatchingDefaultKIND
{"kind",
277 {IntType
, KindCode::kindArg
}, Rank::scalar
, Optionality::optional
,
278 common::Intent::In
, {ArgFlag::defaultsToSameKind
}};
279 // SizeDefaultKind is a KIND= argument whose default value should be
280 // the kind of INTEGER used for address calculations, and can be
281 // set so with a compiler flag; but the standard mandates the
282 // kind of default INTEGER.
283 static constexpr IntrinsicDummyArgument SizeDefaultKIND
{"kind",
284 {IntType
, KindCode::kindArg
}, Rank::scalar
, Optionality::optional
,
285 common::Intent::In
, {ArgFlag::defaultsToSizeKind
}};
286 static constexpr IntrinsicDummyArgument RequiredDIM
{"dim",
287 {IntType
, KindCode::dimArg
}, Rank::scalar
, Optionality::required
,
289 static constexpr IntrinsicDummyArgument OptionalDIM
{"dim",
290 {IntType
, KindCode::dimArg
}, Rank::scalar
, Optionality::optional
,
292 static constexpr IntrinsicDummyArgument MissingDIM
{"dim",
293 {IntType
, KindCode::dimArg
}, Rank::scalar
, Optionality::missing
,
295 static constexpr IntrinsicDummyArgument OptionalMASK
{"mask", AnyLogical
,
296 Rank::conformable
, Optionality::optional
, common::Intent::In
};
297 static constexpr IntrinsicDummyArgument OptionalTEAM
{
298 "team", TeamType
, Rank::scalar
, Optionality::optional
, common::Intent::In
};
300 struct IntrinsicInterface
{
301 static constexpr int maxArguments
{7}; // if not a MAX/MIN(...)
302 const char *name
{nullptr};
303 IntrinsicDummyArgument dummy
[maxArguments
];
305 Rank rank
{Rank::elemental
};
306 IntrinsicClass intrinsicClass
{IntrinsicClass::elementalFunction
};
307 std::optional
<SpecificCall
> Match(const CallCharacteristics
&,
308 const common::IntrinsicTypeDefaultKinds
&, ActualArguments
&,
309 FoldingContext
&context
, const semantics::Scope
*builtins
) const;
310 int CountArguments() const;
311 llvm::raw_ostream
&Dump(llvm::raw_ostream
&) const;
314 int IntrinsicInterface::CountArguments() const {
316 while (n
< maxArguments
&& dummy
[n
].keyword
) {
322 // GENERIC INTRINSIC FUNCTION INTERFACES
323 // Each entry in this table defines a pattern. Some intrinsic
324 // functions have more than one such pattern. Besides the name
325 // of the intrinsic function, each pattern has specifications for
326 // the dummy arguments and for the result of the function.
327 // The dummy argument patterns each have a name (these are from the
328 // standard, but rarely appear in actual code), a type and kind
329 // pattern, allowable ranks, and optionality indicators.
330 // Be advised, the default rank pattern is "elemental".
331 static const IntrinsicInterface genericIntrinsicFunction
[]{
332 {"abs", {{"a", SameIntOrReal
}}, SameIntOrReal
},
333 {"abs", {{"a", SameComplex
}}, SameReal
},
334 {"achar", {{"i", AnyInt
, Rank::elementalOrBOZ
}, DefaultingKIND
}, KINDChar
},
335 {"acos", {{"x", SameFloating
}}, SameFloating
},
336 {"acosd", {{"x", SameFloating
}}, SameFloating
},
337 {"acosh", {{"x", SameFloating
}}, SameFloating
},
338 {"adjustl", {{"string", SameChar
}}, SameChar
},
339 {"adjustr", {{"string", SameChar
}}, SameChar
},
340 {"aimag", {{"z", SameComplex
}}, SameReal
},
341 {"aint", {{"a", SameReal
}, MatchingDefaultKIND
}, KINDReal
},
342 {"all", {{"mask", SameLogical
, Rank::array
}, OptionalDIM
}, SameLogical
,
343 Rank::dimReduced
, IntrinsicClass::transformationalFunction
},
344 {"allocated", {{"scalar", AnyData
, Rank::scalar
}}, DefaultLogical
,
345 Rank::elemental
, IntrinsicClass::inquiryFunction
},
346 {"allocated", {{"array", AnyData
, Rank::anyOrAssumedRank
}}, DefaultLogical
,
347 Rank::elemental
, IntrinsicClass::inquiryFunction
},
348 {"anint", {{"a", SameReal
}, MatchingDefaultKIND
}, KINDReal
},
349 {"any", {{"mask", SameLogical
, Rank::array
}, OptionalDIM
}, SameLogical
,
350 Rank::dimReduced
, IntrinsicClass::transformationalFunction
},
351 {"asin", {{"x", SameFloating
}}, SameFloating
},
352 {"asind", {{"x", SameFloating
}}, SameFloating
},
353 {"asinh", {{"x", SameFloating
}}, SameFloating
},
355 {{"pointer", AnyPointer
, Rank::anyOrAssumedRank
, Optionality::required
,
356 common::Intent::In
, {ArgFlag::canBeNull
}},
357 {"target", Addressable
, Rank::anyOrAssumedRank
,
358 Optionality::optional
, common::Intent::In
,
359 {ArgFlag::canBeNull
}}},
360 DefaultLogical
, Rank::elemental
, IntrinsicClass::inquiryFunction
},
361 {"atan", {{"x", SameFloating
}}, SameFloating
},
362 {"atan", {{"y", OperandReal
}, {"x", OperandReal
}}, OperandReal
},
363 {"atand", {{"x", SameFloating
}}, SameFloating
},
364 {"atand", {{"y", OperandReal
}, {"x", OperandReal
}}, OperandReal
},
365 {"atan2", {{"y", OperandReal
}, {"x", OperandReal
}}, OperandReal
},
366 {"atan2d", {{"y", OperandReal
}, {"x", OperandReal
}}, OperandReal
},
367 {"atanpi", {{"x", SameFloating
}}, SameFloating
},
368 {"atanpi", {{"y", OperandReal
}, {"x", OperandReal
}}, OperandReal
},
369 {"atan2pi", {{"y", OperandReal
}, {"x", OperandReal
}}, OperandReal
},
370 {"atanh", {{"x", SameFloating
}}, SameFloating
},
371 {"bessel_j0", {{"x", SameReal
}}, SameReal
},
372 {"bessel_j1", {{"x", SameReal
}}, SameReal
},
373 {"bessel_jn", {{"n", AnyInt
}, {"x", SameReal
}}, SameReal
},
375 {{"n1", AnyInt
, Rank::scalar
}, {"n2", AnyInt
, Rank::scalar
},
376 {"x", SameReal
, Rank::scalar
}},
377 SameReal
, Rank::vector
, IntrinsicClass::transformationalFunction
},
378 {"bessel_y0", {{"x", SameReal
}}, SameReal
},
379 {"bessel_y1", {{"x", SameReal
}}, SameReal
},
380 {"bessel_yn", {{"n", AnyInt
}, {"x", SameReal
}}, SameReal
},
382 {{"n1", AnyInt
, Rank::scalar
}, {"n2", AnyInt
, Rank::scalar
},
383 {"x", SameReal
, Rank::scalar
}},
384 SameReal
, Rank::vector
, IntrinsicClass::transformationalFunction
},
386 {{"i", AnyIntOrUnsigned
, Rank::elementalOrBOZ
},
387 {"j", AnyIntOrUnsigned
, Rank::elementalOrBOZ
}},
390 {{"i", AnyIntOrUnsigned
, Rank::elementalOrBOZ
},
391 {"j", AnyIntOrUnsigned
, Rank::elementalOrBOZ
}},
394 {{"i", SameIntOrUnsigned
, Rank::anyOrAssumedRank
, Optionality::required
,
395 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
396 SameInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
398 {{"i", AnyIntOrUnsigned
, Rank::elementalOrBOZ
},
399 {"j", AnyIntOrUnsigned
, Rank::elementalOrBOZ
}},
402 {{"i", AnyIntOrUnsigned
, Rank::elementalOrBOZ
},
403 {"j", AnyIntOrUnsigned
, Rank::elementalOrBOZ
}},
405 {"btest", {{"i", AnyIntOrUnsigned
, Rank::elementalOrBOZ
}, {"pos", AnyInt
}},
407 {"ceiling", {{"a", AnyReal
}, DefaultingKIND
}, KINDInt
},
408 {"char", {{"i", AnyInt
, Rank::elementalOrBOZ
}, DefaultingKIND
}, KINDChar
},
409 {"chdir", {{"name", DefaultChar
, Rank::scalar
, Optionality::required
}},
411 {"cmplx", {{"x", AnyComplex
}, DefaultingKIND
}, KINDComplex
},
413 {{"x", AnyIntUnsignedOrReal
, Rank::elementalOrBOZ
},
414 {"y", AnyIntUnsignedOrReal
, Rank::elementalOrBOZ
,
415 Optionality::optional
},
418 {"command_argument_count", {}, DefaultInt
, Rank::scalar
,
419 IntrinsicClass::transformationalFunction
},
420 {"conjg", {{"z", SameComplex
}}, SameComplex
},
421 {"cos", {{"x", SameFloating
}}, SameFloating
},
422 {"cosd", {{"x", SameFloating
}}, SameFloating
},
423 {"cosh", {{"x", SameFloating
}}, SameFloating
},
424 {"count", {{"mask", AnyLogical
, Rank::array
}, OptionalDIM
, DefaultingKIND
},
425 KINDInt
, Rank::dimReduced
, IntrinsicClass::transformationalFunction
},
427 {{"array", SameType
, Rank::array
},
428 {"shift", AnyInt
, Rank::dimRemovedOrScalar
}, OptionalDIM
},
429 SameType
, Rank::conformable
, IntrinsicClass::transformationalFunction
},
430 {"dble", {{"a", AnyNumeric
, Rank::elementalOrBOZ
}}, DoublePrecision
},
432 {{"x", AnyIntUnsignedOrReal
, Rank::anyOrAssumedRank
,
433 Optionality::required
, common::Intent::In
,
434 {ArgFlag::canBeMoldNull
}}},
435 DefaultInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
436 {"dim", {{"x", OperandIntOrReal
}, {"y", OperandIntOrReal
}},
439 {{"vector_a", AnyLogical
, Rank::vector
},
440 {"vector_b", AnyLogical
, Rank::vector
}},
441 ResultLogical
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
443 {{"vector_a", AnyComplex
, Rank::vector
},
444 {"vector_b", AnyNumeric
, Rank::vector
}},
445 ResultNumeric
, Rank::scalar
, // conjugates vector_a
446 IntrinsicClass::transformationalFunction
},
448 {{"vector_a", AnyIntUnsignedOrReal
, Rank::vector
},
449 {"vector_b", AnyNumeric
, Rank::vector
}},
450 ResultNumeric
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
451 {"dprod", {{"x", DefaultReal
}, {"y", DefaultReal
}}, DoublePrecision
},
453 {{"i", SameIntOrUnsigned
},
454 {"j", SameIntOrUnsigned
, Rank::elementalOrBOZ
}, {"shift", AnyInt
}},
456 {"dshiftl", {{"i", BOZ
}, {"j", SameIntOrUnsigned
}, {"shift", AnyInt
}},
459 {{"i", SameIntOrUnsigned
},
460 {"j", SameIntOrUnsigned
, Rank::elementalOrBOZ
}, {"shift", AnyInt
}},
462 {"dshiftr", {{"i", BOZ
}, {"j", SameIntOrUnsigned
}, {"shift", AnyInt
}},
465 {{"array", SameType
, Rank::array
},
466 {"shift", AnyInt
, Rank::dimRemovedOrScalar
},
467 // BOUNDARY= is not optional for non-intrinsic types
468 {"boundary", SameType
, Rank::dimRemovedOrScalar
}, OptionalDIM
},
469 SameType
, Rank::conformable
, IntrinsicClass::transformationalFunction
},
471 {{"array", SameIntrinsic
, Rank::array
},
472 {"shift", AnyInt
, Rank::dimRemovedOrScalar
},
473 {"boundary", SameIntrinsic
, Rank::dimRemovedOrScalar
,
474 Optionality::optional
},
476 SameIntrinsic
, Rank::conformable
,
477 IntrinsicClass::transformationalFunction
},
479 {{"x", SameReal
, Rank::anyOrAssumedRank
, Optionality::required
,
480 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
481 SameReal
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
482 {"erf", {{"x", SameReal
}}, SameReal
},
483 {"erfc", {{"x", SameReal
}}, SameReal
},
484 {"erfc_scaled", {{"x", SameReal
}}, SameReal
},
486 {{"values", TypePattern
{RealType
, KindCode::exactKind
, 4}, Rank::vector
,
487 Optionality::required
, common::Intent::Out
}},
488 TypePattern
{RealType
, KindCode::exactKind
, 4}},
489 {"exp", {{"x", SameFloating
}}, SameFloating
},
490 {"exp", {{"x", SameFloating
}}, SameFloating
},
491 {"exponent", {{"x", AnyReal
}}, DefaultInt
},
492 {"exp", {{"x", SameFloating
}}, SameFloating
},
494 {{"a", ExtensibleDerived
, Rank::anyOrAssumedRank
, Optionality::required
,
495 common::Intent::In
, {ArgFlag::canBeMoldNull
}},
496 {"mold", ExtensibleDerived
, Rank::anyOrAssumedRank
,
497 Optionality::required
, common::Intent::In
,
498 {ArgFlag::canBeMoldNull
}}},
499 DefaultLogical
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
500 {"failed_images", {OptionalTEAM
, SizeDefaultKIND
}, KINDInt
, Rank::vector
,
501 IntrinsicClass::transformationalFunction
},
503 {{"array", AnyNumeric
, Rank::array
},
504 {"value", AnyNumeric
, Rank::scalar
}, RequiredDIM
, OptionalMASK
,
506 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
507 KINDInt
, Rank::locReduced
, IntrinsicClass::transformationalFunction
},
509 {{"array", AnyNumeric
, Rank::array
},
510 {"value", AnyNumeric
, Rank::scalar
}, MissingDIM
, OptionalMASK
,
512 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
513 KINDInt
, Rank::vector
, IntrinsicClass::transformationalFunction
},
515 {{"array", SameCharNoLen
, Rank::array
},
516 {"value", SameCharNoLen
, Rank::scalar
}, RequiredDIM
, OptionalMASK
,
518 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
519 KINDInt
, Rank::locReduced
, IntrinsicClass::transformationalFunction
},
521 {{"array", SameCharNoLen
, Rank::array
},
522 {"value", SameCharNoLen
, Rank::scalar
}, MissingDIM
, OptionalMASK
,
524 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
525 KINDInt
, Rank::vector
, IntrinsicClass::transformationalFunction
},
527 {{"array", AnyLogical
, Rank::array
},
528 {"value", AnyLogical
, Rank::scalar
}, RequiredDIM
, OptionalMASK
,
530 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
531 KINDInt
, Rank::locReduced
, IntrinsicClass::transformationalFunction
},
533 {{"array", AnyLogical
, Rank::array
},
534 {"value", AnyLogical
, Rank::scalar
}, MissingDIM
, OptionalMASK
,
536 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
537 KINDInt
, Rank::vector
, IntrinsicClass::transformationalFunction
},
538 {"floor", {{"a", AnyReal
}, DefaultingKIND
}, KINDInt
},
539 {"fraction", {{"x", SameReal
}}, SameReal
},
540 {"gamma", {{"x", SameReal
}}, SameReal
},
541 {"get_team", {{"level", DefaultInt
, Rank::scalar
, Optionality::optional
}},
542 TeamType
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
544 {{"c", DefaultChar
, Rank::scalar
, Optionality::required
,
545 common::Intent::Out
}},
546 TypePattern
{IntType
, KindCode::greaterOrEqualToKind
, 4}},
547 {"getgid", {}, DefaultInt
},
548 {"getpid", {}, DefaultInt
},
549 {"getuid", {}, DefaultInt
},
551 {{"x", SameIntUnsignedOrReal
, Rank::anyOrAssumedRank
,
552 Optionality::required
, common::Intent::In
,
553 {ArgFlag::canBeMoldNull
}}},
554 SameIntUnsignedOrReal
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
555 {"hypot", {{"x", OperandReal
}, {"y", OperandReal
}}, OperandReal
},
556 {"iachar", {{"c", AnyChar
}, DefaultingKIND
}, KINDInt
},
558 {{"array", SameIntOrUnsigned
, Rank::array
}, RequiredDIM
, OptionalMASK
},
559 SameIntOrUnsigned
, Rank::dimReduced
,
560 IntrinsicClass::transformationalFunction
},
562 {{"array", SameIntOrUnsigned
, Rank::array
}, MissingDIM
, OptionalMASK
},
563 SameIntOrUnsigned
, Rank::scalar
,
564 IntrinsicClass::transformationalFunction
},
566 {{"array", SameIntOrUnsigned
, Rank::array
}, RequiredDIM
, OptionalMASK
},
567 SameIntOrUnsigned
, Rank::dimReduced
,
568 IntrinsicClass::transformationalFunction
},
570 {{"array", SameIntOrUnsigned
, Rank::array
}, MissingDIM
, OptionalMASK
},
571 SameIntOrUnsigned
, Rank::scalar
,
572 IntrinsicClass::transformationalFunction
},
574 {{"array", SameIntOrUnsigned
, Rank::array
}, RequiredDIM
, OptionalMASK
},
575 SameIntOrUnsigned
, Rank::dimReduced
,
576 IntrinsicClass::transformationalFunction
},
578 {{"array", SameIntOrUnsigned
, Rank::array
}, MissingDIM
, OptionalMASK
},
579 SameIntOrUnsigned
, Rank::scalar
,
580 IntrinsicClass::transformationalFunction
},
581 {"iand", {{"i", OperandInt
}, {"j", OperandInt
, Rank::elementalOrBOZ
}},
584 {{"i", OperandUnsigned
}, {"j", OperandUnsigned
, Rank::elementalOrBOZ
}},
586 {"iand", {{"i", BOZ
}, {"j", SameIntOrUnsigned
}}, SameIntOrUnsigned
},
587 {"ibclr", {{"i", SameIntOrUnsigned
}, {"pos", AnyInt
}}, SameIntOrUnsigned
},
588 {"ibits", {{"i", SameIntOrUnsigned
}, {"pos", AnyInt
}, {"len", AnyInt
}},
590 {"ibset", {{"i", SameIntOrUnsigned
}, {"pos", AnyInt
}}, SameIntOrUnsigned
},
591 {"ichar", {{"c", AnyChar
}, DefaultingKIND
}, KINDInt
},
592 {"ieor", {{"i", OperandInt
}, {"j", OperandInt
, Rank::elementalOrBOZ
}},
595 {{"i", OperandUnsigned
}, {"j", OperandUnsigned
, Rank::elementalOrBOZ
}},
597 {"ieor", {{"i", BOZ
}, {"j", SameIntOrUnsigned
}}, SameIntOrUnsigned
},
599 {{"coarray", AnyData
, Rank::coarray
}, {"sub", AnyInt
, Rank::vector
}},
600 DefaultInt
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
602 {{"coarray", AnyData
, Rank::coarray
}, {"sub", AnyInt
, Rank::vector
},
603 {"team", TeamType
, Rank::scalar
}},
604 DefaultInt
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
606 {{"coarray", AnyData
, Rank::coarray
}, {"sub", AnyInt
, Rank::vector
},
607 {"team_number", AnyInt
, Rank::scalar
}},
608 DefaultInt
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
609 {"image_status", {{"image", SameInt
}, OptionalTEAM
}, DefaultInt
},
611 {{"string", SameCharNoLen
}, {"substring", SameCharNoLen
},
612 {"back", AnyLogical
, Rank::elemental
, Optionality::optional
},
615 {"int", {{"a", AnyNumeric
, Rank::elementalOrBOZ
}, DefaultingKIND
}, KINDInt
},
616 {"int2", {{"a", AnyNumeric
, Rank::elementalOrBOZ
}},
617 TypePattern
{IntType
, KindCode::exactKind
, 2}},
618 {"int8", {{"a", AnyNumeric
, Rank::elementalOrBOZ
}},
619 TypePattern
{IntType
, KindCode::exactKind
, 8}},
620 {"int_ptr_kind", {}, DefaultInt
, Rank::scalar
},
621 {"ior", {{"i", OperandInt
}, {"j", OperandInt
, Rank::elementalOrBOZ
}},
624 {{"i", OperandUnsigned
}, {"j", OperandUnsigned
, Rank::elementalOrBOZ
}},
626 {"ior", {{"i", BOZ
}, {"j", SameIntOrUnsigned
}}, SameIntOrUnsigned
},
627 {"ishft", {{"i", SameIntOrUnsigned
}, {"shift", AnyInt
}}, SameIntOrUnsigned
},
629 {{"i", SameIntOrUnsigned
}, {"shift", AnyInt
},
630 {"size", AnyInt
, Rank::elemental
, Optionality::optional
}},
632 {"isnan", {{"a", AnyFloating
}}, DefaultLogical
},
633 {"is_contiguous", {{"array", Addressable
, Rank::anyOrAssumedRank
}},
634 DefaultLogical
, Rank::elemental
, IntrinsicClass::inquiryFunction
},
635 {"is_iostat_end", {{"i", AnyInt
}}, DefaultLogical
},
636 {"is_iostat_eor", {{"i", AnyInt
}}, DefaultLogical
},
637 {"izext", {{"i", AnyInt
}}, TypePattern
{IntType
, KindCode::exactKind
, 2}},
638 {"jzext", {{"i", AnyInt
}}, DefaultInt
},
640 {{"x", AnyIntrinsic
, Rank::anyOrAssumedRank
, Optionality::required
,
641 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
642 DefaultInt
, Rank::elemental
, IntrinsicClass::inquiryFunction
},
644 {{"array", AnyData
, Rank::anyOrAssumedRank
}, RequiredDIM
,
646 KINDInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
647 {"lbound", {{"array", AnyData
, Rank::arrayOrAssumedRank
}, SizeDefaultKIND
},
648 KINDInt
, Rank::vector
, IntrinsicClass::inquiryFunction
},
650 {{"coarray", AnyData
, Rank::coarray
}, OptionalDIM
, SizeDefaultKIND
},
651 KINDInt
, Rank::scalarIfDim
, IntrinsicClass::inquiryFunction
},
652 {"leadz", {{"i", AnyInt
}}, DefaultInt
},
654 {{"string", AnyChar
, Rank::anyOrAssumedRank
, Optionality::required
,
655 common::Intent::In
, {ArgFlag::canBeMoldNull
}},
657 KINDInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
658 {"len_trim", {{"string", AnyChar
}, DefaultingKIND
}, KINDInt
},
659 {"lge", {{"string_a", SameCharNoLen
}, {"string_b", SameCharNoLen
}},
661 {"lgt", {{"string_a", SameCharNoLen
}, {"string_b", SameCharNoLen
}},
663 {"lle", {{"string_a", SameCharNoLen
}, {"string_b", SameCharNoLen
}},
665 {"llt", {{"string_a", SameCharNoLen
}, {"string_b", SameCharNoLen
}},
667 {"lnblnk", {{"string", AnyChar
}}, DefaultInt
},
668 {"loc", {{"x", Addressable
, Rank::anyOrAssumedRank
}}, SubscriptInt
,
670 {"log", {{"x", SameFloating
}}, SameFloating
},
671 {"log10", {{"x", SameReal
}}, SameReal
},
672 {"logical", {{"l", AnyLogical
}, DefaultingKIND
}, KINDLogical
},
673 {"log_gamma", {{"x", SameReal
}}, SameReal
},
674 {"malloc", {{"size", AnyInt
}}, SubscriptInt
},
676 {{"matrix_a", AnyLogical
, Rank::vector
},
677 {"matrix_b", AnyLogical
, Rank::matrix
}},
678 ResultLogical
, Rank::vector
, IntrinsicClass::transformationalFunction
},
680 {{"matrix_a", AnyLogical
, Rank::matrix
},
681 {"matrix_b", AnyLogical
, Rank::vector
}},
682 ResultLogical
, Rank::vector
, IntrinsicClass::transformationalFunction
},
684 {{"matrix_a", AnyLogical
, Rank::matrix
},
685 {"matrix_b", AnyLogical
, Rank::matrix
}},
686 ResultLogical
, Rank::matrix
, IntrinsicClass::transformationalFunction
},
688 {{"matrix_a", AnyNumeric
, Rank::vector
},
689 {"matrix_b", AnyNumeric
, Rank::matrix
}},
690 ResultNumeric
, Rank::vector
, IntrinsicClass::transformationalFunction
},
692 {{"matrix_a", AnyNumeric
, Rank::matrix
},
693 {"matrix_b", AnyNumeric
, Rank::vector
}},
694 ResultNumeric
, Rank::vector
, IntrinsicClass::transformationalFunction
},
696 {{"matrix_a", AnyNumeric
, Rank::matrix
},
697 {"matrix_b", AnyNumeric
, Rank::matrix
}},
698 ResultNumeric
, Rank::matrix
, IntrinsicClass::transformationalFunction
},
699 {"maskl", {{"i", AnyInt
}, DefaultingKIND
}, KINDInt
},
700 {"maskr", {{"i", AnyInt
}, DefaultingKIND
}, KINDInt
},
702 {{"a1", OperandIntOrReal
}, {"a2", OperandIntOrReal
},
703 {"a3", OperandIntOrReal
, Rank::elemental
, Optionality::repeats
}},
706 {{"a1", OperandUnsigned
}, {"a2", OperandUnsigned
},
707 {"a3", OperandUnsigned
, Rank::elemental
, Optionality::repeats
}},
710 {{"a1", SameCharNoLen
}, {"a2", SameCharNoLen
},
711 {"a3", SameCharNoLen
, Rank::elemental
, Optionality::repeats
}},
714 {{"x", AnyReal
, Rank::anyOrAssumedRank
, Optionality::required
,
715 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
716 DefaultInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
718 {{"array", AnyRelatable
, Rank::array
}, RequiredDIM
, OptionalMASK
,
720 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
721 KINDInt
, Rank::locReduced
, IntrinsicClass::transformationalFunction
},
723 {{"array", AnyRelatable
, Rank::array
}, MissingDIM
, OptionalMASK
,
725 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
726 KINDInt
, Rank::locReduced
, IntrinsicClass::transformationalFunction
},
728 {{"array", SameRelatable
, Rank::array
}, RequiredDIM
, OptionalMASK
},
729 SameRelatable
, Rank::dimReduced
,
730 IntrinsicClass::transformationalFunction
},
732 {{"array", SameRelatable
, Rank::array
}, MissingDIM
, OptionalMASK
},
733 SameRelatable
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
735 {{"tsource", SameType
}, {"fsource", SameType
}, {"mask", AnyLogical
}},
738 {{"i", SameIntOrUnsigned
},
739 {"j", SameIntOrUnsigned
, Rank::elementalOrBOZ
},
740 {"mask", SameIntOrUnsigned
, Rank::elementalOrBOZ
}},
743 {{"i", BOZ
}, {"j", SameIntOrUnsigned
},
744 {"mask", SameIntOrUnsigned
, Rank::elementalOrBOZ
}},
747 {{"a1", OperandIntOrReal
}, {"a2", OperandIntOrReal
},
748 {"a3", OperandIntOrReal
, Rank::elemental
, Optionality::repeats
}},
751 {{"a1", OperandUnsigned
}, {"a2", OperandUnsigned
},
752 {"a3", OperandUnsigned
, Rank::elemental
, Optionality::repeats
}},
755 {{"a1", SameCharNoLen
}, {"a2", SameCharNoLen
},
756 {"a3", SameCharNoLen
, Rank::elemental
, Optionality::repeats
}},
759 {{"x", AnyReal
, Rank::anyOrAssumedRank
, Optionality::required
,
760 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
761 DefaultInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
763 {{"array", AnyRelatable
, Rank::array
}, RequiredDIM
, OptionalMASK
,
765 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
766 KINDInt
, Rank::locReduced
, IntrinsicClass::transformationalFunction
},
768 {{"array", AnyRelatable
, Rank::array
}, MissingDIM
, OptionalMASK
,
770 {"back", AnyLogical
, Rank::scalar
, Optionality::optional
}},
771 KINDInt
, Rank::locReduced
, IntrinsicClass::transformationalFunction
},
773 {{"array", SameRelatable
, Rank::array
}, RequiredDIM
, OptionalMASK
},
774 SameRelatable
, Rank::dimReduced
,
775 IntrinsicClass::transformationalFunction
},
777 {{"array", SameRelatable
, Rank::array
}, MissingDIM
, OptionalMASK
},
778 SameRelatable
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
779 {"mod", {{"a", OperandIntOrReal
}, {"p", OperandIntOrReal
}},
781 {"mod", {{"a", OperandUnsigned
}, {"p", OperandUnsigned
}}, OperandUnsigned
},
782 {"modulo", {{"a", OperandIntOrReal
}, {"p", OperandIntOrReal
}},
784 {"modulo", {{"a", OperandUnsigned
}, {"p", OperandUnsigned
}},
786 {"nearest", {{"x", SameReal
}, {"s", AnyReal
}}, SameReal
},
788 {{"a", SameCharNoLen
, Rank::anyOrAssumedRank
, Optionality::required
,
789 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
790 SameCharNoLen
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
791 {"nint", {{"a", AnyReal
}, DefaultingKIND
}, KINDInt
},
792 {"norm2", {{"x", SameReal
, Rank::array
}, RequiredDIM
}, SameReal
,
793 Rank::dimReduced
, IntrinsicClass::transformationalFunction
},
794 {"norm2", {{"x", SameReal
, Rank::array
}, MissingDIM
}, SameReal
,
795 Rank::scalar
, IntrinsicClass::transformationalFunction
},
796 {"not", {{"i", SameIntOrUnsigned
}}, SameIntOrUnsigned
},
797 // NULL() is a special case handled in Probe() below
798 {"num_images", {}, DefaultInt
, Rank::scalar
,
799 IntrinsicClass::transformationalFunction
},
800 {"num_images", {{"team", TeamType
, Rank::scalar
}}, DefaultInt
, Rank::scalar
,
801 IntrinsicClass::transformationalFunction
},
802 {"num_images", {{"team_number", AnyInt
, Rank::scalar
}}, DefaultInt
,
803 Rank::scalar
, IntrinsicClass::transformationalFunction
},
805 {{"x", AnyIntOrReal
}, {"mold", AnyIntOrReal
, Rank::scalar
}},
808 {{"x", AnyReal
}, {"mold", AnyInt
, Rank::scalar
},
809 {"round", AnyLogical
, Rank::scalar
, Optionality::optional
}},
811 {"out_of_range", {{"x", AnyReal
}, {"mold", AnyReal
}}, DefaultLogical
},
813 {{"array", SameType
, Rank::array
},
814 {"mask", AnyLogical
, Rank::conformable
},
815 {"vector", SameType
, Rank::vector
, Optionality::optional
}},
816 SameType
, Rank::vector
, IntrinsicClass::transformationalFunction
},
817 {"parity", {{"mask", SameLogical
, Rank::array
}, OptionalDIM
}, SameLogical
,
818 Rank::dimReduced
, IntrinsicClass::transformationalFunction
},
819 {"popcnt", {{"i", AnyInt
}}, DefaultInt
},
820 {"poppar", {{"i", AnyInt
}}, DefaultInt
},
822 {{"array", SameNumeric
, Rank::array
}, RequiredDIM
, OptionalMASK
},
823 SameNumeric
, Rank::dimReduced
,
824 IntrinsicClass::transformationalFunction
},
825 {"product", {{"array", SameNumeric
, Rank::array
}, MissingDIM
, OptionalMASK
},
826 SameNumeric
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
828 {{"x", AnyFloating
, Rank::anyOrAssumedRank
, Optionality::required
,
829 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
830 DefaultInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
831 {"present", {{"a", Addressable
, Rank::anyOrAssumedRank
}}, DefaultLogical
,
832 Rank::scalar
, IntrinsicClass::inquiryFunction
},
834 {{"x", AnyIntOrReal
, Rank::anyOrAssumedRank
, Optionality::required
,
835 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
836 DefaultInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
838 {{"x", AnyNumeric
, Rank::anyOrAssumedRank
, Optionality::required
,
839 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
840 DefaultInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
842 {{"a", AnyData
, Rank::anyOrAssumedRank
, Optionality::required
,
843 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
844 DefaultInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
845 {"real", {{"a", SameComplex
, Rank::elemental
}},
846 SameReal
}, // 16.9.160(4)(ii)
847 {"real", {{"a", AnyNumeric
, Rank::elementalOrBOZ
}, DefaultingKIND
},
850 {{"array", SameType
, Rank::array
},
851 {"operation", SameType
, Rank::reduceOperation
}, RequiredDIM
,
853 {"identity", SameType
, Rank::scalar
, Optionality::optional
},
854 {"ordered", AnyLogical
, Rank::scalar
, Optionality::optional
}},
855 SameType
, Rank::dimReduced
, IntrinsicClass::transformationalFunction
},
857 {{"array", SameType
, Rank::array
},
858 {"operation", SameType
, Rank::reduceOperation
}, MissingDIM
,
860 {"identity", SameType
, Rank::scalar
, Optionality::optional
},
861 {"ordered", AnyLogical
, Rank::scalar
, Optionality::optional
}},
862 SameType
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
864 {{"path1", DefaultChar
, Rank::scalar
},
865 {"path2", DefaultChar
, Rank::scalar
}},
866 DefaultInt
, Rank::scalar
},
868 {{"string", SameCharNoLen
, Rank::scalar
},
869 {"ncopies", AnyInt
, Rank::scalar
}},
870 SameCharNoLen
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
872 {{"source", SameType
, Rank::array
}, {"shape", AnyInt
, Rank::shape
},
873 {"pad", SameType
, Rank::array
, Optionality::optional
},
874 {"order", AnyInt
, Rank::vector
, Optionality::optional
}},
875 SameType
, Rank::shaped
, IntrinsicClass::transformationalFunction
},
876 {"rrspacing", {{"x", SameReal
}}, SameReal
},
878 {{"a", ExtensibleDerived
, Rank::anyOrAssumedRank
, Optionality::required
,
879 common::Intent::In
, {ArgFlag::canBeMoldNull
}},
880 {"b", ExtensibleDerived
, Rank::anyOrAssumedRank
,
881 Optionality::required
, common::Intent::In
,
882 {ArgFlag::canBeMoldNull
}}},
883 DefaultLogical
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
884 {"scale", {{"x", SameReal
}, {"i", AnyInt
}}, SameReal
}, // == IEEE_SCALB()
886 {{"string", SameCharNoLen
}, {"set", SameCharNoLen
},
887 {"back", AnyLogical
, Rank::elemental
, Optionality::optional
},
890 {"second", {}, DefaultReal
, Rank::scalar
},
891 {"selected_char_kind", {{"name", DefaultChar
, Rank::scalar
}}, DefaultInt
,
892 Rank::scalar
, IntrinsicClass::transformationalFunction
},
893 {"selected_int_kind", {{"r", AnyInt
, Rank::scalar
}}, DefaultInt
,
894 Rank::scalar
, IntrinsicClass::transformationalFunction
},
895 {"selected_logical_kind", {{"bits", AnyInt
, Rank::scalar
}}, DefaultInt
,
896 Rank::scalar
, IntrinsicClass::transformationalFunction
},
897 {"selected_real_kind",
898 {{"p", AnyInt
, Rank::scalar
},
899 {"r", AnyInt
, Rank::scalar
, Optionality::optional
},
900 {"radix", AnyInt
, Rank::scalar
, Optionality::optional
}},
901 DefaultInt
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
902 {"selected_real_kind",
903 {{"p", AnyInt
, Rank::scalar
, Optionality::optional
},
904 {"r", AnyInt
, Rank::scalar
},
905 {"radix", AnyInt
, Rank::scalar
, Optionality::optional
}},
906 DefaultInt
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
907 {"selected_real_kind",
908 {{"p", AnyInt
, Rank::scalar
, Optionality::optional
},
909 {"r", AnyInt
, Rank::scalar
, Optionality::optional
},
910 {"radix", AnyInt
, Rank::scalar
}},
911 DefaultInt
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
912 {"selected_unsigned_kind", {{"r", AnyInt
, Rank::scalar
}}, DefaultInt
,
913 Rank::scalar
, IntrinsicClass::transformationalFunction
},
914 {"set_exponent", {{"x", SameReal
}, {"i", AnyInt
}}, SameReal
},
915 {"shape", {{"source", AnyData
, Rank::anyOrAssumedRank
}, SizeDefaultKIND
},
916 KINDInt
, Rank::vector
, IntrinsicClass::inquiryFunction
},
917 {"shifta", {{"i", SameIntOrUnsigned
}, {"shift", AnyInt
}},
919 {"shiftl", {{"i", SameIntOrUnsigned
}, {"shift", AnyInt
}},
921 {"shiftr", {{"i", SameIntOrUnsigned
}, {"shift", AnyInt
}},
923 {"sign", {{"a", SameInt
}, {"b", AnyInt
}}, SameInt
},
924 {"sign", {{"a", SameReal
}, {"b", AnyReal
}}, SameReal
},
925 {"sin", {{"x", SameFloating
}}, SameFloating
},
926 {"sind", {{"x", SameFloating
}}, SameFloating
},
927 {"sinh", {{"x", SameFloating
}}, SameFloating
},
929 {{"array", AnyData
, Rank::arrayOrAssumedRank
},
930 OptionalDIM
, // unless array is assumed-size
932 KINDInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
933 {"sizeof", {{"a", AnyData
, Rank::anyOrAssumedRank
}}, SubscriptInt
,
934 Rank::scalar
, IntrinsicClass::inquiryFunction
},
935 {"spacing", {{"x", SameReal
}}, SameReal
},
937 {{"source", SameType
, Rank::known
, Optionality::required
,
938 common::Intent::In
, {ArgFlag::notAssumedSize
}},
939 RequiredDIM
, {"ncopies", AnyInt
, Rank::scalar
}},
940 SameType
, Rank::rankPlus1
, IntrinsicClass::transformationalFunction
},
941 {"sqrt", {{"x", SameFloating
}}, SameFloating
},
942 {"stopped_images", {OptionalTEAM
, SizeDefaultKIND
}, KINDInt
, Rank::vector
,
943 IntrinsicClass::transformationalFunction
},
945 {{"a", AnyData
, Rank::anyOrAssumedRank
, Optionality::required
,
946 common::Intent::In
, {ArgFlag::canBeMoldNull
}},
948 KINDInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
949 {"sum", {{"array", SameNumeric
, Rank::array
}, RequiredDIM
, OptionalMASK
},
950 SameNumeric
, Rank::dimReduced
,
951 IntrinsicClass::transformationalFunction
},
952 {"sum", {{"array", SameNumeric
, Rank::array
}, MissingDIM
, OptionalMASK
},
953 SameNumeric
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
954 {"system", {{"command", DefaultChar
, Rank::scalar
}}, DefaultInt
,
956 {"tan", {{"x", SameFloating
}}, SameFloating
},
957 {"tand", {{"x", SameFloating
}}, SameFloating
},
958 {"tanh", {{"x", SameFloating
}}, SameFloating
},
959 {"team_number", {OptionalTEAM
}, DefaultInt
, Rank::scalar
,
960 IntrinsicClass::transformationalFunction
},
962 {{"coarray", AnyData
, Rank::coarray
}, RequiredDIM
, OptionalTEAM
},
963 DefaultInt
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
964 {"this_image", {{"coarray", AnyData
, Rank::coarray
}, OptionalTEAM
},
965 DefaultInt
, Rank::vector
, IntrinsicClass::transformationalFunction
},
966 {"this_image", {OptionalTEAM
}, DefaultInt
, Rank::scalar
,
967 IntrinsicClass::transformationalFunction
},
969 {{"x", SameReal
, Rank::anyOrAssumedRank
, Optionality::required
,
970 common::Intent::In
, {ArgFlag::canBeMoldNull
}}},
971 SameReal
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
972 {"trailz", {{"i", AnyInt
}}, DefaultInt
},
974 {{"source", AnyData
, Rank::known
}, {"mold", SameType
, Rank::scalar
}},
975 SameType
, Rank::scalar
, IntrinsicClass::transformationalFunction
},
977 {{"source", AnyData
, Rank::known
}, {"mold", SameType
, Rank::array
}},
978 SameType
, Rank::vector
, IntrinsicClass::transformationalFunction
},
980 {{"source", AnyData
, Rank::anyOrAssumedRank
},
981 {"mold", SameType
, Rank::anyOrAssumedRank
},
982 {"size", AnyInt
, Rank::scalar
}},
983 SameType
, Rank::vector
, IntrinsicClass::transformationalFunction
},
984 {"transpose", {{"matrix", SameType
, Rank::matrix
}}, SameType
, Rank::matrix
,
985 IntrinsicClass::transformationalFunction
},
986 {"trim", {{"string", SameCharNoLen
, Rank::scalar
}}, SameCharNoLen
,
987 Rank::scalar
, IntrinsicClass::transformationalFunction
},
989 {{"array", AnyData
, Rank::anyOrAssumedRank
}, RequiredDIM
,
991 KINDInt
, Rank::scalar
, IntrinsicClass::inquiryFunction
},
992 {"ubound", {{"array", AnyData
, Rank::arrayOrAssumedRank
}, SizeDefaultKIND
},
993 KINDInt
, Rank::vector
, IntrinsicClass::inquiryFunction
},
995 {{"coarray", AnyData
, Rank::coarray
}, OptionalDIM
, SizeDefaultKIND
},
996 KINDInt
, Rank::scalarIfDim
, IntrinsicClass::inquiryFunction
},
997 {"uint", {{"a", AnyNumeric
, Rank::elementalOrBOZ
}, DefaultingKIND
},
999 {"umaskl", {{"i", AnyInt
}, DefaultingKIND
}, KINDUnsigned
},
1000 {"umaskr", {{"i", AnyInt
}, DefaultingKIND
}, KINDUnsigned
},
1002 {{"vector", SameType
, Rank::vector
}, {"mask", AnyLogical
, Rank::array
},
1003 {"field", SameType
, Rank::conformable
}},
1004 SameType
, Rank::conformable
, IntrinsicClass::transformationalFunction
},
1006 {{"string", SameCharNoLen
}, {"set", SameCharNoLen
},
1007 {"back", AnyLogical
, Rank::elemental
, Optionality::optional
},
1010 {"__builtin_compiler_options", {}, DefaultChar
},
1011 {"__builtin_compiler_version", {}, DefaultChar
},
1012 {"__builtin_fma", {{"f1", SameReal
}, {"f2", SameReal
}, {"f3", SameReal
}},
1014 {"__builtin_ieee_int",
1015 {{"a", AnyFloating
}, {"round", IeeeRoundType
}, DefaultingKIND
},
1017 {"__builtin_ieee_is_nan", {{"a", AnyFloating
}}, DefaultLogical
},
1018 {"__builtin_ieee_is_negative", {{"a", AnyFloating
}}, DefaultLogical
},
1019 {"__builtin_ieee_is_normal", {{"a", AnyFloating
}}, DefaultLogical
},
1020 {"__builtin_ieee_next_after", {{"x", SameReal
}, {"y", AnyReal
}}, SameReal
},
1021 {"__builtin_ieee_next_down", {{"x", SameReal
}}, SameReal
},
1022 {"__builtin_ieee_next_up", {{"x", SameReal
}}, SameReal
},
1023 {"__builtin_ieee_real", {{"a", AnyIntOrReal
}, DefaultingKIND
}, KINDReal
},
1024 {"__builtin_ieee_support_datatype",
1025 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1027 {"__builtin_ieee_support_denormal",
1028 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1030 {"__builtin_ieee_support_divide",
1031 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1033 {"__builtin_ieee_support_flag",
1034 {{"flag", IeeeFlagType
, Rank::scalar
},
1035 {"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1037 {"__builtin_ieee_support_halting", {{"flag", IeeeFlagType
, Rank::scalar
}},
1039 {"__builtin_ieee_support_inf",
1040 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1042 {"__builtin_ieee_support_io",
1043 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1045 {"__builtin_ieee_support_nan",
1046 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1048 {"__builtin_ieee_support_rounding",
1049 {{"round_value", IeeeRoundType
, Rank::scalar
},
1050 {"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1052 {"__builtin_ieee_support_sqrt",
1053 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1055 {"__builtin_ieee_support_standard",
1056 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1058 {"__builtin_ieee_support_subnormal",
1059 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1061 {"__builtin_ieee_support_underflow_control",
1062 {{"x", AnyReal
, Rank::elemental
, Optionality::optional
}},
1064 {"__builtin_numeric_storage_size", {}, DefaultInt
},
1067 // TODO: Coarray intrinsic functions
1069 // TODO: Non-standard intrinsic functions
1071 // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT,
1072 // QCMPLX, QEXT, QFLOAT, QREAL, DNUM,
1073 // INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN,
1074 // MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR
1075 // IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE,
1076 // EOF, FP_CLASS, INT_PTR_KIND, MALLOC
1077 // probably more (these are PGI + Intel, possibly incomplete)
1078 // TODO: Optionally warn on use of non-standard intrinsics:
1079 // LOC, probably others
1080 // TODO: Optionally warn on operand promotion extension
1082 // Aliases for a few generic intrinsic functions for legacy
1083 // compatibility and builtins.
1084 static const std::pair
<const char *, const char *> genericAlias
[]{
1086 {"getenv", "get_environment_variable"},
1088 {"lshift", "shiftl"},
1090 {"rshift", "shifta"},
1091 {"unsigned", "uint"}, // Sun vs gfortran names
1093 {"__builtin_ieee_selected_real_kind", "selected_real_kind"},
1096 // The following table contains the intrinsic functions listed in
1097 // Tables 16.2 and 16.3 in Fortran 2018. The "unrestricted" functions
1098 // in Table 16.2 can be used as actual arguments, PROCEDURE() interfaces,
1099 // and procedure pointer targets.
1100 // Note that the restricted conversion functions dcmplx, dreal, float, idint,
1101 // ifix, and sngl are extended to accept any argument kind because this is a
1102 // common Fortran compilers behavior, and as far as we can tell, is safe and
1104 struct SpecificIntrinsicInterface
: public IntrinsicInterface
{
1105 const char *generic
{nullptr};
1106 bool isRestrictedSpecific
{false};
1107 // Exact actual/dummy type matching is required by default for specific
1108 // intrinsics. If useGenericAndForceResultType is set, then the probing will
1109 // also attempt to use the related generic intrinsic and to convert the result
1110 // to the specific intrinsic result type if needed. This also prevents
1111 // using the generic name so that folding can insert the conversion on the
1112 // result and not the arguments.
1114 // This is not enabled on all specific intrinsics because an alternative
1115 // is to convert the actual arguments to the required dummy types and this is
1116 // not numerically equivalent.
1117 // e.g. IABS(INT(i, 4)) not equiv to INT(ABS(i), 4).
1118 // This is allowed for restricted min/max specific functions because
1119 // the expected behavior is clear from their definitions. A warning is though
1120 // always emitted because other compilers' behavior is not ubiquitous here and
1121 // the results in case of conversion overflow might not be equivalent.
1122 // e.g for MIN0: INT(MIN(2147483647_8, 2*2147483647_8), 4) = 2147483647_4
1123 // but: MIN(INT(2147483647_8, 4), INT(2*2147483647_8, 4)) = -2_4
1124 // xlf and ifort return the first, and pgfortran the later. f18 will return
1125 // the first because this matches more closely the MIN0 definition in
1126 // Fortran 2018 table 16.3 (although it is still an extension to allow
1127 // non default integer argument in MIN0).
1128 bool useGenericAndForceResultType
{false};
1131 static const SpecificIntrinsicInterface specificIntrinsicFunction
[]{
1132 {{"abs", {{"a", DefaultReal
}}, DefaultReal
}},
1133 {{"acos", {{"x", DefaultReal
}}, DefaultReal
}},
1134 {{"aimag", {{"z", DefaultComplex
}}, DefaultReal
}},
1135 {{"aint", {{"a", DefaultReal
}}, DefaultReal
}},
1136 {{"alog", {{"x", DefaultReal
}}, DefaultReal
}, "log"},
1137 {{"alog10", {{"x", DefaultReal
}}, DefaultReal
}, "log10"},
1139 {{"a1", DefaultInt
}, {"a2", DefaultInt
},
1140 {"a3", DefaultInt
, Rank::elemental
, Optionality::repeats
}},
1144 {{"a1", DefaultReal
}, {"a2", DefaultReal
},
1145 {"a3", DefaultReal
, Rank::elemental
, Optionality::repeats
}},
1149 {{"a1", DefaultInt
}, {"a2", DefaultInt
},
1150 {"a3", DefaultInt
, Rank::elemental
, Optionality::repeats
}},
1154 {{"a1", DefaultReal
}, {"a2", DefaultReal
},
1155 {"a3", DefaultReal
, Rank::elemental
, Optionality::repeats
}},
1158 {{"amod", {{"a", DefaultReal
}, {"p", DefaultReal
}}, DefaultReal
}, "mod"},
1159 {{"anint", {{"a", DefaultReal
}}, DefaultReal
}},
1160 {{"asin", {{"x", DefaultReal
}}, DefaultReal
}},
1161 {{"atan", {{"x", DefaultReal
}}, DefaultReal
}},
1162 {{"atan2", {{"y", DefaultReal
}, {"x", DefaultReal
}}, DefaultReal
}},
1163 {{"babs", {{"a", TypePattern
{IntType
, KindCode::exactKind
, 1}}},
1164 TypePattern
{IntType
, KindCode::exactKind
, 1}},
1166 {{"cabs", {{"a", DefaultComplex
}}, DefaultReal
}, "abs"},
1167 {{"ccos", {{"x", DefaultComplex
}}, DefaultComplex
}, "cos"},
1168 {{"cdabs", {{"a", DoublePrecisionComplex
}}, DoublePrecision
}, "abs"},
1169 {{"cdcos", {{"x", DoublePrecisionComplex
}}, DoublePrecisionComplex
}, "cos"},
1170 {{"cdexp", {{"x", DoublePrecisionComplex
}}, DoublePrecisionComplex
}, "exp"},
1171 {{"cdlog", {{"x", DoublePrecisionComplex
}}, DoublePrecisionComplex
}, "log"},
1172 {{"cdsin", {{"x", DoublePrecisionComplex
}}, DoublePrecisionComplex
}, "sin"},
1173 {{"cdsqrt", {{"x", DoublePrecisionComplex
}}, DoublePrecisionComplex
},
1175 {{"cexp", {{"x", DefaultComplex
}}, DefaultComplex
}, "exp"},
1176 {{"clog", {{"x", DefaultComplex
}}, DefaultComplex
}, "log"},
1177 {{"conjg", {{"z", DefaultComplex
}}, DefaultComplex
}},
1178 {{"cos", {{"x", DefaultReal
}}, DefaultReal
}},
1179 {{"cosh", {{"x", DefaultReal
}}, DefaultReal
}},
1180 {{"csin", {{"x", DefaultComplex
}}, DefaultComplex
}, "sin"},
1181 {{"csqrt", {{"x", DefaultComplex
}}, DefaultComplex
}, "sqrt"},
1182 {{"ctan", {{"x", DefaultComplex
}}, DefaultComplex
}, "tan"},
1183 {{"dabs", {{"a", DoublePrecision
}}, DoublePrecision
}, "abs"},
1184 {{"dacos", {{"x", DoublePrecision
}}, DoublePrecision
}, "acos"},
1185 {{"dasin", {{"x", DoublePrecision
}}, DoublePrecision
}, "asin"},
1186 {{"datan", {{"x", DoublePrecision
}}, DoublePrecision
}, "atan"},
1187 {{"datan2", {{"y", DoublePrecision
}, {"x", DoublePrecision
}},
1190 {{"dcmplx", {{"x", AnyComplex
}}, DoublePrecisionComplex
}, "cmplx", true},
1192 {{"x", AnyIntOrReal
, Rank::elementalOrBOZ
},
1193 {"y", AnyIntOrReal
, Rank::elementalOrBOZ
, Optionality::optional
}},
1194 DoublePrecisionComplex
},
1196 {{"dconjg", {{"z", DoublePrecisionComplex
}}, DoublePrecisionComplex
},
1198 {{"dcos", {{"x", DoublePrecision
}}, DoublePrecision
}, "cos"},
1199 {{"dcosh", {{"x", DoublePrecision
}}, DoublePrecision
}, "cosh"},
1200 {{"ddim", {{"x", DoublePrecision
}, {"y", DoublePrecision
}},
1203 {{"derf", {{"x", DoublePrecision
}}, DoublePrecision
}, "erf"},
1204 {{"dexp", {{"x", DoublePrecision
}}, DoublePrecision
}, "exp"},
1205 {{"dfloat", {{"a", AnyInt
}}, DoublePrecision
}, "real", true},
1206 {{"dim", {{"x", DefaultReal
}, {"y", DefaultReal
}}, DefaultReal
}},
1207 {{"dimag", {{"z", DoublePrecisionComplex
}}, DoublePrecision
}, "aimag"},
1208 {{"dint", {{"a", DoublePrecision
}}, DoublePrecision
}, "aint"},
1209 {{"dlog", {{"x", DoublePrecision
}}, DoublePrecision
}, "log"},
1210 {{"dlog10", {{"x", DoublePrecision
}}, DoublePrecision
}, "log10"},
1212 {{"a1", DoublePrecision
}, {"a2", DoublePrecision
},
1213 {"a3", DoublePrecision
, Rank::elemental
, Optionality::repeats
}},
1217 {{"a1", DoublePrecision
}, {"a2", DoublePrecision
},
1218 {"a3", DoublePrecision
, Rank::elemental
, Optionality::repeats
}},
1221 {{"dmod", {{"a", DoublePrecision
}, {"p", DoublePrecision
}},
1224 {{"dnint", {{"a", DoublePrecision
}}, DoublePrecision
}, "anint"},
1225 {{"dprod", {{"x", DefaultReal
}, {"y", DefaultReal
}}, DoublePrecision
}},
1226 {{"dreal", {{"a", AnyComplex
}}, DoublePrecision
}, "real", true},
1227 {{"dsign", {{"a", DoublePrecision
}, {"b", DoublePrecision
}},
1230 {{"dsin", {{"x", DoublePrecision
}}, DoublePrecision
}, "sin"},
1231 {{"dsinh", {{"x", DoublePrecision
}}, DoublePrecision
}, "sinh"},
1232 {{"dsqrt", {{"x", DoublePrecision
}}, DoublePrecision
}, "sqrt"},
1233 {{"dtan", {{"x", DoublePrecision
}}, DoublePrecision
}, "tan"},
1234 {{"dtanh", {{"x", DoublePrecision
}}, DoublePrecision
}, "tanh"},
1235 {{"exp", {{"x", DefaultReal
}}, DefaultReal
}},
1236 {{"float", {{"a", AnyInt
}}, DefaultReal
}, "real", true},
1237 {{"iabs", {{"a", DefaultInt
}}, DefaultInt
}, "abs"},
1238 {{"idim", {{"x", DefaultInt
}, {"y", DefaultInt
}}, DefaultInt
}, "dim"},
1239 {{"idint", {{"a", AnyReal
}}, DefaultInt
}, "int", true},
1240 {{"idnint", {{"a", DoublePrecision
}}, DefaultInt
}, "nint"},
1241 {{"ifix", {{"a", AnyReal
}}, DefaultInt
}, "int", true},
1242 {{"iiabs", {{"a", TypePattern
{IntType
, KindCode::exactKind
, 2}}},
1243 TypePattern
{IntType
, KindCode::exactKind
, 2}},
1245 // The definition of the unrestricted specific intrinsic function INDEX
1246 // in F'77 and F'90 has only two arguments; later standards omit the
1247 // argument information for all unrestricted specific intrinsic
1248 // procedures. No compiler supports an implementation that allows
1249 // INDEX with BACK= to work when associated as an actual procedure or
1250 // procedure pointer target.
1251 {{"index", {{"string", DefaultChar
}, {"substring", DefaultChar
}},
1253 {{"isign", {{"a", DefaultInt
}, {"b", DefaultInt
}}, DefaultInt
}, "sign"},
1254 {{"jiabs", {{"a", TypePattern
{IntType
, KindCode::exactKind
, 4}}},
1255 TypePattern
{IntType
, KindCode::exactKind
, 4}},
1257 {{"kiabs", {{"a", TypePattern
{IntType
, KindCode::exactKind
, 8}}},
1258 TypePattern
{IntType
, KindCode::exactKind
, 8}},
1260 {{"kidnnt", {{"a", DoublePrecision
}},
1261 TypePattern
{IntType
, KindCode::exactKind
, 8}},
1263 {{"knint", {{"a", DefaultReal
}},
1264 TypePattern
{IntType
, KindCode::exactKind
, 8}},
1266 {{"len", {{"string", DefaultChar
, Rank::anyOrAssumedRank
}}, DefaultInt
,
1267 Rank::scalar
, IntrinsicClass::inquiryFunction
}},
1268 {{"lge", {{"string_a", DefaultChar
}, {"string_b", DefaultChar
}},
1271 {{"lgt", {{"string_a", DefaultChar
}, {"string_b", DefaultChar
}},
1274 {{"lle", {{"string_a", DefaultChar
}, {"string_b", DefaultChar
}},
1277 {{"llt", {{"string_a", DefaultChar
}, {"string_b", DefaultChar
}},
1280 {{"log", {{"x", DefaultReal
}}, DefaultReal
}},
1281 {{"log10", {{"x", DefaultReal
}}, DefaultReal
}},
1283 {{"a1", DefaultInt
}, {"a2", DefaultInt
},
1284 {"a3", DefaultInt
, Rank::elemental
, Optionality::repeats
}},
1288 {{"a1", DefaultReal
}, {"a2", DefaultReal
},
1289 {"a3", DefaultReal
, Rank::elemental
, Optionality::repeats
}},
1293 {{"a1", DefaultInt
}, {"a2", DefaultInt
},
1294 {"a3", DefaultInt
, Rank::elemental
, Optionality::repeats
}},
1298 {{"a1", DefaultReal
}, {"a2", DefaultReal
},
1299 {"a3", DefaultReal
, Rank::elemental
, Optionality::repeats
}},
1302 {{"mod", {{"a", DefaultInt
}, {"p", DefaultInt
}}, DefaultInt
}},
1303 {{"nint", {{"a", DefaultReal
}}, DefaultInt
}},
1304 {{"sign", {{"a", DefaultReal
}, {"b", DefaultReal
}}, DefaultReal
}},
1305 {{"sin", {{"x", DefaultReal
}}, DefaultReal
}},
1306 {{"sinh", {{"x", DefaultReal
}}, DefaultReal
}},
1307 {{"sngl", {{"a", AnyReal
}}, DefaultReal
}, "real", true},
1308 {{"sqrt", {{"x", DefaultReal
}}, DefaultReal
}},
1309 {{"tan", {{"x", DefaultReal
}}, DefaultReal
}},
1310 {{"tanh", {{"x", DefaultReal
}}, DefaultReal
}},
1311 {{"zabs", {{"a", TypePattern
{ComplexType
, KindCode::exactKind
, 8}}},
1312 TypePattern
{RealType
, KindCode::exactKind
, 8}},
1316 static const IntrinsicInterface intrinsicSubroutine
[]{
1317 {"abort", {}, {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1319 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1320 common::Intent::InOut
},
1321 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1322 common::Intent::In
},
1323 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1324 common::Intent::Out
}},
1325 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1327 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1328 common::Intent::InOut
},
1329 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1330 common::Intent::In
},
1331 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1332 common::Intent::Out
}},
1333 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1335 {{"atom", SameAtom
, Rank::atom
, Optionality::required
,
1336 common::Intent::InOut
},
1337 {"old", SameAtom
, Rank::scalar
, Optionality::required
,
1338 common::Intent::Out
},
1339 {"compare", SameAtom
, Rank::scalar
, Optionality::required
,
1340 common::Intent::In
},
1341 {"new", SameAtom
, Rank::scalar
, Optionality::required
,
1342 common::Intent::In
},
1343 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1344 common::Intent::Out
}},
1345 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1347 {{"atom", AtomicIntOrLogical
, Rank::atom
, Optionality::required
,
1348 common::Intent::Out
},
1349 {"value", AnyIntOrLogical
, Rank::scalar
, Optionality::required
,
1350 common::Intent::In
},
1351 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1352 common::Intent::Out
}},
1353 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1354 {"atomic_fetch_add",
1355 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1356 common::Intent::InOut
},
1357 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1358 common::Intent::In
},
1359 {"old", AtomicInt
, Rank::scalar
, Optionality::required
,
1360 common::Intent::Out
},
1361 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1362 common::Intent::Out
}},
1363 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1364 {"atomic_fetch_and",
1365 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1366 common::Intent::InOut
},
1367 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1368 common::Intent::In
},
1369 {"old", AtomicInt
, Rank::scalar
, Optionality::required
,
1370 common::Intent::Out
},
1371 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1372 common::Intent::Out
}},
1373 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1375 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1376 common::Intent::InOut
},
1377 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1378 common::Intent::In
},
1379 {"old", AtomicInt
, Rank::scalar
, Optionality::required
,
1380 common::Intent::Out
},
1381 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1382 common::Intent::Out
}},
1383 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1384 {"atomic_fetch_xor",
1385 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1386 common::Intent::InOut
},
1387 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1388 common::Intent::In
},
1389 {"old", AtomicInt
, Rank::scalar
, Optionality::required
,
1390 common::Intent::Out
},
1391 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1392 common::Intent::Out
}},
1393 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1395 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1396 common::Intent::InOut
},
1397 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1398 common::Intent::In
},
1399 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1400 common::Intent::Out
}},
1401 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1403 {{"value", AnyIntOrLogical
, Rank::scalar
, Optionality::required
,
1404 common::Intent::Out
},
1405 {"atom", AtomicIntOrLogical
, Rank::atom
, Optionality::required
,
1406 common::Intent::In
},
1407 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1408 common::Intent::Out
}},
1409 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1411 {{"atom", AtomicInt
, Rank::atom
, Optionality::required
,
1412 common::Intent::InOut
},
1413 {"value", AnyInt
, Rank::scalar
, Optionality::required
,
1414 common::Intent::In
},
1415 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1416 common::Intent::Out
}},
1417 {}, Rank::elemental
, IntrinsicClass::atomicSubroutine
},
1419 {{"name", DefaultChar
, Rank::scalar
, Optionality::required
},
1420 {"status", AnyInt
, Rank::scalar
, Optionality::optional
,
1421 common::Intent::Out
}},
1422 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1424 {{"a", AnyData
, Rank::anyOrAssumedRank
, Optionality::required
,
1425 common::Intent::InOut
},
1426 {"source_image", AnyInt
, Rank::scalar
, Optionality::required
,
1427 common::Intent::In
},
1428 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1429 common::Intent::Out
},
1430 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1431 common::Intent::InOut
}},
1432 {}, Rank::elemental
, IntrinsicClass::collectiveSubroutine
},
1434 {{"a", AnyIntOrRealOrChar
, Rank::anyOrAssumedRank
,
1435 Optionality::required
, common::Intent::InOut
},
1436 {"result_image", AnyInt
, Rank::scalar
, Optionality::optional
,
1437 common::Intent::In
},
1438 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1439 common::Intent::Out
},
1440 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1441 common::Intent::InOut
}},
1442 {}, Rank::elemental
, IntrinsicClass::collectiveSubroutine
},
1444 {{"a", AnyIntOrRealOrChar
, Rank::anyOrAssumedRank
,
1445 Optionality::required
, common::Intent::InOut
},
1446 {"result_image", AnyInt
, Rank::scalar
, Optionality::optional
,
1447 common::Intent::In
},
1448 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1449 common::Intent::Out
},
1450 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1451 common::Intent::InOut
}},
1452 {}, Rank::elemental
, IntrinsicClass::collectiveSubroutine
},
1454 {{"a", AnyNumeric
, Rank::anyOrAssumedRank
, Optionality::required
,
1455 common::Intent::InOut
},
1456 {"result_image", AnyInt
, Rank::scalar
, Optionality::optional
,
1457 common::Intent::In
},
1458 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1459 common::Intent::Out
},
1460 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1461 common::Intent::InOut
}},
1462 {}, Rank::elemental
, IntrinsicClass::collectiveSubroutine
},
1464 {{"time", AnyReal
, Rank::scalar
, Optionality::required
,
1465 common::Intent::Out
}},
1466 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1468 {{"date", DefaultChar
, Rank::scalar
, Optionality::optional
,
1469 common::Intent::Out
},
1470 {"time", DefaultChar
, Rank::scalar
, Optionality::optional
,
1471 common::Intent::Out
},
1472 {"zone", DefaultChar
, Rank::scalar
, Optionality::optional
,
1473 common::Intent::Out
},
1474 {"values", AnyInt
, Rank::vector
, Optionality::optional
,
1475 common::Intent::Out
}},
1476 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1478 {{"values", TypePattern
{RealType
, KindCode::exactKind
, 4}, Rank::vector
,
1479 Optionality::required
, common::Intent::Out
},
1480 {"time", TypePattern
{RealType
, KindCode::exactKind
, 4},
1481 Rank::scalar
, Optionality::required
, common::Intent::Out
}},
1482 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1484 {{"event", EventType
, Rank::scalar
},
1485 {"count", AnyInt
, Rank::scalar
, Optionality::required
,
1486 common::Intent::Out
},
1487 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1488 common::Intent::Out
}},
1489 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1490 {"execute_command_line",
1491 {{"command", DefaultChar
, Rank::scalar
},
1492 {"wait", AnyLogical
, Rank::scalar
, Optionality::optional
},
1494 TypePattern
{IntType
, KindCode::greaterOrEqualToKind
, 4},
1495 Rank::scalar
, Optionality::optional
, common::Intent::InOut
},
1496 {"cmdstat", TypePattern
{IntType
, KindCode::greaterOrEqualToKind
, 2},
1497 Rank::scalar
, Optionality::optional
, common::Intent::Out
},
1498 {"cmdmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1499 common::Intent::InOut
}},
1500 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1501 {"exit", {{"status", DefaultInt
, Rank::scalar
, Optionality::optional
}}, {},
1502 Rank::elemental
, IntrinsicClass::impureSubroutine
},
1503 {"free", {{"ptr", Addressable
}}, {}},
1505 {{"command", DefaultChar
, Rank::scalar
, Optionality::optional
,
1506 common::Intent::Out
},
1507 {"length", AnyInt
, Rank::scalar
, Optionality::optional
,
1508 common::Intent::Out
},
1509 {"status", AnyInt
, Rank::scalar
, Optionality::optional
,
1510 common::Intent::Out
},
1511 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1512 common::Intent::InOut
}},
1513 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1514 {"get_command_argument",
1515 {{"number", AnyInt
, Rank::scalar
},
1516 {"value", DefaultChar
, Rank::scalar
, Optionality::optional
,
1517 common::Intent::Out
},
1518 {"length", AnyInt
, Rank::scalar
, Optionality::optional
,
1519 common::Intent::Out
},
1520 {"status", AnyInt
, Rank::scalar
, Optionality::optional
,
1521 common::Intent::Out
},
1522 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1523 common::Intent::InOut
}},
1524 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1525 {"get_environment_variable",
1526 {{"name", DefaultChar
, Rank::scalar
},
1527 {"value", DefaultChar
, Rank::scalar
, Optionality::optional
,
1528 common::Intent::Out
},
1529 {"length", AnyInt
, Rank::scalar
, Optionality::optional
,
1530 common::Intent::Out
},
1531 {"status", AnyInt
, Rank::scalar
, Optionality::optional
,
1532 common::Intent::Out
},
1533 {"trim_name", AnyLogical
, Rank::scalar
, Optionality::optional
},
1534 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1535 common::Intent::InOut
}},
1536 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1538 {{"c", DefaultChar
, Rank::scalar
, Optionality::required
,
1539 common::Intent::Out
},
1540 {"status", TypePattern
{IntType
, KindCode::greaterOrEqualToKind
, 4},
1541 Rank::scalar
, Optionality::optional
, common::Intent::Out
}},
1542 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1544 {{"from", SameType
, Rank::known
, Optionality::required
,
1545 common::Intent::InOut
},
1546 {"to", SameType
, Rank::known
, Optionality::required
,
1547 common::Intent::Out
},
1548 {"stat", AnyInt
, Rank::scalar
, Optionality::optional
,
1549 common::Intent::Out
},
1550 {"errmsg", DefaultChar
, Rank::scalar
, Optionality::optional
,
1551 common::Intent::InOut
}},
1552 {}, Rank::elemental
, IntrinsicClass::pureSubroutine
},
1554 {{"from", SameIntOrUnsigned
}, {"frompos", AnyInt
}, {"len", AnyInt
},
1555 {"to", SameIntOrUnsigned
, Rank::elemental
, Optionality::required
,
1556 common::Intent::Out
},
1558 {}, Rank::elemental
, IntrinsicClass::elementalSubroutine
}, // elemental
1560 {{"repeatable", AnyLogical
, Rank::scalar
},
1561 {"image_distinct", AnyLogical
, Rank::scalar
}},
1562 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1564 {{"harvest", {RealType
| UnsignedType
, KindCode::any
}, Rank::known
,
1565 Optionality::required
, common::Intent::Out
,
1566 {ArgFlag::notAssumedSize
}}},
1567 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1569 {{"size", DefaultInt
, Rank::scalar
, Optionality::optional
,
1570 common::Intent::Out
},
1571 {"put", DefaultInt
, Rank::vector
, Optionality::optional
},
1572 {"get", DefaultInt
, Rank::vector
, Optionality::optional
,
1573 common::Intent::Out
}},
1574 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1576 {{"path1", DefaultChar
, Rank::scalar
},
1577 {"path2", DefaultChar
, Rank::scalar
},
1578 {"status", DefaultInt
, Rank::scalar
, Optionality::optional
,
1579 common::Intent::Out
}},
1580 {}, Rank::scalar
, IntrinsicClass::impureSubroutine
},
1581 {"second", {{"time", DefaultReal
, Rank::scalar
}}, {}, Rank::scalar
,
1582 IntrinsicClass::impureSubroutine
},
1584 {{"command", DefaultChar
, Rank::scalar
},
1585 {"exitstat", DefaultInt
, Rank::scalar
, Optionality::optional
,
1586 common::Intent::Out
}},
1587 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1589 {{"count", AnyInt
, Rank::scalar
, Optionality::optional
,
1590 common::Intent::Out
},
1591 {"count_rate", AnyIntOrReal
, Rank::scalar
, Optionality::optional
,
1592 common::Intent::Out
},
1593 {"count_max", AnyInt
, Rank::scalar
, Optionality::optional
,
1594 common::Intent::Out
}},
1595 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1597 {{"number", AnyInt
, Rank::scalar
, Optionality::required
,
1598 common::Intent::In
},
1599 // note: any pointer also accepts AnyInt
1600 {"handler", AnyPointer
, Rank::scalar
, Optionality::required
,
1601 common::Intent::In
},
1602 {"status", AnyInt
, Rank::scalar
, Optionality::optional
,
1603 common::Intent::Out
}},
1604 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1606 {{"seconds", AnyInt
, Rank::scalar
, Optionality::required
,
1607 common::Intent::In
}},
1608 {}, Rank::elemental
, IntrinsicClass::impureSubroutine
},
1611 // TODO: Collective intrinsic subroutines: co_reduce
1613 // Finds a built-in derived type and returns it as a DynamicType.
1614 static DynamicType
GetBuiltinDerivedType(
1615 const semantics::Scope
*builtinsScope
, const char *which
) {
1616 if (!builtinsScope
) {
1617 common::die("INTERNAL: The __fortran_builtins module was not found, and "
1618 "the type '%s' was required",
1622 builtinsScope
->find(semantics::SourceName
{which
, std::strlen(which
)})};
1623 if (iter
== builtinsScope
->cend()) {
1624 // keep the string all together
1627 "INTERNAL: The __fortran_builtins module does not define the type '%s'",
1631 const semantics::Symbol
&symbol
{*iter
->second
};
1632 const semantics::Scope
&scope
{DEREF(symbol
.scope())};
1633 const semantics::DerivedTypeSpec
&derived
{DEREF(scope
.derivedTypeSpec())};
1634 return DynamicType
{derived
};
1637 static std::int64_t GetBuiltinKind(
1638 const semantics::Scope
*builtinsScope
, const char *which
) {
1639 if (!builtinsScope
) {
1640 common::die("INTERNAL: The __fortran_builtins module was not found, and "
1641 "the kind '%s' was required",
1645 builtinsScope
->find(semantics::SourceName
{which
, std::strlen(which
)})};
1646 if (iter
== builtinsScope
->cend()) {
1648 "INTERNAL: The __fortran_builtins module does not define the kind '%s'",
1651 const semantics::Symbol
&symbol
{*iter
->second
};
1652 const auto &details
{
1653 DEREF(symbol
.detailsIf
<semantics::ObjectEntityDetails
>())};
1654 if (const auto kind
{ToInt64(details
.init())}) {
1658 "INTERNAL: The __fortran_builtins module does not define the kind '%s'",
1664 // Ensure that the keywords of arguments to MAX/MIN and their variants
1665 // are of the form A123 with no duplicates or leading zeroes.
1666 static bool CheckMaxMinArgument(parser::CharBlock keyword
,
1667 std::set
<parser::CharBlock
> &set
, const char *intrinsicName
,
1668 parser::ContextualMessages
&messages
) {
1670 for (; j
< keyword
.size(); ++j
) {
1671 char ch
{(keyword
)[j
]};
1672 if (ch
< (j
== 1 ? '1' : '0') || ch
> '9') {
1676 if (keyword
.size() < 2 || (keyword
)[0] != 'a' || j
< keyword
.size()) {
1677 messages
.Say(keyword
,
1678 "argument keyword '%s=' is not known in call to '%s'"_err_en_US
,
1679 keyword
, intrinsicName
);
1682 if (!set
.insert(keyword
).second
) {
1683 messages
.Say(keyword
,
1684 "argument keyword '%s=' was repeated in call to '%s'"_err_en_US
,
1685 keyword
, intrinsicName
);
1691 // Validate the keyword, if any, and ensure that A1 and A2 are always placed in
1692 // first and second position in actualForDummy. A1 and A2 are special since they
1693 // are not optional. The rest of the arguments are not sorted, there are no
1694 // differences between them.
1695 static bool CheckAndPushMinMaxArgument(ActualArgument
&arg
,
1696 std::vector
<ActualArgument
*> &actualForDummy
,
1697 std::set
<parser::CharBlock
> &set
, const char *intrinsicName
,
1698 parser::ContextualMessages
&messages
) {
1699 if (std::optional
<parser::CharBlock
> keyword
{arg
.keyword()}) {
1700 if (!CheckMaxMinArgument(*keyword
, set
, intrinsicName
, messages
)) {
1703 const bool isA1
{*keyword
== parser::CharBlock
{"a1", 2}};
1704 if (isA1
&& !actualForDummy
[0]) {
1705 actualForDummy
[0] = &arg
;
1708 const bool isA2
{*keyword
== parser::CharBlock
{"a2", 2}};
1709 if (isA2
&& !actualForDummy
[1]) {
1710 actualForDummy
[1] = &arg
;
1714 // Note that for arguments other than a1 and a2, this error will be caught
1715 // later in check-call.cpp.
1716 messages
.Say(*keyword
,
1717 "keyword argument '%s=' to intrinsic '%s' was supplied "
1718 "positionally by an earlier actual argument"_err_en_US
,
1719 *keyword
, intrinsicName
);
1723 if (actualForDummy
.size() == 2) {
1724 if (!actualForDummy
[0] && !actualForDummy
[1]) {
1725 actualForDummy
[0] = &arg
;
1727 } else if (!actualForDummy
[1]) {
1728 actualForDummy
[1] = &arg
;
1733 actualForDummy
.push_back(&arg
);
1737 static bool CheckAtomicKind(const ActualArgument
&arg
,
1738 const semantics::Scope
*builtinsScope
, parser::ContextualMessages
&messages
,
1739 const char *keyword
) {
1740 std::string atomicKindStr
;
1741 std::optional
<DynamicType
> type
{arg
.GetType()};
1743 if (type
->category() == TypeCategory::Integer
) {
1744 atomicKindStr
= "atomic_int_kind";
1745 } else if (type
->category() == TypeCategory::Logical
) {
1746 atomicKindStr
= "atomic_logical_kind";
1748 common::die("atomic_int_kind or atomic_logical_kind from iso_fortran_env "
1749 "must be used with IntType or LogicalType");
1752 bool argOk
{type
->kind() ==
1753 GetBuiltinKind(builtinsScope
, ("__builtin_" + atomicKindStr
).c_str())};
1755 messages
.Say(arg
.sourceLocation(),
1756 "Actual argument for '%s=' must have kind=atomic_%s_kind, but is '%s'"_err_en_US
,
1757 keyword
, type
->category() == TypeCategory::Integer
? "int" : "logical",
1763 // Intrinsic interface matching against the arguments of a particular
1764 // procedure reference.
1765 std::optional
<SpecificCall
> IntrinsicInterface::Match(
1766 const CallCharacteristics
&call
,
1767 const common::IntrinsicTypeDefaultKinds
&defaults
,
1768 ActualArguments
&arguments
, FoldingContext
&context
,
1769 const semantics::Scope
*builtinsScope
) const {
1770 auto &messages
{context
.messages()};
1771 // Attempt to construct a 1-1 correspondence between the dummy arguments in
1772 // a particular intrinsic procedure's generic interface and the actual
1773 // arguments in a procedure reference.
1774 std::size_t dummyArgPatterns
{0};
1775 for (; dummyArgPatterns
< maxArguments
&& dummy
[dummyArgPatterns
].keyword
;
1776 ++dummyArgPatterns
) {
1778 // MAX and MIN (and others that map to them) allow their last argument to
1779 // be repeated indefinitely. The actualForDummy vector is sized
1780 // and null-initialized to the non-repeated dummy argument count
1781 // for other intrinsics.
1782 bool isMaxMin
{dummyArgPatterns
> 0 &&
1783 dummy
[dummyArgPatterns
- 1].optionality
== Optionality::repeats
};
1784 std::vector
<ActualArgument
*> actualForDummy(
1785 isMaxMin
? 2 : dummyArgPatterns
, nullptr);
1786 bool anyMissingActualArgument
{false};
1787 std::set
<parser::CharBlock
> maxMinKeywords
;
1788 bool anyKeyword
{false};
1790 for (std::optional
<ActualArgument
> &arg
: arguments
) {
1793 if (arg
->isAlternateReturn()) {
1794 messages
.Say(arg
->sourceLocation(),
1795 "alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US
,
1797 return std::nullopt
;
1799 if (arg
->keyword()) {
1801 } else if (anyKeyword
) {
1802 messages
.Say(arg
? arg
->sourceLocation() : std::nullopt
,
1803 "actual argument #%d without a keyword may not follow an actual argument with a keyword"_err_en_US
,
1805 return std::nullopt
;
1808 anyMissingActualArgument
= true;
1812 if (!CheckAndPushMinMaxArgument(
1813 *arg
, actualForDummy
, maxMinKeywords
, name
, messages
)) {
1814 return std::nullopt
;
1818 for (std::size_t j
{0}; j
< dummyArgPatterns
&& !found
; ++j
) {
1819 if (dummy
[j
].optionality
== Optionality::missing
) {
1822 if (arg
->keyword()) {
1823 found
= *arg
->keyword() == dummy
[j
].keyword
;
1825 if (const auto *previous
{actualForDummy
[j
]}) {
1826 if (previous
->keyword()) {
1827 messages
.Say(*arg
->keyword(),
1828 "repeated keyword argument to intrinsic '%s'"_err_en_US
,
1831 messages
.Say(*arg
->keyword(),
1832 "keyword argument to intrinsic '%s' was supplied "
1833 "positionally by an earlier actual argument"_err_en_US
,
1836 return std::nullopt
;
1840 found
= !actualForDummy
[j
] && !anyMissingActualArgument
;
1843 actualForDummy
[j
] = &*arg
;
1847 if (arg
->keyword()) {
1848 messages
.Say(*arg
->keyword(),
1849 "unknown keyword argument to intrinsic '%s'"_err_en_US
, name
);
1852 "too many actual arguments for intrinsic '%s'"_err_en_US
, name
);
1854 return std::nullopt
;
1859 std::size_t dummies
{actualForDummy
.size()};
1861 // Check types and kinds of the actual arguments against the intrinsic's
1862 // interface. Ensure that two or more arguments that have to have the same
1863 // (or compatible) type and kind do so. Check for missing non-optional
1864 // arguments now, too.
1865 const ActualArgument
*sameArg
{nullptr};
1866 const ActualArgument
*operandArg
{nullptr};
1867 const IntrinsicDummyArgument
*kindDummyArg
{nullptr};
1868 const ActualArgument
*kindArg
{nullptr};
1869 std::optional
<int> dimArg
;
1870 for (std::size_t j
{0}; j
< dummies
; ++j
) {
1871 const IntrinsicDummyArgument
&d
{dummy
[std::min(j
, dummyArgPatterns
- 1)]};
1872 if (d
.typePattern
.kindCode
== KindCode::kindArg
) {
1873 CHECK(!kindDummyArg
);
1876 const ActualArgument
*arg
{actualForDummy
[j
]};
1878 if (d
.optionality
== Optionality::required
) {
1879 std::string kw
{d
.keyword
};
1880 if (isMaxMin
&& !actualForDummy
[0] && !actualForDummy
[1]) {
1881 messages
.Say("missing mandatory 'a1=' and 'a2=' arguments"_err_en_US
);
1884 "missing mandatory '%s=' argument"_err_en_US
, kw
.c_str());
1886 return std::nullopt
; // missing non-OPTIONAL argument
1891 if (d
.optionality
== Optionality::missing
) {
1892 messages
.Say(arg
->sourceLocation(), "unexpected '%s=' argument"_err_en_US
,
1894 return std::nullopt
;
1896 if (!d
.flags
.test(ArgFlag::canBeNull
)) {
1897 if (const auto *expr
{arg
->UnwrapExpr()}; expr
&& IsNullPointer(*expr
)) {
1898 if (!IsBareNullPointer(expr
) && IsNullObjectPointer(*expr
) &&
1899 d
.flags
.test(ArgFlag::canBeMoldNull
)) {
1902 messages
.Say(arg
->sourceLocation(),
1903 "A NULL() pointer is not allowed for '%s=' intrinsic argument"_err_en_US
,
1905 return std::nullopt
;
1909 if (d
.flags
.test(ArgFlag::notAssumedSize
)) {
1910 if (auto named
{ExtractNamedEntity(*arg
)}) {
1911 if (semantics::IsAssumedSizeArray(named
->GetLastSymbol())) {
1912 messages
.Say(arg
->sourceLocation(),
1913 "The '%s=' argument to the intrinsic procedure '%s' may not be assumed-size"_err_en_US
,
1915 return std::nullopt
;
1919 if (arg
->GetAssumedTypeDummy()) {
1920 // TYPE(*) assumed-type dummy argument forwarded to intrinsic
1921 if (d
.typePattern
.categorySet
== AnyType
&&
1922 (d
.rank
== Rank::anyOrAssumedRank
||
1923 d
.rank
== Rank::arrayOrAssumedRank
) &&
1924 (d
.typePattern
.kindCode
== KindCode::any
||
1925 d
.typePattern
.kindCode
== KindCode::addressable
)) {
1928 messages
.Say(arg
->sourceLocation(),
1929 "Assumed type TYPE(*) dummy argument not allowed for '%s=' intrinsic argument"_err_en_US
,
1931 return std::nullopt
;
1934 std::optional
<DynamicType
> type
{arg
->GetType()};
1936 CHECK(arg
->Rank() == 0);
1937 const Expr
<SomeType
> &expr
{DEREF(arg
->UnwrapExpr())};
1938 if (IsBOZLiteral(expr
)) {
1939 if (d
.typePattern
.kindCode
== KindCode::typeless
||
1940 d
.rank
== Rank::elementalOrBOZ
) {
1943 const IntrinsicDummyArgument
*nextParam
{
1944 j
+ 1 < dummies
? &dummy
[j
+ 1] : nullptr};
1945 if (nextParam
&& nextParam
->rank
== Rank::elementalOrBOZ
) {
1946 messages
.Say(arg
->sourceLocation(),
1947 "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US
, // C7109
1948 d
.keyword
, nextParam
->keyword
);
1950 messages
.Say(arg
->sourceLocation(),
1951 "Typeless (BOZ) not allowed for '%s=' argument"_err_en_US
,
1956 // NULL(no MOLD=), procedure, or procedure pointer
1957 CHECK(IsProcedurePointerTarget(expr
));
1958 if (d
.typePattern
.kindCode
== KindCode::addressable
||
1959 d
.rank
== Rank::reduceOperation
) {
1961 } else if (d
.typePattern
.kindCode
== KindCode::nullPointerType
) {
1963 } else if (IsBareNullPointer(&expr
)) {
1964 // checked elsewhere
1967 CHECK(IsProcedure(expr
) || IsProcedurePointer(expr
));
1968 messages
.Say(arg
->sourceLocation(),
1969 "Actual argument for '%s=' may not be a procedure"_err_en_US
,
1973 return std::nullopt
;
1974 } else if (!d
.typePattern
.categorySet
.test(type
->category())) {
1975 messages
.Say(arg
->sourceLocation(),
1976 "Actual argument for '%s=' has bad type '%s'"_err_en_US
, d
.keyword
,
1978 return std::nullopt
; // argument has invalid type category
1981 switch (d
.typePattern
.kindCode
) {
1982 case KindCode::none
:
1983 case KindCode::typeless
:
1986 case KindCode::eventType
:
1987 argOk
= !type
->IsUnlimitedPolymorphic() &&
1988 type
->category() == TypeCategory::Derived
&&
1989 semantics::IsEventType(&type
->GetDerivedTypeSpec());
1991 case KindCode::ieeeFlagType
:
1992 argOk
= !type
->IsUnlimitedPolymorphic() &&
1993 type
->category() == TypeCategory::Derived
&&
1994 semantics::IsIeeeFlagType(&type
->GetDerivedTypeSpec());
1996 case KindCode::ieeeRoundType
:
1997 argOk
= !type
->IsUnlimitedPolymorphic() &&
1998 type
->category() == TypeCategory::Derived
&&
1999 semantics::IsIeeeRoundType(&type
->GetDerivedTypeSpec());
2001 case KindCode::teamType
:
2002 argOk
= !type
->IsUnlimitedPolymorphic() &&
2003 type
->category() == TypeCategory::Derived
&&
2004 semantics::IsTeamType(&type
->GetDerivedTypeSpec());
2006 case KindCode::defaultIntegerKind
:
2007 argOk
= type
->kind() == defaults
.GetDefaultKind(TypeCategory::Integer
);
2009 case KindCode::defaultRealKind
:
2010 argOk
= type
->kind() == defaults
.GetDefaultKind(TypeCategory::Real
);
2012 case KindCode::doublePrecision
:
2013 argOk
= type
->kind() == defaults
.doublePrecisionKind();
2015 case KindCode::defaultCharKind
:
2016 argOk
= type
->kind() == defaults
.GetDefaultKind(TypeCategory::Character
);
2018 case KindCode::defaultLogicalKind
:
2019 argOk
= type
->kind() == defaults
.GetDefaultKind(TypeCategory::Logical
);
2024 case KindCode::kindArg
:
2025 CHECK(type
->category() == TypeCategory::Integer
);
2030 case KindCode::dimArg
:
2031 CHECK(type
->category() == TypeCategory::Integer
);
2035 case KindCode::same
: {
2039 auto sameType
{sameArg
->GetType().value()};
2040 if (name
== "move_alloc"s
) {
2041 // second argument can be more general
2042 argOk
= type
->IsTkLenCompatibleWith(sameType
);
2043 } else if (name
== "merge"s
) {
2044 argOk
= type
->IsTkLenCompatibleWith(sameType
) &&
2045 sameType
.IsTkLenCompatibleWith(*type
);
2047 argOk
= sameType
.IsTkLenCompatibleWith(*type
);
2050 case KindCode::sameKind
:
2054 argOk
= type
->IsTkCompatibleWith(sameArg
->GetType().value());
2056 case KindCode::operand
:
2059 } else if (auto prev
{operandArg
->GetType()}) {
2060 if (type
->category() == prev
->category()) {
2061 if (type
->kind() > prev
->kind()) {
2064 } else if (prev
->category() == TypeCategory::Integer
) {
2070 case KindCode::effectiveKind
:
2071 common::die("INTERNAL: KindCode::effectiveKind appears on argument '%s' "
2072 "for intrinsic '%s'",
2075 case KindCode::addressable
:
2076 case KindCode::nullPointerType
:
2079 case KindCode::exactKind
:
2080 argOk
= type
->kind() == d
.typePattern
.kindValue
;
2082 case KindCode::greaterOrEqualToKind
:
2083 argOk
= type
->kind() >= d
.typePattern
.kindValue
;
2085 case KindCode::sameAtom
:
2088 argOk
= CheckAtomicKind(DEREF(arg
), builtinsScope
, messages
, d
.keyword
);
2090 argOk
= type
->IsTkCompatibleWith(sameArg
->GetType().value());
2092 messages
.Say(arg
->sourceLocation(),
2093 "Actual argument for '%s=' must have same type and kind as 'atom=', but is '%s'"_err_en_US
,
2094 d
.keyword
, type
->AsFortran());
2098 return std::nullopt
;
2101 case KindCode::atomicIntKind
:
2102 argOk
= CheckAtomicKind(DEREF(arg
), builtinsScope
, messages
, d
.keyword
);
2104 return std::nullopt
;
2107 case KindCode::atomicIntOrLogicalKind
:
2108 argOk
= CheckAtomicKind(DEREF(arg
), builtinsScope
, messages
, d
.keyword
);
2110 return std::nullopt
;
2117 messages
.Say(arg
->sourceLocation(),
2118 "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US
,
2119 d
.keyword
, type
->AsFortran());
2120 return std::nullopt
;
2124 // Check the ranks of the arguments against the intrinsic's interface.
2125 const ActualArgument
*arrayArg
{nullptr};
2126 const char *arrayArgName
{nullptr};
2127 const ActualArgument
*knownArg
{nullptr};
2128 std::optional
<std::int64_t> shapeArgSize
;
2129 int elementalRank
{0};
2130 for (std::size_t j
{0}; j
< dummies
; ++j
) {
2131 const IntrinsicDummyArgument
&d
{dummy
[std::min(j
, dummyArgPatterns
- 1)]};
2132 if (const ActualArgument
*arg
{actualForDummy
[j
]}) {
2133 bool isAssumedRank
{IsAssumedRank(*arg
)};
2134 if (isAssumedRank
&& d
.rank
!= Rank::anyOrAssumedRank
&&
2135 d
.rank
!= Rank::arrayOrAssumedRank
) {
2136 messages
.Say(arg
->sourceLocation(),
2137 "Assumed-rank array cannot be forwarded to '%s=' argument"_err_en_US
,
2139 return std::nullopt
;
2141 int rank
{arg
->Rank()};
2144 case Rank::elemental
:
2145 case Rank::elementalOrBOZ
:
2146 if (elementalRank
== 0) {
2147 elementalRank
= rank
;
2149 argOk
= rank
== 0 || rank
== elementalRank
;
2158 CHECK(!shapeArgSize
);
2160 messages
.Say(arg
->sourceLocation(),
2161 "'shape=' argument must be an array of rank 1"_err_en_US
);
2162 return std::nullopt
;
2164 if (auto shape
{GetShape(context
, *arg
)}) {
2165 if (auto constShape
{AsConstantShape(context
, *shape
)}) {
2166 shapeArgSize
= constShape
->At(ConstantSubscripts
{1}).ToInt64();
2167 CHECK(shapeArgSize
.value() >= 0);
2168 argOk
= *shapeArgSize
<= common::maxRank
;
2173 if (shapeArgSize
.value_or(0) > common::maxRank
) {
2174 messages
.Say(arg
->sourceLocation(),
2175 "'shape=' argument must be a vector of at most %d elements (has %jd)"_err_en_US
,
2176 common::maxRank
, std::intmax_t{*shapeArgSize
});
2178 messages
.Say(arg
->sourceLocation(),
2179 "'shape=' argument must be a vector of known size"_err_en_US
);
2181 return std::nullopt
;
2191 arrayArgName
= d
.keyword
;
2195 argOk
= IsCoarray(*arg
);
2197 messages
.Say(arg
->sourceLocation(),
2198 "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US
,
2200 return std::nullopt
;
2204 argOk
= rank
== 0 && (IsCoarray(*arg
) || ExtractCoarrayRef(*arg
));
2206 messages
.Say(arg
->sourceLocation(),
2207 "'%s=' argument must be a scalar coarray or coindexed object for intrinsic '%s'"_err_en_US
,
2209 return std::nullopt
;
2216 argOk
= !isAssumedRank
&& rank
== knownArg
->Rank();
2218 case Rank::anyOrAssumedRank
:
2219 case Rank::arrayOrAssumedRank
:
2220 if (isAssumedRank
) {
2224 if (d
.rank
== Rank::arrayOrAssumedRank
&& rank
== 0) {
2231 if (!dimArg
&& rank
> 0 &&
2232 (std::strcmp(name
, "shape") == 0 ||
2233 std::strcmp(name
, "size") == 0 ||
2234 std::strcmp(name
, "ubound") == 0)) {
2235 // Check for a whole assumed-size array argument.
2236 // These are disallowed for SHAPE, and require DIM= for
2238 // (A previous error message for UBOUND will take precedence
2239 // over this one, as this error is caught by the second entry
2241 if (auto named
{ExtractNamedEntity(*arg
)}) {
2242 if (semantics::IsAssumedSizeArray(named
->GetLastSymbol())) {
2243 if (strcmp(name
, "shape") == 0) {
2244 messages
.Say(arg
->sourceLocation(),
2245 "The 'source=' argument to the intrinsic function 'shape' may not be assumed-size"_err_en_US
);
2247 messages
.Say(arg
->sourceLocation(),
2248 "A dim= argument is required for '%s' when the array is assumed-size"_err_en_US
,
2251 return std::nullopt
;
2257 case Rank::conformable
: // arg must be conformable with previous arrayArg
2259 CHECK(arrayArgName
);
2260 if (const std::optional
<Shape
> &arrayArgShape
{
2261 GetShape(context
, *arrayArg
)}) {
2262 if (std::optional
<Shape
> argShape
{GetShape(context
, *arg
)}) {
2263 std::string arrayArgMsg
{"'"};
2264 arrayArgMsg
= arrayArgMsg
+ arrayArgName
+ "='" + " argument";
2265 std::string argMsg
{"'"};
2266 argMsg
= argMsg
+ d
.keyword
+ "='" + " argument";
2267 CheckConformance(context
.messages(), *arrayArgShape
, *argShape
,
2268 CheckConformanceFlags::RightScalarExpandable
,
2269 arrayArgMsg
.c_str(), argMsg
.c_str());
2272 argOk
= true; // Avoid an additional error message
2274 case Rank::dimReduced
:
2275 case Rank::dimRemovedOrScalar
:
2277 argOk
= rank
== 0 || rank
+ 1 == arrayArg
->Rank();
2279 case Rank::reduceOperation
:
2280 // The reduction function is validated in ApplySpecificChecks().
2283 case Rank::scalarIfDim
:
2284 case Rank::locReduced
:
2285 case Rank::rankPlus1
:
2287 common::die("INTERNAL: result-only rank code appears on argument '%s' "
2288 "for intrinsic '%s'",
2292 messages
.Say(arg
->sourceLocation(),
2293 "'%s=' argument has unacceptable rank %d"_err_en_US
, d
.keyword
,
2295 return std::nullopt
;
2300 // Calculate the characteristics of the function result, if any
2301 std::optional
<DynamicType
> resultType
;
2302 if (auto category
{result
.categorySet
.LeastElement()}) {
2303 // The intrinsic is not a subroutine.
2304 if (call
.isSubroutineCall
) {
2305 return std::nullopt
;
2307 switch (result
.kindCode
) {
2308 case KindCode::defaultIntegerKind
:
2309 CHECK(result
.categorySet
== IntType
);
2310 CHECK(*category
== TypeCategory::Integer
);
2311 resultType
= DynamicType
{TypeCategory::Integer
,
2312 defaults
.GetDefaultKind(TypeCategory::Integer
)};
2314 case KindCode::defaultRealKind
:
2315 CHECK(result
.categorySet
== CategorySet
{*category
});
2316 CHECK(FloatingType
.test(*category
));
2318 DynamicType
{*category
, defaults
.GetDefaultKind(TypeCategory::Real
)};
2320 case KindCode::doublePrecision
:
2321 CHECK(result
.categorySet
== CategorySet
{*category
});
2322 CHECK(FloatingType
.test(*category
));
2323 resultType
= DynamicType
{*category
, defaults
.doublePrecisionKind()};
2325 case KindCode::defaultLogicalKind
:
2326 CHECK(result
.categorySet
== LogicalType
);
2327 CHECK(*category
== TypeCategory::Logical
);
2328 resultType
= DynamicType
{TypeCategory::Logical
,
2329 defaults
.GetDefaultKind(TypeCategory::Logical
)};
2331 case KindCode::defaultCharKind
:
2332 CHECK(result
.categorySet
== CharType
);
2333 CHECK(*category
== TypeCategory::Character
);
2334 resultType
= DynamicType
{TypeCategory::Character
,
2335 defaults
.GetDefaultKind(TypeCategory::Character
)};
2337 case KindCode::same
:
2339 if (std::optional
<DynamicType
> aType
{sameArg
->GetType()}) {
2340 if (result
.categorySet
.test(aType
->category())) {
2341 if (const auto *sameChar
{UnwrapExpr
<Expr
<SomeCharacter
>>(*sameArg
)}) {
2342 if (auto len
{ToInt64(Fold(context
, sameChar
->LEN()))}) {
2343 resultType
= DynamicType
{aType
->kind(), *len
};
2345 resultType
= *aType
;
2348 resultType
= *aType
;
2351 resultType
= DynamicType
{*category
, aType
->kind()};
2355 case KindCode::sameKind
:
2357 if (std::optional
<DynamicType
> aType
{sameArg
->GetType()}) {
2358 resultType
= DynamicType
{*category
, aType
->kind()};
2361 case KindCode::operand
:
2363 resultType
= operandArg
->GetType();
2364 CHECK(!resultType
|| result
.categorySet
.test(resultType
->category()));
2366 case KindCode::effectiveKind
:
2367 CHECK(kindDummyArg
);
2368 CHECK(result
.categorySet
== CategorySet
{*category
});
2370 if (auto *expr
{kindArg
->UnwrapExpr()}) {
2371 CHECK(expr
->Rank() == 0);
2372 if (auto code
{ToInt64(Fold(context
, common::Clone(*expr
)))}) {
2373 if (context
.targetCharacteristics().IsTypeEnabled(
2374 *category
, *code
)) {
2375 if (*category
== TypeCategory::Character
) { // ACHAR & CHAR
2376 resultType
= DynamicType
{static_cast<int>(*code
), 1};
2378 resultType
= DynamicType
{*category
, static_cast<int>(*code
)};
2385 "'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type"_err_en_US
);
2386 // use default kind below for error recovery
2387 } else if (kindDummyArg
->flags
.test(ArgFlag::defaultsToSameKind
)) {
2389 resultType
= *sameArg
->GetType();
2390 } else if (kindDummyArg
->flags
.test(ArgFlag::defaultsToSizeKind
)) {
2391 CHECK(*category
== TypeCategory::Integer
);
2393 DynamicType
{TypeCategory::Integer
, defaults
.sizeIntegerKind()};
2395 CHECK(kindDummyArg
->flags
.test(ArgFlag::defaultsToDefaultForResult
));
2398 int kind
{defaults
.GetDefaultKind(*category
)};
2399 if (*category
== TypeCategory::Character
) { // ACHAR & CHAR
2400 resultType
= DynamicType
{kind
, 1};
2402 resultType
= DynamicType
{*category
, kind
};
2406 case KindCode::likeMultiply
:
2407 CHECK(dummies
>= 2);
2408 CHECK(actualForDummy
[0]);
2409 CHECK(actualForDummy
[1]);
2410 resultType
= actualForDummy
[0]->GetType()->ResultTypeForMultiply(
2411 *actualForDummy
[1]->GetType());
2413 case KindCode::subscript
:
2414 CHECK(result
.categorySet
== IntType
);
2415 CHECK(*category
== TypeCategory::Integer
);
2417 DynamicType
{TypeCategory::Integer
, defaults
.subscriptIntegerKind()};
2419 case KindCode::size
:
2420 CHECK(result
.categorySet
== IntType
);
2421 CHECK(*category
== TypeCategory::Integer
);
2423 DynamicType
{TypeCategory::Integer
, defaults
.sizeIntegerKind()};
2425 case KindCode::teamType
:
2426 CHECK(result
.categorySet
== DerivedType
);
2427 CHECK(*category
== TypeCategory::Derived
);
2428 resultType
= DynamicType
{
2429 GetBuiltinDerivedType(builtinsScope
, "__builtin_team_type")};
2431 case KindCode::greaterOrEqualToKind
:
2432 case KindCode::exactKind
:
2433 resultType
= DynamicType
{*category
, result
.kindValue
};
2435 case KindCode::typeless
:
2437 case KindCode::kindArg
:
2438 case KindCode::dimArg
:
2440 "INTERNAL: bad KindCode appears on intrinsic '%s' result", name
);
2446 if (!call
.isSubroutineCall
) {
2447 return std::nullopt
;
2449 CHECK(result
.kindCode
== KindCode::none
);
2452 // Emit warnings when the syntactic presence of a DIM= argument determines
2453 // the semantics of the call but the associated actual argument may not be
2454 // present at execution time.
2456 std::optional
<int> arrayRank
;
2458 arrayRank
= arrayArg
->Rank();
2459 if (auto dimVal
{ToInt64(actualForDummy
[*dimArg
])}) {
2462 "The value of DIM= (%jd) may not be less than 1"_err_en_US
,
2463 static_cast<std::intmax_t>(*dimVal
));
2464 } else if (*dimVal
> *arrayRank
) {
2466 "The value of DIM= (%jd) may not be greater than %d"_err_en_US
,
2467 static_cast<std::intmax_t>(*dimVal
), *arrayRank
);
2472 case Rank::dimReduced
:
2473 case Rank::dimRemovedOrScalar
:
2474 case Rank::locReduced
:
2475 case Rank::scalarIfDim
:
2476 if (dummy
[*dimArg
].optionality
== Optionality::required
) {
2477 if (const Symbol
*whole
{
2478 UnwrapWholeSymbolOrComponentDataRef(actualForDummy
[*dimArg
])}) {
2479 if (IsOptional(*whole
) || IsAllocatableOrObjectPointer(whole
)) {
2480 if (context
.languageFeatures().ShouldWarn(
2481 common::UsageWarning::OptionalMustBePresent
)) {
2482 if (rank
== Rank::scalarIfDim
|| arrayRank
.value_or(-1) == 1) {
2483 messages
.Say(common::UsageWarning::OptionalMustBePresent
,
2484 "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_warn_en_US
);
2486 messages
.Say(common::UsageWarning::OptionalMustBePresent
,
2487 "The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning"_warn_en_US
);
2498 // At this point, the call is acceptable.
2499 // Determine the rank of the function result.
2502 case Rank::elemental
:
2503 resultRank
= elementalRank
;
2514 case Rank::conformable
:
2516 resultRank
= arrayArg
->Rank();
2518 case Rank::dimReduced
:
2520 resultRank
= dimArg
? arrayArg
->Rank() - 1 : 0;
2522 case Rank::locReduced
:
2524 resultRank
= dimArg
? arrayArg
->Rank() - 1 : 1;
2526 case Rank::rankPlus1
:
2528 resultRank
= knownArg
->Rank() + 1;
2531 CHECK(shapeArgSize
);
2532 resultRank
= *shapeArgSize
;
2534 case Rank::scalarIfDim
:
2535 resultRank
= dimArg
? 0 : 1;
2537 case Rank::elementalOrBOZ
:
2543 case Rank::anyOrAssumedRank
:
2544 case Rank::arrayOrAssumedRank
:
2545 case Rank::reduceOperation
:
2546 case Rank::dimRemovedOrScalar
:
2547 common::die("INTERNAL: bad Rank code on intrinsic '%s' result", name
);
2550 CHECK(resultRank
>= 0);
2552 // Rearrange the actual arguments into dummy argument order.
2553 ActualArguments
rearranged(dummies
);
2554 for (std::size_t j
{0}; j
< dummies
; ++j
) {
2555 if (ActualArgument
*arg
{actualForDummy
[j
]}) {
2556 rearranged
[j
] = std::move(*arg
);
2560 // Characterize the specific intrinsic procedure.
2561 characteristics::DummyArguments dummyArgs
;
2562 std::optional
<int> sameDummyArg
;
2564 for (std::size_t j
{0}; j
< dummies
; ++j
) {
2565 const IntrinsicDummyArgument
&d
{dummy
[std::min(j
, dummyArgPatterns
- 1)]};
2566 if (const auto &arg
{rearranged
[j
]}) {
2567 if (const Expr
<SomeType
> *expr
{arg
->UnwrapExpr()}) {
2568 std::string kw
{d
.keyword
};
2569 if (arg
->keyword()) {
2570 kw
= arg
->keyword()->ToString();
2571 } else if (isMaxMin
) {
2572 for (std::size_t k
{j
+ 1};; ++k
) {
2573 kw
= "a"s
+ std::to_string(k
);
2574 auto iter
{std::find_if(dummyArgs
.begin(), dummyArgs
.end(),
2575 [&kw
](const characteristics::DummyArgument
&prev
) {
2576 return prev
.name
== kw
;
2578 if (iter
== dummyArgs
.end()) {
2583 if (auto dc
{characteristics::DummyArgument::FromActual(std::move(kw
),
2584 *expr
, context
, /*forImplicitInterface=*/false)}) {
2585 if (auto *dummyProc
{
2586 std::get_if
<characteristics::DummyProcedure
>(&dc
->u
)}) {
2587 // Dummy procedures are never elemental.
2588 dummyProc
->procedure
.value().attrs
.reset(
2589 characteristics::Procedure::Attr::Elemental
);
2590 } else if (auto *dummyObject
{
2591 std::get_if
<characteristics::DummyDataObject
>(
2593 dummyObject
->type
.set_corank(0);
2595 dummyArgs
.emplace_back(std::move(*dc
));
2596 if (d
.typePattern
.kindCode
== KindCode::same
&& !sameDummyArg
) {
2599 } else { // error recovery
2601 "Could not characterize intrinsic function actual argument '%s'"_err_en_US
,
2602 expr
->AsFortran().c_str());
2603 return std::nullopt
;
2606 CHECK(arg
->GetAssumedTypeDummy());
2607 dummyArgs
.emplace_back(std::string
{d
.keyword
},
2608 characteristics::DummyDataObject
{DynamicType::AssumedType()});
2611 // optional argument is absent
2612 CHECK(d
.optionality
!= Optionality::required
);
2613 if (d
.typePattern
.kindCode
== KindCode::same
) {
2614 dummyArgs
.emplace_back(dummyArgs
[sameDummyArg
.value()]);
2616 auto category
{d
.typePattern
.categorySet
.LeastElement().value()};
2617 if (category
== TypeCategory::Derived
) {
2618 // TODO: any other built-in derived types used as optional intrinsic
2620 CHECK(d
.typePattern
.kindCode
== KindCode::teamType
);
2621 characteristics::TypeAndShape typeAndShape
{
2622 GetBuiltinDerivedType(builtinsScope
, "__builtin_team_type")};
2623 dummyArgs
.emplace_back(std::string
{d
.keyword
},
2624 characteristics::DummyDataObject
{std::move(typeAndShape
)});
2626 characteristics::TypeAndShape typeAndShape
{
2627 DynamicType
{category
, defaults
.GetDefaultKind(category
)}};
2628 dummyArgs
.emplace_back(std::string
{d
.keyword
},
2629 characteristics::DummyDataObject
{std::move(typeAndShape
)});
2632 dummyArgs
.back().SetOptional();
2634 dummyArgs
.back().SetIntent(d
.intent
);
2636 characteristics::Procedure::Attrs attrs
;
2637 if (elementalRank
> 0) {
2638 attrs
.set(characteristics::Procedure::Attr::Elemental
);
2640 if (call
.isSubroutineCall
) {
2641 if (intrinsicClass
== IntrinsicClass::pureSubroutine
/* MOVE_ALLOC */ ||
2642 intrinsicClass
== IntrinsicClass::elementalSubroutine
/* MVBITS */) {
2643 attrs
.set(characteristics::Procedure::Attr::Pure
);
2645 return SpecificCall
{
2647 name
, characteristics::Procedure
{std::move(dummyArgs
), attrs
}},
2648 std::move(rearranged
)};
2650 attrs
.set(characteristics::Procedure::Attr::Pure
);
2651 characteristics::TypeAndShape typeAndShape
{resultType
.value(), resultRank
};
2652 characteristics::FunctionResult funcResult
{std::move(typeAndShape
)};
2653 characteristics::Procedure chars
{
2654 std::move(funcResult
), std::move(dummyArgs
), attrs
};
2655 return SpecificCall
{
2656 SpecificIntrinsic
{name
, std::move(chars
)}, std::move(rearranged
)};
2660 class IntrinsicProcTable::Implementation
{
2662 explicit Implementation(const common::IntrinsicTypeDefaultKinds
&dfts
)
2664 for (const IntrinsicInterface
&f
: genericIntrinsicFunction
) {
2665 genericFuncs_
.insert(std::make_pair(std::string
{f
.name
}, &f
));
2667 for (const std::pair
<const char *, const char *> &a
: genericAlias
) {
2669 std::make_pair(std::string
{a
.first
}, std::string
{a
.second
}));
2671 for (const SpecificIntrinsicInterface
&f
: specificIntrinsicFunction
) {
2672 specificFuncs_
.insert(std::make_pair(std::string
{f
.name
}, &f
));
2674 for (const IntrinsicInterface
&f
: intrinsicSubroutine
) {
2675 subroutines_
.insert(std::make_pair(std::string
{f
.name
}, &f
));
2679 void SupplyBuiltins(const semantics::Scope
&builtins
) {
2680 builtinsScope_
= &builtins
;
2683 bool IsIntrinsic(const std::string
&) const;
2684 bool IsIntrinsicFunction(const std::string
&) const;
2685 bool IsIntrinsicSubroutine(const std::string
&) const;
2686 bool IsDualIntrinsic(const std::string
&) const;
2688 IntrinsicClass
GetIntrinsicClass(const std::string
&) const;
2689 std::string
GetGenericIntrinsicName(const std::string
&) const;
2691 std::optional
<SpecificCall
> Probe(
2692 const CallCharacteristics
&, ActualArguments
&, FoldingContext
&) const;
2694 std::optional
<SpecificIntrinsicFunctionInterface
> IsSpecificIntrinsicFunction(
2695 const std::string
&) const;
2697 llvm::raw_ostream
&Dump(llvm::raw_ostream
&) const;
2700 DynamicType
GetSpecificType(const TypePattern
&) const;
2701 SpecificCall
HandleNull(ActualArguments
&, FoldingContext
&) const;
2702 std::optional
<SpecificCall
> HandleC_F_Pointer(
2703 ActualArguments
&, FoldingContext
&) const;
2704 std::optional
<SpecificCall
> HandleC_Loc(
2705 ActualArguments
&, FoldingContext
&) const;
2706 std::optional
<SpecificCall
> HandleC_Devloc(
2707 ActualArguments
&, FoldingContext
&) const;
2708 const std::string
&ResolveAlias(const std::string
&name
) const {
2709 auto iter
{aliases_
.find(name
)};
2710 return iter
== aliases_
.end() ? name
: iter
->second
;
2713 common::IntrinsicTypeDefaultKinds defaults_
;
2714 std::multimap
<std::string
, const IntrinsicInterface
*> genericFuncs_
;
2715 std::multimap
<std::string
, const SpecificIntrinsicInterface
*> specificFuncs_
;
2716 std::multimap
<std::string
, const IntrinsicInterface
*> subroutines_
;
2717 const semantics::Scope
*builtinsScope_
{nullptr};
2718 std::map
<std::string
, std::string
> aliases_
;
2719 semantics::ParamValue assumedLen_
{
2720 semantics::ParamValue::Assumed(common::TypeParamAttr::Len
)};
2723 bool IntrinsicProcTable::Implementation::IsIntrinsicFunction(
2724 const std::string
&name0
) const {
2725 const std::string
&name
{ResolveAlias(name0
)};
2726 auto specificRange
{specificFuncs_
.equal_range(name
)};
2727 if (specificRange
.first
!= specificRange
.second
) {
2730 auto genericRange
{genericFuncs_
.equal_range(name
)};
2731 if (genericRange
.first
!= genericRange
.second
) {
2735 return name
== "__builtin_c_loc" || name
== "__builtin_c_devloc" ||
2738 bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine(
2739 const std::string
&name0
) const {
2740 const std::string
&name
{ResolveAlias(name0
)};
2741 auto subrRange
{subroutines_
.equal_range(name
)};
2742 if (subrRange
.first
!= subrRange
.second
) {
2746 return name
== "__builtin_c_f_pointer";
2748 bool IntrinsicProcTable::Implementation::IsIntrinsic(
2749 const std::string
&name
) const {
2750 return IsIntrinsicFunction(name
) || IsIntrinsicSubroutine(name
);
2752 bool IntrinsicProcTable::Implementation::IsDualIntrinsic(
2753 const std::string
&name
) const {
2754 // Collection for some intrinsics with function and subroutine form,
2755 // in order to pass the semantic check.
2756 static const std::string dualIntrinsic
[]{{"chdir"s
}, {"etime"s
}, {"getcwd"s
},
2757 {"rename"s
}, {"second"s
}, {"system"s
}};
2759 return llvm::is_contained(dualIntrinsic
, name
);
2762 IntrinsicClass
IntrinsicProcTable::Implementation::GetIntrinsicClass(
2763 const std::string
&name
) const {
2764 auto specificIntrinsic
{specificFuncs_
.find(name
)};
2765 if (specificIntrinsic
!= specificFuncs_
.end()) {
2766 return specificIntrinsic
->second
->intrinsicClass
;
2768 auto genericIntrinsic
{genericFuncs_
.find(name
)};
2769 if (genericIntrinsic
!= genericFuncs_
.end()) {
2770 return genericIntrinsic
->second
->intrinsicClass
;
2772 auto subrIntrinsic
{subroutines_
.find(name
)};
2773 if (subrIntrinsic
!= subroutines_
.end()) {
2774 return subrIntrinsic
->second
->intrinsicClass
;
2776 return IntrinsicClass::noClass
;
2779 std::string
IntrinsicProcTable::Implementation::GetGenericIntrinsicName(
2780 const std::string
&name
) const {
2781 auto specificIntrinsic
{specificFuncs_
.find(name
)};
2782 if (specificIntrinsic
!= specificFuncs_
.end()) {
2783 if (const char *genericName
{specificIntrinsic
->second
->generic
}) {
2784 return {genericName
};
2790 bool CheckAndRearrangeArguments(ActualArguments
&arguments
,
2791 parser::ContextualMessages
&messages
, const char *const dummyKeywords
[],
2792 std::size_t trailingOptionals
) {
2793 std::size_t numDummies
{0};
2794 while (dummyKeywords
[numDummies
]) {
2797 CHECK(trailingOptionals
<= numDummies
);
2798 if (arguments
.size() > numDummies
) {
2799 messages
.Say("Too many actual arguments (%zd > %zd)"_err_en_US
,
2800 arguments
.size(), numDummies
);
2803 ActualArguments
rearranged(numDummies
);
2804 bool anyKeywords
{false};
2805 std::size_t position
{0};
2806 for (std::optional
<ActualArgument
> &arg
: arguments
) {
2807 std::size_t dummyIndex
{0};
2808 if (arg
&& arg
->keyword()) {
2810 for (; dummyIndex
< numDummies
; ++dummyIndex
) {
2811 if (*arg
->keyword() == dummyKeywords
[dummyIndex
]) {
2815 if (dummyIndex
>= numDummies
) {
2816 messages
.Say(*arg
->keyword(),
2817 "Unknown argument keyword '%s='"_err_en_US
, *arg
->keyword());
2820 } else if (anyKeywords
) {
2821 messages
.Say(arg
? arg
->sourceLocation() : messages
.at(),
2822 "A positional actual argument may not appear after any keyword arguments"_err_en_US
);
2825 dummyIndex
= position
++;
2827 if (rearranged
[dummyIndex
]) {
2828 messages
.Say(arg
? arg
->sourceLocation() : messages
.at(),
2829 "Dummy argument '%s=' appears more than once"_err_en_US
,
2830 dummyKeywords
[dummyIndex
]);
2833 rearranged
[dummyIndex
] = std::move(arg
);
2836 bool anyMissing
{false};
2837 for (std::size_t j
{0}; j
< numDummies
- trailingOptionals
; ++j
) {
2838 if (!rearranged
[j
]) {
2839 messages
.Say("Dummy argument '%s=' is absent and not OPTIONAL"_err_en_US
,
2844 arguments
= std::move(rearranged
);
2848 // The NULL() intrinsic is a special case.
2849 SpecificCall
IntrinsicProcTable::Implementation::HandleNull(
2850 ActualArguments
&arguments
, FoldingContext
&context
) const {
2851 static const char *const keywords
[]{"mold", nullptr};
2852 if (CheckAndRearrangeArguments(arguments
, context
.messages(), keywords
, 1) &&
2854 Expr
<SomeType
> *mold
{arguments
[0]->UnwrapExpr()};
2855 bool isBareNull
{IsBareNullPointer(mold
)};
2857 // NULL(NULL()), NULL(NULL(NULL())), &c. are all just NULL()
2861 if (IsAssumedRank(*arguments
[0])) {
2862 context
.messages().Say(arguments
[0]->sourceLocation(),
2863 "MOLD= argument to NULL() must not be assumed-rank"_err_en_US
);
2865 bool isProcPtrTarget
{
2866 IsProcedurePointerTarget(*mold
) && !IsNullObjectPointer(*mold
)};
2867 if (isProcPtrTarget
|| IsAllocatableOrPointerObject(*mold
)) {
2868 characteristics::DummyArguments args
;
2869 std::optional
<characteristics::FunctionResult
> fResult
;
2870 if (isProcPtrTarget
) {
2871 // MOLD= procedure pointer
2872 std::optional
<characteristics::Procedure
> procPointer
;
2873 if (IsNullProcedurePointer(*mold
)) {
2875 characteristics::Procedure::Characterize(*mold
, context
);
2877 const Symbol
*last
{GetLastSymbol(*mold
)};
2879 characteristics::Procedure::Characterize(DEREF(last
), context
);
2881 // procPointer is vacant if there was an error with the analysis
2882 // associated with the procedure pointer
2884 args
.emplace_back("mold"s
,
2885 characteristics::DummyProcedure
{common::Clone(*procPointer
)});
2886 fResult
.emplace(std::move(*procPointer
));
2888 } else if (auto type
{mold
->GetType()}) {
2889 // MOLD= object pointer
2890 characteristics::TypeAndShape typeAndShape
{
2891 *type
, GetShape(context
, *mold
)};
2893 "mold"s
, characteristics::DummyDataObject
{typeAndShape
});
2894 fResult
.emplace(std::move(typeAndShape
));
2896 context
.messages().Say(arguments
[0]->sourceLocation(),
2897 "MOLD= argument to NULL() lacks type"_err_en_US
);
2900 fResult
->attrs
.set(characteristics::FunctionResult::Attr::Pointer
);
2901 characteristics::Procedure::Attrs attrs
;
2902 attrs
.set(characteristics::Procedure::Attr::NullPointer
);
2903 characteristics::Procedure chars
{
2904 std::move(*fResult
), std::move(args
), attrs
};
2905 return SpecificCall
{SpecificIntrinsic
{"null"s
, std::move(chars
)},
2906 std::move(arguments
)};
2911 context
.messages().Say(arguments
[0]->sourceLocation(),
2912 "MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US
);
2915 characteristics::Procedure::Attrs attrs
;
2916 attrs
.set(characteristics::Procedure::Attr::NullPointer
);
2917 attrs
.set(characteristics::Procedure::Attr::Pure
);
2919 return SpecificCall
{
2920 SpecificIntrinsic
{"null"s
,
2921 characteristics::Procedure
{characteristics::DummyArguments
{}, attrs
}},
2922 std::move(arguments
)};
2925 // Subroutine C_F_POINTER(CPTR=,FPTR=[,SHAPE=]) from
2926 // intrinsic module ISO_C_BINDING (18.2.3.3)
2927 std::optional
<SpecificCall
>
2928 IntrinsicProcTable::Implementation::HandleC_F_Pointer(
2929 ActualArguments
&arguments
, FoldingContext
&context
) const {
2930 characteristics::Procedure::Attrs attrs
;
2931 attrs
.set(characteristics::Procedure::Attr::Subroutine
);
2932 static const char *const keywords
[]{"cptr", "fptr", "shape", nullptr};
2933 characteristics::DummyArguments dummies
;
2934 if (CheckAndRearrangeArguments(arguments
, context
.messages(), keywords
, 1)) {
2935 CHECK(arguments
.size() == 3);
2936 if (const auto *expr
{arguments
[0].value().UnwrapExpr()}) {
2937 // General semantic checks will catch an actual argument that's not
2939 if (auto type
{expr
->GetType()}) {
2940 if (type
->category() != TypeCategory::Derived
||
2941 type
->IsPolymorphic() ||
2942 (type
->GetDerivedTypeSpec().typeSymbol().name() !=
2943 "__builtin_c_ptr" &&
2944 type
->GetDerivedTypeSpec().typeSymbol().name() !=
2945 "__builtin_c_devptr")) {
2946 context
.messages().Say(arguments
[0]->sourceLocation(),
2947 "CPTR= argument to C_F_POINTER() must be a C_PTR"_err_en_US
);
2949 characteristics::DummyDataObject cptr
{
2950 characteristics::TypeAndShape
{*type
}};
2951 cptr
.intent
= common::Intent::In
;
2952 dummies
.emplace_back("cptr"s
, std::move(cptr
));
2955 if (const auto *expr
{arguments
[1].value().UnwrapExpr()}) {
2956 int fptrRank
{expr
->Rank()};
2957 auto at
{arguments
[1]->sourceLocation()};
2958 if (auto type
{expr
->GetType()}) {
2959 if (type
->HasDeferredTypeParameter()) {
2960 context
.messages().Say(at
,
2961 "FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US
);
2962 } else if (type
->category() == TypeCategory::Derived
) {
2963 if (context
.languageFeatures().ShouldWarn(
2964 common::UsageWarning::Interoperability
) &&
2965 type
->IsUnlimitedPolymorphic()) {
2966 context
.messages().Say(common::UsageWarning::Interoperability
, at
,
2967 "FPTR= argument to C_F_POINTER() should not be unlimited polymorphic"_warn_en_US
);
2968 } else if (!type
->GetDerivedTypeSpec().typeSymbol().attrs().test(
2969 semantics::Attr::BIND_C
) &&
2970 context
.languageFeatures().ShouldWarn(
2971 common::UsageWarning::Portability
)) {
2972 context
.messages().Say(common::UsageWarning::Portability
, at
,
2973 "FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)"_port_en_US
);
2975 } else if (!IsInteroperableIntrinsicType(
2976 *type
, &context
.languageFeatures())
2978 if (type
->category() == TypeCategory::Character
&&
2979 type
->kind() == 1) {
2980 if (context
.languageFeatures().ShouldWarn(
2981 common::UsageWarning::CharacterInteroperability
)) {
2982 context
.messages().Say(
2983 common::UsageWarning::CharacterInteroperability
, at
,
2984 "FPTR= argument to C_F_POINTER() should not have the non-interoperable character length %s"_warn_en_US
,
2987 } else if (context
.languageFeatures().ShouldWarn(
2988 common::UsageWarning::Interoperability
)) {
2989 context
.messages().Say(common::UsageWarning::Interoperability
, at
,
2990 "FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind %s"_warn_en_US
,
2994 if (ExtractCoarrayRef(*expr
)) {
2995 context
.messages().Say(at
,
2996 "FPTR= argument to C_F_POINTER() may not be a coindexed object"_err_en_US
);
2998 characteristics::DummyDataObject fptr
{
2999 characteristics::TypeAndShape
{*type
, fptrRank
}};
3000 fptr
.intent
= common::Intent::Out
;
3001 fptr
.attrs
.set(characteristics::DummyDataObject::Attr::Pointer
);
3002 dummies
.emplace_back("fptr"s
, std::move(fptr
));
3004 context
.messages().Say(
3005 at
, "FPTR= argument to C_F_POINTER() must have a type"_err_en_US
);
3007 if (arguments
[2] && fptrRank
== 0) {
3008 context
.messages().Say(arguments
[2]->sourceLocation(),
3009 "SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US
);
3010 } else if (!arguments
[2] && fptrRank
> 0) {
3011 context
.messages().Say(
3012 "SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array"_err_en_US
);
3013 } else if (arguments
[2]) {
3014 if (const auto *argExpr
{arguments
[2].value().UnwrapExpr()}) {
3015 if (argExpr
->Rank() > 1) {
3016 context
.messages().Say(arguments
[2]->sourceLocation(),
3017 "SHAPE= argument to C_F_POINTER() must be a rank-one array."_err_en_US
);
3018 } else if (argExpr
->Rank() == 1) {
3019 if (auto constShape
{GetConstantShape(context
, *argExpr
)}) {
3020 if (constShape
->At(ConstantSubscripts
{1}).ToInt64() != fptrRank
) {
3021 context
.messages().Say(arguments
[2]->sourceLocation(),
3022 "SHAPE= argument to C_F_POINTER() must have size equal to the rank of FPTR="_err_en_US
);
3030 if (dummies
.size() == 2) {
3031 DynamicType shapeType
{TypeCategory::Integer
, defaults_
.sizeIntegerKind()};
3033 if (auto type
{arguments
[2]->GetType()}) {
3034 if (type
->category() == TypeCategory::Integer
) {
3039 characteristics::DummyDataObject shape
{
3040 characteristics::TypeAndShape
{shapeType
, 1}};
3041 shape
.intent
= common::Intent::In
;
3042 shape
.attrs
.set(characteristics::DummyDataObject::Attr::Optional
);
3043 dummies
.emplace_back("shape"s
, std::move(shape
));
3044 return SpecificCall
{
3045 SpecificIntrinsic
{"__builtin_c_f_pointer"s
,
3046 characteristics::Procedure
{std::move(dummies
), attrs
}},
3047 std::move(arguments
)};
3049 return std::nullopt
;
3053 // Function C_LOC(X) from intrinsic module ISO_C_BINDING (18.2.3.6)
3054 std::optional
<SpecificCall
> IntrinsicProcTable::Implementation::HandleC_Loc(
3055 ActualArguments
&arguments
, FoldingContext
&context
) const {
3056 static const char *const keywords
[]{"x", nullptr};
3057 if (CheckAndRearrangeArguments(arguments
, context
.messages(), keywords
)) {
3058 CHECK(arguments
.size() == 1);
3059 CheckForCoindexedObject(context
.messages(), arguments
[0], "c_loc", "x");
3060 const auto *expr
{arguments
[0].value().UnwrapExpr()};
3062 !(IsObjectPointer(*expr
) ||
3063 (IsVariable(*expr
) && GetLastTarget(GetSymbolVector(*expr
))))) {
3064 context
.messages().Say(arguments
[0]->sourceLocation(),
3065 "C_LOC() argument must be a data pointer or target"_err_en_US
);
3067 if (auto typeAndShape
{characteristics::TypeAndShape::Characterize(
3068 arguments
[0], context
)}) {
3069 if (expr
&& !IsContiguous(*expr
, context
).value_or(true)) {
3070 context
.messages().Say(arguments
[0]->sourceLocation(),
3071 "C_LOC() argument must be contiguous"_err_en_US
);
3073 if (auto constExtents
{AsConstantExtents(context
, typeAndShape
->shape())};
3074 constExtents
&& GetSize(*constExtents
) == 0) {
3075 context
.messages().Say(arguments
[0]->sourceLocation(),
3076 "C_LOC() argument may not be a zero-sized array"_err_en_US
);
3078 if (!(typeAndShape
->type().category() != TypeCategory::Derived
||
3079 typeAndShape
->type().IsAssumedType() ||
3080 (!typeAndShape
->type().IsPolymorphic() &&
3081 CountNonConstantLenParameters(
3082 typeAndShape
->type().GetDerivedTypeSpec()) == 0))) {
3083 context
.messages().Say(arguments
[0]->sourceLocation(),
3084 "C_LOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter"_err_en_US
);
3085 } else if (typeAndShape
->type().knownLength().value_or(1) == 0) {
3086 context
.messages().Say(arguments
[0]->sourceLocation(),
3087 "C_LOC() argument may not be zero-length character"_err_en_US
);
3088 } else if (typeAndShape
->type().category() != TypeCategory::Derived
&&
3089 !IsInteroperableIntrinsicType(typeAndShape
->type()).value_or(true)) {
3090 if (typeAndShape
->type().category() == TypeCategory::Character
&&
3091 typeAndShape
->type().kind() == 1) {
3092 // Default character kind, but length is not known to be 1
3093 if (context
.languageFeatures().ShouldWarn(
3094 common::UsageWarning::CharacterInteroperability
)) {
3095 context
.messages().Say(
3096 common::UsageWarning::CharacterInteroperability
,
3097 arguments
[0]->sourceLocation(),
3098 "C_LOC() argument has non-interoperable character length"_warn_en_US
);
3100 } else if (context
.languageFeatures().ShouldWarn(
3101 common::UsageWarning::Interoperability
)) {
3102 context
.messages().Say(common::UsageWarning::Interoperability
,
3103 arguments
[0]->sourceLocation(),
3104 "C_LOC() argument has non-interoperable intrinsic type or kind"_warn_en_US
);
3108 characteristics::DummyDataObject ddo
{std::move(*typeAndShape
)};
3109 ddo
.intent
= common::Intent::In
;
3110 return SpecificCall
{
3111 SpecificIntrinsic
{"__builtin_c_loc"s
,
3112 characteristics::Procedure
{
3113 characteristics::FunctionResult
{
3114 DynamicType
{GetBuiltinDerivedType(
3115 builtinsScope_
, "__builtin_c_ptr")}},
3116 characteristics::DummyArguments
{
3117 characteristics::DummyArgument
{"x"s
, std::move(ddo
)}},
3118 characteristics::Procedure::Attrs
{
3119 characteristics::Procedure::Attr::Pure
}}},
3120 std::move(arguments
)};
3123 return std::nullopt
;
3126 // CUDA Fortran C_DEVLOC(x)
3127 std::optional
<SpecificCall
> IntrinsicProcTable::Implementation::HandleC_Devloc(
3128 ActualArguments
&arguments
, FoldingContext
&context
) const {
3129 static const char *const keywords
[]{"cptr", nullptr};
3131 if (CheckAndRearrangeArguments(arguments
, context
.messages(), keywords
)) {
3132 CHECK(arguments
.size() == 1);
3133 const auto *expr
{arguments
[0].value().UnwrapExpr()};
3134 if (auto typeAndShape
{characteristics::TypeAndShape::Characterize(
3135 arguments
[0], context
)}) {
3136 if (expr
&& !IsContiguous(*expr
, context
).value_or(true)) {
3137 context
.messages().Say(arguments
[0]->sourceLocation(),
3138 "C_DEVLOC() argument must be contiguous"_err_en_US
);
3140 if (auto constExtents
{AsConstantExtents(context
, typeAndShape
->shape())};
3141 constExtents
&& GetSize(*constExtents
) == 0) {
3142 context
.messages().Say(arguments
[0]->sourceLocation(),
3143 "C_DEVLOC() argument may not be a zero-sized array"_err_en_US
);
3145 if (!(typeAndShape
->type().category() != TypeCategory::Derived
||
3146 typeAndShape
->type().IsAssumedType() ||
3147 (!typeAndShape
->type().IsPolymorphic() &&
3148 CountNonConstantLenParameters(
3149 typeAndShape
->type().GetDerivedTypeSpec()) == 0))) {
3150 context
.messages().Say(arguments
[0]->sourceLocation(),
3151 "C_DEVLOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter"_err_en_US
);
3152 } else if (typeAndShape
->type().knownLength().value_or(1) == 0) {
3153 context
.messages().Say(arguments
[0]->sourceLocation(),
3154 "C_DEVLOC() argument may not be zero-length character"_err_en_US
);
3155 } else if (typeAndShape
->type().category() != TypeCategory::Derived
&&
3156 !IsInteroperableIntrinsicType(typeAndShape
->type()).value_or(true)) {
3157 if (typeAndShape
->type().category() == TypeCategory::Character
&&
3158 typeAndShape
->type().kind() == 1) {
3159 // Default character kind, but length is not known to be 1
3160 if (context
.languageFeatures().ShouldWarn(
3161 common::UsageWarning::CharacterInteroperability
)) {
3162 context
.messages().Say(
3163 common::UsageWarning::CharacterInteroperability
,
3164 arguments
[0]->sourceLocation(),
3165 "C_DEVLOC() argument has non-interoperable character length"_warn_en_US
);
3167 } else if (context
.languageFeatures().ShouldWarn(
3168 common::UsageWarning::Interoperability
)) {
3169 context
.messages().Say(common::UsageWarning::Interoperability
,
3170 arguments
[0]->sourceLocation(),
3171 "C_DEVLOC() argument has non-interoperable intrinsic type or kind"_warn_en_US
);
3175 characteristics::DummyDataObject ddo
{std::move(*typeAndShape
)};
3176 ddo
.intent
= common::Intent::In
;
3177 return SpecificCall
{
3178 SpecificIntrinsic
{"__builtin_c_devloc"s
,
3179 characteristics::Procedure
{
3180 characteristics::FunctionResult
{
3181 DynamicType
{GetBuiltinDerivedType(
3182 builtinsScope_
, "__builtin_c_devptr")}},
3183 characteristics::DummyArguments
{
3184 characteristics::DummyArgument
{"cptr"s
, std::move(ddo
)}},
3185 characteristics::Procedure::Attrs
{
3186 characteristics::Procedure::Attr::Pure
}}},
3187 std::move(arguments
)};
3190 return std::nullopt
;
3193 static bool CheckForNonPositiveValues(FoldingContext
&context
,
3194 const ActualArgument
&arg
, const std::string
&procName
,
3195 const std::string
&argName
) {
3197 if (arg
.Rank() > 0) {
3198 if (const Expr
<SomeType
> *expr
{arg
.UnwrapExpr()}) {
3199 if (const auto *intExpr
{std::get_if
<Expr
<SomeInteger
>>(&expr
->u
)}) {
3200 Fortran::common::visit(
3201 [&](const auto &kindExpr
) {
3202 using IntType
= typename
std::decay_t
<decltype(kindExpr
)>::Result
;
3203 if (const auto *constArray
{
3204 UnwrapConstantValue
<IntType
>(kindExpr
)}) {
3205 for (std::size_t j
{0}; j
< constArray
->size(); ++j
) {
3206 auto arrayExpr
{constArray
->values().at(j
)};
3207 if (arrayExpr
.IsNegative() || arrayExpr
.IsZero()) {
3209 context
.messages().Say(arg
.sourceLocation(),
3210 "'%s=' argument for intrinsic '%s' must contain all positive values"_err_en_US
,
3220 if (auto val
{ToInt64(arg
.UnwrapExpr())}) {
3223 context
.messages().Say(arg
.sourceLocation(),
3224 "'%s=' argument for intrinsic '%s' must be a positive value, but is %jd"_err_en_US
,
3225 argName
, procName
, static_cast<std::intmax_t>(*val
));
3232 static bool CheckAtomicDefineAndRef(FoldingContext
&context
,
3233 const std::optional
<ActualArgument
> &atomArg
,
3234 const std::optional
<ActualArgument
> &valueArg
,
3235 const std::optional
<ActualArgument
> &statArg
, const std::string
&procName
) {
3236 bool sameType
{true};
3237 if (valueArg
&& atomArg
) {
3238 // for atomic_define and atomic_ref, 'value' arg must be the same type as
3239 // 'atom', but it doesn't have to be the same kind
3240 if (valueArg
->GetType()->category() != atomArg
->GetType()->category()) {
3242 context
.messages().Say(valueArg
->sourceLocation(),
3243 "'value=' argument to '%s' must have same type as 'atom=', but is '%s'"_err_en_US
,
3244 procName
, valueArg
->GetType()->AsFortran());
3249 CheckForCoindexedObject(context
.messages(), statArg
, procName
, "stat");
3252 // Applies any semantic checks peculiar to an intrinsic.
3253 // TODO: Move the rest of these checks to Semantics/check-call.cpp.
3254 static bool ApplySpecificChecks(SpecificCall
&call
, FoldingContext
&context
) {
3256 const std::string
&name
{call
.specificIntrinsic
.name
};
3257 if (name
== "allocated") {
3258 const auto &arg
{call
.arguments
[0]};
3260 if (const auto *expr
{arg
->UnwrapExpr()}) {
3261 ok
= evaluate::IsAllocatableDesignator(*expr
);
3265 context
.messages().Say(
3266 arg
? arg
->sourceLocation() : context
.messages().at(),
3267 "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US
);
3269 } else if (name
== "atomic_add" || name
== "atomic_and" ||
3270 name
== "atomic_or" || name
== "atomic_xor" || name
== "event_query") {
3271 return CheckForCoindexedObject(
3272 context
.messages(), call
.arguments
[2], name
, "stat");
3273 } else if (name
== "atomic_cas") {
3274 return CheckForCoindexedObject(
3275 context
.messages(), call
.arguments
[4], name
, "stat");
3276 } else if (name
== "atomic_define") {
3277 return CheckAtomicDefineAndRef(
3278 context
, call
.arguments
[0], call
.arguments
[1], call
.arguments
[2], name
);
3279 } else if (name
== "atomic_fetch_add" || name
== "atomic_fetch_and" ||
3280 name
== "atomic_fetch_or" || name
== "atomic_fetch_xor") {
3281 return CheckForCoindexedObject(
3282 context
.messages(), call
.arguments
[3], name
, "stat");
3283 } else if (name
== "atomic_ref") {
3284 return CheckAtomicDefineAndRef(
3285 context
, call
.arguments
[1], call
.arguments
[0], call
.arguments
[2], name
);
3286 } else if (name
== "co_broadcast" || name
== "co_max" || name
== "co_min" ||
3288 bool aOk
{CheckForCoindexedObject(
3289 context
.messages(), call
.arguments
[0], name
, "a")};
3290 bool statOk
{CheckForCoindexedObject(
3291 context
.messages(), call
.arguments
[2], name
, "stat")};
3292 bool errmsgOk
{CheckForCoindexedObject(
3293 context
.messages(), call
.arguments
[3], name
, "errmsg")};
3294 ok
= aOk
&& statOk
&& errmsgOk
;
3295 } else if (name
== "image_status") {
3296 if (const auto &arg
{call
.arguments
[0]}) {
3297 ok
= CheckForNonPositiveValues(context
, *arg
, name
, "image");
3299 } else if (name
== "loc") {
3300 const auto &arg
{call
.arguments
[0]};
3302 arg
&& (arg
->GetAssumedTypeDummy() || GetLastSymbol(arg
->UnwrapExpr()));
3304 context
.messages().Say(
3305 arg
? arg
->sourceLocation() : context
.messages().at(),
3306 "Argument of LOC() must be an object or procedure"_err_en_US
);
3312 static DynamicType
GetReturnType(const SpecificIntrinsicInterface
&interface
,
3313 const common::IntrinsicTypeDefaultKinds
&defaults
) {
3314 TypeCategory category
{TypeCategory::Integer
};
3315 switch (interface
.result
.kindCode
) {
3316 case KindCode::defaultIntegerKind
:
3318 case KindCode::doublePrecision
:
3319 case KindCode::defaultRealKind
:
3320 category
= TypeCategory::Real
;
3325 int kind
{interface
.result
.kindCode
== KindCode::doublePrecision
3326 ? defaults
.doublePrecisionKind()
3327 : defaults
.GetDefaultKind(category
)};
3328 return DynamicType
{category
, kind
};
3331 // Probe the configured intrinsic procedure pattern tables in search of a
3332 // match for a given procedure reference.
3333 std::optional
<SpecificCall
> IntrinsicProcTable::Implementation::Probe(
3334 const CallCharacteristics
&call
, ActualArguments
&arguments
,
3335 FoldingContext
&context
) const {
3337 // All special cases handled here before the table probes below must
3338 // also be recognized as special names in IsIntrinsicSubroutine().
3339 if (call
.isSubroutineCall
) {
3340 if (call
.name
== "__builtin_c_f_pointer") {
3341 return HandleC_F_Pointer(arguments
, context
);
3342 } else if (call
.name
== "random_seed") {
3343 int optionalCount
{0};
3344 for (const auto &arg
: arguments
) {
3345 if (const auto *expr
{arg
->UnwrapExpr()}) {
3347 Fortran::evaluate::MayBePassedAsAbsentOptional(*expr
);
3350 if (arguments
.size() - optionalCount
> 1) {
3351 context
.messages().Say(
3352 "RANDOM_SEED must have either 1 or no arguments"_err_en_US
);
3355 } else { // function
3356 if (call
.name
== "__builtin_c_loc") {
3357 return HandleC_Loc(arguments
, context
);
3358 } else if (call
.name
== "__builtin_c_devloc") {
3359 return HandleC_Devloc(arguments
, context
);
3360 } else if (call
.name
== "null") {
3361 return HandleNull(arguments
, context
);
3365 if (call
.isSubroutineCall
) {
3366 const std::string
&name
{ResolveAlias(call
.name
)};
3367 auto subrRange
{subroutines_
.equal_range(name
)};
3368 for (auto iter
{subrRange
.first
}; iter
!= subrRange
.second
; ++iter
) {
3369 if (auto specificCall
{iter
->second
->Match(
3370 call
, defaults_
, arguments
, context
, builtinsScope_
)}) {
3371 ApplySpecificChecks(*specificCall
, context
);
3372 return specificCall
;
3375 if (IsIntrinsicFunction(call
.name
) && !IsDualIntrinsic(call
.name
)) {
3376 context
.messages().Say(
3377 "Cannot use intrinsic function '%s' as a subroutine"_err_en_US
,
3380 return std::nullopt
;
3383 // Helper to avoid emitting errors before it is sure there is no match
3384 parser::Messages localBuffer
;
3385 parser::Messages
*finalBuffer
{context
.messages().messages()};
3386 parser::ContextualMessages localMessages
{
3387 context
.messages().at(), finalBuffer
? &localBuffer
: nullptr};
3388 FoldingContext localContext
{context
, localMessages
};
3389 auto matchOrBufferMessages
{
3390 [&](const IntrinsicInterface
&intrinsic
,
3391 parser::Messages
&buffer
) -> std::optional
<SpecificCall
> {
3392 if (auto specificCall
{intrinsic
.Match(
3393 call
, defaults_
, arguments
, localContext
, builtinsScope_
)}) {
3395 finalBuffer
->Annex(std::move(localBuffer
));
3397 return specificCall
;
3398 } else if (buffer
.empty()) {
3399 buffer
.Annex(std::move(localBuffer
));
3401 // When there are multiple entries in the table for an
3402 // intrinsic that has multiple forms depending on the
3403 // presence of DIM=, use messages from a later entry if
3404 // the messages from an earlier entry complain about the
3405 // DIM= argument and it wasn't specified with a keyword.
3406 for (const auto &m
: buffer
.messages()) {
3407 if (m
.ToString().find("'dim='") != std::string::npos
) {
3408 bool hadDimKeyword
{false};
3409 for (const auto &a
: arguments
) {
3411 if (auto kw
{a
->keyword()}; kw
&& kw
== "dim") {
3412 hadDimKeyword
= true;
3417 if (!hadDimKeyword
) {
3418 buffer
= std::move(localBuffer
);
3423 localBuffer
.clear();
3425 return std::nullopt
;
3428 // Probe the generic intrinsic function table first; allow for
3429 // the use of a legacy alias.
3430 parser::Messages genericBuffer
;
3431 const std::string
&name
{ResolveAlias(call
.name
)};
3432 auto genericRange
{genericFuncs_
.equal_range(name
)};
3433 for (auto iter
{genericRange
.first
}; iter
!= genericRange
.second
; ++iter
) {
3434 if (auto specificCall
{
3435 matchOrBufferMessages(*iter
->second
, genericBuffer
)}) {
3436 ApplySpecificChecks(*specificCall
, context
);
3437 return specificCall
;
3441 // Probe the specific intrinsic function table next.
3442 parser::Messages specificBuffer
;
3443 auto specificRange
{specificFuncs_
.equal_range(call
.name
)};
3444 for (auto specIter
{specificRange
.first
}; specIter
!= specificRange
.second
;
3446 // We only need to check the cases with distinct generic names.
3447 if (const char *genericName
{specIter
->second
->generic
}) {
3448 if (auto specificCall
{
3449 matchOrBufferMessages(*specIter
->second
, specificBuffer
)}) {
3450 if (!specIter
->second
->useGenericAndForceResultType
) {
3451 specificCall
->specificIntrinsic
.name
= genericName
;
3453 specificCall
->specificIntrinsic
.isRestrictedSpecific
=
3454 specIter
->second
->isRestrictedSpecific
;
3455 // TODO test feature AdditionalIntrinsics, warn on nonstandard
3456 // specifics with DoublePrecisionComplex arguments.
3457 return specificCall
;
3462 // If there was no exact match with a specific, try to match the related
3463 // generic and convert the result to the specific required type.
3464 if (context
.languageFeatures().IsEnabled(common::LanguageFeature::
3465 UseGenericIntrinsicWhenSpecificDoesntMatch
)) {
3466 for (auto specIter
{specificRange
.first
}; specIter
!= specificRange
.second
;
3468 // We only need to check the cases with distinct generic names.
3469 if (const char *genericName
{specIter
->second
->generic
}) {
3470 if (specIter
->second
->useGenericAndForceResultType
) {
3471 auto genericRange
{genericFuncs_
.equal_range(genericName
)};
3472 for (auto genIter
{genericRange
.first
}; genIter
!= genericRange
.second
;
3474 if (auto specificCall
{
3475 matchOrBufferMessages(*genIter
->second
, specificBuffer
)}) {
3476 // Force the call result type to the specific intrinsic result
3477 // type, if possible.
3478 DynamicType genericType
{
3479 DEREF(specificCall
->specificIntrinsic
.characteristics
.value()
3480 .functionResult
.value()
3483 DynamicType newType
{GetReturnType(*specIter
->second
, defaults_
)};
3484 if (genericType
.category() == newType
.category() ||
3485 ((genericType
.category() == TypeCategory::Integer
||
3486 genericType
.category() == TypeCategory::Real
) &&
3487 (newType
.category() == TypeCategory::Integer
||
3488 newType
.category() == TypeCategory::Real
))) {
3489 if (context
.languageFeatures().ShouldWarn(
3490 common::LanguageFeature::
3491 UseGenericIntrinsicWhenSpecificDoesntMatch
)) {
3492 context
.messages().Say(
3493 common::LanguageFeature::
3494 UseGenericIntrinsicWhenSpecificDoesntMatch
,
3495 "Argument types do not match specific intrinsic '%s' requirements; using '%s' generic instead and converting the result to %s if needed"_port_en_US
,
3496 call
.name
, genericName
, newType
.AsFortran());
3498 specificCall
->specificIntrinsic
.name
= call
.name
;
3499 specificCall
->specificIntrinsic
.characteristics
.value()
3500 .functionResult
.value()
3502 return specificCall
;
3511 if (specificBuffer
.empty() && genericBuffer
.empty() &&
3512 IsIntrinsicSubroutine(call
.name
) && !IsDualIntrinsic(call
.name
)) {
3513 context
.messages().Say(
3514 "Cannot use intrinsic subroutine '%s' as a function"_err_en_US
,
3518 // No match; report the right errors, if any
3520 if (specificBuffer
.empty()) {
3521 finalBuffer
->Annex(std::move(genericBuffer
));
3523 finalBuffer
->Annex(std::move(specificBuffer
));
3526 return std::nullopt
;
3529 std::optional
<SpecificIntrinsicFunctionInterface
>
3530 IntrinsicProcTable::Implementation::IsSpecificIntrinsicFunction(
3531 const std::string
&name
) const {
3532 auto specificRange
{specificFuncs_
.equal_range(name
)};
3533 for (auto iter
{specificRange
.first
}; iter
!= specificRange
.second
; ++iter
) {
3534 const SpecificIntrinsicInterface
&specific
{*iter
->second
};
3535 std::string genericName
{name
};
3536 if (specific
.generic
) {
3537 genericName
= std::string(specific
.generic
);
3539 characteristics::FunctionResult fResult
{GetSpecificType(specific
.result
)};
3540 characteristics::DummyArguments args
;
3541 int dummies
{specific
.CountArguments()};
3542 for (int j
{0}; j
< dummies
; ++j
) {
3543 characteristics::DummyDataObject dummy
{
3544 GetSpecificType(specific
.dummy
[j
].typePattern
)};
3545 dummy
.intent
= specific
.dummy
[j
].intent
;
3547 std::string
{specific
.dummy
[j
].keyword
}, std::move(dummy
));
3549 characteristics::Procedure::Attrs attrs
;
3550 attrs
.set(characteristics::Procedure::Attr::Pure
)
3551 .set(characteristics::Procedure::Attr::Elemental
);
3552 characteristics::Procedure chars
{
3553 std::move(fResult
), std::move(args
), attrs
};
3554 return SpecificIntrinsicFunctionInterface
{
3555 std::move(chars
), genericName
, specific
.isRestrictedSpecific
};
3557 return std::nullopt
;
3560 DynamicType
IntrinsicProcTable::Implementation::GetSpecificType(
3561 const TypePattern
&pattern
) const {
3562 const CategorySet
&set
{pattern
.categorySet
};
3563 CHECK(set
.count() == 1);
3564 TypeCategory category
{set
.LeastElement().value()};
3565 if (pattern
.kindCode
== KindCode::doublePrecision
) {
3566 return DynamicType
{category
, defaults_
.doublePrecisionKind()};
3567 } else if (category
== TypeCategory::Character
) {
3568 // All character arguments to specific intrinsic functions are
3570 return DynamicType
{defaults_
.GetDefaultKind(category
), assumedLen_
};
3572 return DynamicType
{category
, defaults_
.GetDefaultKind(category
)};
3576 IntrinsicProcTable::~IntrinsicProcTable() = default;
3578 IntrinsicProcTable
IntrinsicProcTable::Configure(
3579 const common::IntrinsicTypeDefaultKinds
&defaults
) {
3580 IntrinsicProcTable result
;
3581 result
.impl_
= std::make_unique
<IntrinsicProcTable::Implementation
>(defaults
);
3585 void IntrinsicProcTable::SupplyBuiltins(
3586 const semantics::Scope
&builtins
) const {
3587 DEREF(impl_
.get()).SupplyBuiltins(builtins
);
3590 bool IntrinsicProcTable::IsIntrinsic(const std::string
&name
) const {
3591 return DEREF(impl_
.get()).IsIntrinsic(name
);
3593 bool IntrinsicProcTable::IsIntrinsicFunction(const std::string
&name
) const {
3594 return DEREF(impl_
.get()).IsIntrinsicFunction(name
);
3596 bool IntrinsicProcTable::IsIntrinsicSubroutine(const std::string
&name
) const {
3597 return DEREF(impl_
.get()).IsIntrinsicSubroutine(name
);
3600 IntrinsicClass
IntrinsicProcTable::GetIntrinsicClass(
3601 const std::string
&name
) const {
3602 return DEREF(impl_
.get()).GetIntrinsicClass(name
);
3605 std::string
IntrinsicProcTable::GetGenericIntrinsicName(
3606 const std::string
&name
) const {
3607 return DEREF(impl_
.get()).GetGenericIntrinsicName(name
);
3610 std::optional
<SpecificCall
> IntrinsicProcTable::Probe(
3611 const CallCharacteristics
&call
, ActualArguments
&arguments
,
3612 FoldingContext
&context
) const {
3613 return DEREF(impl_
.get()).Probe(call
, arguments
, context
);
3616 std::optional
<SpecificIntrinsicFunctionInterface
>
3617 IntrinsicProcTable::IsSpecificIntrinsicFunction(const std::string
&name
) const {
3618 return DEREF(impl_
.get()).IsSpecificIntrinsicFunction(name
);
3621 llvm::raw_ostream
&TypePattern::Dump(llvm::raw_ostream
&o
) const {
3622 if (categorySet
== AnyType
) {
3625 const char *sep
= "";
3626 auto set
{categorySet
};
3627 while (auto least
{set
.LeastElement()}) {
3628 o
<< sep
<< EnumToString(*least
);
3633 o
<< '(' << EnumToString(kindCode
) << ')';
3637 llvm::raw_ostream
&IntrinsicDummyArgument::Dump(llvm::raw_ostream
&o
) const {
3639 o
<< keyword
<< '=';
3641 return typePattern
.Dump(o
)
3642 << ' ' << EnumToString(rank
) << ' ' << EnumToString(optionality
)
3643 << EnumToString(intent
);
3646 llvm::raw_ostream
&IntrinsicInterface::Dump(llvm::raw_ostream
&o
) const {
3649 for (const auto &d
: dummy
) {
3650 if (d
.typePattern
.kindCode
== KindCode::none
) {
3659 return result
.Dump(o
<< " -> ") << ' ' << EnumToString(rank
);
3662 llvm::raw_ostream
&IntrinsicProcTable::Implementation::Dump(
3663 llvm::raw_ostream
&o
) const {
3664 o
<< "generic intrinsic functions:\n";
3665 for (const auto &iter
: genericFuncs_
) {
3666 iter
.second
->Dump(o
<< iter
.first
<< ": ") << '\n';
3668 o
<< "specific intrinsic functions:\n";
3669 for (const auto &iter
: specificFuncs_
) {
3670 iter
.second
->Dump(o
<< iter
.first
<< ": ");
3671 if (const char *g
{iter
.second
->generic
}) {
3676 o
<< "subroutines:\n";
3677 for (const auto &iter
: subroutines_
) {
3678 iter
.second
->Dump(o
<< iter
.first
<< ": ") << '\n';
3683 llvm::raw_ostream
&IntrinsicProcTable::Dump(llvm::raw_ostream
&o
) const {
3684 return DEREF(impl_
.get()).Dump(o
);
3687 // In general C846 prohibits allocatable coarrays to be passed to INTENT(OUT)
3688 // dummy arguments. This rule does not apply to intrinsics in general.
3689 // Some intrinsic explicitly allow coarray allocatable in their description.
3690 // It is assumed that unless explicitly allowed for an intrinsic,
3691 // this is forbidden.
3692 // Since there are very few intrinsic identified that allow this, they are
3693 // listed here instead of adding a field in the table.
3694 bool AcceptsIntentOutAllocatableCoarray(const std::string
&intrinsic
) {
3695 return intrinsic
== "move_alloc";
3697 } // namespace Fortran::evaluate