1//===-- lib/Evaluate/intrinsics.cpp ---------------------------------------===//
2//
3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4// See https://llvm.org/LICENSE.txt for license information.
5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6//
7//===----------------------------------------------------------------------===//
8
9#include "flang/Evaluate/intrinsics.h"
10#include "flang/Common/enum-set.h"
11#include "flang/Common/float128.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 "flang/Support/Fortran.h"
23#include "llvm/Support/raw_ostream.h"
24#include <algorithm>
25#include <cmath>
26#include <map>
27#include <string>
28#include <utility>
29
30using namespace Fortran::parser::literals;
31
32namespace Fortran::evaluate {
33
34class FoldingContext;
35
36// This file defines the supported intrinsic procedures and implements
37// their recognition and validation. It is largely table-driven. See
38// docs/intrinsics.md and section 16 of the Fortran 2018 standard
39// for full details on each of the intrinsics. Be advised, they have
40// complicated details, and the design of these tables has to accommodate
41// that complexity.
42
43// Dummy arguments to generic intrinsic procedures are each specified by
44// their keyword name (rarely used, but always defined), allowable type
45// categories, a kind pattern, a rank pattern, and information about
46// optionality and defaults. The kind and rank patterns are represented
47// here with code values that are significant to the matching/validation engine.
48
49// An actual argument to an intrinsic procedure may be a procedure itself
50// only if the dummy argument is Rank::reduceOperation,
51// KindCode::addressable, or the special case of NULL(MOLD=procedurePointer).
52
53// These are small bit-sets of type category enumerators.
54// Note that typeless (BOZ literal) values don't have a distinct type category.
55// These typeless arguments are represented in the tables as if they were
56// INTEGER with a special "typeless" kind code. Arguments of intrinsic types
57// that can also be typeless values are encoded with an "elementalOrBOZ"
58// rank pattern.
59// Assumed-type (TYPE(*)) dummy arguments can be forwarded along to some
60// intrinsic functions that accept AnyType + Rank::anyOrAssumedRank,
61// AnyType + Rank::arrayOrAssumedRank, or AnyType + Kind::addressable.
62using CategorySet = common::EnumSet<TypeCategory, 8>;
63static constexpr CategorySet IntType{TypeCategory::Integer};
64static constexpr CategorySet UnsignedType{TypeCategory::Unsigned};
65static constexpr CategorySet RealType{TypeCategory::Real};
66static constexpr CategorySet ComplexType{TypeCategory::Complex};
67static constexpr CategorySet CharType{TypeCategory::Character};
68static constexpr CategorySet LogicalType{TypeCategory::Logical};
69static constexpr CategorySet IntOrUnsignedType{IntType | UnsignedType};
70static constexpr CategorySet IntOrRealType{IntType | RealType};
71static constexpr CategorySet IntUnsignedOrRealType{
72 IntType | UnsignedType | RealType};
73static constexpr CategorySet IntOrRealOrCharType{IntType | RealType | CharType};
74static constexpr CategorySet IntOrLogicalType{IntType | LogicalType};
75static constexpr CategorySet FloatingType{RealType | ComplexType};
76static constexpr CategorySet NumericType{
77 IntType | UnsignedType | RealType | ComplexType};
78static constexpr CategorySet RelatableType{
79 IntType | UnsignedType | RealType | CharType};
80static constexpr CategorySet DerivedType{TypeCategory::Derived};
81static constexpr CategorySet IntrinsicType{
82 IntType | UnsignedType | RealType | ComplexType | CharType | LogicalType};
83static constexpr CategorySet AnyType{IntrinsicType | DerivedType};
84
85ENUM_CLASS(KindCode, none, defaultIntegerKind,
86 defaultRealKind, // is also the default COMPLEX kind
87 doublePrecision, quadPrecision, defaultCharKind, defaultLogicalKind,
88 greaterOrEqualToKind, // match kind value greater than or equal to a single
89 // explicit kind value
90 any, // matches any kind value; each instance is independent
91 // match any kind, but all "same" kinds must be equal. For characters, also
92 // implies that lengths must be equal.
93 same,
94 // for characters that only require the same kind, not length
95 sameKind,
96 operand, // match any kind, with promotion (non-standard)
97 typeless, // BOZ literals are INTEGER with this kind
98 ieeeFlagType, // IEEE_FLAG_TYPE from ISO_FORTRAN_EXCEPTION
99 ieeeRoundType, // IEEE_ROUND_TYPE from ISO_FORTRAN_ARITHMETIC
100 eventType, // EVENT_TYPE from module ISO_FORTRAN_ENV (for coarrays)
101 teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays)
102 kindArg, // this argument is KIND=
103 effectiveKind, // for function results: "kindArg" value, possibly defaulted
104 dimArg, // this argument is DIM=
105 likeMultiply, // for DOT_PRODUCT and MATMUL
106 subscript, // address-sized integer
107 size, // default KIND= for SIZE(), UBOUND, &c.
108 addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ
109 nullPointerType, // for ASSOCIATED(NULL())
110 exactKind, // a single explicit exactKindValue
111 atomicIntKind, // atomic_int_kind from iso_fortran_env
112 atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind
113 sameAtom, // same type and kind as atom
114)
115
116struct TypePattern {
117 CategorySet categorySet;
118 KindCode kindCode{KindCode::none};
119 int kindValue{0}; // for KindCode::exactKind and greaterOrEqualToKind
120 llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
121};
122
123// Abbreviations for argument and result patterns in the intrinsic prototypes:
124
125// Match specific kinds of intrinsic types
126static constexpr TypePattern DefaultInt{IntType, KindCode::defaultIntegerKind};
127static constexpr TypePattern DefaultReal{RealType, KindCode::defaultRealKind};
128static constexpr TypePattern DefaultComplex{
129 ComplexType, KindCode::defaultRealKind};
130static constexpr TypePattern DefaultChar{CharType, KindCode::defaultCharKind};
131static constexpr TypePattern DefaultLogical{
132 LogicalType, KindCode::defaultLogicalKind};
133static constexpr TypePattern BOZ{IntType, KindCode::typeless};
134static constexpr TypePattern EventType{DerivedType, KindCode::eventType};
135static constexpr TypePattern IeeeFlagType{DerivedType, KindCode::ieeeFlagType};
136static constexpr TypePattern IeeeRoundType{
137 DerivedType, KindCode::ieeeRoundType};
138static constexpr TypePattern TeamType{DerivedType, KindCode::teamType};
139static constexpr TypePattern DoublePrecision{
140 RealType, KindCode::doublePrecision};
141static constexpr TypePattern DoublePrecisionComplex{
142 ComplexType, KindCode::doublePrecision};
143static constexpr TypePattern QuadPrecision{RealType, KindCode::quadPrecision};
144static constexpr TypePattern SubscriptInt{IntType, KindCode::subscript};
145
146// Match any kind of some intrinsic or derived types
147static constexpr TypePattern AnyInt{IntType, KindCode::any};
148static constexpr TypePattern AnyIntOrUnsigned{IntOrUnsignedType, KindCode::any};
149static constexpr TypePattern AnyReal{RealType, KindCode::any};
150static constexpr TypePattern AnyIntOrReal{IntOrRealType, KindCode::any};
151static constexpr TypePattern AnyIntUnsignedOrReal{
152 IntUnsignedOrRealType, KindCode::any};
153static constexpr TypePattern AnyIntOrRealOrChar{
154 IntOrRealOrCharType, KindCode::any};
155static constexpr TypePattern AnyIntOrLogical{IntOrLogicalType, KindCode::any};
156static constexpr TypePattern AnyComplex{ComplexType, KindCode::any};
157static constexpr TypePattern AnyFloating{FloatingType, KindCode::any};
158static constexpr TypePattern AnyNumeric{NumericType, KindCode::any};
159static constexpr TypePattern AnyChar{CharType, KindCode::any};
160static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
161static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
162static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
163static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any};
164static constexpr TypePattern AnyData{AnyType, KindCode::any};
165
166// Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.)
167static constexpr TypePattern Addressable{AnyType, KindCode::addressable};
168
169// Match some kind of some intrinsic type(s); all "Same" values must match,
170// even when not in the same category (e.g., SameComplex and SameReal).
171// Can be used to specify a result so long as at least one argument is
172// a "Same".
173static constexpr TypePattern SameInt{IntType, KindCode::same};
174static constexpr TypePattern SameIntOrUnsigned{
175 IntOrUnsignedType, KindCode::same};
176static constexpr TypePattern SameReal{RealType, KindCode::same};
177static constexpr TypePattern SameIntOrReal{IntOrRealType, KindCode::same};
178static constexpr TypePattern SameIntUnsignedOrReal{
179 IntUnsignedOrRealType, KindCode::same};
180static constexpr TypePattern SameComplex{ComplexType, KindCode::same};
181static constexpr TypePattern SameFloating{FloatingType, KindCode::same};
182static constexpr TypePattern SameNumeric{NumericType, KindCode::same};
183static constexpr TypePattern SameChar{CharType, KindCode::same};
184static constexpr TypePattern SameCharNoLen{CharType, KindCode::sameKind};
185static constexpr TypePattern SameLogical{LogicalType, KindCode::same};
186static constexpr TypePattern SameRelatable{RelatableType, KindCode::same};
187static constexpr TypePattern SameIntrinsic{IntrinsicType, KindCode::same};
188static constexpr TypePattern SameType{AnyType, KindCode::same};
189
190// Match some kind of some INTEGER or REAL type(s); when argument types
191// &/or kinds differ, their values are converted as if they were operands to
192// an intrinsic operation like addition. This is a nonstandard but nearly
193// universal extension feature.
194static constexpr TypePattern OperandInt{IntType, KindCode::operand};
195static constexpr TypePattern OperandReal{RealType, KindCode::operand};
196static constexpr TypePattern OperandIntOrReal{IntOrRealType, KindCode::operand};
197
198static constexpr TypePattern OperandUnsigned{UnsignedType, KindCode::operand};
199
200// For ASSOCIATED, the first argument is a typeless pointer
201static constexpr TypePattern AnyPointer{AnyType, KindCode::nullPointerType};
202
203// For DOT_PRODUCT and MATMUL, the result type depends on the arguments
204static constexpr TypePattern ResultLogical{LogicalType, KindCode::likeMultiply};
205static constexpr TypePattern ResultNumeric{NumericType, KindCode::likeMultiply};
206
207// Result types with known category and KIND=
208static constexpr TypePattern KINDInt{IntType, KindCode::effectiveKind};
209static constexpr TypePattern KINDUnsigned{
210 UnsignedType, KindCode::effectiveKind};
211static constexpr TypePattern KINDReal{RealType, KindCode::effectiveKind};
212static constexpr TypePattern KINDComplex{ComplexType, KindCode::effectiveKind};
213static constexpr TypePattern KINDChar{CharType, KindCode::effectiveKind};
214static constexpr TypePattern KINDLogical{LogicalType, KindCode::effectiveKind};
215
216static constexpr TypePattern AtomicInt{IntType, KindCode::atomicIntKind};
217static constexpr TypePattern AtomicIntOrLogical{
218 IntOrLogicalType, KindCode::atomicIntOrLogicalKind};
219static constexpr TypePattern SameAtom{IntOrLogicalType, KindCode::sameAtom};
220
221// The default rank pattern for dummy arguments and function results is
222// "elemental".
223ENUM_CLASS(Rank,
224 elemental, // scalar, or array that conforms with other array arguments
225 elementalOrBOZ, // elemental, or typeless BOZ literal scalar
226 scalar, vector,
227 shape, // INTEGER vector of known length and no negative element
228 matrix,
229 array, // not scalar, rank is known and greater than zero
230 coarray, // rank is known and can be scalar; has nonzero corank
231 atom, // is scalar and has nonzero corank or is coindexed
232 known, // rank is known and can be scalar
233 anyOrAssumedRank, // any rank, or assumed; assumed-type TYPE(*) allowed
234 arrayOrAssumedRank, // rank >= 1 or assumed; assumed-type TYPE(*) allowed
235 conformable, // scalar, or array of same rank & shape as "array" argument
236 reduceOperation, // a pure function with constraints for REDUCE
237 dimReduced, // scalar if no DIM= argument, else rank(array)-1
238 dimRemovedOrScalar, // rank(array)-1 (less DIM) or scalar
239 scalarIfDim, // scalar if DIM= argument is present, else rank one array
240 locReduced, // vector(1:rank) if no DIM= argument, else rank(array)-1
241 rankPlus1, // rank(known)+1
242 shaped, // rank is length of SHAPE vector
243)
244
245ENUM_CLASS(Optionality, required,
246 optional, // unless DIM= for SIZE(assumedSize)
247 missing, // for DIM= cases like FINDLOC
248 repeats, // for MAX/MIN and their several variants
249)
250
251ENUM_CLASS(ArgFlag, none,
252 canBeNullPointer, // actual argument can be NULL(with or without
253 // MOLD=pointer)
254 canBeMoldNull, // actual argument can be NULL(MOLD=any)
255 canBeNullAllocatable, // actual argument can be NULL(MOLD=allocatable)
256 defaultsToSameKind, // for MatchingDefaultKIND
257 defaultsToSizeKind, // for SizeDefaultKIND
258 defaultsToDefaultForResult, // for DefaultingKIND
259 notAssumedSize,
260 onlyConstantInquiry) // e.g., PRECISION(X)
261
262struct IntrinsicDummyArgument {
263 const char *keyword{nullptr};
264 TypePattern typePattern;
265 Rank rank{Rank::elemental};
266 Optionality optionality{Optionality::required};
267 common::Intent intent{common::Intent::In};
268 common::EnumSet<ArgFlag, 32> flags{};
269 llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
270};
271
272// constexpr abbreviations for popular arguments:
273// DefaultingKIND is a KIND= argument whose default value is the appropriate
274// KIND(0), KIND(0.0), KIND(''), &c. value for the function result.
275static constexpr IntrinsicDummyArgument DefaultingKIND{"kind",
276 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::optional,
277 common::Intent::In, {ArgFlag::defaultsToDefaultForResult}};
278// MatchingDefaultKIND is a KIND= argument whose default value is the
279// kind of any "Same" function argument (viz., the one whose kind pattern is
280// "same").
281static constexpr IntrinsicDummyArgument MatchingDefaultKIND{"kind",
282 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::optional,
283 common::Intent::In, {ArgFlag::defaultsToSameKind}};
284// SizeDefaultKind is a KIND= argument whose default value should be
285// the kind of INTEGER used for address calculations, and can be
286// set so with a compiler flag; but the standard mandates the
287// kind of default INTEGER.
288static constexpr IntrinsicDummyArgument SizeDefaultKIND{"kind",
289 {IntType, KindCode::kindArg}, Rank::scalar, Optionality::optional,
290 common::Intent::In, {ArgFlag::defaultsToSizeKind}};
291static constexpr IntrinsicDummyArgument RequiredDIM{"dim",
292 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::required,
293 common::Intent::In};
294static constexpr IntrinsicDummyArgument OptionalDIM{"dim",
295 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::optional,
296 common::Intent::In};
297static constexpr IntrinsicDummyArgument MissingDIM{"dim",
298 {IntType, KindCode::dimArg}, Rank::scalar, Optionality::missing,
299 common::Intent::In};
300static constexpr IntrinsicDummyArgument OptionalMASK{"mask", AnyLogical,
301 Rank::conformable, Optionality::optional, common::Intent::In};
302static constexpr IntrinsicDummyArgument OptionalTEAM{
303 "team", TeamType, Rank::scalar, Optionality::optional, common::Intent::In};
304
305struct IntrinsicInterface {
306 static constexpr int maxArguments{7}; // if not a MAX/MIN(...)
307 const char *name{nullptr};
308 IntrinsicDummyArgument dummy[maxArguments];
309 TypePattern result;
310 Rank rank{Rank::elemental};
311 IntrinsicClass intrinsicClass{IntrinsicClass::elementalFunction};
312 std::optional<SpecificCall> Match(const CallCharacteristics &,
313 const common::IntrinsicTypeDefaultKinds &, ActualArguments &,
314 FoldingContext &context, const semantics::Scope *builtins) const;
315 int CountArguments() const;
316 llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
317};
318
319int IntrinsicInterface::CountArguments() const {
320 int n{0};
321 while (n < maxArguments && dummy[n].keyword) {
322 ++n;
323 }
324 return n;
325}
326
327// GENERIC INTRINSIC FUNCTION INTERFACES
328// Each entry in this table defines a pattern. Some intrinsic
329// functions have more than one such pattern. Besides the name
330// of the intrinsic function, each pattern has specifications for
331// the dummy arguments and for the result of the function.
332// The dummy argument patterns each have a name (these are from the
333// standard, but rarely appear in actual code), a type and kind
334// pattern, allowable ranks, and optionality indicators.
335// Be advised, the default rank pattern is "elemental".
336static const IntrinsicInterface genericIntrinsicFunction[]{
337 {"abs", {{"a", SameIntOrReal}}, SameIntOrReal},
338 {"abs", {{"a", SameComplex}}, SameReal},
339 {"achar", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar},
340 {"acos", {{"x", SameFloating}}, SameFloating},
341 {"acosd", {{"x", SameFloating}}, SameFloating},
342 {"acosh", {{"x", SameFloating}}, SameFloating},
343 {"adjustl", {{"string", SameChar}}, SameChar},
344 {"adjustr", {{"string", SameChar}}, SameChar},
345 {"aimag", {{"z", SameComplex}}, SameReal},
346 {"aint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
347 {"all", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
348 Rank::dimReduced, IntrinsicClass::transformationalFunction},
349 {"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical,
350 Rank::elemental, IntrinsicClass::inquiryFunction},
351 {"allocated",
352 {{"array", AnyData, Rank::anyOrAssumedRank, Optionality::required,
353 common::Intent::In, {ArgFlag::canBeNullAllocatable}}},
354 DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
355 {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
356 {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
357 Rank::dimReduced, IntrinsicClass::transformationalFunction},
358 {"asin", {{"x", SameFloating}}, SameFloating},
359 {"asind", {{"x", SameFloating}}, SameFloating},
360 {"asinh", {{"x", SameFloating}}, SameFloating},
361 {"associated",
362 {{"pointer", AnyPointer, Rank::anyOrAssumedRank, Optionality::required,
363 common::Intent::In, {ArgFlag::canBeNullPointer}},
364 {"target", Addressable, Rank::anyOrAssumedRank,
365 Optionality::optional, common::Intent::In,
366 {ArgFlag::canBeNullPointer}}},
367 DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
368 {"atan", {{"x", SameFloating}}, SameFloating},
369 {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
370 {"atand", {{"x", SameFloating}}, SameFloating},
371 {"atand", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
372 {"atan2", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
373 {"atan2d", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
374 {"atanpi", {{"x", SameFloating}}, SameFloating},
375 {"atanpi", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
376 {"atan2pi", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
377 {"atanh", {{"x", SameFloating}}, SameFloating},
378 {"bessel_j0", {{"x", SameReal}}, SameReal},
379 {"bessel_j1", {{"x", SameReal}}, SameReal},
380 {"bessel_jn", {{"n", AnyInt}, {"x", SameReal}}, SameReal},
381 {"bessel_jn",
382 {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar},
383 {"x", SameReal, Rank::scalar}},
384 SameReal, Rank::vector, IntrinsicClass::transformationalFunction},
385 {"bessel_y0", {{"x", SameReal}}, SameReal},
386 {"bessel_y1", {{"x", SameReal}}, SameReal},
387 {"bessel_yn", {{"n", AnyInt}, {"x", SameReal}}, SameReal},
388 {"bessel_yn",
389 {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar},
390 {"x", SameReal, Rank::scalar}},
391 SameReal, Rank::vector, IntrinsicClass::transformationalFunction},
392 {"bge",
393 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ},
394 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}},
395 DefaultLogical},
396 {"bgt",
397 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ},
398 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}},
399 DefaultLogical},
400 {"bit_size",
401 {{"i", SameIntOrUnsigned, Rank::anyOrAssumedRank, Optionality::required,
402 common::Intent::In,
403 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
404 SameInt, Rank::scalar, IntrinsicClass::inquiryFunction},
405 {"ble",
406 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ},
407 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}},
408 DefaultLogical},
409 {"blt",
410 {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ},
411 {"j", AnyIntOrUnsigned, Rank::elementalOrBOZ}},
412 DefaultLogical},
413 {"btest", {{"i", AnyIntOrUnsigned, Rank::elementalOrBOZ}, {"pos", AnyInt}},
414 DefaultLogical},
415 {"ceiling", {{"a", AnyReal}, DefaultingKIND}, KINDInt},
416 {"char", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar},
417 {"chdir", {{"name", DefaultChar, Rank::scalar, Optionality::required}},
418 DefaultInt},
419 {"cmplx", {{"x", AnyComplex}, DefaultingKIND}, KINDComplex},
420 {"cmplx",
421 {{"x", AnyIntUnsignedOrReal, Rank::elementalOrBOZ},
422 {"y", AnyIntUnsignedOrReal, Rank::elementalOrBOZ,
423 Optionality::optional},
424 DefaultingKIND},
425 KINDComplex},
426 {"command_argument_count", {}, DefaultInt, Rank::scalar,
427 IntrinsicClass::transformationalFunction},
428 {"conjg", {{"z", SameComplex}}, SameComplex},
429 {"cos", {{"x", SameFloating}}, SameFloating},
430 {"cosd", {{"x", SameFloating}}, SameFloating},
431 {"cosh", {{"x", SameFloating}}, SameFloating},
432 {"coshape", {{"coarray", AnyData, Rank::coarray}, SizeDefaultKIND}, KINDInt,
433 Rank::vector, IntrinsicClass::inquiryFunction},
434 {"count", {{"mask", AnyLogical, Rank::array}, OptionalDIM, DefaultingKIND},
435 KINDInt, Rank::dimReduced, IntrinsicClass::transformationalFunction},
436 {"cshift",
437 {{"array", SameType, Rank::array},
438 {"shift", AnyInt, Rank::dimRemovedOrScalar}, OptionalDIM},
439 SameType, Rank::conformable, IntrinsicClass::transformationalFunction},
440 {"dble", {{"a", AnyNumeric, Rank::elementalOrBOZ}}, DoublePrecision},
441 {"digits",
442 {{"x", AnyIntUnsignedOrReal, Rank::anyOrAssumedRank,
443 Optionality::required, common::Intent::In,
444 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
445 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
446 {"dim", {{"x", OperandIntOrReal}, {"y", OperandIntOrReal}},
447 OperandIntOrReal},
448 {"dot_product",
449 {{"vector_a", AnyLogical, Rank::vector},
450 {"vector_b", AnyLogical, Rank::vector}},
451 ResultLogical, Rank::scalar, IntrinsicClass::transformationalFunction},
452 {"dot_product",
453 {{"vector_a", AnyComplex, Rank::vector},
454 {"vector_b", AnyNumeric, Rank::vector}},
455 ResultNumeric, Rank::scalar, // conjugates vector_a
456 IntrinsicClass::transformationalFunction},
457 {"dot_product",
458 {{"vector_a", AnyIntUnsignedOrReal, Rank::vector},
459 {"vector_b", AnyNumeric, Rank::vector}},
460 ResultNumeric, Rank::scalar, IntrinsicClass::transformationalFunction},
461 {"dprod", {{"x", DefaultReal}, {"y", DefaultReal}}, DoublePrecision},
462 {"dshiftl",
463 {{"i", SameIntOrUnsigned},
464 {"j", SameIntOrUnsigned, Rank::elementalOrBOZ}, {"shift", AnyInt}},
465 SameIntOrUnsigned},
466 {"dshiftl", {{"i", BOZ}, {"j", SameIntOrUnsigned}, {"shift", AnyInt}},
467 SameIntOrUnsigned},
468 {"dshiftr",
469 {{"i", SameIntOrUnsigned},
470 {"j", SameIntOrUnsigned, Rank::elementalOrBOZ}, {"shift", AnyInt}},
471 SameIntOrUnsigned},
472 {"dshiftr", {{"i", BOZ}, {"j", SameIntOrUnsigned}, {"shift", AnyInt}},
473 SameIntOrUnsigned},
474 {"eoshift",
475 {{"array", SameType, Rank::array},
476 {"shift", AnyInt, Rank::dimRemovedOrScalar},
477 // BOUNDARY= is not optional for non-intrinsic types
478 {"boundary", SameType, Rank::dimRemovedOrScalar}, OptionalDIM},
479 SameType, Rank::conformable, IntrinsicClass::transformationalFunction},
480 {"eoshift",
481 {{"array", SameIntrinsic, Rank::array},
482 {"shift", AnyInt, Rank::dimRemovedOrScalar},
483 {"boundary", SameIntrinsic, Rank::dimRemovedOrScalar,
484 Optionality::optional},
485 OptionalDIM},
486 SameIntrinsic, Rank::conformable,
487 IntrinsicClass::transformationalFunction},
488 {"epsilon",
489 {{"x", SameReal, Rank::anyOrAssumedRank, Optionality::required,
490 common::Intent::In,
491 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
492 SameReal, Rank::scalar, IntrinsicClass::inquiryFunction},
493 {"erf", {{"x", SameReal}}, SameReal},
494 {"erfc", {{"x", SameReal}}, SameReal},
495 {"erfc_scaled", {{"x", SameReal}}, SameReal},
496 {"etime",
497 {{"values", TypePattern{RealType, KindCode::exactKind, 4}, Rank::vector,
498 Optionality::required, common::Intent::Out}},
499 TypePattern{RealType, KindCode::exactKind, 4}},
500 {"exp", {{"x", SameFloating}}, SameFloating},
501 {"exp", {{"x", SameFloating}}, SameFloating},
502 {"exponent", {{"x", AnyReal}}, DefaultInt},
503 {"exp", {{"x", SameFloating}}, SameFloating},
504 {"extends_type_of",
505 {{"a", ExtensibleDerived, Rank::anyOrAssumedRank, Optionality::required,
506 common::Intent::In, {ArgFlag::canBeMoldNull}},
507 {"mold", ExtensibleDerived, Rank::anyOrAssumedRank,
508 Optionality::required, common::Intent::In,
509 {ArgFlag::canBeMoldNull}}},
510 DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction},
511 {"failed_images", {OptionalTEAM, SizeDefaultKIND}, KINDInt, Rank::vector,
512 IntrinsicClass::transformationalFunction},
513 {"findloc",
514 {{"array", AnyNumeric, Rank::array},
515 {"value", AnyNumeric, Rank::scalar}, RequiredDIM, OptionalMASK,
516 SizeDefaultKIND,
517 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
518 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
519 {"findloc",
520 {{"array", AnyNumeric, Rank::array},
521 {"value", AnyNumeric, Rank::scalar}, MissingDIM, OptionalMASK,
522 SizeDefaultKIND,
523 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
524 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction},
525 {"findloc",
526 {{"array", SameCharNoLen, Rank::array},
527 {"value", SameCharNoLen, Rank::scalar}, RequiredDIM, OptionalMASK,
528 SizeDefaultKIND,
529 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
530 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
531 {"findloc",
532 {{"array", SameCharNoLen, Rank::array},
533 {"value", SameCharNoLen, Rank::scalar}, MissingDIM, OptionalMASK,
534 SizeDefaultKIND,
535 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
536 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction},
537 {"findloc",
538 {{"array", AnyLogical, Rank::array},
539 {"value", AnyLogical, Rank::scalar}, RequiredDIM, OptionalMASK,
540 SizeDefaultKIND,
541 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
542 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
543 {"findloc",
544 {{"array", AnyLogical, Rank::array},
545 {"value", AnyLogical, Rank::scalar}, MissingDIM, OptionalMASK,
546 SizeDefaultKIND,
547 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
548 KINDInt, Rank::vector, IntrinsicClass::transformationalFunction},
549 {"floor", {{"a", AnyReal}, DefaultingKIND}, KINDInt},
550 {"fraction", {{"x", SameReal}}, SameReal},
551 {"fseek",
552 {{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar},
553 {"whence", AnyInt, Rank::scalar}},
554 DefaultInt, Rank::scalar},
555 {"ftell", {{"unit", AnyInt, Rank::scalar}},
556 TypePattern{IntType, KindCode::exactKind, 8}, Rank::scalar},
557 {"gamma", {{"x", SameReal}}, SameReal},
558 {"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}},
559 TeamType, Rank::scalar, IntrinsicClass::transformationalFunction},
560 {"getcwd",
561 {{"c", DefaultChar, Rank::scalar, Optionality::required,
562 common::Intent::Out}},
563 TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}},
564 {"getgid", {}, DefaultInt},
565 {"getpid", {}, DefaultInt},
566 {"getuid", {}, DefaultInt},
567 {"hostnm",
568 {{"c", DefaultChar, Rank::scalar, Optionality::required,
569 common::Intent::Out}},
570 TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}},
571 {"huge",
572 {{"x", SameIntUnsignedOrReal, Rank::anyOrAssumedRank,
573 Optionality::required, common::Intent::In,
574 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
575 SameIntUnsignedOrReal, Rank::scalar, IntrinsicClass::inquiryFunction},
576 {"hypot", {{"x", OperandReal}, {"y", OperandReal}}, OperandReal},
577 {"iachar", {{"c", AnyChar}, DefaultingKIND}, KINDInt},
578 {"iall",
579 {{"array", SameIntOrUnsigned, Rank::array}, RequiredDIM, OptionalMASK},
580 SameIntOrUnsigned, Rank::dimReduced,
581 IntrinsicClass::transformationalFunction},
582 {"iall",
583 {{"array", SameIntOrUnsigned, Rank::array}, MissingDIM, OptionalMASK},
584 SameIntOrUnsigned, Rank::scalar,
585 IntrinsicClass::transformationalFunction},
586 {"iany",
587 {{"array", SameIntOrUnsigned, Rank::array}, RequiredDIM, OptionalMASK},
588 SameIntOrUnsigned, Rank::dimReduced,
589 IntrinsicClass::transformationalFunction},
590 {"iany",
591 {{"array", SameIntOrUnsigned, Rank::array}, MissingDIM, OptionalMASK},
592 SameIntOrUnsigned, Rank::scalar,
593 IntrinsicClass::transformationalFunction},
594 {"iparity",
595 {{"array", SameIntOrUnsigned, Rank::array}, RequiredDIM, OptionalMASK},
596 SameIntOrUnsigned, Rank::dimReduced,
597 IntrinsicClass::transformationalFunction},
598 {"iparity",
599 {{"array", SameIntOrUnsigned, Rank::array}, MissingDIM, OptionalMASK},
600 SameIntOrUnsigned, Rank::scalar,
601 IntrinsicClass::transformationalFunction},
602 {"iand", {{"i", OperandInt}, {"j", OperandInt, Rank::elementalOrBOZ}},
603 OperandInt},
604 {"iand",
605 {{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}},
606 OperandUnsigned},
607 {"iand", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned},
608 {"ibclr", {{"i", SameIntOrUnsigned}, {"pos", AnyInt}}, SameIntOrUnsigned},
609 {"ibits", {{"i", SameIntOrUnsigned}, {"pos", AnyInt}, {"len", AnyInt}},
610 SameIntOrUnsigned},
611 {"ibset", {{"i", SameIntOrUnsigned}, {"pos", AnyInt}}, SameIntOrUnsigned},
612 {"ichar", {{"c", AnyChar}, DefaultingKIND}, KINDInt},
613 {"ieor", {{"i", OperandInt}, {"j", OperandInt, Rank::elementalOrBOZ}},
614 OperandInt},
615 {"ieor",
616 {{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}},
617 OperandUnsigned},
618 {"ieor", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned},
619 {"image_index",
620 {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector}},
621 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
622 {"image_index",
623 {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector},
624 {"team", TeamType, Rank::scalar}},
625 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
626 {"image_index",
627 {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector},
628 {"team_number", AnyInt, Rank::scalar}},
629 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
630 {"image_status", {{"image", SameInt}, OptionalTEAM}, DefaultInt},
631 {"index",
632 {{"string", SameCharNoLen}, {"substring", SameCharNoLen},
633 {"back", AnyLogical, Rank::elemental, Optionality::optional},
634 DefaultingKIND},
635 KINDInt},
636 {"int", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND}, KINDInt},
637 {"int2", {{"a", AnyNumeric, Rank::elementalOrBOZ}},
638 TypePattern{IntType, KindCode::exactKind, 2}},
639 {"int8", {{"a", AnyNumeric, Rank::elementalOrBOZ}},
640 TypePattern{IntType, KindCode::exactKind, 8}},
641 {"int_ptr_kind", {}, DefaultInt, Rank::scalar},
642 {"ior", {{"i", OperandInt}, {"j", OperandInt, Rank::elementalOrBOZ}},
643 OperandInt},
644 {"ior",
645 {{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}},
646 OperandUnsigned},
647 {"ior", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned},
648 {"ishft", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}}, SameIntOrUnsigned},
649 {"ishftc",
650 {{"i", SameIntOrUnsigned}, {"shift", AnyInt},
651 {"size", AnyInt, Rank::elemental, Optionality::optional}},
652 SameIntOrUnsigned},
653 {"isnan", {{"a", AnyFloating}}, DefaultLogical},
654 {"is_contiguous", {{"array", Addressable, Rank::anyOrAssumedRank}},
655 DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
656 {"is_iostat_end", {{"i", AnyInt}}, DefaultLogical},
657 {"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical},
658 {"izext", {{"i", AnyInt}}, TypePattern{IntType, KindCode::exactKind, 2}},
659 {"jzext", {{"i", AnyInt}}, DefaultInt},
660 {"kind",
661 {{"x", AnyIntrinsic, Rank::anyOrAssumedRank, Optionality::required,
662 common::Intent::In,
663 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
664 DefaultInt, Rank::elemental, IntrinsicClass::inquiryFunction},
665 {"lbound",
666 {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM,
667 SizeDefaultKIND},
668 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction},
669 {"lbound", {{"array", AnyData, Rank::arrayOrAssumedRank}, SizeDefaultKIND},
670 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction},
671 {"lcobound",
672 {{"coarray", AnyData, Rank::coarray}, OptionalDIM, SizeDefaultKIND},
673 KINDInt, Rank::scalarIfDim, IntrinsicClass::inquiryFunction},
674 {"leadz", {{"i", AnyInt}}, DefaultInt},
675 {"len",
676 {{"string", AnyChar, Rank::anyOrAssumedRank, Optionality::required,
677 common::Intent::In, {ArgFlag::canBeMoldNull}},
678 DefaultingKIND},
679 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction},
680 {"len_trim", {{"string", AnyChar}, DefaultingKIND}, KINDInt},
681 {"lge", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
682 DefaultLogical},
683 {"lgt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
684 DefaultLogical},
685 {"lle", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
686 DefaultLogical},
687 {"llt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
688 DefaultLogical},
689 {"lnblnk", {{"string", AnyChar}}, DefaultInt},
690 {"loc", {{"x", Addressable, Rank::anyOrAssumedRank}}, SubscriptInt,
691 Rank::scalar},
692 {"log", {{"x", SameFloating}}, SameFloating},
693 {"log10", {{"x", SameReal}}, SameReal},
694 {"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical},
695 {"log_gamma", {{"x", SameReal}}, SameReal},
696 {"malloc", {{"size", AnyInt}}, SubscriptInt},
697 {"matmul",
698 {{"matrix_a", AnyLogical, Rank::vector},
699 {"matrix_b", AnyLogical, Rank::matrix}},
700 ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction},
701 {"matmul",
702 {{"matrix_a", AnyLogical, Rank::matrix},
703 {"matrix_b", AnyLogical, Rank::vector}},
704 ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction},
705 {"matmul",
706 {{"matrix_a", AnyLogical, Rank::matrix},
707 {"matrix_b", AnyLogical, Rank::matrix}},
708 ResultLogical, Rank::matrix, IntrinsicClass::transformationalFunction},
709 {"matmul",
710 {{"matrix_a", AnyNumeric, Rank::vector},
711 {"matrix_b", AnyNumeric, Rank::matrix}},
712 ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction},
713 {"matmul",
714 {{"matrix_a", AnyNumeric, Rank::matrix},
715 {"matrix_b", AnyNumeric, Rank::vector}},
716 ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction},
717 {"matmul",
718 {{"matrix_a", AnyNumeric, Rank::matrix},
719 {"matrix_b", AnyNumeric, Rank::matrix}},
720 ResultNumeric, Rank::matrix, IntrinsicClass::transformationalFunction},
721 {"maskl", {{"i", AnyInt}, DefaultingKIND}, KINDInt},
722 {"maskr", {{"i", AnyInt}, DefaultingKIND}, KINDInt},
723 {"max",
724 {{"a1", OperandIntOrReal}, {"a2", OperandIntOrReal},
725 {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}},
726 OperandIntOrReal},
727 {"max",
728 {{"a1", OperandUnsigned}, {"a2", OperandUnsigned},
729 {"a3", OperandUnsigned, Rank::elemental, Optionality::repeats}},
730 OperandUnsigned},
731 {"max",
732 {{"a1", SameCharNoLen}, {"a2", SameCharNoLen},
733 {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}},
734 SameCharNoLen},
735 {"maxexponent",
736 {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required,
737 common::Intent::In,
738 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
739 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
740 {"maxloc",
741 {{"array", AnyRelatable, Rank::array}, RequiredDIM, OptionalMASK,
742 SizeDefaultKIND,
743 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
744 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
745 {"maxloc",
746 {{"array", AnyRelatable, Rank::array}, MissingDIM, OptionalMASK,
747 SizeDefaultKIND,
748 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
749 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
750 {"maxval",
751 {{"array", SameRelatable, Rank::array}, RequiredDIM, OptionalMASK},
752 SameRelatable, Rank::dimReduced,
753 IntrinsicClass::transformationalFunction},
754 {"maxval",
755 {{"array", SameRelatable, Rank::array}, MissingDIM, OptionalMASK},
756 SameRelatable, Rank::scalar, IntrinsicClass::transformationalFunction},
757 {"merge",
758 {{"tsource", SameType}, {"fsource", SameType}, {"mask", AnyLogical}},
759 SameType},
760 {"merge_bits",
761 {{"i", SameIntOrUnsigned},
762 {"j", SameIntOrUnsigned, Rank::elementalOrBOZ},
763 {"mask", SameIntOrUnsigned, Rank::elementalOrBOZ}},
764 SameIntOrUnsigned},
765 {"merge_bits",
766 {{"i", BOZ}, {"j", SameIntOrUnsigned},
767 {"mask", SameIntOrUnsigned, Rank::elementalOrBOZ}},
768 SameIntOrUnsigned},
769 {"min",
770 {{"a1", OperandIntOrReal}, {"a2", OperandIntOrReal},
771 {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}},
772 OperandIntOrReal},
773 {"min",
774 {{"a1", OperandUnsigned}, {"a2", OperandUnsigned},
775 {"a3", OperandUnsigned, Rank::elemental, Optionality::repeats}},
776 OperandUnsigned},
777 {"min",
778 {{"a1", SameCharNoLen}, {"a2", SameCharNoLen},
779 {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}},
780 SameCharNoLen},
781 {"minexponent",
782 {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required,
783 common::Intent::In,
784 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
785 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
786 {"minloc",
787 {{"array", AnyRelatable, Rank::array}, RequiredDIM, OptionalMASK,
788 SizeDefaultKIND,
789 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
790 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
791 {"minloc",
792 {{"array", AnyRelatable, Rank::array}, MissingDIM, OptionalMASK,
793 SizeDefaultKIND,
794 {"back", AnyLogical, Rank::scalar, Optionality::optional}},
795 KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction},
796 {"minval",
797 {{"array", SameRelatable, Rank::array}, RequiredDIM, OptionalMASK},
798 SameRelatable, Rank::dimReduced,
799 IntrinsicClass::transformationalFunction},
800 {"minval",
801 {{"array", SameRelatable, Rank::array}, MissingDIM, OptionalMASK},
802 SameRelatable, Rank::scalar, IntrinsicClass::transformationalFunction},
803 {"mod", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}},
804 OperandIntOrReal},
805 {"mod", {{"a", OperandUnsigned}, {"p", OperandUnsigned}}, OperandUnsigned},
806 {"modulo", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}},
807 OperandIntOrReal},
808 {"modulo", {{"a", OperandUnsigned}, {"p", OperandUnsigned}},
809 OperandUnsigned},
810 {"nearest", {{"x", SameReal}, {"s", AnyReal}}, SameReal},
811 {"new_line",
812 {{"a", SameCharNoLen, Rank::anyOrAssumedRank, Optionality::required,
813 common::Intent::In,
814 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
815 SameCharNoLen, Rank::scalar, IntrinsicClass::inquiryFunction},
816 {"nint", {{"a", AnyReal}, DefaultingKIND}, KINDInt},
817 {"norm2", {{"x", SameReal, Rank::array}, RequiredDIM}, SameReal,
818 Rank::dimReduced, IntrinsicClass::transformationalFunction},
819 {"norm2", {{"x", SameReal, Rank::array}, MissingDIM}, SameReal,
820 Rank::scalar, IntrinsicClass::transformationalFunction},
821 {"not", {{"i", SameIntOrUnsigned}}, SameIntOrUnsigned},
822 // NULL() is a special case handled in Probe() below
823 {"num_images", {}, DefaultInt, Rank::scalar,
824 IntrinsicClass::transformationalFunction},
825 {"num_images", {{"team", TeamType, Rank::scalar}}, DefaultInt, Rank::scalar,
826 IntrinsicClass::transformationalFunction},
827 {"num_images", {{"team_number", AnyInt, Rank::scalar}}, DefaultInt,
828 Rank::scalar, IntrinsicClass::transformationalFunction},
829 {"out_of_range",
830 {{"x", AnyIntOrReal}, {"mold", AnyIntOrReal, Rank::scalar}},
831 DefaultLogical},
832 {"out_of_range",
833 {{"x", AnyReal}, {"mold", AnyInt, Rank::scalar},
834 {"round", AnyLogical, Rank::scalar, Optionality::optional}},
835 DefaultLogical},
836 {"out_of_range", {{"x", AnyReal}, {"mold", AnyReal}}, DefaultLogical},
837 {"pack",
838 {{"array", SameType, Rank::array},
839 {"mask", AnyLogical, Rank::conformable},
840 {"vector", SameType, Rank::vector, Optionality::optional}},
841 SameType, Rank::vector, IntrinsicClass::transformationalFunction},
842 {"parity", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
843 Rank::dimReduced, IntrinsicClass::transformationalFunction},
844 {"popcnt", {{"i", AnyInt}}, DefaultInt},
845 {"poppar", {{"i", AnyInt}}, DefaultInt},
846 {"product",
847 {{"array", SameNumeric, Rank::array}, RequiredDIM, OptionalMASK},
848 SameNumeric, Rank::dimReduced,
849 IntrinsicClass::transformationalFunction},
850 {"product", {{"array", SameNumeric, Rank::array}, MissingDIM, OptionalMASK},
851 SameNumeric, Rank::scalar, IntrinsicClass::transformationalFunction},
852 {"precision",
853 {{"x", AnyFloating, Rank::anyOrAssumedRank, Optionality::required,
854 common::Intent::In,
855 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
856 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
857 {"present", {{"a", Addressable, Rank::anyOrAssumedRank}}, DefaultLogical,
858 Rank::scalar, IntrinsicClass::inquiryFunction},
859 {"putenv", {{"str", DefaultChar, Rank::scalar}}, DefaultInt, Rank::scalar,
860 IntrinsicClass::transformationalFunction},
861 {"radix",
862 {{"x", AnyIntOrReal, Rank::anyOrAssumedRank, Optionality::required,
863 common::Intent::In,
864 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
865 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
866 {"range",
867 {{"x", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required,
868 common::Intent::In,
869 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
870 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
871 {"rank",
872 {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required,
873 common::Intent::In,
874 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
875 DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
876 {"real", {{"a", SameComplex, Rank::elemental}},
877 SameReal}, // 16.9.160(4)(ii)
878 {"real", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND},
879 KINDReal},
880 {"reduce",
881 {{"array", SameType, Rank::array},
882 {"operation", SameType, Rank::reduceOperation}, RequiredDIM,
883 OptionalMASK,
884 {"identity", SameType, Rank::scalar, Optionality::optional},
885 {"ordered", AnyLogical, Rank::scalar, Optionality::optional}},
886 SameType, Rank::dimReduced, IntrinsicClass::transformationalFunction},
887 {"reduce",
888 {{"array", SameType, Rank::array},
889 {"operation", SameType, Rank::reduceOperation}, MissingDIM,
890 OptionalMASK,
891 {"identity", SameType, Rank::scalar, Optionality::optional},
892 {"ordered", AnyLogical, Rank::scalar, Optionality::optional}},
893 SameType, Rank::scalar, IntrinsicClass::transformationalFunction},
894 {"rename",
895 {{"path1", DefaultChar, Rank::scalar},
896 {"path2", DefaultChar, Rank::scalar}},
897 DefaultInt, Rank::scalar},
898 {"repeat",
899 {{"string", SameCharNoLen, Rank::scalar},
900 {"ncopies", AnyInt, Rank::scalar}},
901 SameCharNoLen, Rank::scalar, IntrinsicClass::transformationalFunction},
902 {"reshape",
903 {{"source", SameType, Rank::array}, {"shape", AnyInt, Rank::shape},
904 {"pad", SameType, Rank::array, Optionality::optional},
905 {"order", AnyInt, Rank::vector, Optionality::optional}},
906 SameType, Rank::shaped, IntrinsicClass::transformationalFunction},
907 {"rrspacing", {{"x", SameReal}}, SameReal},
908 {"same_type_as",
909 {{"a", ExtensibleDerived, Rank::anyOrAssumedRank, Optionality::required,
910 common::Intent::In, {ArgFlag::canBeMoldNull}},
911 {"b", ExtensibleDerived, Rank::anyOrAssumedRank,
912 Optionality::required, common::Intent::In,
913 {ArgFlag::canBeMoldNull}}},
914 DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction},
915 {"scale", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, // == IEEE_SCALB()
916 {"scan",
917 {{"string", SameCharNoLen}, {"set", SameCharNoLen},
918 {"back", AnyLogical, Rank::elemental, Optionality::optional},
919 DefaultingKIND},
920 KINDInt},
921 {"second", {}, DefaultReal, Rank::scalar},
922 {"selected_char_kind", {{"name", DefaultChar, Rank::scalar}}, DefaultInt,
923 Rank::scalar, IntrinsicClass::transformationalFunction},
924 {"selected_int_kind", {{"r", AnyInt, Rank::scalar}}, DefaultInt,
925 Rank::scalar, IntrinsicClass::transformationalFunction},
926 {"selected_logical_kind", {{"bits", AnyInt, Rank::scalar}}, DefaultInt,
927 Rank::scalar, IntrinsicClass::transformationalFunction},
928 {"selected_real_kind",
929 {{"p", AnyInt, Rank::scalar},
930 {"r", AnyInt, Rank::scalar, Optionality::optional},
931 {"radix", AnyInt, Rank::scalar, Optionality::optional}},
932 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
933 {"selected_real_kind",
934 {{"p", AnyInt, Rank::scalar, Optionality::optional},
935 {"r", AnyInt, Rank::scalar},
936 {"radix", AnyInt, Rank::scalar, Optionality::optional}},
937 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
938 {"selected_real_kind",
939 {{"p", AnyInt, Rank::scalar, Optionality::optional},
940 {"r", AnyInt, Rank::scalar, Optionality::optional},
941 {"radix", AnyInt, Rank::scalar}},
942 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
943 {"selected_unsigned_kind", {{"r", AnyInt, Rank::scalar}}, DefaultInt,
944 Rank::scalar, IntrinsicClass::transformationalFunction},
945 {"set_exponent", {{"x", SameReal}, {"i", AnyInt}}, SameReal},
946 {"shape", {{"source", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND},
947 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction},
948 {"shifta", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}},
949 SameIntOrUnsigned},
950 {"shiftl", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}},
951 SameIntOrUnsigned},
952 {"shiftr", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}},
953 SameIntOrUnsigned},
954 {"sign", {{"a", SameInt}, {"b", AnyInt}}, SameInt},
955 {"sign", {{"a", SameReal}, {"b", AnyReal}}, SameReal},
956 {"sin", {{"x", SameFloating}}, SameFloating},
957 {"sind", {{"x", SameFloating}}, SameFloating},
958 {"sinh", {{"x", SameFloating}}, SameFloating},
959 {"size",
960 {{"array", AnyData, Rank::arrayOrAssumedRank},
961 OptionalDIM, // unless array is assumed-size
962 SizeDefaultKIND},
963 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction},
964 {"sizeof", {{"x", AnyData, Rank::anyOrAssumedRank}}, SubscriptInt,
965 Rank::scalar, IntrinsicClass::inquiryFunction},
966 {"spacing", {{"x", SameReal}}, SameReal},
967 {"spread",
968 {{"source", SameType, Rank::known, Optionality::required,
969 common::Intent::In, {ArgFlag::notAssumedSize}},
970 RequiredDIM, {"ncopies", AnyInt, Rank::scalar}},
971 SameType, Rank::rankPlus1, IntrinsicClass::transformationalFunction},
972 {"sqrt", {{"x", SameFloating}}, SameFloating},
973 {"stopped_images", {OptionalTEAM, SizeDefaultKIND}, KINDInt, Rank::vector,
974 IntrinsicClass::transformationalFunction},
975 {"storage_size",
976 {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required,
977 common::Intent::In, {ArgFlag::canBeMoldNull}},
978 SizeDefaultKIND},
979 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction},
980 {"sum", {{"array", SameNumeric, Rank::array}, RequiredDIM, OptionalMASK},
981 SameNumeric, Rank::dimReduced,
982 IntrinsicClass::transformationalFunction},
983 {"sum", {{"array", SameNumeric, Rank::array}, MissingDIM, OptionalMASK},
984 SameNumeric, Rank::scalar, IntrinsicClass::transformationalFunction},
985 {"system", {{"command", DefaultChar, Rank::scalar}}, DefaultInt,
986 Rank::scalar},
987 {"tan", {{"x", SameFloating}}, SameFloating},
988 {"tand", {{"x", SameFloating}}, SameFloating},
989 {"tanh", {{"x", SameFloating}}, SameFloating},
990 {"team_number", {OptionalTEAM}, DefaultInt, Rank::scalar,
991 IntrinsicClass::transformationalFunction},
992 {"this_image",
993 {{"coarray", AnyData, Rank::coarray}, RequiredDIM, OptionalTEAM},
994 DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
995 {"this_image", {{"coarray", AnyData, Rank::coarray}, OptionalTEAM},
996 DefaultInt, Rank::vector, IntrinsicClass::transformationalFunction},
997 {"this_image", {OptionalTEAM}, DefaultInt, Rank::scalar,
998 IntrinsicClass::transformationalFunction},
999 {"time", {}, TypePattern{IntType, KindCode::exactKind, 8}, Rank::scalar,
1000 IntrinsicClass::transformationalFunction},
1001 {"tiny",
1002 {{"x", SameReal, Rank::anyOrAssumedRank, Optionality::required,
1003 common::Intent::In,
1004 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1005 SameReal, Rank::scalar, IntrinsicClass::inquiryFunction},
1006 {"trailz", {{"i", AnyInt}}, DefaultInt},
1007 {"transfer",
1008 {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::scalar}},
1009 SameType, Rank::scalar, IntrinsicClass::transformationalFunction},
1010 {"transfer",
1011 {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::array}},
1012 SameType, Rank::vector, IntrinsicClass::transformationalFunction},
1013 {"transfer",
1014 {{"source", AnyData, Rank::anyOrAssumedRank},
1015 {"mold", SameType, Rank::anyOrAssumedRank},
1016 {"size", AnyInt, Rank::scalar}},
1017 SameType, Rank::vector, IntrinsicClass::transformationalFunction},
1018 // TRANSFER(BOZ, MOLD=integer or real scalar) extension
1019 {"transfer",
1020 {{"source", AnyNumeric, Rank::elementalOrBOZ},
1021 {"mold", SameInt, Rank::scalar}},
1022 SameInt, Rank::scalar, IntrinsicClass::transformationalFunction},
1023 {"transfer",
1024 {{"source", AnyNumeric, Rank::elementalOrBOZ},
1025 {"mold", SameReal, Rank::scalar}},
1026 SameReal, Rank::scalar, IntrinsicClass::transformationalFunction},
1027 {"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix,
1028 IntrinsicClass::transformationalFunction},
1029 {"trim", {{"string", SameCharNoLen, Rank::scalar}}, SameCharNoLen,
1030 Rank::scalar, IntrinsicClass::transformationalFunction},
1031 {"ubound",
1032 {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM,
1033 SizeDefaultKIND},
1034 KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction},
1035 {"ubound", {{"array", AnyData, Rank::arrayOrAssumedRank}, SizeDefaultKIND},
1036 KINDInt, Rank::vector, IntrinsicClass::inquiryFunction},
1037 {"ucobound",
1038 {{"coarray", AnyData, Rank::coarray}, OptionalDIM, SizeDefaultKIND},
1039 KINDInt, Rank::scalarIfDim, IntrinsicClass::inquiryFunction},
1040 {"uint", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND},
1041 KINDUnsigned},
1042 {"umaskl", {{"i", AnyInt}, DefaultingKIND}, KINDUnsigned},
1043 {"umaskr", {{"i", AnyInt}, DefaultingKIND}, KINDUnsigned},
1044 {"unlink", {{"path", DefaultChar, Rank::scalar}}, DefaultInt, Rank::scalar,
1045 IntrinsicClass::transformationalFunction},
1046 {"unpack",
1047 {{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array},
1048 {"field", SameType, Rank::conformable}},
1049 SameType, Rank::conformable, IntrinsicClass::transformationalFunction},
1050 {"verify",
1051 {{"string", SameCharNoLen}, {"set", SameCharNoLen},
1052 {"back", AnyLogical, Rank::elemental, Optionality::optional},
1053 DefaultingKIND},
1054 KINDInt},
1055 {"__builtin_compiler_options", {}, DefaultChar},
1056 {"__builtin_compiler_version", {}, DefaultChar},
1057 {"__builtin_fma", {{"f1", SameReal}, {"f2", SameReal}, {"f3", SameReal}},
1058 SameReal},
1059 {"__builtin_ieee_int",
1060 {{"a", AnyFloating}, {"round", IeeeRoundType}, DefaultingKIND},
1061 KINDInt},
1062 {"__builtin_ieee_is_nan", {{"a", AnyFloating}}, DefaultLogical},
1063 {"__builtin_ieee_is_negative", {{"a", AnyFloating}}, DefaultLogical},
1064 {"__builtin_ieee_is_normal", {{"a", AnyFloating}}, DefaultLogical},
1065 {"__builtin_ieee_next_after", {{"x", SameReal}, {"y", AnyReal}}, SameReal},
1066 {"__builtin_ieee_next_down", {{"x", SameReal}}, SameReal},
1067 {"__builtin_ieee_next_up", {{"x", SameReal}}, SameReal},
1068 {"__builtin_ieee_real", {{"a", AnyIntOrReal}, DefaultingKIND}, KINDReal},
1069 {"__builtin_ieee_support_datatype",
1070 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1071 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1072 DefaultLogical},
1073 {"__builtin_ieee_support_denormal",
1074 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1075 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1076 DefaultLogical},
1077 {"__builtin_ieee_support_divide",
1078 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1079 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1080 DefaultLogical},
1081 {"__builtin_ieee_support_flag",
1082 {{"flag", IeeeFlagType, Rank::scalar},
1083 {"x", AnyReal, Rank::known, Optionality::optional,
1084 common::Intent::In,
1085 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1086 DefaultLogical},
1087 {"__builtin_ieee_support_halting", {{"flag", IeeeFlagType, Rank::scalar}},
1088 DefaultLogical},
1089 {"__builtin_ieee_support_inf",
1090 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1091 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1092 DefaultLogical},
1093 {"__builtin_ieee_support_io",
1094 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1095 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1096 DefaultLogical},
1097 {"__builtin_ieee_support_nan",
1098 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1099 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1100 DefaultLogical},
1101 {"__builtin_ieee_support_rounding",
1102 {{"round_value", IeeeRoundType, Rank::scalar},
1103 {"x", AnyReal, Rank::known, Optionality::optional,
1104 common::Intent::In,
1105 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1106 DefaultLogical},
1107 {"__builtin_ieee_support_sqrt",
1108 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1109 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1110 DefaultLogical},
1111 {"__builtin_ieee_support_standard",
1112 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1113 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1114 DefaultLogical},
1115 {"__builtin_ieee_support_subnormal",
1116 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1117 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1118 DefaultLogical},
1119 {"__builtin_ieee_support_underflow_control",
1120 {{"x", AnyReal, Rank::known, Optionality::optional, common::Intent::In,
1121 {ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
1122 DefaultLogical},
1123 {"__builtin_numeric_storage_size", {}, DefaultInt},
1124};
1125
1126// TODO: Non-standard intrinsic functions
1127// SHIFT,
1128// COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT,
1129// QCMPLX, QEXT, QFLOAT, QREAL, DNUM,
1130// INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN,
1131// MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR
1132// IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE,
1133// EOF, FP_CLASS, INT_PTR_KIND, MALLOC
1134// probably more (these are PGI + Intel, possibly incomplete)
1135// TODO: Optionally warn on use of non-standard intrinsics:
1136// LOC, probably others
1137// TODO: Optionally warn on operand promotion extension
1138
1139// Aliases for a few generic procedures for legacy compatibility and builtins.
1140static const std::pair<const char *, const char *> genericAlias[]{
1141 {"and", "iand"},
1142 {"getenv", "get_environment_variable"},
1143 {"fseek64", "fseek"},
1144 {"fseeko64", "fseek"}, // SUN
1145 {"fseeki8", "fseek"}, // Intel
1146 {"ftell64", "ftell"},
1147 {"ftello64", "ftell"}, // SUN
1148 {"ftelli8", "ftell"}, // Intel
1149 {"imag", "aimag"},
1150 {"lshift", "shiftl"},
1151 {"or", "ior"},
1152 {"rshift", "shifta"},
1153 {"unsigned", "uint"}, // Sun vs gfortran names
1154 {"xor", "ieor"},
1155 {"__builtin_ieee_selected_real_kind", "selected_real_kind"},
1156};
1157
1158// The following table contains the intrinsic functions listed in
1159// Tables 16.2 and 16.3 in Fortran 2018. The "unrestricted" functions
1160// in Table 16.2 can be used as actual arguments, PROCEDURE() interfaces,
1161// and procedure pointer targets.
1162// Note that the restricted conversion functions dcmplx, dreal, float, idint,
1163// ifix, and sngl are extended to accept any argument kind because this is a
1164// common Fortran compilers behavior, and as far as we can tell, is safe and
1165// useful.
1166struct SpecificIntrinsicInterface : public IntrinsicInterface {
1167 const char *generic{nullptr};
1168 bool isRestrictedSpecific{false};
1169 // Exact actual/dummy type matching is required by default for specific
1170 // intrinsics. If useGenericAndForceResultType is set, then the probing will
1171 // also attempt to use the related generic intrinsic and to convert the result
1172 // to the specific intrinsic result type if needed. This also prevents
1173 // using the generic name so that folding can insert the conversion on the
1174 // result and not the arguments.
1175 //
1176 // This is not enabled on all specific intrinsics because an alternative
1177 // is to convert the actual arguments to the required dummy types and this is
1178 // not numerically equivalent.
1179 // e.g. IABS(INT(i, 4)) not equiv to INT(ABS(i), 4).
1180 // This is allowed for restricted min/max specific functions because
1181 // the expected behavior is clear from their definitions. A warning is though
1182 // always emitted because other compilers' behavior is not ubiquitous here and
1183 // the results in case of conversion overflow might not be equivalent.
1184 // e.g for MIN0: INT(MIN(2147483647_8, 2*2147483647_8), 4) = 2147483647_4
1185 // but: MIN(INT(2147483647_8, 4), INT(2*2147483647_8, 4)) = -2_4
1186 // xlf and ifort return the first, and pgfortran the later. f18 will return
1187 // the first because this matches more closely the MIN0 definition in
1188 // Fortran 2018 table 16.3 (although it is still an extension to allow
1189 // non default integer argument in MIN0).
1190 bool useGenericAndForceResultType{false};
1191};
1192
1193static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
1194 {{"abs", {{"a", DefaultReal}}, DefaultReal}},
1195 {{"acos", {{"x", DefaultReal}}, DefaultReal}},
1196 {{"aimag", {{"z", DefaultComplex}}, DefaultReal}},
1197 {{"aint", {{"a", DefaultReal}}, DefaultReal}},
1198 {{"alog", {{"x", DefaultReal}}, DefaultReal}, "log"},
1199 {{"alog10", {{"x", DefaultReal}}, DefaultReal}, "log10"},
1200 {{"amax0",
1201 {{"a1", DefaultInt}, {"a2", DefaultInt},
1202 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}},
1203 DefaultReal},
1204 "max", true, true},
1205 {{"amax1",
1206 {{"a1", DefaultReal}, {"a2", DefaultReal},
1207 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}},
1208 DefaultReal},
1209 "max", true, true},
1210 {{"amin0",
1211 {{"a1", DefaultInt}, {"a2", DefaultInt},
1212 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}},
1213 DefaultReal},
1214 "min", true, true},
1215 {{"amin1",
1216 {{"a1", DefaultReal}, {"a2", DefaultReal},
1217 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}},
1218 DefaultReal},
1219 "min", true, true},
1220 {{"amod", {{"a", DefaultReal}, {"p", DefaultReal}}, DefaultReal}, "mod"},
1221 {{"anint", {{"a", DefaultReal}}, DefaultReal}},
1222 {{"asin", {{"x", DefaultReal}}, DefaultReal}},
1223 {{"atan", {{"x", DefaultReal}}, DefaultReal}},
1224 {{"atan2", {{"y", DefaultReal}, {"x", DefaultReal}}, DefaultReal}},
1225 {{"babs", {{"a", TypePattern{IntType, KindCode::exactKind, 1}}},
1226 TypePattern{IntType, KindCode::exactKind, 1}},
1227 "abs"},
1228 {{"cabs", {{"a", DefaultComplex}}, DefaultReal}, "abs"},
1229 {{"ccos", {{"x", DefaultComplex}}, DefaultComplex}, "cos"},
1230 {{"cdabs", {{"a", DoublePrecisionComplex}}, DoublePrecision}, "abs"},
1231 {{"cdcos", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "cos"},
1232 {{"cdexp", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "exp"},
1233 {{"cdlog", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "log"},
1234 {{"cdsin", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex}, "sin"},
1235 {{"cdsqrt", {{"x", DoublePrecisionComplex}}, DoublePrecisionComplex},
1236 "sqrt"},
1237 {{"cexp", {{"x", DefaultComplex}}, DefaultComplex}, "exp"},
1238 {{"clog", {{"x", DefaultComplex}}, DefaultComplex}, "log"},
1239 {{"conjg", {{"z", DefaultComplex}}, DefaultComplex}},
1240 {{"cos", {{"x", DefaultReal}}, DefaultReal}},
1241 {{"cosh", {{"x", DefaultReal}}, DefaultReal}},
1242 {{"csin", {{"x", DefaultComplex}}, DefaultComplex}, "sin"},
1243 {{"csqrt", {{"x", DefaultComplex}}, DefaultComplex}, "sqrt"},
1244 {{"ctan", {{"x", DefaultComplex}}, DefaultComplex}, "tan"},
1245 {{"dabs", {{"a", DoublePrecision}}, DoublePrecision}, "abs"},
1246 {{"dacos", {{"x", DoublePrecision}}, DoublePrecision}, "acos"},
1247 {{"dasin", {{"x", DoublePrecision}}, DoublePrecision}, "asin"},
1248 {{"datan", {{"x", DoublePrecision}}, DoublePrecision}, "atan"},
1249 {{"datan2", {{"y", DoublePrecision}, {"x", DoublePrecision}},
1250 DoublePrecision},
1251 "atan2"},
1252 {{"dcmplx", {{"x", AnyComplex}}, DoublePrecisionComplex}, "cmplx", true},
1253 {{"dcmplx",
1254 {{"x", AnyIntOrReal, Rank::elementalOrBOZ},
1255 {"y", AnyIntOrReal, Rank::elementalOrBOZ, Optionality::optional}},
1256 DoublePrecisionComplex},
1257 "cmplx", true},
1258 {{"dconjg", {{"z", DoublePrecisionComplex}}, DoublePrecisionComplex},
1259 "conjg"},
1260 {{"dcos", {{"x", DoublePrecision}}, DoublePrecision}, "cos"},
1261 {{"dcosh", {{"x", DoublePrecision}}, DoublePrecision}, "cosh"},
1262 {{"ddim", {{"x", DoublePrecision}, {"y", DoublePrecision}},
1263 DoublePrecision},
1264 "dim"},
1265 {{"derf", {{"x", DoublePrecision}}, DoublePrecision}, "erf"},
1266 {{"derfc", {{"x", DoublePrecision}}, DoublePrecision}, "erfc"},
1267 {{"derfc_scaled", {{"x", DoublePrecision}}, DoublePrecision},
1268 "erfc_scaled"},
1269 {{"dexp", {{"x", DoublePrecision}}, DoublePrecision}, "exp"},
1270 {{"dfloat", {{"a", AnyInt}}, DoublePrecision}, "real", true},
1271 {{"dim", {{"x", DefaultReal}, {"y", DefaultReal}}, DefaultReal}},
1272 {{"dimag", {{"z", DoublePrecisionComplex}}, DoublePrecision}, "aimag"},
1273 {{"dint", {{"a", DoublePrecision}}, DoublePrecision}, "aint"},
1274 {{"dlog", {{"x", DoublePrecision}}, DoublePrecision}, "log"},
1275 {{"dlog10", {{"x", DoublePrecision}}, DoublePrecision}, "log10"},
1276 {{"dmax1",
1277 {{"a1", DoublePrecision}, {"a2", DoublePrecision},
1278 {"a3", DoublePrecision, Rank::elemental, Optionality::repeats}},
1279 DoublePrecision},
1280 "max", true, true},
1281 {{"dmin1",
1282 {{"a1", DoublePrecision}, {"a2", DoublePrecision},
1283 {"a3", DoublePrecision, Rank::elemental, Optionality::repeats}},
1284 DoublePrecision},
1285 "min", true, true},
1286 {{"dmod", {{"a", DoublePrecision}, {"p", DoublePrecision}},
1287 DoublePrecision},
1288 "mod"},
1289 {{"dnint", {{"a", DoublePrecision}}, DoublePrecision}, "anint"},
1290 {{"dprod", {{"x", DefaultReal}, {"y", DefaultReal}}, DoublePrecision}},
1291 {{"dreal", {{"a", AnyComplex}}, DoublePrecision}, "real", true},
1292 {{"dsign", {{"a", DoublePrecision}, {"b", DoublePrecision}},
1293 DoublePrecision},
1294 "sign"},
1295 {{"dsin", {{"x", DoublePrecision}}, DoublePrecision}, "sin"},
1296 {{"dsinh", {{"x", DoublePrecision}}, DoublePrecision}, "sinh"},
1297 {{"dsqrt", {{"x", DoublePrecision}}, DoublePrecision}, "sqrt"},
1298 {{"dtan", {{"x", DoublePrecision}}, DoublePrecision}, "tan"},
1299 {{"dtanh", {{"x", DoublePrecision}}, DoublePrecision}, "tanh"},
1300 {{"exp", {{"x", DefaultReal}}, DefaultReal}},
1301 {{"float", {{"a", AnyInt}}, DefaultReal}, "real", true},
1302 {{"iabs", {{"a", DefaultInt}}, DefaultInt}, "abs"},
1303 {{"idim", {{"x", DefaultInt}, {"y", DefaultInt}}, DefaultInt}, "dim"},
1304 {{"idint", {{"a", AnyReal}}, DefaultInt}, "int", true},
1305 {{"idnint", {{"a", DoublePrecision}}, DefaultInt}, "nint"},
1306 {{"ifix", {{"a", AnyReal}}, DefaultInt}, "int", true},
1307 {{"iiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 2}}},
1308 TypePattern{IntType, KindCode::exactKind, 2}},
1309 "abs"},
1310 // The definition of the unrestricted specific intrinsic function INDEX
1311 // in F'77 and F'90 has only two arguments; later standards omit the
1312 // argument information for all unrestricted specific intrinsic
1313 // procedures. No compiler supports an implementation that allows
1314 // INDEX with BACK= to work when associated as an actual procedure or
1315 // procedure pointer target.
1316 {{"index", {{"string", DefaultChar}, {"substring", DefaultChar}},
1317 DefaultInt}},
1318 {{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"},
1319 {{"jiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 4}}},
1320 TypePattern{IntType, KindCode::exactKind, 4}},
1321 "abs"},
1322 {{"kiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 8}}},
1323 TypePattern{IntType, KindCode::exactKind, 8}},
1324 "abs"},
1325 {{"kidnnt", {{"a", DoublePrecision}},
1326 TypePattern{IntType, KindCode::exactKind, 8}},
1327 "nint"},
1328 {{"knint", {{"a", DefaultReal}},
1329 TypePattern{IntType, KindCode::exactKind, 8}},
1330 "nint"},
1331 {{"len", {{"string", DefaultChar, Rank::anyOrAssumedRank}}, DefaultInt,
1332 Rank::scalar, IntrinsicClass::inquiryFunction}},
1333 {{"lge", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
1334 DefaultLogical},
1335 "lge", true},
1336 {{"lgt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
1337 DefaultLogical},
1338 "lgt", true},
1339 {{"lle", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
1340 DefaultLogical},
1341 "lle", true},
1342 {{"llt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
1343 DefaultLogical},
1344 "llt", true},
1345 {{"log", {{"x", DefaultReal}}, DefaultReal}},
1346 {{"log10", {{"x", DefaultReal}}, DefaultReal}},
1347 {{"max0",
1348 {{"a1", DefaultInt}, {"a2", DefaultInt},
1349 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}},
1350 DefaultInt},
1351 "max", true, true},
1352 {{"max1",
1353 {{"a1", DefaultReal}, {"a2", DefaultReal},
1354 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}},
1355 DefaultInt},
1356 "max", true, true},
1357 {{"min0",
1358 {{"a1", DefaultInt}, {"a2", DefaultInt},
1359 {"a3", DefaultInt, Rank::elemental, Optionality::repeats}},
1360 DefaultInt},
1361 "min", true, true},
1362 {{"min1",
1363 {{"a1", DefaultReal}, {"a2", DefaultReal},
1364 {"a3", DefaultReal, Rank::elemental, Optionality::repeats}},
1365 DefaultInt},
1366 "min", true, true},
1367 {{"mod", {{"a", DefaultInt}, {"p", DefaultInt}}, DefaultInt}},
1368 {{"nint", {{"a", DefaultReal}}, DefaultInt}},
1369 {{"qerf", {{"x", QuadPrecision}}, QuadPrecision}, "erf"},
1370 {{"qerfc", {{"x", QuadPrecision}}, QuadPrecision}, "erfc"},
1371 {{"qerfc_scaled", {{"x", QuadPrecision}}, QuadPrecision}, "erfc_scaled"},
1372 {{"sign", {{"a", DefaultReal}, {"b", DefaultReal}}, DefaultReal}},
1373 {{"sin", {{"x", DefaultReal}}, DefaultReal}},
1374 {{"sinh", {{"x", DefaultReal}}, DefaultReal}},
1375 {{"sngl", {{"a", AnyReal}}, DefaultReal}, "real", true},
1376 {{"sqrt", {{"x", DefaultReal}}, DefaultReal}},
1377 {{"tan", {{"x", DefaultReal}}, DefaultReal}},
1378 {{"tanh", {{"x", DefaultReal}}, DefaultReal}},
1379 {{"zabs", {{"a", TypePattern{ComplexType, KindCode::exactKind, 8}}},
1380 TypePattern{RealType, KindCode::exactKind, 8}},
1381 "abs"},
1382};
1383
1384// Must be sorted by name. The rank of the return value is ignored since
1385// subroutines are do not have a return value.
1386static const IntrinsicInterface intrinsicSubroutine[]{
1387 {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1388 {"atomic_add",
1389 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1390 common::Intent::InOut},
1391 {"value", AnyInt, Rank::scalar, Optionality::required,
1392 common::Intent::In},
1393 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1394 common::Intent::Out}},
1395 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1396 {"atomic_and",
1397 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1398 common::Intent::InOut},
1399 {"value", AnyInt, Rank::scalar, Optionality::required,
1400 common::Intent::In},
1401 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1402 common::Intent::Out}},
1403 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1404 {"atomic_cas",
1405 {{"atom", SameAtom, Rank::atom, Optionality::required,
1406 common::Intent::InOut},
1407 {"old", SameAtom, Rank::scalar, Optionality::required,
1408 common::Intent::Out},
1409 {"compare", SameAtom, Rank::scalar, Optionality::required,
1410 common::Intent::In},
1411 {"new", SameAtom, Rank::scalar, Optionality::required,
1412 common::Intent::In},
1413 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1414 common::Intent::Out}},
1415 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1416 {"atomic_define",
1417 {{"atom", AtomicIntOrLogical, Rank::atom, Optionality::required,
1418 common::Intent::Out},
1419 {"value", AnyIntOrLogical, Rank::scalar, Optionality::required,
1420 common::Intent::In},
1421 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1422 common::Intent::Out}},
1423 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1424 {"atomic_fetch_add",
1425 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1426 common::Intent::InOut},
1427 {"value", AnyInt, Rank::scalar, Optionality::required,
1428 common::Intent::In},
1429 {"old", AtomicInt, Rank::scalar, Optionality::required,
1430 common::Intent::Out},
1431 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1432 common::Intent::Out}},
1433 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1434 {"atomic_fetch_and",
1435 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1436 common::Intent::InOut},
1437 {"value", AnyInt, Rank::scalar, Optionality::required,
1438 common::Intent::In},
1439 {"old", AtomicInt, Rank::scalar, Optionality::required,
1440 common::Intent::Out},
1441 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1442 common::Intent::Out}},
1443 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1444 {"atomic_fetch_or",
1445 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1446 common::Intent::InOut},
1447 {"value", AnyInt, Rank::scalar, Optionality::required,
1448 common::Intent::In},
1449 {"old", AtomicInt, Rank::scalar, Optionality::required,
1450 common::Intent::Out},
1451 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1452 common::Intent::Out}},
1453 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1454 {"atomic_fetch_xor",
1455 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1456 common::Intent::InOut},
1457 {"value", AnyInt, Rank::scalar, Optionality::required,
1458 common::Intent::In},
1459 {"old", AtomicInt, Rank::scalar, Optionality::required,
1460 common::Intent::Out},
1461 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1462 common::Intent::Out}},
1463 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1464 {"atomic_or",
1465 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1466 common::Intent::InOut},
1467 {"value", AnyInt, Rank::scalar, Optionality::required,
1468 common::Intent::In},
1469 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1470 common::Intent::Out}},
1471 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1472 {"atomic_ref",
1473 {{"value", AnyIntOrLogical, Rank::scalar, Optionality::required,
1474 common::Intent::Out},
1475 {"atom", AtomicIntOrLogical, Rank::atom, Optionality::required,
1476 common::Intent::In},
1477 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1478 common::Intent::Out}},
1479 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1480 {"atomic_xor",
1481 {{"atom", AtomicInt, Rank::atom, Optionality::required,
1482 common::Intent::InOut},
1483 {"value", AnyInt, Rank::scalar, Optionality::required,
1484 common::Intent::In},
1485 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1486 common::Intent::Out}},
1487 {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
1488 {"chdir",
1489 {{"name", DefaultChar, Rank::scalar, Optionality::required},
1490 {"status", AnyInt, Rank::scalar, Optionality::optional,
1491 common::Intent::Out}},
1492 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1493 {"co_broadcast",
1494 {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required,
1495 common::Intent::InOut},
1496 {"source_image", AnyInt, Rank::scalar, Optionality::required,
1497 common::Intent::In},
1498 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1499 common::Intent::Out},
1500 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1501 common::Intent::InOut}},
1502 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
1503 {"co_max",
1504 {{"a", AnyIntOrRealOrChar, Rank::anyOrAssumedRank,
1505 Optionality::required, common::Intent::InOut},
1506 {"result_image", AnyInt, Rank::scalar, Optionality::optional,
1507 common::Intent::In},
1508 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1509 common::Intent::Out},
1510 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1511 common::Intent::InOut}},
1512 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
1513 {"co_min",
1514 {{"a", AnyIntOrRealOrChar, Rank::anyOrAssumedRank,
1515 Optionality::required, common::Intent::InOut},
1516 {"result_image", AnyInt, Rank::scalar, Optionality::optional,
1517 common::Intent::In},
1518 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1519 common::Intent::Out},
1520 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1521 common::Intent::InOut}},
1522 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
1523 {"co_reduce",
1524 {{"a", AnyData, Rank::known, Optionality::required,
1525 common::Intent::InOut},
1526 {"operation", SameType, Rank::reduceOperation},
1527 {"result_image", AnyInt, Rank::scalar, Optionality::optional,
1528 common::Intent::In},
1529 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1530 common::Intent::Out},
1531 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1532 common::Intent::InOut}},
1533 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
1534 {"co_sum",
1535 {{"a", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required,
1536 common::Intent::InOut},
1537 {"result_image", AnyInt, Rank::scalar, Optionality::optional,
1538 common::Intent::In},
1539 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1540 common::Intent::Out},
1541 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1542 common::Intent::InOut}},
1543 {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
1544 {"cpu_time",
1545 {{"time", AnyReal, Rank::scalar, Optionality::required,
1546 common::Intent::Out}},
1547 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1548 {"date_and_time",
1549 {{"date", DefaultChar, Rank::scalar, Optionality::optional,
1550 common::Intent::Out},
1551 {"time", DefaultChar, Rank::scalar, Optionality::optional,
1552 common::Intent::Out},
1553 {"zone", DefaultChar, Rank::scalar, Optionality::optional,
1554 common::Intent::Out},
1555 {"values", AnyInt, Rank::vector, Optionality::optional,
1556 common::Intent::Out}},
1557 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1558 {"etime",
1559 {{"values", TypePattern{RealType, KindCode::exactKind, 4}, Rank::vector,
1560 Optionality::required, common::Intent::Out},
1561 {"time", TypePattern{RealType, KindCode::exactKind, 4},
1562 Rank::scalar, Optionality::required, common::Intent::Out}},
1563 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1564 {"event_query",
1565 {{"event", EventType, Rank::scalar},
1566 {"count", AnyInt, Rank::scalar, Optionality::required,
1567 common::Intent::Out},
1568 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1569 common::Intent::Out}},
1570 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1571 {"execute_command_line",
1572 {{"command", DefaultChar, Rank::scalar},
1573 {"wait", AnyLogical, Rank::scalar, Optionality::optional},
1574 {"exitstat",
1575 TypePattern{IntType, KindCode::greaterOrEqualToKind, 4},
1576 Rank::scalar, Optionality::optional, common::Intent::InOut},
1577 {"cmdstat", TypePattern{IntType, KindCode::greaterOrEqualToKind, 2},
1578 Rank::scalar, Optionality::optional, common::Intent::Out},
1579 {"cmdmsg", DefaultChar, Rank::scalar, Optionality::optional,
1580 common::Intent::InOut}},
1581 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1582 {"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {},
1583 Rank::elemental, IntrinsicClass::impureSubroutine},
1584 {"free", {{"ptr", Addressable}}, {}},
1585 {"fseek",
1586 {{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar},
1587 {"whence", AnyInt, Rank::scalar},
1588 {"status", AnyInt, Rank::scalar, Optionality::optional,
1589 common::Intent::InOut}},
1590 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1591 {"ftell",
1592 {{"unit", AnyInt, Rank::scalar},
1593 {"offset", AnyInt, Rank::scalar, Optionality::required,
1594 common::Intent::Out}},
1595 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1596 {"get_command",
1597 {{"command", DefaultChar, Rank::scalar, Optionality::optional,
1598 common::Intent::Out},
1599 {"length", TypePattern{IntType, KindCode::greaterOrEqualToKind, 2},
1600 Rank::scalar, Optionality::optional, common::Intent::Out},
1601 {"status", AnyInt, Rank::scalar, Optionality::optional,
1602 common::Intent::Out},
1603 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1604 common::Intent::InOut}},
1605 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1606 {"get_command_argument",
1607 {{"number", AnyInt, Rank::scalar},
1608 {"value", DefaultChar, Rank::scalar, Optionality::optional,
1609 common::Intent::Out},
1610 {"length", TypePattern{IntType, KindCode::greaterOrEqualToKind, 2},
1611 Rank::scalar, Optionality::optional, common::Intent::Out},
1612 {"status", AnyInt, Rank::scalar, Optionality::optional,
1613 common::Intent::Out},
1614 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1615 common::Intent::InOut}},
1616 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1617 {"get_environment_variable",
1618 {{"name", DefaultChar, Rank::scalar},
1619 {"value", DefaultChar, Rank::scalar, Optionality::optional,
1620 common::Intent::Out},
1621 {"length", AnyInt, Rank::scalar, Optionality::optional,
1622 common::Intent::Out},
1623 {"status", AnyInt, Rank::scalar, Optionality::optional,
1624 common::Intent::Out},
1625 {"trim_name", AnyLogical, Rank::scalar, Optionality::optional},
1626 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1627 common::Intent::InOut}},
1628 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1629 {"getcwd",
1630 {{"c", DefaultChar, Rank::scalar, Optionality::required,
1631 common::Intent::Out},
1632 {"status", TypePattern{IntType, KindCode::greaterOrEqualToKind, 4},
1633 Rank::scalar, Optionality::optional, common::Intent::Out}},
1634 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1635 {"hostnm",
1636 {{"c", DefaultChar, Rank::scalar, Optionality::required,
1637 common::Intent::Out},
1638 {"status", TypePattern{IntType, KindCode::greaterOrEqualToKind, 4},
1639 Rank::scalar, Optionality::optional, common::Intent::Out}},
1640 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1641 {"move_alloc",
1642 {{"from", SameType, Rank::known, Optionality::required,
1643 common::Intent::InOut},
1644 {"to", SameType, Rank::known, Optionality::required,
1645 common::Intent::Out},
1646 {"stat", AnyInt, Rank::scalar, Optionality::optional,
1647 common::Intent::Out},
1648 {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
1649 common::Intent::InOut}},
1650 {}, Rank::elemental, IntrinsicClass::pureSubroutine},
1651 {"perror", {{"string", DefaultChar, Rank::scalar}}, {}, Rank::elemental,
1652 IntrinsicClass::impureSubroutine},
1653 {"putenv",
1654 {{"str", DefaultChar, Rank::scalar, Optionality::required,
1655 common::Intent::In},
1656 {"status", DefaultInt, Rank::scalar, Optionality::optional,
1657 common::Intent::Out}},
1658 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1659 {"mvbits",
1660 {{"from", SameIntOrUnsigned}, {"frompos", AnyInt}, {"len", AnyInt},
1661 {"to", SameIntOrUnsigned, Rank::elemental, Optionality::required,
1662 common::Intent::Out},
1663 {"topos", AnyInt}},
1664 {}, Rank::elemental, IntrinsicClass::elementalSubroutine}, // elemental
1665 {"random_init",
1666 {{"repeatable", AnyLogical, Rank::scalar},
1667 {"image_distinct", AnyLogical, Rank::scalar}},
1668 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1669 {"random_number",
1670 {{"harvest", {RealType | UnsignedType, KindCode::any}, Rank::known,
1671 Optionality::required, common::Intent::Out,
1672 {ArgFlag::notAssumedSize}}},
1673 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1674 {"random_seed",
1675 {{"size", DefaultInt, Rank::scalar, Optionality::optional,
1676 common::Intent::Out},
1677 {"put", DefaultInt, Rank::vector, Optionality::optional},
1678 {"get", DefaultInt, Rank::vector, Optionality::optional,
1679 common::Intent::Out}},
1680 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1681 {"rename",
1682 {{"path1", DefaultChar, Rank::scalar},
1683 {"path2", DefaultChar, Rank::scalar},
1684 {"status", DefaultInt, Rank::scalar, Optionality::optional,
1685 common::Intent::Out}},
1686 {}, Rank::scalar, IntrinsicClass::impureSubroutine},
1687 {"second", {{"time", DefaultReal, Rank::scalar}}, {}, Rank::scalar,
1688 IntrinsicClass::impureSubroutine},
1689 {"system",
1690 {{"command", DefaultChar, Rank::scalar},
1691 {"exitstat", DefaultInt, Rank::scalar, Optionality::optional,
1692 common::Intent::Out}},
1693 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1694 {"system_clock",
1695 {{"count", AnyInt, Rank::scalar, Optionality::optional,
1696 common::Intent::Out},
1697 {"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional,
1698 common::Intent::Out},
1699 {"count_max", AnyInt, Rank::scalar, Optionality::optional,
1700 common::Intent::Out}},
1701 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1702 {"signal",
1703 {{"number", AnyInt, Rank::scalar, Optionality::required,
1704 common::Intent::In},
1705 // note: any pointer also accepts AnyInt
1706 {"handler", AnyPointer, Rank::scalar, Optionality::required,
1707 common::Intent::In},
1708 {"status", AnyInt, Rank::scalar, Optionality::optional,
1709 common::Intent::Out}},
1710 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1711 {"sleep",
1712 {{"seconds", AnyInt, Rank::scalar, Optionality::required,
1713 common::Intent::In}},
1714 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1715 {"unlink",
1716 {{"path", DefaultChar, Rank::scalar, Optionality::required,
1717 common::Intent::In},
1718 {"status", DefaultInt, Rank::scalar, Optionality::optional,
1719 common::Intent::Out}},
1720 {}, Rank::elemental, IntrinsicClass::impureSubroutine},
1721};
1722
1723// Finds a built-in derived type and returns it as a DynamicType.
1724static DynamicType GetBuiltinDerivedType(
1725 const semantics::Scope *builtinsScope, const char *which) {
1726 if (!builtinsScope) {
1727 common::die("INTERNAL: The __fortran_builtins module was not found, and "
1728 "the type '%s' was required",
1729 which);
1730 }
1731 auto iter{
1732 builtinsScope->find(semantics::SourceName{which, std::strlen(which)})};
1733 if (iter == builtinsScope->cend()) {
1734 // keep the string all together
1735 // clang-format off
1736 common::die(
1737 "INTERNAL: The __fortran_builtins module does not define the type '%s'",
1738 which);
1739 // clang-format on
1740 }
1741 const semantics::Symbol &symbol{*iter->second};
1742 const semantics::Scope &scope{DEREF(symbol.scope())};
1743 const semantics::DerivedTypeSpec &derived{DEREF(scope.derivedTypeSpec())};
1744 return DynamicType{derived};
1745}
1746
1747static std::int64_t GetBuiltinKind(
1748 const semantics::Scope *builtinsScope, const char *which) {
1749 if (!builtinsScope) {
1750 common::die("INTERNAL: The __fortran_builtins module was not found, and "
1751 "the kind '%s' was required",
1752 which);
1753 }
1754 auto iter{
1755 builtinsScope->find(semantics::SourceName{which, std::strlen(which)})};
1756 if (iter == builtinsScope->cend()) {
1757 common::die(
1758 "INTERNAL: The __fortran_builtins module does not define the kind '%s'",
1759 which);
1760 }
1761 const semantics::Symbol &symbol{*iter->second};
1762 const auto &details{
1763 DEREF(symbol.detailsIf<semantics::ObjectEntityDetails>())};
1764 if (const auto kind{ToInt64(details.init())}) {
1765 return *kind;
1766 } else {
1767 common::die(
1768 "INTERNAL: The __fortran_builtins module does not define the kind '%s'",
1769 which);
1770 return -1;
1771 }
1772}
1773
1774// Ensure that the keywords of arguments to MAX/MIN and their variants
1775// are of the form A123 with no duplicates or leading zeroes.
1776static bool CheckMaxMinArgument(parser::CharBlock keyword,
1777 std::set<parser::CharBlock> &set, const char *intrinsicName,
1778 parser::ContextualMessages &messages) {
1779 std::size_t j{1};
1780 for (; j < keyword.size(); ++j) {
1781 char ch{(keyword)[j]};
1782 if (ch < (j == 1 ? '1' : '0') || ch > '9') {
1783 break;
1784 }
1785 }
1786 if (keyword.size() < 2 || (keyword)[0] != 'a' || j < keyword.size()) {
1787 messages.Say(keyword,
1788 "argument keyword '%s=' is not known in call to '%s'"_err_en_US,
1789 keyword, intrinsicName);
1790 return false;
1791 }
1792 if (!set.insert(keyword).second) {
1793 messages.Say(keyword,
1794 "argument keyword '%s=' was repeated in call to '%s'"_err_en_US,
1795 keyword, intrinsicName);
1796 return false;
1797 }
1798 return true;
1799}
1800
1801// Validate the keyword, if any, and ensure that A1 and A2 are always placed in
1802// first and second position in actualForDummy. A1 and A2 are special since they
1803// are not optional. The rest of the arguments are not sorted, there are no
1804// differences between them.
1805static bool CheckAndPushMinMaxArgument(ActualArgument &arg,
1806 std::vector<ActualArgument *> &actualForDummy,
1807 std::set<parser::CharBlock> &set, const char *intrinsicName,
1808 parser::ContextualMessages &messages) {
1809 if (std::optional<parser::CharBlock> keyword{arg.keyword()}) {
1810 if (!CheckMaxMinArgument(*keyword, set, intrinsicName, messages)) {
1811 return false;
1812 }
1813 const bool isA1{*keyword == parser::CharBlock{"a1", 2}};
1814 if (isA1 && !actualForDummy[0]) {
1815 actualForDummy[0] = &arg;
1816 return true;
1817 }
1818 const bool isA2{*keyword == parser::CharBlock{"a2", 2}};
1819 if (isA2 && !actualForDummy[1]) {
1820 actualForDummy[1] = &arg;
1821 return true;
1822 }
1823 if (isA1 || isA2) {
1824 // Note that for arguments other than a1 and a2, this error will be caught
1825 // later in check-call.cpp.
1826 messages.Say(*keyword,
1827 "keyword argument '%s=' to intrinsic '%s' was supplied "
1828 "positionally by an earlier actual argument"_err_en_US,
1829 *keyword, intrinsicName);
1830 return false;
1831 }
1832 } else {
1833 if (actualForDummy.size() == 2) {
1834 if (!actualForDummy[0] && !actualForDummy[1]) {
1835 actualForDummy[0] = &arg;
1836 return true;
1837 } else if (!actualForDummy[1]) {
1838 actualForDummy[1] = &arg;
1839 return true;
1840 }
1841 }
1842 }
1843 actualForDummy.push_back(&arg);
1844 return true;
1845}
1846
1847static bool CheckAtomicKind(const ActualArgument &arg,
1848 const semantics::Scope *builtinsScope, parser::ContextualMessages &messages,
1849 const char *keyword) {
1850 std::string atomicKindStr;
1851 std::optional<DynamicType> type{arg.GetType()};
1852
1853 if (type->category() == TypeCategory::Integer) {
1854 atomicKindStr = "atomic_int_kind";
1855 } else if (type->category() == TypeCategory::Logical) {
1856 atomicKindStr = "atomic_logical_kind";
1857 } else {
1858 common::die("atomic_int_kind or atomic_logical_kind from iso_fortran_env "
1859 "must be used with IntType or LogicalType");
1860 }
1861
1862 bool argOk{type->kind() ==
1863 GetBuiltinKind(builtinsScope, ("__builtin_" + atomicKindStr).c_str())};
1864 if (!argOk) {
1865 messages.Say(arg.sourceLocation(),
1866 "Actual argument for '%s=' must have kind=atomic_%s_kind, but is '%s'"_err_en_US,
1867 keyword, type->category() == TypeCategory::Integer ? "int" : "logical",
1868 type->AsFortran());
1869 }
1870 return argOk;
1871}
1872
1873// Intrinsic interface matching against the arguments of a particular
1874// procedure reference.
1875std::optional<SpecificCall> IntrinsicInterface::Match(
1876 const CallCharacteristics &call,
1877 const common::IntrinsicTypeDefaultKinds &defaults,
1878 ActualArguments &arguments, FoldingContext &context,
1879 const semantics::Scope *builtinsScope) const {
1880 auto &messages{context.messages()};
1881 // Attempt to construct a 1-1 correspondence between the dummy arguments in
1882 // a particular intrinsic procedure's generic interface and the actual
1883 // arguments in a procedure reference.
1884 std::size_t dummyArgPatterns{0};
1885 for (; dummyArgPatterns < maxArguments && dummy[dummyArgPatterns].keyword;
1886 ++dummyArgPatterns) {
1887 }
1888 // MAX and MIN (and others that map to them) allow their last argument to
1889 // be repeated indefinitely. The actualForDummy vector is sized
1890 // and null-initialized to the non-repeated dummy argument count
1891 // for other intrinsics.
1892 bool isMaxMin{dummyArgPatterns > 0 &&
1893 dummy[dummyArgPatterns - 1].optionality == Optionality::repeats};
1894 std::vector<ActualArgument *> actualForDummy(
1895 isMaxMin ? 2 : dummyArgPatterns, nullptr);
1896 bool anyMissingActualArgument{false};
1897 std::set<parser::CharBlock> maxMinKeywords;
1898 bool anyKeyword{false};
1899 int which{0};
1900 for (std::optional<ActualArgument> &arg : arguments) {
1901 ++which;
1902 if (arg) {
1903 if (arg->isAlternateReturn()) {
1904 messages.Say(arg->sourceLocation(),
1905 "alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US,
1906 name);
1907 return std::nullopt;
1908 }
1909 if (arg->keyword()) {
1910 anyKeyword = true;
1911 } else if (anyKeyword) {
1912 messages.Say(arg ? arg->sourceLocation() : std::nullopt,
1913 "actual argument #%d without a keyword may not follow an actual argument with a keyword"_err_en_US,
1914 which);
1915 return std::nullopt;
1916 }
1917 } else {
1918 anyMissingActualArgument = true;
1919 continue;
1920 }
1921 if (isMaxMin) {
1922 if (!CheckAndPushMinMaxArgument(
1923 *arg, actualForDummy, maxMinKeywords, name, messages)) {
1924 return std::nullopt;
1925 }
1926 } else {
1927 bool found{false};
1928 for (std::size_t j{0}; j < dummyArgPatterns && !found; ++j) {
1929 if (dummy[j].optionality == Optionality::missing) {
1930 continue;
1931 }
1932 if (arg->keyword()) {
1933 found = *arg->keyword() == dummy[j].keyword;
1934 if (found) {
1935 if (const auto *previous{actualForDummy[j]}) {
1936 if (previous->keyword()) {
1937 messages.Say(*arg->keyword(),
1938 "repeated keyword argument to intrinsic '%s'"_err_en_US,
1939 name);
1940 } else {
1941 messages.Say(*arg->keyword(),
1942 "keyword argument to intrinsic '%s' was supplied "
1943 "positionally by an earlier actual argument"_err_en_US,
1944 name);
1945 }
1946 return std::nullopt;
1947 }
1948 }
1949 } else {
1950 found = !actualForDummy[j] && !anyMissingActualArgument;
1951 }
1952 if (found) {
1953 actualForDummy[j] = &*arg;
1954 }
1955 }
1956 if (!found) {
1957 if (arg->keyword()) {
1958 messages.Say(*arg->keyword(),
1959 "unknown keyword argument to intrinsic '%s'"_err_en_US, name);
1960 } else {
1961 messages.Say(
1962 "too many actual arguments for intrinsic '%s'"_err_en_US, name);
1963 }
1964 return std::nullopt;
1965 }
1966 }
1967 }
1968
1969 std::size_t dummies{actualForDummy.size()};
1970
1971 // Check types and kinds of the actual arguments against the intrinsic's
1972 // interface. Ensure that two or more arguments that have to have the same
1973 // (or compatible) type and kind do so. Check for missing non-optional
1974 // arguments now, too.
1975 const ActualArgument *sameArg{nullptr};
1976 const ActualArgument *operandArg{nullptr};
1977 const IntrinsicDummyArgument *kindDummyArg{nullptr};
1978 const ActualArgument *kindArg{nullptr};
1979 std::optional<int> dimArg;
1980 for (std::size_t j{0}; j < dummies; ++j) {
1981 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
1982 if (d.typePattern.kindCode == KindCode::kindArg) {
1983 CHECK(!kindDummyArg);
1984 kindDummyArg = &d;
1985 }
1986 const ActualArgument *arg{actualForDummy[j]};
1987 if (!arg) {
1988 if (d.optionality == Optionality::required) {
1989 std::string kw{d.keyword};
1990 if (isMaxMin && !actualForDummy[0] && !actualForDummy[1]) {
1991 messages.Say("missing mandatory 'a1=' and 'a2=' arguments"_err_en_US);
1992 } else {
1993 messages.Say(
1994 "missing mandatory '%s=' argument"_err_en_US, kw.c_str());
1995 }
1996 return std::nullopt; // missing non-OPTIONAL argument
1997 } else {
1998 continue;
1999 }
2000 }
2001 if (d.optionality == Optionality::missing) {
2002 messages.Say(arg->sourceLocation(), "unexpected '%s=' argument"_err_en_US,
2003 d.keyword);
2004 return std::nullopt;
2005 }
2006 if (!d.flags.test(ArgFlag::canBeNullPointer)) {
2007 if (const auto *expr{arg->UnwrapExpr()}; IsNullPointer(expr)) {
2008 if (!IsBareNullPointer(expr) && IsNullObjectPointer(expr) &&
2009 d.flags.test(ArgFlag::canBeMoldNull)) {
2010 // ok
2011 } else {
2012 messages.Say(arg->sourceLocation(),
2013 "A NULL() pointer is not allowed for '%s=' intrinsic argument"_err_en_US,
2014 d.keyword);
2015 return std::nullopt;
2016 }
2017 }
2018 }
2019 if (!d.flags.test(ArgFlag::canBeNullAllocatable) &&
2020 IsNullAllocatable(arg->UnwrapExpr()) &&
2021 !d.flags.test(ArgFlag::canBeMoldNull)) {
2022 messages.Say(arg->sourceLocation(),
2023 "A NULL() allocatable is not allowed for '%s=' intrinsic argument"_err_en_US,
2024 d.keyword);
2025 return std::nullopt;
2026 }
2027 if (d.flags.test(ArgFlag::notAssumedSize)) {
2028 if (auto named{ExtractNamedEntity(*arg)}) {
2029 if (semantics::IsAssumedSizeArray(named->GetLastSymbol())) {
2030 messages.Say(arg->sourceLocation(),
2031 "The '%s=' argument to the intrinsic procedure '%s' may not be assumed-size"_err_en_US,
2032 d.keyword, name);
2033 return std::nullopt;
2034 }
2035 }
2036 }
2037 if (arg->GetAssumedTypeDummy()) {
2038 // TYPE(*) assumed-type dummy argument forwarded to intrinsic
2039 if (d.typePattern.categorySet == AnyType &&
2040 (d.rank == Rank::anyOrAssumedRank ||
2041 d.rank == Rank::arrayOrAssumedRank) &&
2042 (d.typePattern.kindCode == KindCode::any ||
2043 d.typePattern.kindCode == KindCode::addressable)) {
2044 continue;
2045 } else {
2046 messages.Say(arg->sourceLocation(),
2047 "Assumed type TYPE(*) dummy argument not allowed for '%s=' intrinsic argument"_err_en_US,
2048 d.keyword);
2049 return std::nullopt;
2050 }
2051 }
2052 std::optional<DynamicType> type{arg->GetType()};
2053 if (!type) {
2054 CHECK(arg->Rank() == 0);
2055 const Expr<SomeType> &expr{DEREF(arg->UnwrapExpr())};
2056 if (IsBOZLiteral(expr)) {
2057 if (d.typePattern.kindCode == KindCode::typeless ||
2058 d.rank == Rank::elementalOrBOZ) {
2059 continue;
2060 } else {
2061 const IntrinsicDummyArgument *nextParam{
2062 j + 1 < dummies ? &dummy[j + 1] : nullptr};
2063 if (nextParam && nextParam->rank == Rank::elementalOrBOZ) {
2064 messages.Say(arg->sourceLocation(),
2065 "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109
2066 d.keyword, nextParam->keyword);
2067 } else {
2068 messages.Say(arg->sourceLocation(),
2069 "Typeless (BOZ) not allowed for '%s=' argument"_err_en_US,
2070 d.keyword);
2071 }
2072 }
2073 } else {
2074 // NULL(no MOLD=), procedure, or procedure pointer
2075 CHECK(IsProcedurePointerTarget(expr));
2076 if (d.typePattern.kindCode == KindCode::addressable ||
2077 d.rank == Rank::reduceOperation) {
2078 continue;
2079 } else if (d.typePattern.kindCode == KindCode::nullPointerType) {
2080 continue;
2081 } else if (IsBareNullPointer(&expr)) {
2082 // checked elsewhere
2083 continue;
2084 } else {
2085 CHECK(IsProcedure(expr) || IsProcedurePointer(expr));
2086 messages.Say(arg->sourceLocation(),
2087 "Actual argument for '%s=' may not be a procedure"_err_en_US,
2088 d.keyword);
2089 }
2090 }
2091 return std::nullopt;
2092 } else if (!d.typePattern.categorySet.test(type->category())) {
2093 messages.Say(arg->sourceLocation(),
2094 "Actual argument for '%s=' has bad type '%s'"_err_en_US, d.keyword,
2095 type->AsFortran());
2096 return std::nullopt; // argument has invalid type category
2097 }
2098 bool argOk{false};
2099 switch (d.typePattern.kindCode) {
2100 case KindCode::none:
2101 case KindCode::typeless:
2102 argOk = false;
2103 break;
2104 case KindCode::eventType:
2105 argOk = !type->IsUnlimitedPolymorphic() &&
2106 type->category() == TypeCategory::Derived &&
2107 semantics::IsEventType(&type->GetDerivedTypeSpec());
2108 break;
2109 case KindCode::ieeeFlagType:
2110 argOk = !type->IsUnlimitedPolymorphic() &&
2111 type->category() == TypeCategory::Derived &&
2112 semantics::IsIeeeFlagType(&type->GetDerivedTypeSpec());
2113 break;
2114 case KindCode::ieeeRoundType:
2115 argOk = !type->IsUnlimitedPolymorphic() &&
2116 type->category() == TypeCategory::Derived &&
2117 semantics::IsIeeeRoundType(&type->GetDerivedTypeSpec());
2118 break;
2119 case KindCode::teamType:
2120 argOk = !type->IsUnlimitedPolymorphic() &&
2121 type->category() == TypeCategory::Derived &&
2122 semantics::IsTeamType(&type->GetDerivedTypeSpec());
2123 break;
2124 case KindCode::defaultIntegerKind:
2125 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Integer);
2126 break;
2127 case KindCode::defaultRealKind:
2128 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Real);
2129 break;
2130 case KindCode::doublePrecision:
2131 argOk = type->kind() == defaults.doublePrecisionKind();
2132 break;
2133 case KindCode::quadPrecision:
2134 argOk = type->kind() == defaults.quadPrecisionKind();
2135 break;
2136 case KindCode::defaultCharKind:
2137 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Character);
2138 break;
2139 case KindCode::defaultLogicalKind:
2140 argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Logical);
2141 break;
2142 case KindCode::any:
2143 argOk = true;
2144 break;
2145 case KindCode::kindArg:
2146 CHECK(type->category() == TypeCategory::Integer);
2147 CHECK(!kindArg);
2148 kindArg = arg;
2149 argOk = true;
2150 break;
2151 case KindCode::dimArg:
2152 CHECK(type->category() == TypeCategory::Integer);
2153 dimArg = j;
2154 argOk = true;
2155 break;
2156 case KindCode::same: {
2157 if (!sameArg) {
2158 sameArg = arg;
2159 }
2160 auto sameType{sameArg->GetType().value()};
2161 if (name == "move_alloc"s) {
2162 // second argument can be more general
2163 argOk = type->IsTkLenCompatibleWith(sameType);
2164 } else if (name == "merge"s) {
2165 argOk = type->IsTkLenCompatibleWith(sameType) &&
2166 sameType.IsTkLenCompatibleWith(*type);
2167 } else {
2168 argOk = sameType.IsTkLenCompatibleWith(*type);
2169 }
2170 } break;
2171 case KindCode::sameKind:
2172 if (!sameArg) {
2173 sameArg = arg;
2174 }
2175 argOk = type->IsTkCompatibleWith(sameArg->GetType().value());
2176 break;
2177 case KindCode::operand:
2178 if (!operandArg) {
2179 operandArg = arg;
2180 } else if (auto prev{operandArg->GetType()}) {
2181 if (type->category() == prev->category()) {
2182 if (type->kind() > prev->kind()) {
2183 operandArg = arg;
2184 }
2185 } else if (prev->category() == TypeCategory::Integer) {
2186 operandArg = arg;
2187 }
2188 }
2189 argOk = true;
2190 break;
2191 case KindCode::effectiveKind:
2192 common::die("INTERNAL: KindCode::effectiveKind appears on argument '%s' "
2193 "for intrinsic '%s'",
2194 d.keyword, name);
2195 break;
2196 case KindCode::addressable:
2197 case KindCode::nullPointerType:
2198 argOk = true;
2199 break;
2200 case KindCode::exactKind:
2201 argOk = type->kind() == d.typePattern.kindValue;
2202 break;
2203 case KindCode::greaterOrEqualToKind:
2204 argOk = type->kind() >= d.typePattern.kindValue;
2205 break;
2206 case KindCode::sameAtom:
2207 if (!sameArg) {
2208 sameArg = arg;
2209 argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword);
2210 } else {
2211 argOk = type->IsTkCompatibleWith(sameArg->GetType().value());
2212 if (!argOk) {
2213 messages.Say(arg->sourceLocation(),
2214 "Actual argument for '%s=' must have same type and kind as 'atom=', but is '%s'"_err_en_US,
2215 d.keyword, type->AsFortran());
2216 }
2217 }
2218 if (!argOk) {
2219 return std::nullopt;
2220 }
2221 break;
2222 case KindCode::atomicIntKind:
2223 argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword);
2224 if (!argOk) {
2225 return std::nullopt;
2226 }
2227 break;
2228 case KindCode::atomicIntOrLogicalKind:
2229 argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword);
2230 if (!argOk) {
2231 return std::nullopt;
2232 }
2233 break;
2234 default:
2235 CRASH_NO_CASE;
2236 }
2237 if (!argOk) {
2238 messages.Say(arg->sourceLocation(),
2239 "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
2240 d.keyword, type->AsFortran());
2241 return std::nullopt;
2242 }
2243 }
2244
2245 // Check the ranks of the arguments against the intrinsic's interface.
2246 const ActualArgument *arrayArg{nullptr};
2247 const char *arrayArgName{nullptr};
2248 const ActualArgument *knownArg{nullptr};
2249 std::optional<std::int64_t> shapeArgSize;
2250 int elementalRank{0};
2251 for (std::size_t j{0}; j < dummies; ++j) {
2252 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
2253 if (const ActualArgument *arg{actualForDummy[j]}) {
2254 bool isAssumedRank{IsAssumedRank(*arg)};
2255 if (isAssumedRank && d.rank != Rank::anyOrAssumedRank &&
2256 d.rank != Rank::arrayOrAssumedRank) {
2257 messages.Say(arg->sourceLocation(),
2258 "Assumed-rank array cannot be forwarded to '%s=' argument"_err_en_US,
2259 d.keyword);
2260 return std::nullopt;
2261 }
2262 int rank{arg->Rank()};
2263 bool argOk{false};
2264 switch (d.rank) {
2265 case Rank::elemental:
2266 case Rank::elementalOrBOZ:
2267 if (elementalRank == 0) {
2268 elementalRank = rank;
2269 }
2270 argOk = rank == 0 || rank == elementalRank;
2271 break;
2272 case Rank::scalar:
2273 argOk = rank == 0;
2274 break;
2275 case Rank::vector:
2276 argOk = rank == 1;
2277 break;
2278 case Rank::shape:
2279 CHECK(!shapeArgSize);
2280 if (rank != 1) {
2281 messages.Say(arg->sourceLocation(),
2282 "'shape=' argument must be an array of rank 1"_err_en_US);
2283 return std::nullopt;
2284 } else {
2285 if (auto shape{GetShape(context, *arg)}) {
2286 if (auto constShape{AsConstantShape(context, *shape)}) {
2287 shapeArgSize = constShape->At(ConstantSubscripts{1}).ToInt64();
2288 CHECK(shapeArgSize.value() >= 0);
2289 argOk = *shapeArgSize <= common::maxRank;
2290 }
2291 }
2292 }
2293 if (!argOk) {
2294 if (shapeArgSize.value_or(0) > common::maxRank) {
2295 messages.Say(arg->sourceLocation(),
2296 "'shape=' argument must be a vector of at most %d elements (has %jd)"_err_en_US,
2297 common::maxRank, std::intmax_t{*shapeArgSize});
2298 } else {
2299 messages.Say(arg->sourceLocation(),
2300 "'shape=' argument must be a vector of known size"_err_en_US);
2301 }
2302 return std::nullopt;
2303 }
2304 break;
2305 case Rank::matrix:
2306 argOk = rank == 2;
2307 break;
2308 case Rank::array:
2309 argOk = rank > 0;
2310 if (!arrayArg) {
2311 arrayArg = arg;
2312 arrayArgName = d.keyword;
2313 }
2314 break;
2315 case Rank::coarray:
2316 argOk = IsCoarray(*arg);
2317 if (!argOk) {
2318 messages.Say(arg->sourceLocation(),
2319 "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US,
2320 name);
2321 return std::nullopt;
2322 }
2323 break;
2324 case Rank::atom:
2325 argOk = rank == 0 && (IsCoarray(*arg) || ExtractCoarrayRef(*arg));
2326 if (!argOk) {
2327 messages.Say(arg->sourceLocation(),
2328 "'%s=' argument must be a scalar coarray or coindexed object for intrinsic '%s'"_err_en_US,
2329 d.keyword, name);
2330 return std::nullopt;
2331 }
2332 break;
2333 case Rank::known:
2334 if (!knownArg) {
2335 knownArg = arg;
2336 }
2337 argOk = !isAssumedRank && rank == knownArg->Rank();
2338 break;
2339 case Rank::anyOrAssumedRank:
2340 case Rank::arrayOrAssumedRank:
2341 if (isAssumedRank) {
2342 argOk = true;
2343 break;
2344 }
2345 if (d.rank == Rank::arrayOrAssumedRank && rank == 0) {
2346 argOk = false;
2347 break;
2348 }
2349 if (!knownArg) {
2350 knownArg = arg;
2351 }
2352 if (rank > 0 &&
2353 (std::strcmp(s1: name, s2: "shape") == 0 ||
2354 std::strcmp(s1: name, s2: "size") == 0 ||
2355 std::strcmp(s1: name, s2: "ubound") == 0)) {
2356 // Check for a whole assumed-size array argument.
2357 // These are disallowed for SHAPE, and require DIM= for
2358 // SIZE and UBOUND.
2359 // (A previous error message for UBOUND will take precedence
2360 // over this one, as this error is caught by the second entry
2361 // for UBOUND.)
2362 if (auto named{ExtractNamedEntity(*arg)}) {
2363 if (semantics::IsAssumedSizeArray(ResolveAssociations(
2364 named->GetLastSymbol().GetUltimate()))) {
2365 if (strcmp(s1: name, s2: "shape") == 0) {
2366 messages.Say(arg->sourceLocation(),
2367 "The 'source=' argument to the intrinsic function 'shape' may not be assumed-size"_err_en_US);
2368 return std::nullopt;
2369 } else if (!dimArg) {
2370 messages.Say(arg->sourceLocation(),
2371 "A dim= argument is required for '%s' when the array is assumed-size"_err_en_US,
2372 name);
2373 return std::nullopt;
2374 }
2375 }
2376 }
2377 }
2378 argOk = true;
2379 break;
2380 case Rank::conformable: // arg must be conformable with previous arrayArg
2381 CHECK(arrayArg);
2382 CHECK(arrayArgName);
2383 if (const std::optional<Shape> &arrayArgShape{
2384 GetShape(context, *arrayArg)}) {
2385 if (std::optional<Shape> argShape{GetShape(context, *arg)}) {
2386 std::string arrayArgMsg{"'"};
2387 arrayArgMsg = arrayArgMsg + arrayArgName + "='" + " argument";
2388 std::string argMsg{"'"};
2389 argMsg = argMsg + d.keyword + "='" + " argument";
2390 CheckConformance(context.messages(), *arrayArgShape, *argShape,
2391 CheckConformanceFlags::RightScalarExpandable,
2392 arrayArgMsg.c_str(), argMsg.c_str());
2393 }
2394 }
2395 argOk = true; // Avoid an additional error message
2396 break;
2397 case Rank::dimReduced:
2398 case Rank::dimRemovedOrScalar:
2399 CHECK(arrayArg);
2400 argOk = rank == 0 || rank + 1 == arrayArg->Rank();
2401 break;
2402 case Rank::reduceOperation:
2403 // The reduction function is validated in ApplySpecificChecks().
2404 argOk = true;
2405 break;
2406 case Rank::scalarIfDim:
2407 case Rank::locReduced:
2408 case Rank::rankPlus1:
2409 case Rank::shaped:
2410 common::die("INTERNAL: result-only rank code appears on argument '%s' "
2411 "for intrinsic '%s'",
2412 d.keyword, name);
2413 }
2414 if (!argOk) {
2415 messages.Say(arg->sourceLocation(),
2416 "'%s=' argument has unacceptable rank %d"_err_en_US, d.keyword,
2417 rank);
2418 return std::nullopt;
2419 }
2420 }
2421 }
2422
2423 // Calculate the characteristics of the function result, if any
2424 std::optional<DynamicType> resultType;
2425 if (auto category{result.categorySet.LeastElement()}) {
2426 // The intrinsic is not a subroutine.
2427 if (call.isSubroutineCall) {
2428 return std::nullopt;
2429 }
2430 switch (result.kindCode) {
2431 case KindCode::defaultIntegerKind:
2432 CHECK(result.categorySet == IntType);
2433 CHECK(*category == TypeCategory::Integer);
2434 resultType = DynamicType{TypeCategory::Integer,
2435 defaults.GetDefaultKind(TypeCategory::Integer)};
2436 break;
2437 case KindCode::defaultRealKind:
2438 CHECK(result.categorySet == CategorySet{*category});
2439 CHECK(FloatingType.test(*category));
2440 resultType =
2441 DynamicType{*category, defaults.GetDefaultKind(TypeCategory::Real)};
2442 break;
2443 case KindCode::doublePrecision:
2444 CHECK(result.categorySet == CategorySet{*category});
2445 CHECK(FloatingType.test(*category));
2446 resultType = DynamicType{*category, defaults.doublePrecisionKind()};
2447 break;
2448 case KindCode::quadPrecision:
2449 CHECK(result.categorySet == CategorySet{*category});
2450 CHECK(FloatingType.test(*category));
2451 resultType = DynamicType{*category, defaults.quadPrecisionKind()};
2452 if (!context.targetCharacteristics().CanSupportType(
2453 *category, defaults.quadPrecisionKind())) {
2454 messages.Say(
2455 "%s(KIND=%jd) type not supported on this target."_err_en_US,
2456 parser::ToUpperCaseLetters(EnumToString(*category)),
2457 defaults.quadPrecisionKind());
2458 }
2459 break;
2460 case KindCode::defaultLogicalKind:
2461 CHECK(result.categorySet == LogicalType);
2462 CHECK(*category == TypeCategory::Logical);
2463 resultType = DynamicType{TypeCategory::Logical,
2464 defaults.GetDefaultKind(TypeCategory::Logical)};
2465 break;
2466 case KindCode::defaultCharKind:
2467 CHECK(result.categorySet == CharType);
2468 CHECK(*category == TypeCategory::Character);
2469 resultType = DynamicType{TypeCategory::Character,
2470 defaults.GetDefaultKind(TypeCategory::Character)};
2471 break;
2472 case KindCode::same:
2473 CHECK(sameArg);
2474 if (std::optional<DynamicType> aType{sameArg->GetType()}) {
2475 if (result.categorySet.test(aType->category())) {
2476 if (const auto *sameChar{UnwrapExpr<Expr<SomeCharacter>>(*sameArg)}) {
2477 if (auto len{ToInt64(Fold(context, sameChar->LEN()))}) {
2478 resultType = DynamicType{aType->kind(), *len};
2479 } else {
2480 resultType = *aType;
2481 }
2482 } else {
2483 resultType = *aType;
2484 }
2485 } else {
2486 resultType = DynamicType{*category, aType->kind()};
2487 }
2488 }
2489 break;
2490 case KindCode::sameKind:
2491 CHECK(sameArg);
2492 if (std::optional<DynamicType> aType{sameArg->GetType()}) {
2493 resultType = DynamicType{*category, aType->kind()};
2494 }
2495 break;
2496 case KindCode::operand:
2497 CHECK(operandArg);
2498 resultType = operandArg->GetType();
2499 CHECK(!resultType || result.categorySet.test(resultType->category()));
2500 break;
2501 case KindCode::effectiveKind:
2502 CHECK(kindDummyArg);
2503 CHECK(result.categorySet == CategorySet{*category});
2504 if (kindArg) {
2505 if (auto *expr{kindArg->UnwrapExpr()}) {
2506 CHECK(expr->Rank() == 0);
2507 if (auto code{ToInt64(Fold(context, common::Clone(*expr)))}) {
2508 if (context.targetCharacteristics().IsTypeEnabled(
2509 *category, *code)) {
2510 if (*category == TypeCategory::Character) { // ACHAR & CHAR
2511 resultType = DynamicType{static_cast<int>(*code), 1};
2512 } else {
2513 resultType = DynamicType{*category, static_cast<int>(*code)};
2514 }
2515 break;
2516 }
2517 }
2518 }
2519 messages.Say(
2520 "'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type"_err_en_US);
2521 // use default kind below for error recovery
2522 } else if (kindDummyArg->flags.test(ArgFlag::defaultsToSameKind)) {
2523 CHECK(sameArg);
2524 resultType = *sameArg->GetType();
2525 } else if (kindDummyArg->flags.test(ArgFlag::defaultsToSizeKind)) {
2526 CHECK(*category == TypeCategory::Integer);
2527 resultType =
2528 DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()};
2529 } else {
2530 CHECK(kindDummyArg->flags.test(ArgFlag::defaultsToDefaultForResult));
2531 }
2532 if (!resultType) {
2533 int kind{defaults.GetDefaultKind(*category)};
2534 if (*category == TypeCategory::Character) { // ACHAR & CHAR
2535 resultType = DynamicType{kind, 1};
2536 } else {
2537 resultType = DynamicType{*category, kind};
2538 }
2539 }
2540 break;
2541 case KindCode::likeMultiply:
2542 CHECK(dummies >= 2);
2543 CHECK(actualForDummy[0]);
2544 CHECK(actualForDummy[1]);
2545 resultType = actualForDummy[0]->GetType()->ResultTypeForMultiply(
2546 *actualForDummy[1]->GetType());
2547 break;
2548 case KindCode::subscript:
2549 CHECK(result.categorySet == IntType);
2550 CHECK(*category == TypeCategory::Integer);
2551 resultType =
2552 DynamicType{TypeCategory::Integer, defaults.subscriptIntegerKind()};
2553 break;
2554 case KindCode::size:
2555 CHECK(result.categorySet == IntType);
2556 CHECK(*category == TypeCategory::Integer);
2557 resultType =
2558 DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()};
2559 break;
2560 case KindCode::teamType:
2561 CHECK(result.categorySet == DerivedType);
2562 CHECK(*category == TypeCategory::Derived);
2563 resultType = DynamicType{
2564 GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")};
2565 break;
2566 case KindCode::greaterOrEqualToKind:
2567 case KindCode::exactKind:
2568 resultType = DynamicType{*category, result.kindValue};
2569 break;
2570 case KindCode::typeless:
2571 case KindCode::any:
2572 case KindCode::kindArg:
2573 case KindCode::dimArg:
2574 common::die(
2575 "INTERNAL: bad KindCode appears on intrinsic '%s' result", name);
2576 break;
2577 default:
2578 CRASH_NO_CASE;
2579 }
2580 } else {
2581 if (!call.isSubroutineCall) {
2582 return std::nullopt;
2583 }
2584 CHECK(result.kindCode == KindCode::none);
2585 }
2586
2587 // Emit warnings when the syntactic presence of a DIM= argument determines
2588 // the semantics of the call but the associated actual argument may not be
2589 // present at execution time.
2590 if (dimArg) {
2591 std::optional<int> arrayRank;
2592 if (arrayArg) {
2593 arrayRank = arrayArg->Rank();
2594 if (auto dimVal{ToInt64(actualForDummy[*dimArg])}) {
2595 if (*dimVal < 1) {
2596 messages.Say(
2597 "The value of DIM= (%jd) may not be less than 1"_err_en_US,
2598 static_cast<std::intmax_t>(*dimVal));
2599 } else if (*dimVal > *arrayRank) {
2600 messages.Say(
2601 "The value of DIM= (%jd) may not be greater than %d"_err_en_US,
2602 static_cast<std::intmax_t>(*dimVal), *arrayRank);
2603 }
2604 }
2605 }
2606 switch (rank) {
2607 case Rank::dimReduced:
2608 case Rank::dimRemovedOrScalar:
2609 case Rank::locReduced:
2610 case Rank::scalarIfDim:
2611 if (dummy[*dimArg].optionality == Optionality::required) {
2612 if (const Symbol *whole{
2613 UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) {
2614 if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) {
2615 if (context.languageFeatures().ShouldWarn(
2616 common::UsageWarning::OptionalMustBePresent)) {
2617 if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
2618 messages.Say(common::UsageWarning::OptionalMustBePresent,
2619 "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);
2620 } else {
2621 messages.Say(common::UsageWarning::OptionalMustBePresent,
2622 "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);
2623 }
2624 }
2625 }
2626 }
2627 }
2628 break;
2629 default:;
2630 }
2631 }
2632
2633 // At this point, the call is acceptable.
2634 // Determine the rank of the function result.
2635 int resultRank{0};
2636 switch (rank) {
2637 case Rank::elemental:
2638 resultRank = elementalRank;
2639 break;
2640 case Rank::scalar:
2641 resultRank = 0;
2642 break;
2643 case Rank::vector:
2644 resultRank = 1;
2645 break;
2646 case Rank::matrix:
2647 resultRank = 2;
2648 break;
2649 case Rank::conformable:
2650 CHECK(arrayArg);
2651 resultRank = arrayArg->Rank();
2652 break;
2653 case Rank::dimReduced:
2654 CHECK(arrayArg);
2655 resultRank = dimArg ? arrayArg->Rank() - 1 : 0;
2656 break;
2657 case Rank::locReduced:
2658 CHECK(arrayArg);
2659 resultRank = dimArg ? arrayArg->Rank() - 1 : 1;
2660 break;
2661 case Rank::rankPlus1:
2662 CHECK(knownArg);
2663 resultRank = knownArg->Rank() + 1;
2664 break;
2665 case Rank::shaped:
2666 CHECK(shapeArgSize);
2667 resultRank = *shapeArgSize;
2668 break;
2669 case Rank::scalarIfDim:
2670 resultRank = dimArg ? 0 : 1;
2671 break;
2672 case Rank::elementalOrBOZ:
2673 case Rank::shape:
2674 case Rank::array:
2675 case Rank::coarray:
2676 case Rank::atom:
2677 case Rank::known:
2678 case Rank::anyOrAssumedRank:
2679 case Rank::arrayOrAssumedRank:
2680 case Rank::reduceOperation:
2681 case Rank::dimRemovedOrScalar:
2682 common::die("INTERNAL: bad Rank code on intrinsic '%s' result", name);
2683 break;
2684 }
2685 CHECK(resultRank >= 0);
2686
2687 // Rearrange the actual arguments into dummy argument order.
2688 ActualArguments rearranged(dummies);
2689 for (std::size_t j{0}; j < dummies; ++j) {
2690 if (ActualArgument *arg{actualForDummy[j]}) {
2691 rearranged[j] = std::move(*arg);
2692 }
2693 }
2694
2695 // Characterize the specific intrinsic procedure.
2696 characteristics::DummyArguments dummyArgs;
2697 std::optional<int> sameDummyArg;
2698
2699 for (std::size_t j{0}; j < dummies; ++j) {
2700 const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
2701 if (const auto &arg{rearranged[j]}) {
2702 if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
2703 std::string kw{d.keyword};
2704 if (arg->keyword()) {
2705 kw = arg->keyword()->ToString();
2706 } else if (isMaxMin) {
2707 for (std::size_t k{j + 1};; ++k) {
2708 kw = "a"s + std::to_string(k);
2709 auto iter{std::find_if(dummyArgs.begin(), dummyArgs.end(),
2710 [&kw](const characteristics::DummyArgument &prev) {
2711 return prev.name == kw;
2712 })};
2713 if (iter == dummyArgs.end()) {
2714 break;
2715 }
2716 }
2717 }
2718 if (auto dc{characteristics::DummyArgument::FromActual(std::move(kw),
2719 *expr, context, /*forImplicitInterface=*/false)}) {
2720 if (auto *dummyProc{
2721 std::get_if<characteristics::DummyProcedure>(&dc->u)}) {
2722 // Dummy procedures are never elemental.
2723 dummyProc->procedure.value().attrs.reset(
2724 characteristics::Procedure::Attr::Elemental);
2725 } else if (auto *dummyObject{
2726 std::get_if<characteristics::DummyDataObject>(
2727 &dc->u)}) {
2728 dummyObject->type.set_corank(0);
2729 if (d.flags.test(ArgFlag::onlyConstantInquiry)) {
2730 dummyObject->attrs.set(
2731 characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry);
2732 }
2733 }
2734 dummyArgs.emplace_back(std::move(*dc));
2735 if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) {
2736 sameDummyArg = j;
2737 }
2738 } else { // error recovery
2739 messages.Say(
2740 "Could not characterize intrinsic function actual argument '%s'"_err_en_US,
2741 expr->AsFortran().c_str());
2742 return std::nullopt;
2743 }
2744 } else {
2745 CHECK(arg->GetAssumedTypeDummy());
2746 dummyArgs.emplace_back(std::string{d.keyword},
2747 characteristics::DummyDataObject{DynamicType::AssumedType()});
2748 }
2749 } else {
2750 // optional argument is absent
2751 CHECK(d.optionality != Optionality::required);
2752 if (d.typePattern.kindCode == KindCode::same) {
2753 dummyArgs.emplace_back(dummyArgs[sameDummyArg.value()]);
2754 } else {
2755 auto category{d.typePattern.categorySet.LeastElement().value()};
2756 if (category == TypeCategory::Derived) {
2757 // TODO: any other built-in derived types used as optional intrinsic
2758 // dummies?
2759 CHECK(d.typePattern.kindCode == KindCode::teamType);
2760 characteristics::TypeAndShape typeAndShape{
2761 GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")};
2762 dummyArgs.emplace_back(std::string{d.keyword},
2763 characteristics::DummyDataObject{std::move(typeAndShape)});
2764 } else {
2765 characteristics::TypeAndShape typeAndShape{
2766 DynamicType{category, defaults.GetDefaultKind(category)}};
2767 dummyArgs.emplace_back(std::string{d.keyword},
2768 characteristics::DummyDataObject{std::move(typeAndShape)});
2769 }
2770 }
2771 dummyArgs.back().SetOptional();
2772 }
2773 dummyArgs.back().SetIntent(d.intent);
2774 }
2775 characteristics::Procedure::Attrs attrs;
2776 if (elementalRank > 0) {
2777 attrs.set(characteristics::Procedure::Attr::Elemental);
2778 }
2779 if (call.isSubroutineCall) {
2780 if (intrinsicClass == IntrinsicClass::pureSubroutine /* MOVE_ALLOC */ ||
2781 intrinsicClass == IntrinsicClass::elementalSubroutine /* MVBITS */) {
2782 attrs.set(characteristics::Procedure::Attr::Pure);
2783 }
2784 return SpecificCall{
2785 SpecificIntrinsic{
2786 name, characteristics::Procedure{std::move(dummyArgs), attrs}},
2787 std::move(rearranged)};
2788 } else {
2789 attrs.set(characteristics::Procedure::Attr::Pure);
2790 characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
2791 characteristics::FunctionResult funcResult{std::move(typeAndShape)};
2792 characteristics::Procedure chars{
2793 std::move(funcResult), std::move(dummyArgs), attrs};
2794 return SpecificCall{
2795 SpecificIntrinsic{name, std::move(chars)}, std::move(rearranged)};
2796 }
2797}
2798
2799class IntrinsicProcTable::Implementation {
2800public:
2801 explicit Implementation(const common::IntrinsicTypeDefaultKinds &dfts)
2802 : defaults_{dfts} {
2803 for (const IntrinsicInterface &f : genericIntrinsicFunction) {
2804 genericFuncs_.insert(std::make_pair(std::string{f.name}, &f));
2805 }
2806 for (const std::pair<const char *, const char *> &a : genericAlias) {
2807 aliases_.insert(
2808 std::make_pair(std::string{a.first}, std::string{a.second}));
2809 }
2810 for (const SpecificIntrinsicInterface &f : specificIntrinsicFunction) {
2811 specificFuncs_.insert(std::make_pair(std::string{f.name}, &f));
2812 }
2813 for (const IntrinsicInterface &f : intrinsicSubroutine) {
2814 subroutines_.insert(std::make_pair(std::string{f.name}, &f));
2815 }
2816 }
2817
2818 void SupplyBuiltins(const semantics::Scope &builtins) {
2819 builtinsScope_ = &builtins;
2820 }
2821
2822 bool IsIntrinsic(const std::string &) const;
2823 bool IsIntrinsicFunction(const std::string &) const;
2824 bool IsIntrinsicSubroutine(const std::string &) const;
2825 bool IsDualIntrinsic(const std::string &) const;
2826
2827 IntrinsicClass GetIntrinsicClass(const std::string &) const;
2828 std::string GetGenericIntrinsicName(const std::string &) const;
2829
2830 std::optional<SpecificCall> Probe(
2831 const CallCharacteristics &, ActualArguments &, FoldingContext &) const;
2832
2833 std::optional<SpecificIntrinsicFunctionInterface> IsSpecificIntrinsicFunction(
2834 const std::string &) const;
2835
2836 llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
2837
2838private:
2839 DynamicType GetSpecificType(const TypePattern &) const;
2840 SpecificCall HandleNull(ActualArguments &, FoldingContext &) const;
2841 std::optional<SpecificCall> HandleC_F_Pointer(
2842 ActualArguments &, FoldingContext &) const;
2843 std::optional<SpecificCall> HandleC_Loc(
2844 ActualArguments &, FoldingContext &) const;
2845 std::optional<SpecificCall> HandleC_Devloc(
2846 ActualArguments &, FoldingContext &) const;
2847 const std::string &ResolveAlias(const std::string &name) const {
2848 auto iter{aliases_.find(name)};
2849 return iter == aliases_.end() ? name : iter->second;
2850 }
2851
2852 common::IntrinsicTypeDefaultKinds defaults_;
2853 std::multimap<std::string, const IntrinsicInterface *> genericFuncs_;
2854 std::multimap<std::string, const SpecificIntrinsicInterface *> specificFuncs_;
2855 std::multimap<std::string, const IntrinsicInterface *> subroutines_;
2856 const semantics::Scope *builtinsScope_{nullptr};
2857 std::map<std::string, std::string> aliases_;
2858 semantics::ParamValue assumedLen_{
2859 semantics::ParamValue::Assumed(common::TypeParamAttr::Len)};
2860};
2861
2862bool IntrinsicProcTable::Implementation::IsIntrinsicFunction(
2863 const std::string &name0) const {
2864 const std::string &name{ResolveAlias(name0)};
2865 auto specificRange{specificFuncs_.equal_range(name)};
2866 if (specificRange.first != specificRange.second) {
2867 return true;
2868 }
2869 auto genericRange{genericFuncs_.equal_range(name)};
2870 if (genericRange.first != genericRange.second) {
2871 return true;
2872 }
2873 // special cases
2874 return name == "__builtin_c_loc" || name == "__builtin_c_devloc" ||
2875 name == "null";
2876}
2877bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine(
2878 const std::string &name0) const {
2879 const std::string &name{ResolveAlias(name0)};
2880 auto subrRange{subroutines_.equal_range(name)};
2881 if (subrRange.first != subrRange.second) {
2882 return true;
2883 }
2884 // special cases
2885 return name == "__builtin_c_f_pointer";
2886}
2887bool IntrinsicProcTable::Implementation::IsIntrinsic(
2888 const std::string &name) const {
2889 return IsIntrinsicFunction(name) || IsIntrinsicSubroutine(name);
2890}
2891bool IntrinsicProcTable::Implementation::IsDualIntrinsic(
2892 const std::string &name) const {
2893 // Collection for some intrinsics with function and subroutine form,
2894 // in order to pass the semantic check.
2895 static const std::string dualIntrinsic[]{{"chdir"}, {"etime"}, {"fseek"},
2896 {"ftell"}, {"getcwd"}, {"hostnm"}, {"putenv"s}, {"rename"}, {"second"},
2897 {"system"}, {"unlink"}};
2898 return llvm::is_contained(dualIntrinsic, name);
2899}
2900
2901IntrinsicClass IntrinsicProcTable::Implementation::GetIntrinsicClass(
2902 const std::string &name) const {
2903 auto specificIntrinsic{specificFuncs_.find(name)};
2904 if (specificIntrinsic != specificFuncs_.end()) {
2905 return specificIntrinsic->second->intrinsicClass;
2906 }
2907 auto genericIntrinsic{genericFuncs_.find(name)};
2908 if (genericIntrinsic != genericFuncs_.end()) {
2909 return genericIntrinsic->second->intrinsicClass;
2910 }
2911 auto subrIntrinsic{subroutines_.find(name)};
2912 if (subrIntrinsic != subroutines_.end()) {
2913 return subrIntrinsic->second->intrinsicClass;
2914 }
2915 return IntrinsicClass::noClass;
2916}
2917
2918std::string IntrinsicProcTable::Implementation::GetGenericIntrinsicName(
2919 const std::string &name) const {
2920 auto specificIntrinsic{specificFuncs_.find(name)};
2921 if (specificIntrinsic != specificFuncs_.end()) {
2922 if (const char *genericName{specificIntrinsic->second->generic}) {
2923 return {genericName};
2924 }
2925 }
2926 return name;
2927}
2928
2929bool CheckAndRearrangeArguments(ActualArguments &arguments,
2930 parser::ContextualMessages &messages, const char *const dummyKeywords[],
2931 std::size_t trailingOptionals) {
2932 std::size_t numDummies{0};
2933 while (dummyKeywords[numDummies]) {
2934 ++numDummies;
2935 }
2936 CHECK(trailingOptionals <= numDummies);
2937 if (arguments.size() > numDummies) {
2938 messages.Say("Too many actual arguments (%zd > %zd)"_err_en_US,
2939 arguments.size(), numDummies);
2940 return false;
2941 }
2942 ActualArguments rearranged(numDummies);
2943 bool anyKeywords{false};
2944 std::size_t position{0};
2945 for (std::optional<ActualArgument> &arg : arguments) {
2946 std::size_t dummyIndex{0};
2947 if (arg && arg->keyword()) {
2948 anyKeywords = true;
2949 for (; dummyIndex < numDummies; ++dummyIndex) {
2950 if (*arg->keyword() == dummyKeywords[dummyIndex]) {
2951 break;
2952 }
2953 }
2954 if (dummyIndex >= numDummies) {
2955 messages.Say(*arg->keyword(),
2956 "Unknown argument keyword '%s='"_err_en_US, *arg->keyword());
2957 return false;
2958 }
2959 } else if (anyKeywords) {
2960 messages.Say(arg ? arg->sourceLocation() : messages.at(),
2961 "A positional actual argument may not appear after any keyword arguments"_err_en_US);
2962 return false;
2963 } else {
2964 dummyIndex = position++;
2965 }
2966 if (rearranged[dummyIndex]) {
2967 messages.Say(arg ? arg->sourceLocation() : messages.at(),
2968 "Dummy argument '%s=' appears more than once"_err_en_US,
2969 dummyKeywords[dummyIndex]);
2970 return false;
2971 }
2972 rearranged[dummyIndex] = std::move(arg);
2973 arg.reset();
2974 }
2975 bool anyMissing{false};
2976 for (std::size_t j{0}; j < numDummies - trailingOptionals; ++j) {
2977 if (!rearranged[j]) {
2978 messages.Say("Dummy argument '%s=' is absent and not OPTIONAL"_err_en_US,
2979 dummyKeywords[j]);
2980 anyMissing = true;
2981 }
2982 }
2983 arguments = std::move(rearranged);
2984 return !anyMissing;
2985}
2986
2987// The NULL() intrinsic is a special case.
2988SpecificCall IntrinsicProcTable::Implementation::HandleNull(
2989 ActualArguments &arguments, FoldingContext &context) const {
2990 static const char *const keywords[]{"mold", nullptr};
2991 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) &&
2992 arguments[0]) {
2993 Expr<SomeType> *mold{arguments[0]->UnwrapExpr()};
2994 bool isBareNull{IsBareNullPointer(mold)};
2995 if (isBareNull) {
2996 // NULL(NULL()), NULL(NULL(NULL())), &c. are all just NULL()
2997 mold = nullptr;
2998 }
2999 if (mold) {
3000 if (IsAssumedRank(*arguments[0])) {
3001 context.messages().Say(arguments[0]->sourceLocation(),
3002 "MOLD= argument to NULL() must not be assumed-rank"_err_en_US);
3003 }
3004 bool isProcPtrTarget{
3005 IsProcedurePointerTarget(*mold) && !IsNullObjectPointer(mold)};
3006 if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold)) {
3007 characteristics::DummyArguments args;
3008 std::optional<characteristics::FunctionResult> fResult;
3009 bool isAllocatableMold{false};
3010 if (isProcPtrTarget) {
3011 // MOLD= procedure pointer
3012 std::optional<characteristics::Procedure> procPointer;
3013 if (IsNullProcedurePointer(mold)) {
3014 procPointer =
3015 characteristics::Procedure::Characterize(*mold, context);
3016 } else {
3017 const Symbol *last{GetLastSymbol(*mold)};
3018 procPointer =
3019 characteristics::Procedure::Characterize(DEREF(last), context);
3020 }
3021 // procPointer is vacant if there was an error with the analysis
3022 // associated with the procedure pointer
3023 if (procPointer) {
3024 args.emplace_back("mold"s,
3025 characteristics::DummyProcedure{common::Clone(*procPointer)});
3026 fResult.emplace(std::move(*procPointer));
3027 }
3028 } else if (auto type{mold->GetType()}) {
3029 // MOLD= object pointer or allocatable
3030 characteristics::TypeAndShape typeAndShape{
3031 *type, GetShape(context, *mold)};
3032 args.emplace_back(
3033 "mold"s, characteristics::DummyDataObject{typeAndShape});
3034 fResult.emplace(std::move(typeAndShape));
3035 isAllocatableMold = IsAllocatableDesignator(*mold);
3036 } else {
3037 context.messages().Say(arguments[0]->sourceLocation(),
3038 "MOLD= argument to NULL() lacks type"_err_en_US);
3039 }
3040 if (fResult) {
3041 fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
3042 characteristics::Procedure::Attrs attrs;
3043 attrs.set(isAllocatableMold
3044 ? characteristics::Procedure::Attr::NullAllocatable
3045 : characteristics::Procedure::Attr::NullPointer);
3046 characteristics::Procedure chars{
3047 std::move(*fResult), std::move(args), attrs};
3048 return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)},
3049 std::move(arguments)};
3050 }
3051 }
3052 }
3053 if (!isBareNull) {
3054 context.messages().Say(arguments[0]->sourceLocation(),
3055 "MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US);
3056 }
3057 }
3058 characteristics::Procedure::Attrs attrs;
3059 attrs.set(characteristics::Procedure::Attr::NullPointer);
3060 attrs.set(characteristics::Procedure::Attr::Pure);
3061 arguments.clear();
3062 return SpecificCall{
3063 SpecificIntrinsic{"null"s,
3064 characteristics::Procedure{characteristics::DummyArguments{}, attrs}},
3065 std::move(arguments)};
3066}
3067
3068// Subroutine C_F_POINTER(CPTR=,FPTR=[,SHAPE=]) from
3069// intrinsic module ISO_C_BINDING (18.2.3.3)
3070std::optional<SpecificCall>
3071IntrinsicProcTable::Implementation::HandleC_F_Pointer(
3072 ActualArguments &arguments, FoldingContext &context) const {
3073 characteristics::Procedure::Attrs attrs;
3074 attrs.set(characteristics::Procedure::Attr::Subroutine);
3075 static const char *const keywords[]{"cptr", "fptr", "shape", nullptr};
3076 characteristics::DummyArguments dummies;
3077 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
3078 CHECK(arguments.size() == 3);
3079 if (const auto *expr{arguments[0].value().UnwrapExpr()}) {
3080 // General semantic checks will catch an actual argument that's not
3081 // scalar.
3082 if (auto type{expr->GetType()}) {
3083 if (type->category() != TypeCategory::Derived ||
3084 type->IsPolymorphic() ||
3085 (type->GetDerivedTypeSpec().typeSymbol().name() !=
3086 "__builtin_c_ptr" &&
3087 type->GetDerivedTypeSpec().typeSymbol().name() !=
3088 "__builtin_c_devptr")) {
3089 context.messages().Say(arguments[0]->sourceLocation(),
3090 "CPTR= argument to C_F_POINTER() must be a C_PTR"_err_en_US);
3091 }
3092 characteristics::DummyDataObject cptr{
3093 characteristics::TypeAndShape{*type}};
3094 cptr.intent = common::Intent::In;
3095 dummies.emplace_back("cptr"s, std::move(cptr));
3096 }
3097 }
3098 if (const auto *expr{arguments[1].value().UnwrapExpr()}) {
3099 int fptrRank{expr->Rank()};
3100 auto at{arguments[1]->sourceLocation()};
3101 if (auto type{expr->GetType()}) {
3102 if (type->HasDeferredTypeParameter()) {
3103 context.messages().Say(at,
3104 "FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US);
3105 } else if (type->category() == TypeCategory::Derived) {
3106 if (context.languageFeatures().ShouldWarn(
3107 common::UsageWarning::Interoperability) &&
3108 type->IsUnlimitedPolymorphic()) {
3109 context.messages().Say(common::UsageWarning::Interoperability, at,
3110 "FPTR= argument to C_F_POINTER() should not be unlimited polymorphic"_warn_en_US);
3111 } else if (!type->GetDerivedTypeSpec().typeSymbol().attrs().test(
3112 semantics::Attr::BIND_C) &&
3113 context.languageFeatures().ShouldWarn(
3114 common::UsageWarning::Portability)) {
3115 context.messages().Say(common::UsageWarning::Portability, at,
3116 "FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)"_port_en_US);
3117 }
3118 } else if (!IsInteroperableIntrinsicType(
3119 *type, &context.languageFeatures())
3120 .value_or(true)) {
3121 if (type->category() == TypeCategory::Character &&
3122 type->kind() == 1) {
3123 if (context.languageFeatures().ShouldWarn(
3124 common::UsageWarning::CharacterInteroperability)) {
3125 context.messages().Say(
3126 common::UsageWarning::CharacterInteroperability, at,
3127 "FPTR= argument to C_F_POINTER() should not have the non-interoperable character length %s"_warn_en_US,
3128 type->AsFortran());
3129 }
3130 } else if (context.languageFeatures().ShouldWarn(
3131 common::UsageWarning::Interoperability)) {
3132 context.messages().Say(common::UsageWarning::Interoperability, at,
3133 "FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind %s"_warn_en_US,
3134 type->AsFortran());
3135 }
3136 }
3137 if (ExtractCoarrayRef(*expr)) {
3138 context.messages().Say(at,
3139 "FPTR= argument to C_F_POINTER() may not be a coindexed object"_err_en_US);
3140 }
3141 characteristics::DummyDataObject fptr{
3142 characteristics::TypeAndShape{*type, fptrRank}};
3143 fptr.intent = common::Intent::Out;
3144 fptr.attrs.set(characteristics::DummyDataObject::Attr::Pointer);
3145 dummies.emplace_back("fptr"s, std::move(fptr));
3146 } else {
3147 context.messages().Say(
3148 at, "FPTR= argument to C_F_POINTER() must have a type"_err_en_US);
3149 }
3150 if (arguments[2] && fptrRank == 0) {
3151 context.messages().Say(arguments[2]->sourceLocation(),
3152 "SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US);
3153 } else if (!arguments[2] && fptrRank > 0) {
3154 context.messages().Say(
3155 "SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array"_err_en_US);
3156 } else if (arguments[2]) {
3157 if (const auto *argExpr{arguments[2].value().UnwrapExpr()}) {
3158 if (argExpr->Rank() > 1) {
3159 context.messages().Say(arguments[2]->sourceLocation(),
3160 "SHAPE= argument to C_F_POINTER() must be a rank-one array."_err_en_US);
3161 } else if (argExpr->Rank() == 1) {
3162 if (auto constShape{GetConstantShape(context, *argExpr)}) {
3163 if (constShape->At(ConstantSubscripts{1}).ToInt64() != fptrRank) {
3164 context.messages().Say(arguments[2]->sourceLocation(),
3165 "SHAPE= argument to C_F_POINTER() must have size equal to the rank of FPTR="_err_en_US);
3166 }
3167 }
3168 }
3169 }
3170 }
3171 }
3172 }
3173 if (dummies.size() == 2) {
3174 DynamicType shapeType{TypeCategory::Integer, defaults_.sizeIntegerKind()};
3175 if (arguments[2]) {
3176 if (auto type{arguments[2]->GetType()}) {
3177 if (type->category() == TypeCategory::Integer) {
3178 shapeType = *type;
3179 }
3180 }
3181 }
3182 characteristics::DummyDataObject shape{
3183 characteristics::TypeAndShape{shapeType, 1}};
3184 shape.intent = common::Intent::In;
3185 shape.attrs.set(characteristics::DummyDataObject::Attr::Optional);
3186 dummies.emplace_back("shape"s, std::move(shape));
3187 return SpecificCall{
3188 SpecificIntrinsic{"__builtin_c_f_pointer"s,
3189 characteristics::Procedure{std::move(dummies), attrs}},
3190 std::move(arguments)};
3191 } else {
3192 return std::nullopt;
3193 }
3194}
3195
3196// Function C_LOC(X) from intrinsic module ISO_C_BINDING (18.2.3.6)
3197std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
3198 ActualArguments &arguments, FoldingContext &context) const {
3199 static const char *const keywords[]{"x", nullptr};
3200 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords)) {
3201 CHECK(arguments.size() == 1);
3202 CheckForCoindexedObject(context.messages(), arguments[0], "c_loc", "x");
3203 const auto *expr{arguments[0].value().UnwrapExpr()};
3204 if (expr &&
3205 !(IsObjectPointer(*expr) ||
3206 (IsVariable(*expr) && GetLastTarget(GetSymbolVector(*expr))))) {
3207 context.messages().Say(arguments[0]->sourceLocation(),
3208 "C_LOC() argument must be a data pointer or target"_err_en_US);
3209 }
3210 if (auto typeAndShape{characteristics::TypeAndShape::Characterize(
3211 arguments[0], context)}) {
3212 if (expr && !IsContiguous(*expr, context).value_or(true)) {
3213 context.messages().Say(arguments[0]->sourceLocation(),
3214 "C_LOC() argument must be contiguous"_err_en_US);
3215 }
3216 if (auto constExtents{AsConstantExtents(context, typeAndShape->shape())};
3217 constExtents && GetSize(*constExtents) == 0) {
3218 context.messages().Say(arguments[0]->sourceLocation(),
3219 "C_LOC() argument may not be a zero-sized array"_err_en_US);
3220 }
3221 if (!(typeAndShape->type().category() != TypeCategory::Derived ||
3222 typeAndShape->type().IsAssumedType() ||
3223 (!typeAndShape->type().IsPolymorphic() &&
3224 CountNonConstantLenParameters(
3225 typeAndShape->type().GetDerivedTypeSpec()) == 0))) {
3226 context.messages().Say(arguments[0]->sourceLocation(),
3227 "C_LOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter"_err_en_US);
3228 } else if (typeAndShape->type().knownLength().value_or(1) == 0) {
3229 context.messages().Say(arguments[0]->sourceLocation(),
3230 "C_LOC() argument may not be zero-length character"_err_en_US);
3231 } else if (typeAndShape->type().category() != TypeCategory::Derived &&
3232 !IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true)) {
3233 if (typeAndShape->type().category() == TypeCategory::Character &&
3234 typeAndShape->type().kind() == 1) {
3235 // Default character kind, but length is not known to be 1
3236 if (context.languageFeatures().ShouldWarn(
3237 common::UsageWarning::CharacterInteroperability)) {
3238 context.messages().Say(
3239 common::UsageWarning::CharacterInteroperability,
3240 arguments[0]->sourceLocation(),
3241 "C_LOC() argument has non-interoperable character length"_warn_en_US);
3242 }
3243 } else if (context.languageFeatures().ShouldWarn(
3244 common::UsageWarning::Interoperability)) {
3245 context.messages().Say(common::UsageWarning::Interoperability,
3246 arguments[0]->sourceLocation(),
3247 "C_LOC() argument has non-interoperable intrinsic type or kind"_warn_en_US);
3248 }
3249 }
3250
3251 characteristics::DummyDataObject ddo{std::move(*typeAndShape)};
3252 ddo.intent = common::Intent::In;
3253 return SpecificCall{
3254 SpecificIntrinsic{"__builtin_c_loc"s,
3255 characteristics::Procedure{
3256 characteristics::FunctionResult{
3257 DynamicType{GetBuiltinDerivedType(
3258 builtinsScope_, "__builtin_c_ptr")}},
3259 characteristics::DummyArguments{
3260 characteristics::DummyArgument{"x"s, std::move(ddo)}},
3261 characteristics::Procedure::Attrs{
3262 characteristics::Procedure::Attr::Pure}}},
3263 std::move(arguments)};
3264 }
3265 }
3266 return std::nullopt;
3267}
3268
3269// CUDA Fortran C_DEVLOC(x)
3270std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Devloc(
3271 ActualArguments &arguments, FoldingContext &context) const {
3272 static const char *const keywords[]{"cptr", nullptr};
3273
3274 if (CheckAndRearrangeArguments(arguments, context.messages(), keywords)) {
3275 CHECK(arguments.size() == 1);
3276 const auto *expr{arguments[0].value().UnwrapExpr()};
3277 if (auto typeAndShape{characteristics::TypeAndShape::Characterize(
3278 arguments[0], context)}) {
3279 if (expr && !IsContiguous(*expr, context).value_or(true)) {
3280 context.messages().Say(arguments[0]->sourceLocation(),
3281 "C_DEVLOC() argument must be contiguous"_err_en_US);
3282 }
3283 if (auto constExtents{AsConstantExtents(context, typeAndShape->shape())};
3284 constExtents && GetSize(*constExtents) == 0) {
3285 context.messages().Say(arguments[0]->sourceLocation(),
3286 "C_DEVLOC() argument may not be a zero-sized array"_err_en_US);
3287 }
3288 if (!(typeAndShape->type().category() != TypeCategory::Derived ||
3289 typeAndShape->type().IsAssumedType() ||
3290 (!typeAndShape->type().IsPolymorphic() &&
3291 CountNonConstantLenParameters(
3292 typeAndShape->type().GetDerivedTypeSpec()) == 0))) {
3293 context.messages().Say(arguments[0]->sourceLocation(),
3294 "C_DEVLOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter"_err_en_US);
3295 } else if (typeAndShape->type().knownLength().value_or(1) == 0) {
3296 context.messages().Say(arguments[0]->sourceLocation(),
3297 "C_DEVLOC() argument may not be zero-length character"_err_en_US);
3298 } else if (typeAndShape->type().category() != TypeCategory::Derived &&
3299 !IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true)) {
3300 if (typeAndShape->type().category() == TypeCategory::Character &&
3301 typeAndShape->type().kind() == 1) {
3302 // Default character kind, but length is not known to be 1
3303 if (context.languageFeatures().ShouldWarn(
3304 common::UsageWarning::CharacterInteroperability)) {
3305 context.messages().Say(
3306 common::UsageWarning::CharacterInteroperability,
3307 arguments[0]->sourceLocation(),
3308 "C_DEVLOC() argument has non-interoperable character length"_warn_en_US);
3309 }
3310 } else if (context.languageFeatures().ShouldWarn(
3311 common::UsageWarning::Interoperability)) {
3312 context.messages().Say(common::UsageWarning::Interoperability,
3313 arguments[0]->sourceLocation(),
3314 "C_DEVLOC() argument has non-interoperable intrinsic type or kind"_warn_en_US);
3315 }
3316 }
3317
3318 characteristics::DummyDataObject ddo{std::move(*typeAndShape)};
3319 ddo.intent = common::Intent::In;
3320 return SpecificCall{
3321 SpecificIntrinsic{"__builtin_c_devloc"s,
3322 characteristics::Procedure{
3323 characteristics::FunctionResult{
3324 DynamicType{GetBuiltinDerivedType(
3325 builtinsScope_, "__builtin_c_devptr")}},
3326 characteristics::DummyArguments{
3327 characteristics::DummyArgument{"cptr"s, std::move(ddo)}},
3328 characteristics::Procedure::Attrs{
3329 characteristics::Procedure::Attr::Pure}}},
3330 std::move(arguments)};
3331 }
3332 }
3333 return std::nullopt;
3334}
3335
3336static bool CheckForNonPositiveValues(FoldingContext &context,
3337 const ActualArgument &arg, const std::string &procName,
3338 const std::string &argName) {
3339 bool ok{true};
3340 if (arg.Rank() > 0) {
3341 if (const Expr<SomeType> *expr{arg.UnwrapExpr()}) {
3342 if (const auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
3343 Fortran::common::visit(
3344 [&](const auto &kindExpr) {
3345 using IntType = typename std::decay_t<decltype(kindExpr)>::Result;
3346 if (const auto *constArray{
3347 UnwrapConstantValue<IntType>(kindExpr)}) {
3348 for (std::size_t j{0}; j < constArray->size(); ++j) {
3349 auto arrayExpr{constArray->values().at(j)};
3350 if (arrayExpr.IsNegative() || arrayExpr.IsZero()) {
3351 ok = false;
3352 context.messages().Say(arg.sourceLocation(),
3353 "'%s=' argument for intrinsic '%s' must contain all positive values"_err_en_US,
3354 argName, procName);
3355 }
3356 }
3357 }
3358 },
3359 intExpr->u);
3360 }
3361 }
3362 } else {
3363 if (auto val{ToInt64(arg.UnwrapExpr())}) {
3364 if (*val <= 0) {
3365 ok = false;
3366 context.messages().Say(arg.sourceLocation(),
3367 "'%s=' argument for intrinsic '%s' must be a positive value, but is %jd"_err_en_US,
3368 argName, procName, static_cast<std::intmax_t>(*val));
3369 }
3370 }
3371 }
3372 return ok;
3373}
3374
3375static bool CheckAtomicDefineAndRef(FoldingContext &context,
3376 const std::optional<ActualArgument> &atomArg,
3377 const std::optional<ActualArgument> &valueArg,
3378 const std::optional<ActualArgument> &statArg, const std::string &procName) {
3379 bool sameType{true};
3380 if (valueArg && atomArg) {
3381 // for atomic_define and atomic_ref, 'value' arg must be the same type as
3382 // 'atom', but it doesn't have to be the same kind
3383 if (valueArg->GetType()->category() != atomArg->GetType()->category()) {
3384 sameType = false;
3385 context.messages().Say(valueArg->sourceLocation(),
3386 "'value=' argument to '%s' must have same type as 'atom=', but is '%s'"_err_en_US,
3387 procName, valueArg->GetType()->AsFortran());
3388 }
3389 }
3390
3391 return sameType &&
3392 CheckForCoindexedObject(context.messages(), statArg, procName, "stat");
3393}
3394
3395// Applies any semantic checks peculiar to an intrinsic.
3396// TODO: Move the rest of these checks to Semantics/check-call.cpp.
3397static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
3398 bool ok{true};
3399 const std::string &name{call.specificIntrinsic.name};
3400 if (name == "allocated") {
3401 const auto &arg{call.arguments[0]};
3402 if (arg) {
3403 if (const auto *expr{arg->UnwrapExpr()}) {
3404 ok = IsAllocatableDesignator(*expr) || IsNullAllocatable(expr);
3405 }
3406 }
3407 if (!ok) {
3408 context.messages().Say(
3409 arg ? arg->sourceLocation() : context.messages().at(),
3410 "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
3411 }
3412 } else if (name == "atomic_add" || name == "atomic_and" ||
3413 name == "atomic_or" || name == "atomic_xor" || name == "event_query") {
3414 return CheckForCoindexedObject(
3415 context.messages(), call.arguments[2], name, "stat");
3416 } else if (name == "atomic_cas") {
3417 return CheckForCoindexedObject(
3418 context.messages(), call.arguments[4], name, "stat");
3419 } else if (name == "atomic_define") {
3420 return CheckAtomicDefineAndRef(
3421 context, call.arguments[0], call.arguments[1], call.arguments[2], name);
3422 } else if (name == "atomic_fetch_add" || name == "atomic_fetch_and" ||
3423 name == "atomic_fetch_or" || name == "atomic_fetch_xor") {
3424 return CheckForCoindexedObject(
3425 context.messages(), call.arguments[3], name, "stat");
3426 } else if (name == "atomic_ref") {
3427 return CheckAtomicDefineAndRef(
3428 context, call.arguments[1], call.arguments[0], call.arguments[2], name);
3429 } else if (name == "co_broadcast" || name == "co_max" || name == "co_min" ||
3430 name == "co_sum") {
3431 bool aOk{CheckForCoindexedObject(
3432 context.messages(), call.arguments[0], name, "a")};
3433 bool statOk{CheckForCoindexedObject(
3434 context.messages(), call.arguments[2], name, "stat")};
3435 bool errmsgOk{CheckForCoindexedObject(
3436 context.messages(), call.arguments[3], name, "errmsg")};
3437 ok = aOk && statOk && errmsgOk;
3438 } else if (name == "image_status") {
3439 if (const auto &arg{call.arguments[0]}) {
3440 ok = CheckForNonPositiveValues(context, *arg, name, "image");
3441 }
3442 } else if (name == "loc") {
3443 const auto &arg{call.arguments[0]};
3444 ok =
3445 arg && (arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr()));
3446 if (!ok) {
3447 context.messages().Say(
3448 arg ? arg->sourceLocation() : context.messages().at(),
3449 "Argument of LOC() must be an object or procedure"_err_en_US);
3450 }
3451 }
3452 return ok;
3453}
3454
3455static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
3456 const common::IntrinsicTypeDefaultKinds &defaults) {
3457 TypeCategory category{TypeCategory::Integer};
3458 switch (interface.result.kindCode) {
3459 case KindCode::defaultIntegerKind:
3460 break;
3461 case KindCode::doublePrecision:
3462 case KindCode::quadPrecision:
3463 case KindCode::defaultRealKind:
3464 category = TypeCategory::Real;
3465 break;
3466 default:
3467 CRASH_NO_CASE;
3468 }
3469 int kind{interface.result.kindCode == KindCode::doublePrecision
3470 ? defaults.doublePrecisionKind()
3471 : interface.result.kindCode == KindCode::quadPrecision
3472 ? defaults.quadPrecisionKind()
3473 : defaults.GetDefaultKind(category)};
3474 return DynamicType{category, kind};
3475}
3476
3477// Probe the configured intrinsic procedure pattern tables in search of a
3478// match for a given procedure reference.
3479std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
3480 const CallCharacteristics &call, ActualArguments &arguments,
3481 FoldingContext &context) const {
3482
3483 // All special cases handled here before the table probes below must
3484 // also be recognized as special names in IsIntrinsicSubroutine().
3485 if (call.isSubroutineCall) {
3486 if (call.name == "__builtin_c_f_pointer") {
3487 return HandleC_F_Pointer(arguments, context);
3488 } else if (call.name == "random_seed") {
3489 int optionalCount{0};
3490 for (const auto &arg : arguments) {
3491 if (const auto *expr{arg->UnwrapExpr()}) {
3492 optionalCount +=
3493 Fortran::evaluate::MayBePassedAsAbsentOptional(*expr);
3494 }
3495 }
3496 if (arguments.size() - optionalCount > 1) {
3497 context.messages().Say(
3498 "RANDOM_SEED must have either 1 or no arguments"_err_en_US);
3499 }
3500 }
3501 } else { // function
3502 if (call.name == "__builtin_c_loc") {
3503 return HandleC_Loc(arguments, context);
3504 } else if (call.name == "__builtin_c_devloc") {
3505 return HandleC_Devloc(arguments, context);
3506 } else if (call.name == "null") {
3507 return HandleNull(arguments, context);
3508 }
3509 }
3510
3511 if (call.isSubroutineCall) {
3512 const std::string &name{ResolveAlias(call.name)};
3513 auto subrRange{subroutines_.equal_range(name)};
3514 for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) {
3515 if (auto specificCall{iter->second->Match(
3516 call, defaults_, arguments, context, builtinsScope_)}) {
3517 ApplySpecificChecks(*specificCall, context);
3518 return specificCall;
3519 }
3520 }
3521 if (IsIntrinsicFunction(call.name) && !IsDualIntrinsic(call.name)) {
3522 context.messages().Say(
3523 "Cannot use intrinsic function '%s' as a subroutine"_err_en_US,
3524 call.name);
3525 }
3526 return std::nullopt;
3527 }
3528
3529 // Helper to avoid emitting errors before it is sure there is no match
3530 parser::Messages localBuffer;
3531 parser::Messages *finalBuffer{context.messages().messages()};
3532 parser::ContextualMessages localMessages{
3533 context.messages().at(), finalBuffer ? &localBuffer : nullptr};
3534 FoldingContext localContext{context, localMessages};
3535 auto matchOrBufferMessages{
3536 [&](const IntrinsicInterface &intrinsic,
3537 parser::Messages &buffer) -> std::optional<SpecificCall> {
3538 if (auto specificCall{intrinsic.Match(
3539 call, defaults_, arguments, localContext, builtinsScope_)}) {
3540 if (finalBuffer) {
3541 finalBuffer->Annex(std::move(localBuffer));
3542 }
3543 return specificCall;
3544 } else if (buffer.empty()) {
3545 buffer.Annex(std::move(localBuffer));
3546 } else {
3547 // When there are multiple entries in the table for an
3548 // intrinsic that has multiple forms depending on the
3549 // presence of DIM=, use messages from a later entry if
3550 // the messages from an earlier entry complain about the
3551 // DIM= argument and it wasn't specified with a keyword.
3552 for (const auto &m : buffer.messages()) {
3553 if (m.ToString().find("'dim='") != std::string::npos) {
3554 bool hadDimKeyword{false};
3555 for (const auto &a : arguments) {
3556 if (a) {
3557 if (auto kw{a->keyword()}; kw && kw == "dim") {
3558 hadDimKeyword = true;
3559 break;
3560 }
3561 }
3562 }
3563 if (!hadDimKeyword) {
3564 buffer = std::move(localBuffer);
3565 }
3566 break;
3567 }
3568 }
3569 localBuffer.clear();
3570 }
3571 return std::nullopt;
3572 }};
3573
3574 // Probe the generic intrinsic function table first; allow for
3575 // the use of a legacy alias.
3576 parser::Messages genericBuffer;
3577 const std::string &name{ResolveAlias(call.name)};
3578 auto genericRange{genericFuncs_.equal_range(name)};
3579 for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) {
3580 if (auto specificCall{
3581 matchOrBufferMessages(*iter->second, genericBuffer)}) {
3582 ApplySpecificChecks(*specificCall, context);
3583 return specificCall;
3584 }
3585 }
3586
3587 // Probe the specific intrinsic function table next.
3588 parser::Messages specificBuffer;
3589 auto specificRange{specificFuncs_.equal_range(call.name)};
3590 for (auto specIter{specificRange.first}; specIter != specificRange.second;
3591 ++specIter) {
3592 // We only need to check the cases with distinct generic names.
3593 if (const char *genericName{specIter->second->generic}) {
3594 if (auto specificCall{
3595 matchOrBufferMessages(*specIter->second, specificBuffer)}) {
3596 if (!specIter->second->useGenericAndForceResultType) {
3597 specificCall->specificIntrinsic.name = genericName;
3598 }
3599 specificCall->specificIntrinsic.isRestrictedSpecific =
3600 specIter->second->isRestrictedSpecific;
3601 // TODO test feature AdditionalIntrinsics, warn on nonstandard
3602 // specifics with DoublePrecisionComplex arguments.
3603 return specificCall;
3604 }
3605 }
3606 }
3607
3608 // If there was no exact match with a specific, try to match the related
3609 // generic and convert the result to the specific required type.
3610 if (context.languageFeatures().IsEnabled(common::LanguageFeature::
3611 UseGenericIntrinsicWhenSpecificDoesntMatch)) {
3612 for (auto specIter{specificRange.first}; specIter != specificRange.second;
3613 ++specIter) {
3614 // We only need to check the cases with distinct generic names.
3615 if (const char *genericName{specIter->second->generic}) {
3616 if (specIter->second->useGenericAndForceResultType) {
3617 auto genericRange{genericFuncs_.equal_range(genericName)};
3618 for (auto genIter{genericRange.first}; genIter != genericRange.second;
3619 ++genIter) {
3620 if (auto specificCall{
3621 matchOrBufferMessages(*genIter->second, specificBuffer)}) {
3622 // Force the call result type to the specific intrinsic result
3623 // type, if possible.
3624 DynamicType genericType{
3625 DEREF(specificCall->specificIntrinsic.characteristics.value()
3626 .functionResult.value()
3627 .GetTypeAndShape())
3628 .type()};
3629 DynamicType newType{GetReturnType(*specIter->second, defaults_)};
3630 if (genericType.category() == newType.category() ||
3631 ((genericType.category() == TypeCategory::Integer ||
3632 genericType.category() == TypeCategory::Real) &&
3633 (newType.category() == TypeCategory::Integer ||
3634 newType.category() == TypeCategory::Real))) {
3635 if (context.languageFeatures().ShouldWarn(
3636 common::LanguageFeature::
3637 UseGenericIntrinsicWhenSpecificDoesntMatch)) {
3638 context.messages().Say(
3639 common::LanguageFeature::
3640 UseGenericIntrinsicWhenSpecificDoesntMatch,
3641 "Argument types do not match specific intrinsic '%s' requirements; using '%s' generic instead and converting the result to %s if needed"_port_en_US,
3642 call.name, genericName, newType.AsFortran());
3643 }
3644 specificCall->specificIntrinsic.name = call.name;
3645 specificCall->specificIntrinsic.characteristics.value()
3646 .functionResult.value()
3647 .SetType(newType);
3648 return specificCall;
3649 }
3650 }
3651 }
3652 }
3653 }
3654 }
3655 }
3656
3657 if (specificBuffer.empty() && genericBuffer.empty() &&
3658 IsIntrinsicSubroutine(call.name) && !IsDualIntrinsic(call.name)) {
3659 context.messages().Say(
3660 "Cannot use intrinsic subroutine '%s' as a function"_err_en_US,
3661 call.name);
3662 }
3663
3664 // No match; report the right errors, if any
3665 if (finalBuffer) {
3666 if (specificBuffer.empty()) {
3667 finalBuffer->Annex(std::move(genericBuffer));
3668 } else {
3669 finalBuffer->Annex(std::move(specificBuffer));
3670 }
3671 }
3672 return std::nullopt;
3673}
3674
3675std::optional<SpecificIntrinsicFunctionInterface>
3676IntrinsicProcTable::Implementation::IsSpecificIntrinsicFunction(
3677 const std::string &name) const {
3678 auto specificRange{specificFuncs_.equal_range(name)};
3679 for (auto iter{specificRange.first}; iter != specificRange.second; ++iter) {
3680 const SpecificIntrinsicInterface &specific{*iter->second};
3681 std::string genericName{name};
3682 if (specific.generic) {
3683 genericName = std::string(specific.generic);
3684 }
3685 characteristics::FunctionResult fResult{GetSpecificType(specific.result)};
3686 characteristics::DummyArguments args;
3687 int dummies{specific.CountArguments()};
3688 for (int j{0}; j < dummies; ++j) {
3689 characteristics::DummyDataObject dummy{
3690 GetSpecificType(specific.dummy[j].typePattern)};
3691 dummy.intent = specific.dummy[j].intent;
3692 args.emplace_back(
3693 std::string{specific.dummy[j].keyword}, std::move(dummy));
3694 }
3695 characteristics::Procedure::Attrs attrs;
3696 attrs.set(characteristics::Procedure::Attr::Pure)
3697 .set(characteristics::Procedure::Attr::Elemental);
3698 characteristics::Procedure chars{
3699 std::move(fResult), std::move(args), attrs};
3700 return SpecificIntrinsicFunctionInterface{
3701 std::move(chars), genericName, specific.isRestrictedSpecific};
3702 }
3703 return std::nullopt;
3704}
3705
3706DynamicType IntrinsicProcTable::Implementation::GetSpecificType(
3707 const TypePattern &pattern) const {
3708 const CategorySet &set{pattern.categorySet};
3709 CHECK(set.count() == 1);
3710 TypeCategory category{set.LeastElement().value()};
3711 if (pattern.kindCode == KindCode::doublePrecision) {
3712 return DynamicType{category, defaults_.doublePrecisionKind()};
3713 } else if (pattern.kindCode == KindCode::quadPrecision) {
3714 return DynamicType{category, defaults_.quadPrecisionKind()};
3715 } else if (category == TypeCategory::Character) {
3716 // All character arguments to specific intrinsic functions are
3717 // assumed-length.
3718 return DynamicType{defaults_.GetDefaultKind(category), assumedLen_};
3719 } else {
3720 return DynamicType{category, defaults_.GetDefaultKind(category)};
3721 }
3722}
3723
3724IntrinsicProcTable::~IntrinsicProcTable() = default;
3725
3726IntrinsicProcTable IntrinsicProcTable::Configure(
3727 const common::IntrinsicTypeDefaultKinds &defaults) {
3728 IntrinsicProcTable result;
3729 result.impl_ = std::make_unique<IntrinsicProcTable::Implementation>(defaults);
3730 return result;
3731}
3732
3733void IntrinsicProcTable::SupplyBuiltins(
3734 const semantics::Scope &builtins) const {
3735 DEREF(impl_.get()).SupplyBuiltins(builtins);
3736}
3737
3738bool IntrinsicProcTable::IsIntrinsic(const std::string &name) const {
3739 return DEREF(impl_.get()).IsIntrinsic(name);
3740}
3741bool IntrinsicProcTable::IsIntrinsicFunction(const std::string &name) const {
3742 return DEREF(impl_.get()).IsIntrinsicFunction(name);
3743}
3744bool IntrinsicProcTable::IsIntrinsicSubroutine(const std::string &name) const {
3745 return DEREF(impl_.get()).IsIntrinsicSubroutine(name);
3746}
3747
3748IntrinsicClass IntrinsicProcTable::GetIntrinsicClass(
3749 const std::string &name) const {
3750 return DEREF(impl_.get()).GetIntrinsicClass(name);
3751}
3752
3753std::string IntrinsicProcTable::GetGenericIntrinsicName(
3754 const std::string &name) const {
3755 return DEREF(impl_.get()).GetGenericIntrinsicName(name);
3756}
3757
3758std::optional<SpecificCall> IntrinsicProcTable::Probe(
3759 const CallCharacteristics &call, ActualArguments &arguments,
3760 FoldingContext &context) const {
3761 return DEREF(impl_.get()).Probe(call, arguments, context);
3762}
3763
3764std::optional<SpecificIntrinsicFunctionInterface>
3765IntrinsicProcTable::IsSpecificIntrinsicFunction(const std::string &name) const {
3766 return DEREF(impl_.get()).IsSpecificIntrinsicFunction(name);
3767}
3768
3769llvm::raw_ostream &TypePattern::Dump(llvm::raw_ostream &o) const {
3770 if (categorySet == AnyType) {
3771 o << "any type";
3772 } else {
3773 const char *sep = "";
3774 auto set{categorySet};
3775 while (auto least{set.LeastElement()}) {
3776 o << sep << EnumToString(*least);
3777 sep = " or ";
3778 set.reset(*least);
3779 }
3780 }
3781 o << '(' << EnumToString(kindCode) << ')';
3782 return o;
3783}
3784
3785llvm::raw_ostream &IntrinsicDummyArgument::Dump(llvm::raw_ostream &o) const {
3786 if (keyword) {
3787 o << keyword << '=';
3788 }
3789 return typePattern.Dump(o)
3790 << ' ' << EnumToString(rank) << ' ' << EnumToString(optionality)
3791 << EnumToString(intent);
3792}
3793
3794llvm::raw_ostream &IntrinsicInterface::Dump(llvm::raw_ostream &o) const {
3795 o << name;
3796 char sep{'('};
3797 for (const auto &d : dummy) {
3798 if (d.typePattern.kindCode == KindCode::none) {
3799 break;
3800 }
3801 d.Dump(o << sep);
3802 sep = ',';
3803 }
3804 if (sep == '(') {
3805 o << "()";
3806 }
3807 return result.Dump(o << " -> ") << ' ' << EnumToString(rank);
3808}
3809
3810llvm::raw_ostream &IntrinsicProcTable::Implementation::Dump(
3811 llvm::raw_ostream &o) const {
3812 o << "generic intrinsic functions:\n";
3813 for (const auto &iter : genericFuncs_) {
3814 iter.second->Dump(o << iter.first << ": ") << '\n';
3815 }
3816 o << "specific intrinsic functions:\n";
3817 for (const auto &iter : specificFuncs_) {
3818 iter.second->Dump(o << iter.first << ": ");
3819 if (const char *g{iter.second->generic}) {
3820 o << " -> " << g;
3821 }
3822 o << '\n';
3823 }
3824 o << "subroutines:\n";
3825 for (const auto &iter : subroutines_) {
3826 iter.second->Dump(o << iter.first << ": ") << '\n';
3827 }
3828 return o;
3829}
3830
3831llvm::raw_ostream &IntrinsicProcTable::Dump(llvm::raw_ostream &o) const {
3832 return DEREF(impl_.get()).Dump(o);
3833}
3834
3835// In general C846 prohibits allocatable coarrays to be passed to INTENT(OUT)
3836// dummy arguments. This rule does not apply to intrinsics in general.
3837// Some intrinsic explicitly allow coarray allocatable in their description.
3838// It is assumed that unless explicitly allowed for an intrinsic,
3839// this is forbidden.
3840// Since there are very few intrinsic identified that allow this, they are
3841// listed here instead of adding a field in the table.
3842bool AcceptsIntentOutAllocatableCoarray(const std::string &intrinsic) {
3843 return intrinsic == "move_alloc";
3844}
3845} // namespace Fortran::evaluate
3846

source code of flang/lib/Evaluate/intrinsics.cpp