1	//===-- lib/Evaluate/fold-implementation.h --------------------------------===//
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	#ifndef FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
10	#define FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
11
12	#include "character.h"
13	#include "host.h"
14	#include "int-power.h"
15	#include "flang/Common/indirection.h"
16	#include "flang/Common/template.h"
17	#include "flang/Common/unwrap.h"
18	#include "flang/Evaluate/characteristics.h"
19	#include "flang/Evaluate/common.h"
20	#include "flang/Evaluate/constant.h"
21	#include "flang/Evaluate/expression.h"
22	#include "flang/Evaluate/fold.h"
23	#include "flang/Evaluate/formatting.h"
24	#include "flang/Evaluate/intrinsics-library.h"
25	#include "flang/Evaluate/intrinsics.h"
26	#include "flang/Evaluate/shape.h"
27	#include "flang/Evaluate/tools.h"
28	#include "flang/Evaluate/traverse.h"
29	#include "flang/Evaluate/type.h"
30	#include "flang/Parser/message.h"
31	#include "flang/Semantics/scope.h"
32	#include "flang/Semantics/symbol.h"
33	#include "flang/Semantics/tools.h"
34	#include <algorithm>
35	#include <cmath>
36	#include <complex>
37	#include <cstdio>
38	#include <optional>
39	#include <type_traits>
40	#include <variant>
41
42	// Some environments, viz. glibc 2.17 and *BSD, allow the macro HUGE
43	// to leak out of <math.h>.
44	#undef HUGE
45
46	namespace Fortran::evaluate {
47
48	// Don't use Kahan extended precision summation any more when folding
49	// transformational intrinsic functions other than SUM, since it is
50	// not used in the runtime implementations of those functions and we
51	// want results to match.
52	static constexpr bool useKahanSummation{false};
53
54	// Utilities
55	template <typename T> class Folder {
56	public:
57	explicit Folder(FoldingContext &c, bool forOptionalArgument = false)
58	: context_{c}, forOptionalArgument_{forOptionalArgument} {}
59	std::optional<Constant<T>> GetNamedConstant(const Symbol &);
60	std::optional<Constant<T>> ApplySubscripts(const Constant<T> &array,
61	const std::vector<Constant<SubscriptInteger>> &subscripts);
62	std::optional<Constant<T>> ApplyComponent(Constant<SomeDerived> &&,
63	const Symbol &component,
64	const std::vector<Constant<SubscriptInteger>> * = nullptr);
65	std::optional<Constant<T>> GetConstantComponent(
66	Component &, const std::vector<Constant<SubscriptInteger>> * = nullptr);
67	std::optional<Constant<T>> Folding(ArrayRef &);
68	std::optional<Constant<T>> Folding(DataRef &);
69	Expr<T> Folding(Designator<T> &&);
70	Constant<T> *Folding(std::optional<ActualArgument> &);
71
72	Expr<T> CSHIFT(FunctionRef<T> &&);
73	Expr<T> EOSHIFT(FunctionRef<T> &&);
74	Expr<T> MERGE(FunctionRef<T> &&);
75	Expr<T> PACK(FunctionRef<T> &&);
76	Expr<T> RESHAPE(FunctionRef<T> &&);
77	Expr<T> SPREAD(FunctionRef<T> &&);
78	Expr<T> TRANSPOSE(FunctionRef<T> &&);
79	Expr<T> UNPACK(FunctionRef<T> &&);
80
81	Expr<T> TRANSFER(FunctionRef<T> &&);
82
83	private:
84	FoldingContext &context_;
85	bool forOptionalArgument_{false};
86	};
87
88	std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
89	FoldingContext &, Subscript &, const NamedEntity &, int dim);
90
91	// Helper to use host runtime on scalars for folding.
92	template <typename TR, typename... TA>
93	std::optional<std::function<Scalar<TR>(FoldingContext &, Scalar<TA>...)>>
94	GetHostRuntimeWrapper(const std::string &name) {
95	std::vector<DynamicType> argTypes{TA{}.GetType()...};
96	if (auto hostWrapper{GetHostRuntimeWrapper(name, TR{}.GetType(), argTypes)}) {
97	return [hostWrapper](
98	FoldingContext &context, Scalar<TA>... args) -> Scalar<TR> {
99	std::vector<Expr<SomeType>> genericArgs{
100	AsGenericExpr(Constant<TA>{args})...};
101	return GetScalarConstantValue<TR>(
102	(*hostWrapper)(context, std::move(genericArgs)))
103	.value();
104	};
105	}
106	return std::nullopt;
107	}
108
109	// FoldOperation() rewrites expression tree nodes.
110	// If there is any possibility that the rewritten node will
111	// not have the same representation type, the result of
112	// FoldOperation() will be packaged in an Expr<> of the same
113	// specific type.
114
115	// no-op base case
116	template <typename A>
117	common::IfNoLvalue<Expr<ResultType<A>>, A> FoldOperation(
118	FoldingContext &, A &&x) {
119	static_assert(!std::is_same_v<A, Expr<ResultType<A>>>,
120	"call Fold() instead for Expr<>");
121	return Expr<ResultType<A>>{std::move(x)};
122	}
123
124	Component FoldOperation(FoldingContext &, Component &&);
125	NamedEntity FoldOperation(FoldingContext &, NamedEntity &&);
126	Triplet FoldOperation(FoldingContext &, Triplet &&);
127	Subscript FoldOperation(FoldingContext &, Subscript &&);
128	ArrayRef FoldOperation(FoldingContext &, ArrayRef &&);
129	CoarrayRef FoldOperation(FoldingContext &, CoarrayRef &&);
130	DataRef FoldOperation(FoldingContext &, DataRef &&);
131	Substring FoldOperation(FoldingContext &, Substring &&);
132	ComplexPart FoldOperation(FoldingContext &, ComplexPart &&);
133	template <typename T>
134	Expr<T> FoldOperation(FoldingContext &, FunctionRef<T> &&);
135	template <typename T>
136	Expr<T> FoldOperation(FoldingContext &context, Designator<T> &&designator) {
137	return Folder<T>{context}.Folding(std::move(designator));
138	}
139	Expr<TypeParamInquiry::Result> FoldOperation(
140	FoldingContext &, TypeParamInquiry &&);
141	Expr<ImpliedDoIndex::Result> FoldOperation(
142	FoldingContext &context, ImpliedDoIndex &&);
143	template <typename T>
144	Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
145	Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
146
147	template <typename T>
148	std::optional<Constant<T>> Folder<T>::GetNamedConstant(const Symbol &symbol0) {
149	const Symbol &symbol{ResolveAssociations(symbol0)};
150	if (IsNamedConstant(symbol)) {
151	if (const auto *object{
152	symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
153	if (const auto *constant{UnwrapConstantValue<T>(object->init())}) {
154	return *constant;
155	}
156	}
157	}
158	return std::nullopt;
159	}
160
161	template <typename T>
162	std::optional<Constant<T>> Folder<T>::Folding(ArrayRef &aRef) {
163	std::vector<Constant<SubscriptInteger>> subscripts;
164	int dim{0};
165	for (Subscript &ss : aRef.subscript()) {
166	if (auto constant{GetConstantSubscript(context_, ss, aRef.base(), dim++)}) {
167	subscripts.emplace_back(std::move(*constant));
168	} else {
169	return std::nullopt;
170	}
171	}
172	if (Component * component{aRef.base().UnwrapComponent()}) {
173	return GetConstantComponent(*component, &subscripts);
174	} else if (std::optional<Constant<T>> array{
175	GetNamedConstant(aRef.base().GetLastSymbol())}) {
176	return ApplySubscripts(*array, subscripts);
177	} else {
178	return std::nullopt;
179	}
180	}
181
182	template <typename T>
183	std::optional<Constant<T>> Folder<T>::Folding(DataRef &ref) {
184	return common::visit(
185	common::visitors{
186	[this](SymbolRef &sym) { return GetNamedConstant(*sym); },
187	[this](Component &comp) {
188	comp = FoldOperation(context_, std::move(comp));
189	return GetConstantComponent(comp);
190	},
191	[this](ArrayRef &aRef) {
192	aRef = FoldOperation(context_, std::move(aRef));
193	return Folding(aRef);
194	},
195	[](CoarrayRef &) { return std::optional<Constant<T>>{}; },
196	},
197	ref.u);
198	}
199
200	// TODO: This would be more natural as a member function of Constant<T>.
201	template <typename T>
202	std::optional<Constant<T>> Folder<T>::ApplySubscripts(const Constant<T> &array,
203	const std::vector<Constant<SubscriptInteger>> &subscripts) {
204	const auto &shape{array.shape()};
205	const auto &lbounds{array.lbounds()};
206	int rank{GetRank(shape)};
207	CHECK(rank == static_cast<int>(subscripts.size()));
208	std::size_t elements{1};
209	ConstantSubscripts resultShape;
210	ConstantSubscripts ssLB;
211	for (const auto &ss : subscripts) {
212	if (ss.Rank() == 1) {
213	resultShape.push_back(static_cast<ConstantSubscript>(ss.size()));
214	elements *= ss.size();
215	ssLB.push_back(ss.lbounds().front());
216	} else if (ss.Rank() > 1) {
217	return std::nullopt; // error recovery
218	}
219	}
220	ConstantSubscripts ssAt(rank, 0), at(rank, 0), tmp(1, 0);
221	std::vector<Scalar<T>> values;
222	while (elements-- > 0) {
223	bool increment{true};
224	int k{0};
225	for (int j{0}; j < rank; ++j) {
226	if (subscripts[j].Rank() == 0) {
227	at[j] = subscripts[j].GetScalarValue().value().ToInt64();
228	} else {
229	CHECK(k < GetRank(resultShape));
230	tmp[0] = ssLB.at(k) + ssAt.at(k);
231	at[j] = subscripts[j].At(tmp).ToInt64();
232	if (increment) {
233	if (++ssAt[k] == resultShape[k]) {
234	ssAt[k] = 0;
235	} else {
236	increment = false;
237	}
238	}
239	++k;
240	}
241	if (at[j] < lbounds[j] || at[j] >= lbounds[j] + shape[j]) {
242	context_.messages().Say(
243	"Subscript value (%jd) is out of range on dimension %d in reference to a constant array value"_err_en_US,
244	at[j], j + 1);
245	return std::nullopt;
246	}
247	}
248	values.emplace_back(array.At(at));
249	CHECK(!increment || elements == 0);
250	CHECK(k == GetRank(resultShape));
251	}
252	if constexpr (T::category == TypeCategory::Character) {
253	return Constant<T>{array.LEN(), std::move(values), std::move(resultShape)};
254	} else if constexpr (std::is_same_v<T, SomeDerived>) {
255	return Constant<T>{array.result().derivedTypeSpec(), std::move(values),
256	std::move(resultShape)};
257	} else {
258	return Constant<T>{std::move(values), std::move(resultShape)};
259	}
260	}
261
262	template <typename T>
263	std::optional<Constant<T>> Folder<T>::ApplyComponent(
264	Constant<SomeDerived> &&structures, const Symbol &component,
265	const std::vector<Constant<SubscriptInteger>> *subscripts) {
266	if (auto scalar{structures.GetScalarValue()}) {
267	if (std::optional<Expr<SomeType>> expr{scalar->Find(component)}) {
268	if (const Constant<T> *value{UnwrapConstantValue<T>(*expr)}) {
269	if (subscripts) {
270	return ApplySubscripts(*value, *subscripts);
271	} else {
272	return *value;
273	}
274	}
275	}
276	} else {
277	// A(:)%scalar_component & A(:)%array_component(subscripts)
278	std::unique_ptr<ArrayConstructor<T>> array;
279	if (structures.empty()) {
280	return std::nullopt;
281	}
282	ConstantSubscripts at{structures.lbounds()};
283	do {
284	StructureConstructor scalar{structures.At(at)};
285	if (std::optional<Expr<SomeType>> expr{scalar.Find(component)}) {
286	if (const Constant<T> *value{UnwrapConstantValue<T>(expr.value())}) {
287	if (!array.get()) {
288	// This technique ensures that character length or derived type
289	// information is propagated to the array constructor.
290	auto *typedExpr{UnwrapExpr<Expr<T>>(expr.value())};
291	CHECK(typedExpr);
292	array = std::make_unique<ArrayConstructor<T>>(*typedExpr);
293	if constexpr (T::category == TypeCategory::Character) {
294	array->set_LEN(Expr<SubscriptInteger>{value->LEN()});
295	}
296	}
297	if (subscripts) {
298	if (auto element{ApplySubscripts(*value, *subscripts)}) {
299	CHECK(element->Rank() == 0);
300	array->Push(Expr<T>{std::move(*element)});
301	} else {
302	return std::nullopt;
303	}
304	} else {
305	CHECK(value->Rank() == 0);
306	array->Push(Expr<T>{*value});
307	}
308	} else {
309	return std::nullopt;
310	}
311	}
312	} while (structures.IncrementSubscripts(at));
313	// Fold the ArrayConstructor<> into a Constant<>.
314	CHECK(array);
315	Expr<T> result{Fold(context_, Expr<T>{std::move(*array)})};
316	if (auto *constant{UnwrapConstantValue<T>(result)}) {
317	return constant->Reshape(common::Clone(structures.shape()));
318	}
319	}
320	return std::nullopt;
321	}
322
323	template <typename T>
324	std::optional<Constant<T>> Folder<T>::GetConstantComponent(Component &component,
325	const std::vector<Constant<SubscriptInteger>> *subscripts) {
326	if (std::optional<Constant<SomeDerived>> structures{common::visit(
327	common::visitors{
328	[&](const Symbol &symbol) {
329	return Folder<SomeDerived>{context_}.GetNamedConstant(symbol);
330	},
331	[&](ArrayRef &aRef) {
332	return Folder<SomeDerived>{context_}.Folding(aRef);
333	},
334	[&](Component &base) {
335	return Folder<SomeDerived>{context_}.GetConstantComponent(base);
336	},
337	[&](CoarrayRef &) {
338	return std::optional<Constant<SomeDerived>>{};
339	},
340	},
341	component.base().u)}) {
342	return ApplyComponent(
343	std::move(*structures), component.GetLastSymbol(), subscripts);
344	} else {
345	return std::nullopt;
346	}
347	}
348
349	template <typename T> Expr<T> Folder<T>::Folding(Designator<T> &&designator) {
350	if constexpr (T::category == TypeCategory::Character) {
351	if (auto *substring{common::Unwrap<Substring>(designator.u)}) {
352	if (std::optional<Expr<SomeCharacter>> folded{
353	substring->Fold(context_)}) {
354	if (const auto *specific{std::get_if<Expr<T>>(&folded->u)}) {
355	return std::move(*specific);
356	}
357	}
358	// We used to fold zero-length substrings into zero-length
359	// constants here, but that led to problems in variable
360	// definition contexts.
361	}
362	} else if constexpr (T::category == TypeCategory::Real) {
363	if (auto *zPart{std::get_if<ComplexPart>(&designator.u)}) {
364	*zPart = FoldOperation(context_, std::move(*zPart));
365	using ComplexT = Type<TypeCategory::Complex, T::kind>;
366	if (auto zConst{Folder<ComplexT>{context_}.Folding(zPart->complex())}) {
367	return Fold(context_,
368	Expr<T>{ComplexComponent<T::kind>{
369	zPart->part() == ComplexPart::Part::IM,
370	Expr<ComplexT>{std::move(*zConst)}}});
371	} else {
372	return Expr<T>{Designator<T>{std::move(*zPart)}};
373	}
374	}
375	}
376	return common::visit(
377	common::visitors{
378	[&](SymbolRef &&symbol) {
379	if (auto constant{GetNamedConstant(*symbol)}) {
380	return Expr<T>{std::move(*constant)};
381	}
382	return Expr<T>{std::move(designator)};
383	},
384	[&](ArrayRef &&aRef) {
385	aRef = FoldOperation(context_, std::move(aRef));
386	if (auto c{Folding(aRef)}) {
387	return Expr<T>{std::move(*c)};
388	} else {
389	return Expr<T>{Designator<T>{std::move(aRef)}};
390	}
391	},
392	[&](Component &&component) {
393	component = FoldOperation(context_, std::move(component));
394	if (auto c{GetConstantComponent(component)}) {
395	return Expr<T>{std::move(*c)};
396	} else {
397	return Expr<T>{Designator<T>{std::move(component)}};
398	}
399	},
400	[&](auto &&x) {
401	return Expr<T>{
402	Designator<T>{FoldOperation(context_, std::move(x))}};
403	},
404	},
405	std::move(designator.u));
406	}
407
408	// Apply type conversion and re-folding if necessary.
409	// This is where BOZ arguments are converted.
410	template <typename T>
411	Constant<T> *Folder<T>::Folding(std::optional<ActualArgument> &arg) {
412	if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
413	*expr = Fold(context_, std::move(*expr));
414	if constexpr (T::category != TypeCategory::Derived) {
415	if (!UnwrapExpr<Expr<T>>(*expr)) {
416	if (const Symbol *
417	var{forOptionalArgument_
418	? UnwrapWholeSymbolOrComponentDataRef(*expr)
419	: nullptr};
420	var && (IsOptional(*var) || IsAllocatableOrObjectPointer(var))) {
421	// can't safely convert item that may not be present
422	} else if (auto converted{
423	ConvertToType(T::GetType(), std::move(*expr))}) {
424	*expr = Fold(context_, std::move(*converted));
425	}
426	}
427	}
428	return UnwrapConstantValue<T>(*expr);
429	}
430	return nullptr;
431	}
432
433	template <typename... A, std::size_t... I>
434	std::optional<std::tuple<const Constant<A> *...>> GetConstantArgumentsHelper(
435	FoldingContext &context, ActualArguments &arguments,
436	bool hasOptionalArgument, std::index_sequence<I...>) {
437	static_assert(sizeof...(A) > 0);
438	std::tuple<const Constant<A> *...> args{
439	Folder<A>{context, hasOptionalArgument}.Folding(arguments.at(I))...};
440	if ((... && (std::get<I>(args)))) {
441	return args;
442	} else {
443	return std::nullopt;
444	}
445	}
446
447	template <typename... A>
448	std::optional<std::tuple<const Constant<A> *...>> GetConstantArguments(
449	FoldingContext &context, ActualArguments &args, bool hasOptionalArgument) {
450	return GetConstantArgumentsHelper<A...>(
451	context, args, hasOptionalArgument, std::index_sequence_for<A...>{});
452	}
453
454	template <typename... A, std::size_t... I>
455	std::optional<std::tuple<Scalar<A>...>> GetScalarConstantArgumentsHelper(
456	FoldingContext &context, ActualArguments &args, bool hasOptionalArgument,
457	std::index_sequence<I...>) {
458	if (auto constArgs{
459	GetConstantArguments<A...>(context, args, hasOptionalArgument)}) {
460	return std::tuple<Scalar<A>...>{
461	std::get<I>(*constArgs)->GetScalarValue().value()...};
462	} else {
463	return std::nullopt;
464	}
465	}
466
467	template <typename... A>
468	std::optional<std::tuple<Scalar<A>...>> GetScalarConstantArguments(
469	FoldingContext &context, ActualArguments &args, bool hasOptionalArgument) {
470	return GetScalarConstantArgumentsHelper<A...>(
471	context, args, hasOptionalArgument, std::index_sequence_for<A...>{});
472	}
473
474	// helpers to fold intrinsic function references
475	// Define callable types used in a common utility that
476	// takes care of array and cast/conversion aspects for elemental intrinsics
477
478	template <typename TR, typename... TArgs>
479	using ScalarFunc = std::function<Scalar<TR>(const Scalar<TArgs> &...)>;
480	template <typename TR, typename... TArgs>
481	using ScalarFuncWithContext =
482	std::function<Scalar<TR>(FoldingContext &, const Scalar<TArgs> &...)>;
483
484	template <template <typename, typename...> typename WrapperType, typename TR,
485	typename... TA, std::size_t... I>
486	Expr<TR> FoldElementalIntrinsicHelper(FoldingContext &context,
487	FunctionRef<TR> &&funcRef, WrapperType<TR, TA...> func,
488	bool hasOptionalArgument, std::index_sequence<I...>) {
489	if (std::optional<std::tuple<const Constant<TA> *...>> args{
490	GetConstantArguments<TA...>(
491	context, funcRef.arguments(), hasOptionalArgument)}) {
492	// Compute the shape of the result based on shapes of arguments
493	ConstantSubscripts shape;
494	int rank{0};
495	const ConstantSubscripts *shapes[]{&std::get<I>(*args)->shape()...};
496	const int ranks[]{std::get<I>(*args)->Rank()...};
497	for (unsigned int i{0}; i < sizeof...(TA); ++i) {
498	if (ranks[i] > 0) {
499	if (rank == 0) {
500	rank = ranks[i];
501	shape = *shapes[i];
502	} else {
503	if (shape != *shapes[i]) {
504	// TODO: Rank compatibility was already checked but it seems to be
505	// the first place where the actual shapes are checked to be the
506	// same. Shouldn't this be checked elsewhere so that this is also
507	// checked for non constexpr call to elemental intrinsics function?
508	context.messages().Say(
509	"Arguments in elemental intrinsic function are not conformable"_err_en_US);
510	return Expr<TR>{std::move(funcRef)};
511	}
512	}
513	}
514	}
515	CHECK(rank == GetRank(shape));
516	// Compute all the scalar values of the results
517	std::vector<Scalar<TR>> results;
518	std::optional<uint64_t> n{TotalElementCount(shape)};
519	if (!n) {
520	context.messages().Say(
521	"Too many elements in elemental intrinsic function result"_err_en_US);
522	return Expr<TR>{std::move(funcRef)};
523	}
524	if (*n > 0) {
525	ConstantBounds bounds{shape};
526	ConstantSubscripts resultIndex(rank, 1);
527	ConstantSubscripts argIndex[]{std::get<I>(*args)->lbounds()...};
528	do {
529	if constexpr (std::is_same_v<WrapperType<TR, TA...>,
530	ScalarFuncWithContext<TR, TA...>>) {
531	results.emplace_back(
532	func(context, std::get<I>(*args)->At(argIndex[I])...));
533	} else if constexpr (std::is_same_v<WrapperType<TR, TA...>,
534	ScalarFunc<TR, TA...>>) {
535	results.emplace_back(func(std::get<I>(*args)->At(argIndex[I])...));
536	}
537	(std::get<I>(*args)->IncrementSubscripts(argIndex[I]), ...);
538	} while (bounds.IncrementSubscripts(resultIndex));
539	}
540	// Build and return constant result
541	if constexpr (TR::category == TypeCategory::Character) {
542	auto len{static_cast<ConstantSubscript>(
543	results.empty() ? 0 : results[0].length())};
544	return Expr<TR>{Constant<TR>{len, std::move(results), std::move(shape)}};
545	} else if constexpr (TR::category == TypeCategory::Derived) {
546	if (!results.empty()) {
547	return Expr<TR>{rank == 0
548	? Constant<TR>{results.front()}
549	: Constant<TR>{results.front().derivedTypeSpec(),
550	std::move(results), std::move(shape)}};
551	}
552	} else {
553	return Expr<TR>{Constant<TR>{std::move(results), std::move(shape)}};
554	}
555	}
556	return Expr<TR>{std::move(funcRef)};
557	}
558
559	template <typename TR, typename... TA>
560	Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
561	FunctionRef<TR> &&funcRef, ScalarFunc<TR, TA...> func,
562	bool hasOptionalArgument = false) {
563	return FoldElementalIntrinsicHelper<ScalarFunc, TR, TA...>(context,
564	std::move(funcRef), func, hasOptionalArgument,
565	std::index_sequence_for<TA...>{});
566	}
567	template <typename TR, typename... TA>
568	Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
569	FunctionRef<TR> &&funcRef, ScalarFuncWithContext<TR, TA...> func,
570	bool hasOptionalArgument = false) {
571	return FoldElementalIntrinsicHelper<ScalarFuncWithContext, TR, TA...>(context,
572	std::move(funcRef), func, hasOptionalArgument,
573	std::index_sequence_for<TA...>{});
574	}
575
576	std::optional<std::int64_t> GetInt64ArgOr(
577	const std::optional<ActualArgument> &, std::int64_t defaultValue);
578
579	template <typename A, typename B>
580	std::optional<std::vector<A>> GetIntegerVector(const B &x) {
581	static_assert(std::is_integral_v<A>);
582	if (const auto *someInteger{UnwrapExpr<Expr<SomeInteger>>(x)}) {
583	return common::visit(
584	[](const auto &typedExpr) -> std::optional<std::vector<A>> {
585	using T = ResultType<decltype(typedExpr)>;
586	if (const auto *constant{UnwrapConstantValue<T>(typedExpr)}) {
587	if (constant->Rank() == 1) {
588	std::vector<A> result;
589	for (const auto &value : constant->values()) {
590	result.push_back(static_cast<A>(value.ToInt64()));
591	}
592	return result;
593	}
594	}
595	return std::nullopt;
596	},
597	someInteger->u);
598	}
599	return std::nullopt;
600	}
601
602	// Transform an intrinsic function reference that contains user errors
603	// into an intrinsic with the same characteristic but the "invalid" name.
604	// This to prevent generating warnings over and over if the expression
605	// gets re-folded.
606	template <typename T> Expr<T> MakeInvalidIntrinsic(FunctionRef<T> &&funcRef) {
607	SpecificIntrinsic invalid{std::get<SpecificIntrinsic>(funcRef.proc().u)};
608	invalid.name = IntrinsicProcTable::InvalidName;
609	return Expr<T>{FunctionRef<T>{ProcedureDesignator{std::move(invalid)},
610	ActualArguments{std::move(funcRef.arguments())}}};
611	}
612
613	template <typename T> Expr<T> Folder<T>::CSHIFT(FunctionRef<T> &&funcRef) {
614	auto args{funcRef.arguments()};
615	CHECK(args.size() == 3);
616	const auto *array{UnwrapConstantValue<T>(args[0])};
617	const auto *shiftExpr{UnwrapExpr<Expr<SomeInteger>>(args[1])};
618	auto dim{GetInt64ArgOr(args[2], 1)};
619	if (!array || !shiftExpr || !dim) {
620	return Expr<T>{std::move(funcRef)};
621	}
622	auto convertedShift{Fold(context_,
623	ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
624	const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
625	if (!shift) {
626	return Expr<T>{std::move(funcRef)};
627	}
628	// Arguments are constant
629	if (*dim < 1 || *dim > array->Rank()) {
630	context_.messages().Say("Invalid 'dim=' argument (%jd) in CSHIFT"_err_en_US,
631	static_cast<std::intmax_t>(*dim));
632	} else if (shift->Rank() > 0 && shift->Rank() != array->Rank() - 1) {
633	// message already emitted from intrinsic look-up
634	} else {
635	int rank{array->Rank()};
636	int zbDim{static_cast<int>(*dim) - 1};
637	bool ok{true};
638	if (shift->Rank() > 0) {
639	int k{0};
640	for (int j{0}; j < rank; ++j) {
641	if (j != zbDim) {
642	if (array->shape()[j] != shift->shape()[k]) {
643	context_.messages().Say(
644	"Invalid 'shift=' argument in CSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US,
645	k + 1, static_cast<std::intmax_t>(shift->shape()[k]),
646	static_cast<std::intmax_t>(array->shape()[j]));
647	ok = false;
648	}
649	++k;
650	}
651	}
652	}
653	if (ok) {
654	std::vector<Scalar<T>> resultElements;
655	ConstantSubscripts arrayLB{array->lbounds()};
656	ConstantSubscripts arrayAt{arrayLB};
657	ConstantSubscript &dimIndex{arrayAt[zbDim]};
658	ConstantSubscript dimLB{dimIndex}; // initial value
659	ConstantSubscript dimExtent{array->shape()[zbDim]};
660	ConstantSubscripts shiftLB{shift->lbounds()};
661	for (auto n{GetSize(array->shape())}; n > 0; --n) {
662	ConstantSubscript origDimIndex{dimIndex};
663	ConstantSubscripts shiftAt;
664	if (shift->Rank() > 0) {
665	int k{0};
666	for (int j{0}; j < rank; ++j) {
667	if (j != zbDim) {
668	shiftAt.emplace_back(shiftLB[k++] + arrayAt[j] - arrayLB[j]);
669	}
670	}
671	}
672	ConstantSubscript shiftCount{shift->At(shiftAt).ToInt64()};
673	dimIndex = dimLB + ((dimIndex - dimLB + shiftCount) % dimExtent);
674	if (dimIndex < dimLB) {
675	dimIndex += dimExtent;
676	} else if (dimIndex >= dimLB + dimExtent) {
677	dimIndex -= dimExtent;
678	}
679	resultElements.push_back(array->At(arrayAt));
680	dimIndex = origDimIndex;
681	array->IncrementSubscripts(arrayAt);
682	}
683	return Expr<T>{PackageConstant<T>(
684	std::move(resultElements), *array, array->shape())};
685	}
686	}
687	// Invalid, prevent re-folding
688	return MakeInvalidIntrinsic(std::move(funcRef));
689	}
690
691	template <typename T> Expr<T> Folder<T>::EOSHIFT(FunctionRef<T> &&funcRef) {
692	auto args{funcRef.arguments()};
693	CHECK(args.size() == 4);
694	const auto *array{UnwrapConstantValue<T>(args[0])};
695	const auto *shiftExpr{UnwrapExpr<Expr<SomeInteger>>(args[1])};
696	auto dim{GetInt64ArgOr(args[3], 1)};
697	if (!array || !shiftExpr || !dim) {
698	return Expr<T>{std::move(funcRef)};
699	}
700	// Apply type conversions to the shift= and boundary= arguments.
701	auto convertedShift{Fold(context_,
702	ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
703	const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
704	if (!shift) {
705	return Expr<T>{std::move(funcRef)};
706	}
707	const Constant<T> *boundary{nullptr};
708	std::optional<Expr<SomeType>> convertedBoundary;
709	if (const auto *boundaryExpr{UnwrapExpr<Expr<SomeType>>(args[2])}) {
710	convertedBoundary = Fold(context_,
711	ConvertToType(array->GetType(), Expr<SomeType>{*boundaryExpr}));
712	boundary = UnwrapExpr<Constant<T>>(convertedBoundary);
713	if (!boundary) {
714	return Expr<T>{std::move(funcRef)};
715	}
716	}
717	// Arguments are constant
718	if (*dim < 1 || *dim > array->Rank()) {
719	context_.messages().Say(
720	"Invalid 'dim=' argument (%jd) in EOSHIFT"_err_en_US,
721	static_cast<std::intmax_t>(*dim));
722	} else if (shift->Rank() > 0 && shift->Rank() != array->Rank() - 1) {
723	// message already emitted from intrinsic look-up
724	} else if (boundary && boundary->Rank() > 0 &&
725	boundary->Rank() != array->Rank() - 1) {
726	// ditto
727	} else {
728	int rank{array->Rank()};
729	int zbDim{static_cast<int>(*dim) - 1};
730	bool ok{true};
731	if (shift->Rank() > 0) {
732	int k{0};
733	for (int j{0}; j < rank; ++j) {
734	if (j != zbDim) {
735	if (array->shape()[j] != shift->shape()[k]) {
736	context_.messages().Say(
737	"Invalid 'shift=' argument in EOSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US,
738	k + 1, static_cast<std::intmax_t>(shift->shape()[k]),
739	static_cast<std::intmax_t>(array->shape()[j]));
740	ok = false;
741	}
742	++k;
743	}
744	}
745	}
746	if (boundary && boundary->Rank() > 0) {
747	int k{0};
748	for (int j{0}; j < rank; ++j) {
749	if (j != zbDim) {
750	if (array->shape()[j] != boundary->shape()[k]) {
751	context_.messages().Say(
752	"Invalid 'boundary=' argument in EOSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US,
753	k + 1, static_cast<std::intmax_t>(boundary->shape()[k]),
754	static_cast<std::intmax_t>(array->shape()[j]));
755	ok = false;
756	}
757	++k;
758	}
759	}
760	}
761	if (ok) {
762	std::vector<Scalar<T>> resultElements;
763	ConstantSubscripts arrayLB{array->lbounds()};
764	ConstantSubscripts arrayAt{arrayLB};
765	ConstantSubscript &dimIndex{arrayAt[zbDim]};
766	ConstantSubscript dimLB{dimIndex}; // initial value
767	ConstantSubscript dimExtent{array->shape()[zbDim]};
768	ConstantSubscripts shiftLB{shift->lbounds()};
769	ConstantSubscripts boundaryLB;
770	if (boundary) {
771	boundaryLB = boundary->lbounds();
772	}
773	for (auto n{GetSize(array->shape())}; n > 0; --n) {
774	ConstantSubscript origDimIndex{dimIndex};
775	ConstantSubscripts shiftAt;
776	if (shift->Rank() > 0) {
777	int k{0};
778	for (int j{0}; j < rank; ++j) {
779	if (j != zbDim) {
780	shiftAt.emplace_back(shiftLB[k++] + arrayAt[j] - arrayLB[j]);
781	}
782	}
783	}
784	ConstantSubscript shiftCount{shift->At(shiftAt).ToInt64()};
785	dimIndex += shiftCount;
786	if (dimIndex >= dimLB && dimIndex < dimLB + dimExtent) {
787	resultElements.push_back(array->At(arrayAt));
788	} else if (boundary) {
789	ConstantSubscripts boundaryAt;
790	if (boundary->Rank() > 0) {
791	for (int j{0}; j < rank; ++j) {
792	int k{0};
793	if (j != zbDim) {
794	boundaryAt.emplace_back(
795	boundaryLB[k++] + arrayAt[j] - arrayLB[j]);
796	}
797	}
798	}
799	resultElements.push_back(boundary->At(boundaryAt));
800	} else if constexpr (T::category == TypeCategory::Integer ||
801	T::category == TypeCategory::Unsigned ||
802	T::category == TypeCategory::Real ||
803	T::category == TypeCategory::Complex ||
804	T::category == TypeCategory::Logical) {
805	resultElements.emplace_back();
806	} else if constexpr (T::category == TypeCategory::Character) {
807	auto len{static_cast<std::size_t>(array->LEN())};
808	typename Scalar<T>::value_type space{' '};
809	resultElements.emplace_back(len, space);
810	} else {
811	DIE("no derived type boundary");
812	}
813	dimIndex = origDimIndex;
814	array->IncrementSubscripts(arrayAt);
815	}
816	return Expr<T>{PackageConstant<T>(
817	std::move(resultElements), *array, array->shape())};
818	}
819	}
820	// Invalid, prevent re-folding
821	return MakeInvalidIntrinsic(std::move(funcRef));
822	}
823
824	template <typename T> Expr<T> Folder<T>::MERGE(FunctionRef<T> &&funcRef) {
825	return FoldElementalIntrinsic<T, T, T, LogicalResult>(context_,
826	std::move(funcRef),
827	ScalarFunc<T, T, T, LogicalResult>(
828	[](const Scalar<T> &ifTrue, const Scalar<T> &ifFalse,
829	const Scalar<LogicalResult> &predicate) -> Scalar<T> {
830	return predicate.IsTrue() ? ifTrue : ifFalse;
831	}));
832	}
833
834	template <typename T> Expr<T> Folder<T>::PACK(FunctionRef<T> &&funcRef) {
835	auto args{funcRef.arguments()};
836	CHECK(args.size() == 3);
837	const auto *array{UnwrapConstantValue<T>(args[0])};
838	const auto *vector{UnwrapConstantValue<T>(args[2])};
839	auto convertedMask{Fold(context_,
840	ConvertToType<LogicalResult>(
841	Expr<SomeLogical>{DEREF(UnwrapExpr<Expr<SomeLogical>>(args[1]))}))};
842	const auto *mask{UnwrapConstantValue<LogicalResult>(convertedMask)};
843	if (!array || !mask || (args[2] && !vector)) {
844	return Expr<T>{std::move(funcRef)};
845	}
846	// Arguments are constant.
847	ConstantSubscript arrayElements{GetSize(array->shape())};
848	ConstantSubscript truths{0};
849	ConstantSubscripts maskAt{mask->lbounds()};
850	if (mask->Rank() == 0) {
851	if (mask->At(maskAt).IsTrue()) {
852	truths = arrayElements;
853	}
854	} else if (array->shape() != mask->shape()) {
855	// Error already emitted from intrinsic processing
856	return MakeInvalidIntrinsic(std::move(funcRef));
857	} else {
858	for (ConstantSubscript j{0}; j < arrayElements;
859	++j, mask->IncrementSubscripts(maskAt)) {
860	if (mask->At(maskAt).IsTrue()) {
861	++truths;
862	}
863	}
864	}
865	std::vector<Scalar<T>> resultElements;
866	ConstantSubscripts arrayAt{array->lbounds()};
867	ConstantSubscript resultSize{truths};
868	if (vector) {
869	resultSize = vector->shape().at(0);
870	if (resultSize < truths) {
871	context_.messages().Say(
872	"Invalid 'vector=' argument in PACK: the 'mask=' argument has %jd true elements, but the vector has only %jd elements"_err_en_US,
873	static_cast<std::intmax_t>(truths),
874	static_cast<std::intmax_t>(resultSize));
875	return MakeInvalidIntrinsic(std::move(funcRef));
876	}
877	}
878	for (ConstantSubscript j{0}; j < truths;) {
879	if (mask->At(maskAt).IsTrue()) {
880	resultElements.push_back(array->At(arrayAt));
881	++j;
882	}
883	array->IncrementSubscripts(arrayAt);
884	mask->IncrementSubscripts(maskAt);
885	}
886	if (vector) {
887	ConstantSubscripts vectorAt{vector->lbounds()};
888	vectorAt.at(0) += truths;
889	for (ConstantSubscript j{truths}; j < resultSize; ++j) {
890	resultElements.push_back(vector->At(vectorAt));
891	++vectorAt[0];
892	}
893	}
894	return Expr<T>{PackageConstant<T>(std::move(resultElements), *array,
895	ConstantSubscripts{static_cast<ConstantSubscript>(resultSize)})};
896	}
897
898	template <typename T> Expr<T> Folder<T>::RESHAPE(FunctionRef<T> &&funcRef) {
899	auto args{funcRef.arguments()};
900	CHECK(args.size() == 4);
901	const auto *source{UnwrapConstantValue<T>(args[0])};
902	const auto *pad{UnwrapConstantValue<T>(args[2])};
903	std::optional<std::vector<ConstantSubscript>> shape{
904	GetIntegerVector<ConstantSubscript>(args[1])};
905	std::optional<std::vector<int>> order{GetIntegerVector<int>(args[3])};
906	std::optional<uint64_t> optResultElement;
907	std::optional<std::vector<int>> dimOrder;
908	bool ok{true};
909	if (shape) {
910	if (shape->size() > common::maxRank) {
911	context_.messages().Say(
912	"Size of 'shape=' argument (%zd) must not be greater than %d"_err_en_US,
913	shape->size(), common::maxRank);
914	ok = false;
915	} else if (HasNegativeExtent(*shape)) {
916	context_.messages().Say(
917	"'shape=' argument (%s) must not have a negative extent"_err_en_US,
918	DEREF(args[1]->UnwrapExpr()).AsFortran());
919	ok = false;
920	} else {
921	optResultElement = TotalElementCount(*shape);
922	if (!optResultElement) {
923	context_.messages().Say(
924	"'shape=' argument (%s) specifies an array with too many elements"_err_en_US,
925	DEREF(args[1]->UnwrapExpr()).AsFortran());
926	ok = false;
927	}
928	}
929	if (order) {
930	dimOrder = ValidateDimensionOrder(GetRank(*shape), *order);
931	if (!dimOrder) {
932	context_.messages().Say(
933	"Invalid 'order=' argument (%s) in RESHAPE"_err_en_US,
934	DEREF(args[3]->UnwrapExpr()).AsFortran());
935	ok = false;
936	}
937	}
938	}
939	if (!ok) {
940	// convert into an invalid intrinsic procedure call below
941	} else if (!source || !shape || (args[2] && !pad) || (args[3] && !order)) {
942	return Expr<T>{std::move(funcRef)}; // Non-constant arguments
943	} else {
944	uint64_t resultElements{*optResultElement};
945	std::vector<int> *dimOrderPtr{dimOrder ? &dimOrder.value() : nullptr};
946	if (resultElements > source->size() && (!pad || pad->empty())) {
947	context_.messages().Say(
948	"Too few elements in 'source=' argument and 'pad=' "
949	"argument is not present or has null size"_err_en_US);
950	ok = false;
951	} else {
952	Constant<T> result{!source->empty() || !pad
953	? source->Reshape(std::move(shape.value()))
954	: pad->Reshape(std::move(shape.value()))};
955	ConstantSubscripts subscripts{result.lbounds()};
956	auto copied{result.CopyFrom(*source,
957	std::min(static_cast<uint64_t>(source->size()), resultElements),
958	subscripts, dimOrderPtr)};
959	if (copied < resultElements) {
960	CHECK(pad);
961	copied += result.CopyFrom(
962	*pad, resultElements - copied, subscripts, dimOrderPtr);
963	}
964	CHECK(copied == resultElements);
965	return Expr<T>{std::move(result)};
966	}
967	}
968	// Invalid, prevent re-folding
969	return MakeInvalidIntrinsic(std::move(funcRef));
970	}
971
972	template <typename T> Expr<T> Folder<T>::SPREAD(FunctionRef<T> &&funcRef) {
973	auto args{funcRef.arguments()};
974	CHECK(args.size() == 3);
975	const Constant<T> *source{UnwrapConstantValue<T>(args[0])};
976	auto dim{ToInt64(args[1])};
977	auto ncopies{ToInt64(args[2])};
978	if (!source || !dim) {
979	return Expr<T>{std::move(funcRef)};
980	}
981	int sourceRank{source->Rank()};
982	if (sourceRank >= common::maxRank) {
983	context_.messages().Say(
984	"SOURCE= argument to SPREAD has rank %d but must have rank less than %d"_err_en_US,
985	sourceRank, common::maxRank);
986	} else if (*dim < 1 || *dim > sourceRank + 1) {
987	context_.messages().Say(
988	"DIM=%d argument to SPREAD must be between 1 and %d"_err_en_US, *dim,
989	sourceRank + 1);
990	} else if (!ncopies) {
991	return Expr<T>{std::move(funcRef)};
992	} else {
993	if (*ncopies < 0) {
994	ncopies = 0;
995	}
996	// TODO: Consider moving this implementation (after the user error
997	// checks), along with other transformational intrinsics, into
998	// constant.h (or a new header) so that the transformationals
999	// are available for all Constant<>s without needing to be packaged
1000	// as references to intrinsic functions for folding.
1001	ConstantSubscripts shape{source->shape()};
1002	shape.insert(shape.begin() + *dim - 1, *ncopies);
1003	Constant<T> spread{source->Reshape(std::move(shape))};
1004	std::optional<uint64_t> n{TotalElementCount(spread.shape())};
1005	if (!n) {
1006	context_.messages().Say("Too many elements in SPREAD result"_err_en_US);
1007	} else {
1008	std::vector<int> dimOrder;
1009	for (int j{0}; j < sourceRank; ++j) {
1010	dimOrder.push_back(j < *dim - 1 ? j : j + 1);
1011	}
1012	dimOrder.push_back(*dim - 1);
1013	ConstantSubscripts at{spread.lbounds()}; // all 1
1014	spread.CopyFrom(*source, *n, at, &dimOrder);
1015	return Expr<T>{std::move(spread)};
1016	}
1017	}
1018	// Invalid, prevent re-folding
1019	return MakeInvalidIntrinsic(std::move(funcRef));
1020	}
1021
1022	template <typename T> Expr<T> Folder<T>::TRANSPOSE(FunctionRef<T> &&funcRef) {
1023	auto args{funcRef.arguments()};
1024	CHECK(args.size() == 1);
1025	const auto *matrix{UnwrapConstantValue<T>(args[0])};
1026	if (!matrix) {
1027	return Expr<T>{std::move(funcRef)};
1028	}
1029	// Argument is constant. Traverse its elements in transposed order.
1030	std::vector<Scalar<T>> resultElements;
1031	ConstantSubscripts at(2);
1032	for (ConstantSubscript j{0}; j < matrix->shape()[0]; ++j) {
1033	at[0] = matrix->lbounds()[0] + j;
1034	for (ConstantSubscript k{0}; k < matrix->shape()[1]; ++k) {
1035	at[1] = matrix->lbounds()[1] + k;
1036	resultElements.push_back(matrix->At(at));
1037	}
1038	}
1039	at = matrix->shape();
1040	std::swap(at[0], at[1]);
1041	return Expr<T>{PackageConstant<T>(std::move(resultElements), *matrix, at)};
1042	}
1043
1044	template <typename T> Expr<T> Folder<T>::UNPACK(FunctionRef<T> &&funcRef) {
1045	auto args{funcRef.arguments()};
1046	CHECK(args.size() == 3);
1047	const auto *vector{UnwrapConstantValue<T>(args[0])};
1048	auto convertedMask{Fold(context_,
1049	ConvertToType<LogicalResult>(
1050	Expr<SomeLogical>{DEREF(UnwrapExpr<Expr<SomeLogical>>(args[1]))}))};
1051	const auto *mask{UnwrapConstantValue<LogicalResult>(convertedMask)};
1052	const auto *field{UnwrapConstantValue<T>(args[2])};
1053	if (!vector || !mask || !field) {
1054	return Expr<T>{std::move(funcRef)};
1055	}
1056	// Arguments are constant.
1057	if (field->Rank() > 0 && field->shape() != mask->shape()) {
1058	// Error already emitted from intrinsic processing
1059	return MakeInvalidIntrinsic(std::move(funcRef));
1060	}
1061	ConstantSubscript maskElements{GetSize(mask->shape())};
1062	ConstantSubscript truths{0};
1063	ConstantSubscripts maskAt{mask->lbounds()};
1064	for (ConstantSubscript j{0}; j < maskElements;
1065	++j, mask->IncrementSubscripts(maskAt)) {
1066	if (mask->At(maskAt).IsTrue()) {
1067	++truths;
1068	}
1069	}
1070	if (truths > GetSize(vector->shape())) {
1071	context_.messages().Say(
1072	"Invalid 'vector=' argument in UNPACK: the 'mask=' argument has %jd true elements, but the vector has only %jd elements"_err_en_US,
1073	static_cast<std::intmax_t>(truths),
1074	static_cast<std::intmax_t>(GetSize(vector->shape())));
1075	return MakeInvalidIntrinsic(std::move(funcRef));
1076	}
1077	std::vector<Scalar<T>> resultElements;
1078	ConstantSubscripts vectorAt{vector->lbounds()};
1079	ConstantSubscripts fieldAt{field->lbounds()};
1080	for (ConstantSubscript j{0}; j < maskElements; ++j) {
1081	if (mask->At(maskAt).IsTrue()) {
1082	resultElements.push_back(vector->At(vectorAt));
1083	vector->IncrementSubscripts(vectorAt);
1084	} else {
1085	resultElements.push_back(field->At(fieldAt));
1086	}
1087	mask->IncrementSubscripts(maskAt);
1088	field->IncrementSubscripts(fieldAt);
1089	}
1090	return Expr<T>{
1091	PackageConstant<T>(std::move(resultElements), *vector, mask->shape())};
1092	}
1093
1094	std::optional<Expr<SomeType>> FoldTransfer(
1095	FoldingContext &, const ActualArguments &);
1096
1097	template <typename T> Expr<T> Folder<T>::TRANSFER(FunctionRef<T> &&funcRef) {
1098	if (auto folded{FoldTransfer(context_, funcRef.arguments())}) {
1099	return DEREF(UnwrapExpr<Expr<T>>(*folded));
1100	} else {
1101	return Expr<T>{std::move(funcRef)};
1102	}
1103	}
1104
1105	// TODO: Once the backend supports character extremums we could support
1106	// min/max with non-optional arguments to trees of extremum operations.
1107	template <typename T>
1108	Expr<T> FoldMINorMAX(
1109	FoldingContext &context, FunctionRef<T> &&funcRef, Ordering order) {
1110	static_assert(T::category == TypeCategory::Integer ||
1111	T::category == TypeCategory::Unsigned ||
1112	T::category == TypeCategory::Real ||
1113	T::category == TypeCategory::Character);
1114
1115	// Lots of constraints:
1116	// - We want Extremum<T> generated by semantics to compare equal to
1117	// Extremum<T> written out to module files as max or min calls.
1118	// - Users can also write min/max calls that must also compare equal
1119	// to min/max calls that wind up being written to module files.
1120	// - Extremeum<T> is binary and can't currently handle processing
1121	// optional arguments that may show up in 3rd + argument.
1122	// - The code below only accepts more than 2 arguments if all the
1123	// arguments are constant (and hence known to be present).
1124	// - ConvertExprToHLFIR can't currently handle Extremum<Character>
1125	// - Semantics doesn't currently generate Extremum<Character>
1126	// The original code did the folding of arguments and the overall extremum
1127	// operation in a single pass. This was shorter code-wise, but took me
1128	// a while to tease out all the logic and was doing redundant work.
1129	// So I split it into two passes:
1130	// 1) fold the arguments and check if they are constant,
1131	// 2) Decide if we:
1132	// - can constant-fold the min/max operation, or
1133	// - need to generate an extremum anyway,
1134	// and do it if so.
1135	// Otherwise, return the original call.
1136	auto &args{funcRef.arguments()};
1137	std::size_t nargs{args.size()};
1138	bool allArgsConstant{true};
1139	bool extremumAnyway{nargs == 2 && T::category != TypeCategory::Character};
1140	// 1a)Fold the first two arguments.
1141	{
1142	Folder<T> folder{context, /*forOptionalArgument=*/false};
1143	if (!folder.Folding(args[0])) {
1144	allArgsConstant = false;
1145	}
1146	if (!folder.Folding(args[1])) {
1147	allArgsConstant = false;
1148	}
1149	}
1150	// 1b) Fold any optional arguments.
1151	if (nargs > 2) {
1152	Folder<T> folder{context, /*forOptionalArgument=*/true};
1153	for (std::size_t i{2}; i < nargs; ++i) {
1154	if (args[i]) {
1155	if (!folder.Folding(args[i])) {
1156	allArgsConstant = false;
1157	}
1158	}
1159	}
1160	}
1161	// 2) If we can fold the result or the call to min/max may compare equal to
1162	// an extremum generated by semantics go ahead and convert to an extremum,
1163	// and try to fold the result.
1164	if (allArgsConstant || extremumAnyway) {
1165	// Folding updates the argument expressions in place, no need to call
1166	// Fold() on each argument again.
1167	if (const auto *resultp{UnwrapExpr<Expr<T>>(args[0])}) {
1168	Expr<T> result{*resultp};
1169	for (std::size_t i{1}; i < nargs; ++i) {
1170	if (const auto *tExpr{UnwrapExpr<Expr<T>>(args[i])}) {
1171	result = FoldOperation(
1172	context, Extremum<T>{order, std::move(result), *tExpr});
1173	} else {
1174	// This should never happen, but here is a value to return.
1175	return Expr<T>{std::move(funcRef)};
1176	}
1177	}
1178	return result;
1179	}
1180	}
1181	// If we decided to not generate an extremum just return the original call,
1182	// with the arguments folded.
1183	return Expr<T>{std::move(funcRef)};
1184	}
1185
1186	// For AMAX0, AMIN0, AMAX1, AMIN1, DMAX1, DMIN1, MAX0, MIN0, MAX1, and MIN1
1187	// a special care has to be taken to insert the conversion on the result
1188	// of the MIN/MAX. This is made slightly more complex by the extension
1189	// supported by f18 that arguments may have different kinds. This implies
1190	// that the created MIN/MAX result type cannot be deduced from the standard but
1191	// has to be deduced from the arguments.
1192	// e.g. AMAX0(int8, int4) is rewritten to REAL(MAX(int8, INT(int4, 8)))).
1193	template <typename T>
1194	Expr<T> RewriteSpecificMINorMAX(
1195	FoldingContext &context, FunctionRef<T> &&funcRef) {
1196	ActualArguments &args{funcRef.arguments()};
1197	auto &intrinsic{DEREF(std::get_if<SpecificIntrinsic>(&funcRef.proc().u))};
1198	// Rewrite MAX1(args) to INT(MAX(args)) and fold. Same logic for MIN1.
1199	// Find result type for max/min based on the arguments.
1200	std::optional<DynamicType> resultType;
1201	ActualArgument *resultTypeArg{nullptr};
1202	for (auto j{args.size()}; j-- > 0;) {
1203	if (args[j]) {
1204	DynamicType type{args[j]->GetType().value()};
1205	// Handle mixed real/integer arguments: all the previous arguments were
1206	// integers and this one is real. The type of the MAX/MIN result will
1207	// be the one of the real argument.
1208	if (!resultType ||
1209	(type.category() == resultType->category() &&
1210	type.kind() > resultType->kind()) ||
1211	resultType->category() == TypeCategory::Integer) {
1212	resultType = type;
1213	resultTypeArg = &*args[j];
1214	}
1215	}
1216	}
1217	if (!resultType) { // error recovery
1218	return Expr<T>{std::move(funcRef)};
1219	}
1220	intrinsic.name =
1221	intrinsic.name.find("max") != std::string::npos ? "max"s : "min"s;
1222	intrinsic.characteristics.value().functionResult.value().SetType(*resultType);
1223	auto insertConversion{[&](const auto &x) -> Expr<T> {
1224	using TR = ResultType<decltype(x)>;
1225	FunctionRef<TR> maxRef{
1226	ProcedureDesignator{funcRef.proc()}, ActualArguments{args}};
1227	return Fold(context, ConvertToType<T>(AsCategoryExpr(std::move(maxRef))));
1228	}};
1229	if (auto *sx{UnwrapExpr<Expr<SomeReal>>(*resultTypeArg)}) {
1230	return common::visit(insertConversion, sx->u);
1231	} else if (auto *sx{UnwrapExpr<Expr<SomeInteger>>(*resultTypeArg)}) {
1232	return common::visit(insertConversion, sx->u);
1233	} else {
1234	return Expr<T>{std::move(funcRef)}; // error recovery
1235	}
1236	}
1237
1238	// FoldIntrinsicFunction()
1239	template <int KIND>
1240	Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
1241	FoldingContext &context, FunctionRef<Type<TypeCategory::Integer, KIND>> &&);
1242	template <int KIND>
1243	Expr<Type<TypeCategory::Unsigned, KIND>> FoldIntrinsicFunction(
1244	FoldingContext &context,
1245	FunctionRef<Type<TypeCategory::Unsigned, KIND>> &&);
1246	template <int KIND>
1247	Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
1248	FoldingContext &context, FunctionRef<Type<TypeCategory::Real, KIND>> &&);
1249	template <int KIND>
1250	Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
1251	FoldingContext &context, FunctionRef<Type<TypeCategory::Complex, KIND>> &&);
1252	template <int KIND>
1253	Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
1254	FoldingContext &context, FunctionRef<Type<TypeCategory::Logical, KIND>> &&);
1255
1256	template <typename T>
1257	Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
1258	ActualArguments &args{funcRef.arguments()};
1259	const auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
1260	if (!intrinsic || intrinsic->name != "kind") {
1261	// Don't fold the argument to KIND(); it might be a TypeParamInquiry
1262	// with a forced result type that doesn't match the parameter.
1263	for (std::optional<ActualArgument> &arg : args) {
1264	if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
1265	*expr = Fold(context, std::move(*expr));
1266	}
1267	}
1268	}
1269	if (intrinsic) {
1270	const std::string name{intrinsic->name};
1271	if (name == "cshift") {
1272	return Folder<T>{context}.CSHIFT(std::move(funcRef));
1273	} else if (name == "eoshift") {
1274	return Folder<T>{context}.EOSHIFT(std::move(funcRef));
1275	} else if (name == "merge") {
1276	return Folder<T>{context}.MERGE(std::move(funcRef));
1277	} else if (name == "pack") {
1278	return Folder<T>{context}.PACK(std::move(funcRef));
1279	} else if (name == "reshape") {
1280	return Folder<T>{context}.RESHAPE(std::move(funcRef));
1281	} else if (name == "spread") {
1282	return Folder<T>{context}.SPREAD(std::move(funcRef));
1283	} else if (name == "transfer") {
1284	return Folder<T>{context}.TRANSFER(std::move(funcRef));
1285	} else if (name == "transpose") {
1286	return Folder<T>{context}.TRANSPOSE(std::move(funcRef));
1287	} else if (name == "unpack") {
1288	return Folder<T>{context}.UNPACK(std::move(funcRef));
1289	}
1290	// TODO: extends_type_of, same_type_as
1291	if constexpr (!std::is_same_v<T, SomeDerived>) {
1292	return FoldIntrinsicFunction(context, std::move(funcRef));
1293	}
1294	}
1295	return Expr<T>{std::move(funcRef)};
1296	}
1297
1298	Expr<ImpliedDoIndex::Result> FoldOperation(FoldingContext &, ImpliedDoIndex &&);
1299
1300	// Array constructor folding
1301	template <typename T> class ArrayConstructorFolder {
1302	public:
1303	explicit ArrayConstructorFolder(FoldingContext &c) : context_{c} {}
1304
1305	Expr<T> FoldArray(ArrayConstructor<T> &&array) {
1306	if constexpr (T::category == TypeCategory::Character) {
1307	if (const auto *len{array.LEN()}) {
1308	charLength_ = ToInt64(Fold(context_, common::Clone(*len)));
1309	knownCharLength_ = charLength_.has_value();
1310	}
1311	}
1312	// Calls FoldArray(const ArrayConstructorValues<T> &) below
1313	if (FoldArray(array)) {
1314	auto n{static_cast<ConstantSubscript>(elements_.size())};
1315	if constexpr (std::is_same_v<T, SomeDerived>) {
1316	return Expr<T>{Constant<T>{array.GetType().GetDerivedTypeSpec(),
1317	std::move(elements_), ConstantSubscripts{n}}};
1318	} else if constexpr (T::category == TypeCategory::Character) {
1319	if (charLength_) {
1320	return Expr<T>{Constant<T>{
1321	*charLength_, std::move(elements_), ConstantSubscripts{n}}};
1322	}
1323	} else {
1324	return Expr<T>{
1325	Constant<T>{std::move(elements_), ConstantSubscripts{n}}};
1326	}
1327	}
1328	return Expr<T>{std::move(array)};
1329	}
1330
1331	private:
1332	bool FoldArray(const Expr<T> &expr) {
1333	Expr<T> folded{Fold(context_, common::Clone(expr))};
1334	if (const auto *c{UnwrapConstantValue<T>(folded)}) {
1335	// Copy elements in Fortran array element order
1336	if (!c->empty()) {
1337	ConstantSubscripts index{c->lbounds()};
1338	do {
1339	elements_.emplace_back(c->At(index));
1340	} while (c->IncrementSubscripts(index));
1341	}
1342	if constexpr (T::category == TypeCategory::Character) {
1343	if (!knownCharLength_) {
1344	charLength_ = std::max(c->LEN(), charLength_.value_or(-1));
1345	}
1346	}
1347	return true;
1348	} else {
1349	return false;
1350	}
1351	}
1352	bool FoldArray(const common::CopyableIndirection<Expr<T>> &expr) {
1353	return FoldArray(expr.value());
1354	}
1355	bool FoldArray(const ImpliedDo<T> &iDo) {
1356	Expr<SubscriptInteger> lower{
1357	Fold(context_, Expr<SubscriptInteger>{iDo.lower()})};
1358	Expr<SubscriptInteger> upper{
1359	Fold(context_, Expr<SubscriptInteger>{iDo.upper()})};
1360	Expr<SubscriptInteger> stride{
1361	Fold(context_, Expr<SubscriptInteger>{iDo.stride()})};
1362	std::optional<ConstantSubscript> start{ToInt64(lower)}, end{ToInt64(upper)},
1363	step{ToInt64(stride)};
1364	if (start && end && step && *step != 0) {
1365	bool result{true};
1366	ConstantSubscript &j{context_.StartImpliedDo(iDo.name(), *start)};
1367	if (*step > 0) {
1368	for (; j <= *end; j += *step) {
1369	result &= FoldArray(iDo.values());
1370	}
1371	} else {
1372	for (; j >= *end; j += *step) {
1373	result &= FoldArray(iDo.values());
1374	}
1375	}
1376	context_.EndImpliedDo(iDo.name());
1377	return result;
1378	} else {
1379	return false;
1380	}
1381	}
1382	bool FoldArray(const ArrayConstructorValue<T> &x) {
1383	return common::visit([&](const auto &y) { return FoldArray(y); }, x.u);
1384	}
1385	bool FoldArray(const ArrayConstructorValues<T> &xs) {
1386	for (const auto &x : xs) {
1387	if (!FoldArray(x)) {
1388	return false;
1389	}
1390	}
1391	return true;
1392	}
1393
1394	FoldingContext &context_;
1395	std::vector<Scalar<T>> elements_;
1396	std::optional<ConstantSubscript> charLength_;
1397	bool knownCharLength_{false};
1398	};
1399
1400	template <typename T>
1401	Expr<T> FoldOperation(FoldingContext &context, ArrayConstructor<T> &&array) {
1402	return ArrayConstructorFolder<T>{context}.FoldArray(std::move(array));
1403	}
1404
1405	// Array operation elemental application: When all operands to an operation
1406	// are constant arrays, array constructors without any implied DO loops,
1407	// &/or expanded scalars, pull the operation "into" the array result by
1408	// applying it in an elementwise fashion. For example, [A,1]+[B,2]
1409	// is rewritten into [A+B,1+2] and then partially folded to [A+B,3].
1410
1411	// If possible, restructures an array expression into an array constructor
1412	// that comprises a "flat" ArrayConstructorValues with no implied DO loops.
1413	template <typename T>
1414	bool ArrayConstructorIsFlat(const ArrayConstructorValues<T> &values) {
1415	for (const ArrayConstructorValue<T> &x : values) {
1416	if (!std::holds_alternative<Expr<T>>(x.u)) {
1417	return false;
1418	}
1419	}
1420	return true;
1421	}
1422
1423	template <typename T>
1424	std::optional<Expr<T>> AsFlatArrayConstructor(const Expr<T> &expr) {
1425	if (const auto *c{UnwrapConstantValue<T>(expr)}) {
1426	ArrayConstructor<T> result{expr};
1427	if (!c->empty()) {
1428	ConstantSubscripts at{c->lbounds()};
1429	do {
1430	result.Push(Expr<T>{Constant<T>{c->At(at)}});
1431	} while (c->IncrementSubscripts(at));
1432	}
1433	return std::make_optional<Expr<T>>(std::move(result));
1434	} else if (const auto *a{UnwrapExpr<ArrayConstructor<T>>(expr)}) {
1435	if (ArrayConstructorIsFlat(*a)) {
1436	return std::make_optional<Expr<T>>(expr);
1437	}
1438	} else if (const auto *p{UnwrapExpr<Parentheses<T>>(expr)}) {
1439	return AsFlatArrayConstructor(Expr<T>{p->left()});
1440	}
1441	return std::nullopt;
1442	}
1443
1444	template <TypeCategory CAT>
1445	std::enable_if_t<CAT != TypeCategory::Derived,
1446	std::optional<Expr<SomeKind<CAT>>>>
1447	AsFlatArrayConstructor(const Expr<SomeKind<CAT>> &expr) {
1448	return common::visit(
1449	[&](const auto &kindExpr) -> std::optional<Expr<SomeKind<CAT>>> {
1450	if (auto flattened{AsFlatArrayConstructor(kindExpr)}) {
1451	return Expr<SomeKind<CAT>>{std::move(*flattened)};
1452	} else {
1453	return std::nullopt;
1454	}
1455	},
1456	expr.u);
1457	}
1458
1459	// FromArrayConstructor is a subroutine for MapOperation() below.
1460	// Given a flat ArrayConstructor<T> and a shape, it wraps the array
1461	// into an Expr<T>, folds it, and returns the resulting wrapped
1462	// array constructor or constant array value.
1463	template <typename T>
1464	std::optional<Expr<T>> FromArrayConstructor(
1465	FoldingContext &context, ArrayConstructor<T> &&values, const Shape &shape) {
1466	if (auto constShape{AsConstantExtents(context, shape)};
1467	constShape && !HasNegativeExtent(*constShape)) {
1468	Expr<T> result{Fold(context, Expr<T>{std::move(values)})};
1469	if (auto *constant{UnwrapConstantValue<T>(result)}) {
1470	// Elements and shape are both constant.
1471	return Expr<T>{constant->Reshape(std::move(*constShape))};
1472	}
1473	if (constShape->size() == 1) {
1474	if (auto elements{GetShape(context, result)}) {
1475	if (auto constElements{AsConstantExtents(context, *elements)}) {
1476	if (constElements->size() == 1 &&
1477	constElements->at(0) == constShape->at(0)) {
1478	// Elements are not constant, but array constructor has
1479	// the right known shape and can be simply returned as is.
1480	return std::move(result);
1481	}
1482	}
1483	}
1484	}
1485	}
1486	return std::nullopt;
1487	}
1488
1489	// MapOperation is a utility for various specializations of ApplyElementwise()
1490	// that follow. Given one or two flat ArrayConstructor<OPERAND> (wrapped in an
1491	// Expr<OPERAND>) for some specific operand type(s), apply a given function f
1492	// to each of their corresponding elements to produce a flat
1493	// ArrayConstructor<RESULT> (wrapped in an Expr<RESULT>).
1494	// Preserves shape.
1495
1496	// Unary case
1497	template <typename RESULT, typename OPERAND>
1498	std::optional<Expr<RESULT>> MapOperation(FoldingContext &context,
1499	std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f, const Shape &shape,
1500	[[maybe_unused]] std::optional<Expr<SubscriptInteger>> &&length,
1501	Expr<OPERAND> &&values) {
1502	ArrayConstructor<RESULT> result{values};
1503	if constexpr (common::HasMember<OPERAND, AllIntrinsicCategoryTypes>) {
1504	common::visit(
1505	[&](auto &&kindExpr) {
1506	using kindType = ResultType<decltype(kindExpr)>;
1507	auto &aConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1508	for (auto &acValue : aConst) {
1509	auto &scalar{std::get<Expr<kindType>>(acValue.u)};
1510	result.Push(Fold(context, f(Expr<OPERAND>{std::move(scalar)})));
1511	}
1512	},
1513	std::move(values.u));
1514	} else {
1515	auto &aConst{std::get<ArrayConstructor<OPERAND>>(values.u)};
1516	for (auto &acValue : aConst) {
1517	auto &scalar{std::get<Expr<OPERAND>>(acValue.u)};
1518	result.Push(Fold(context, f(std::move(scalar))));
1519	}
1520	}
1521	if constexpr (RESULT::category == TypeCategory::Character) {
1522	if (length) {
1523	result.set_LEN(std::move(*length));
1524	}
1525	}
1526	return FromArrayConstructor(context, std::move(result), shape);
1527	}
1528
1529	template <typename RESULT, typename A>
1530	ArrayConstructor<RESULT> ArrayConstructorFromMold(
1531	const A &prototype, std::optional<Expr<SubscriptInteger>> &&length) {
1532	ArrayConstructor<RESULT> result{prototype};
1533	if constexpr (RESULT::category == TypeCategory::Character) {
1534	if (length) {
1535	result.set_LEN(std::move(*length));
1536	}
1537	}
1538	return result;
1539	}
1540
1541	template <typename LEFT, typename RIGHT>
1542	bool ShapesMatch(FoldingContext &context,
1543	const ArrayConstructor<LEFT> &leftArrConst,
1544	const ArrayConstructor<RIGHT> &rightArrConst) {
1545	auto rightIter{rightArrConst.begin()};
1546	for (auto &leftValue : leftArrConst) {
1547	CHECK(rightIter != rightArrConst.end());
1548	auto &leftExpr{std::get<Expr<LEFT>>(leftValue.u)};
1549	auto &rightExpr{std::get<Expr<RIGHT>>(rightIter->u)};
1550	if (leftExpr.Rank() != rightExpr.Rank()) {
1551	return false;
1552	}
1553	std::optional<Shape> leftShape{GetShape(context, leftExpr)};
1554	std::optional<Shape> rightShape{GetShape(context, rightExpr)};
1555	if (!leftShape || !rightShape || *leftShape != *rightShape) {
1556	return false;
1557	}
1558	++rightIter;
1559	}
1560	return true;
1561	}
1562
1563	// array * array case
1564	template <typename RESULT, typename LEFT, typename RIGHT>
1565	auto MapOperation(FoldingContext &context,
1566	std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1567	const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1568	Expr<LEFT> &&leftValues, Expr<RIGHT> &&rightValues)
1569	-> std::optional<Expr<RESULT>> {
1570	auto result{ArrayConstructorFromMold<RESULT>(leftValues, std::move(length))};
1571	auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
1572	if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
1573	bool mapped{common::visit(
1574	[&](auto &&kindExpr) -> bool {
1575	using kindType = ResultType<decltype(kindExpr)>;
1576
1577	auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1578	if (!ShapesMatch(context, leftArrConst, rightArrConst)) {
1579	return false;
1580	}
1581	auto rightIter{rightArrConst.begin()};
1582	for (auto &leftValue : leftArrConst) {
1583	CHECK(rightIter != rightArrConst.end());
1584	auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1585	auto &rightScalar{std::get<Expr<kindType>>(rightIter->u)};
1586	result.Push(Fold(context,
1587	f(std::move(leftScalar), Expr<RIGHT>{std::move(rightScalar)})));
1588	++rightIter;
1589	}
1590	return true;
1591	},
1592	std::move(rightValues.u))};
1593	if (!mapped) {
1594	return std::nullopt;
1595	}
1596	} else {
1597	auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
1598	if (!ShapesMatch(context, leftArrConst, rightArrConst)) {
1599	return std::nullopt;
1600	}
1601	auto rightIter{rightArrConst.begin()};
1602	for (auto &leftValue : leftArrConst) {
1603	CHECK(rightIter != rightArrConst.end());
1604	auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1605	auto &rightScalar{std::get<Expr<RIGHT>>(rightIter->u)};
1606	result.Push(
1607	Fold(context, f(std::move(leftScalar), std::move(rightScalar))));
1608	++rightIter;
1609	}
1610	}
1611	return FromArrayConstructor(context, std::move(result), shape);
1612	}
1613
1614	// array * scalar case
1615	template <typename RESULT, typename LEFT, typename RIGHT>
1616	auto MapOperation(FoldingContext &context,
1617	std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1618	const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1619	Expr<LEFT> &&leftValues, const Expr<RIGHT> &rightScalar)
1620	-> std::optional<Expr<RESULT>> {
1621	auto result{ArrayConstructorFromMold<RESULT>(leftValues, std::move(length))};
1622	auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
1623	for (auto &leftValue : leftArrConst) {
1624	auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1625	result.Push(
1626	Fold(context, f(std::move(leftScalar), Expr<RIGHT>{rightScalar})));
1627	}
1628	return FromArrayConstructor(context, std::move(result), shape);
1629	}
1630
1631	// scalar * array case
1632	template <typename RESULT, typename LEFT, typename RIGHT>
1633	auto MapOperation(FoldingContext &context,
1634	std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1635	const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1636	const Expr<LEFT> &leftScalar, Expr<RIGHT> &&rightValues)
1637	-> std::optional<Expr<RESULT>> {
1638	auto result{ArrayConstructorFromMold<RESULT>(leftScalar, std::move(length))};
1639	if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
1640	common::visit(
1641	[&](auto &&kindExpr) {
1642	using kindType = ResultType<decltype(kindExpr)>;
1643	auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1644	for (auto &rightValue : rightArrConst) {
1645	auto &rightScalar{std::get<Expr<kindType>>(rightValue.u)};
1646	result.Push(Fold(context,
1647	f(Expr<LEFT>{leftScalar},
1648	Expr<RIGHT>{std::move(rightScalar)})));
1649	}
1650	},
1651	std::move(rightValues.u));
1652	} else {
1653	auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
1654	for (auto &rightValue : rightArrConst) {
1655	auto &rightScalar{std::get<Expr<RIGHT>>(rightValue.u)};
1656	result.Push(
1657	Fold(context, f(Expr<LEFT>{leftScalar}, std::move(rightScalar))));
1658	}
1659	}
1660	return FromArrayConstructor(context, std::move(result), shape);
1661	}
1662
1663	template <typename DERIVED, typename RESULT, typename... OPD>
1664	std::optional<Expr<SubscriptInteger>> ComputeResultLength(
1665	Operation<DERIVED, RESULT, OPD...> &operation) {
1666	if constexpr (RESULT::category == TypeCategory::Character) {
1667	return Expr<RESULT>{operation.derived()}.LEN();
1668	}
1669	return std::nullopt;
1670	}
1671
1672	// ApplyElementwise() recursively folds the operand expression(s) of an
1673	// operation, then attempts to apply the operation to the (corresponding)
1674	// scalar element(s) of those operands. Returns std::nullopt for scalars
1675	// or unlinearizable operands.
1676	template <typename DERIVED, typename RESULT, typename OPERAND>
1677	auto ApplyElementwise(FoldingContext &context,
1678	Operation<DERIVED, RESULT, OPERAND> &operation,
1679	std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f)
1680	-> std::optional<Expr<RESULT>> {
1681	auto &expr{operation.left()};
1682	expr = Fold(context, std::move(expr));
1683	if (expr.Rank() > 0) {
1684	if (std::optional<Shape> shape{GetShape(context, expr)}) {
1685	if (auto values{AsFlatArrayConstructor(expr)}) {
1686	return MapOperation(context, std::move(f), *shape,
1687	ComputeResultLength(operation), std::move(*values));
1688	}
1689	}
1690	}
1691	return std::nullopt;
1692	}
1693
1694	template <typename DERIVED, typename RESULT, typename OPERAND>
1695	auto ApplyElementwise(
1696	FoldingContext &context, Operation<DERIVED, RESULT, OPERAND> &operation)
1697	-> std::optional<Expr<RESULT>> {
1698	return ApplyElementwise(context, operation,
1699	std::function<Expr<RESULT>(Expr<OPERAND> &&)>{
1700	[](Expr<OPERAND> &&operand) {
1701	return Expr<RESULT>{DERIVED{std::move(operand)}};
1702	}});
1703	}
1704
1705	template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1706	auto ApplyElementwise(FoldingContext &context,
1707	Operation<DERIVED, RESULT, LEFT, RIGHT> &operation,
1708	std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f)
1709	-> std::optional<Expr<RESULT>> {
1710	auto resultLength{ComputeResultLength(operation)};
1711	auto &leftExpr{operation.left()};
1712	auto &rightExpr{operation.right()};
1713	if (leftExpr.Rank() != rightExpr.Rank() && leftExpr.Rank() != 0 &&
1714	rightExpr.Rank() != 0) {
1715	return std::nullopt; // error recovery
1716	}
1717	leftExpr = Fold(context, std::move(leftExpr));
1718	rightExpr = Fold(context, std::move(rightExpr));
1719	if (leftExpr.Rank() > 0) {
1720	if (std::optional<Shape> leftShape{GetShape(context, leftExpr)}) {
1721	if (auto left{AsFlatArrayConstructor(leftExpr)}) {
1722	if (rightExpr.Rank() > 0) {
1723	if (std::optional<Shape> rightShape{GetShape(context, rightExpr)}) {
1724	if (auto right{AsFlatArrayConstructor(rightExpr)}) {
1725	if (CheckConformance(context.messages(), *leftShape, *rightShape,
1726	CheckConformanceFlags::EitherScalarExpandable)
1727	.value_or(false /*fail if not known now to conform*/)) {
1728	return MapOperation(context, std::move(f), *leftShape,
1729	std::move(resultLength), std::move(*left),
1730	std::move(*right));
1731	} else {
1732	return std::nullopt;
1733	}
1734	return MapOperation(context, std::move(f), *leftShape,
1735	std::move(resultLength), std::move(*left), std::move(*right));
1736	}
1737	}
1738	} else if (IsExpandableScalar(rightExpr, context, *leftShape)) {
1739	return MapOperation(context, std::move(f), *leftShape,
1740	std::move(resultLength), std::move(*left), rightExpr);
1741	}
1742	}
1743	}
1744	} else if (rightExpr.Rank() > 0) {
1745	if (std::optional<Shape> rightShape{GetShape(context, rightExpr)}) {
1746	if (IsExpandableScalar(leftExpr, context, *rightShape)) {
1747	if (auto right{AsFlatArrayConstructor(rightExpr)}) {
1748	return MapOperation(context, std::move(f), *rightShape,
1749	std::move(resultLength), leftExpr, std::move(*right));
1750	}
1751	}
1752	}
1753	}
1754	return std::nullopt;
1755	}
1756
1757	template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1758	auto ApplyElementwise(
1759	FoldingContext &context, Operation<DERIVED, RESULT, LEFT, RIGHT> &operation)
1760	-> std::optional<Expr<RESULT>> {
1761	return ApplyElementwise(context, operation,
1762	std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)>{
1763	[](Expr<LEFT> &&left, Expr<RIGHT> &&right) {
1764	return Expr<RESULT>{DERIVED{std::move(left), std::move(right)}};
1765	}});
1766	}
1767
1768	// Unary operations
1769
1770	template <typename TO, typename FROM>
1771	common::IfNoLvalue<std::optional<TO>, FROM> ConvertString(FROM &&s) {
1772	if constexpr (std::is_same_v<TO, FROM>) {
1773	return std::make_optional<TO>(std::move(s));
1774	} else {
1775	// Fortran character conversion is well defined between distinct kinds
1776	// only when the actual characters are valid 7-bit ASCII.
1777	TO str;
1778	for (auto iter{s.cbegin()}; iter != s.cend(); ++iter) {
1779	if (static_cast<std::uint64_t>(*iter) > 127) {
1780	return std::nullopt;
1781	}
1782	str.push_back(*iter);
1783	}
1784	return std::make_optional<TO>(std::move(str));
1785	}
1786	}
1787
1788	template <typename TO, TypeCategory FROMCAT>
1789	Expr<TO> FoldOperation(
1790	FoldingContext &context, Convert<TO, FROMCAT> &&convert) {
1791	if (auto array{ApplyElementwise(context, convert)}) {
1792	return *array;
1793	}
1794	struct {
1795	FoldingContext &context;
1796	Convert<TO, FROMCAT> &convert;
1797	} msvcWorkaround{context, convert};
1798	return common::visit(
1799	[&msvcWorkaround](auto &kindExpr) -> Expr<TO> {
1800	using Operand = ResultType<decltype(kindExpr)>;
1801	// This variable is a workaround for msvc which emits an error when
1802	// using the FROMCAT template parameter below.
1803	TypeCategory constexpr FromCat{FROMCAT};
1804	static_assert(FromCat == Operand::category);
1805	auto &convert{msvcWorkaround.convert};
1806	if (auto value{GetScalarConstantValue<Operand>(kindExpr)}) {
1807	FoldingContext &ctx{msvcWorkaround.context};
1808	if constexpr (TO::category == TypeCategory::Integer) {
1809	if constexpr (FromCat == TypeCategory::Integer) {
1810	auto converted{Scalar<TO>::ConvertSigned(*value)};
1811	if (converted.overflow &&
1812	msvcWorkaround.context.languageFeatures().ShouldWarn(
1813	common::UsageWarning::FoldingException)) {
1814	ctx.messages().Say(common::UsageWarning::FoldingException,
1815	"conversion of %s_%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
1816	value->SignedDecimal(), Operand::kind, TO::kind,
1817	converted.value.SignedDecimal());
1818	}
1819	return ScalarConstantToExpr(std::move(converted.value));
1820	} else if constexpr (FromCat == TypeCategory::Unsigned) {
1821	auto converted{Scalar<TO>::ConvertUnsigned(*value)};
1822	if ((converted.overflow || converted.value.IsNegative()) &&
1823	msvcWorkaround.context.languageFeatures().ShouldWarn(
1824	common::UsageWarning::FoldingException)) {
1825	ctx.messages().Say(common::UsageWarning::FoldingException,
1826	"conversion of %s_U%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
1827	value->UnsignedDecimal(), Operand::kind, TO::kind,
1828	converted.value.SignedDecimal());
1829	}
1830	return ScalarConstantToExpr(std::move(converted.value));
1831	} else if constexpr (FromCat == TypeCategory::Real) {
1832	auto converted{value->template ToInteger<Scalar<TO>>()};
1833	if (msvcWorkaround.context.languageFeatures().ShouldWarn(
1834	common::UsageWarning::FoldingException)) {
1835	if (converted.flags.test(RealFlag::InvalidArgument)) {
1836	ctx.messages().Say(common::UsageWarning::FoldingException,
1837	"REAL(%d) to INTEGER(%d) conversion: invalid argument"_warn_en_US,
1838	Operand::kind, TO::kind);
1839	} else if (converted.flags.test(RealFlag::Overflow)) {
1840	ctx.messages().Say(
1841	"REAL(%d) to INTEGER(%d) conversion overflowed"_warn_en_US,
1842	Operand::kind, TO::kind);
1843	}
1844	}
1845	return ScalarConstantToExpr(std::move(converted.value));
1846	}
1847	} else if constexpr (TO::category == TypeCategory::Unsigned) {
1848	if constexpr (FromCat == TypeCategory::Integer ||
1849	FromCat == TypeCategory::Unsigned) {
1850	return Expr<TO>{
1851	Constant<TO>{Scalar<TO>::ConvertUnsigned(*value).value}};
1852	} else if constexpr (FromCat == TypeCategory::Real) {
1853	return Expr<TO>{
1854	Constant<TO>{value->template ToInteger<Scalar<TO>>().value}};
1855	}
1856	} else if constexpr (TO::category == TypeCategory::Real) {
1857	if constexpr (FromCat == TypeCategory::Integer ||
1858	FromCat == TypeCategory::Unsigned) {
1859	auto converted{Scalar<TO>::FromInteger(
1860	*value, FromCat == TypeCategory::Unsigned)};
1861	if (!converted.flags.empty()) {
1862	char buffer[64];
1863	std::snprintf(buffer, sizeof buffer,
1864	"INTEGER(%d) to REAL(%d) conversion", Operand::kind,
1865	TO::kind);
1866	RealFlagWarnings(ctx, converted.flags, buffer);
1867	}
1868	return ScalarConstantToExpr(std::move(converted.value));
1869	} else if constexpr (FromCat == TypeCategory::Real) {
1870	auto converted{Scalar<TO>::Convert(*value)};
1871	char buffer[64];
1872	if (!converted.flags.empty()) {
1873	std::snprintf(buffer, sizeof buffer,
1874	"REAL(%d) to REAL(%d) conversion", Operand::kind, TO::kind);
1875	RealFlagWarnings(ctx, converted.flags, buffer);
1876	}
1877	if (ctx.targetCharacteristics().areSubnormalsFlushedToZero()) {
1878	converted.value = converted.value.FlushSubnormalToZero();
1879	}
1880	return ScalarConstantToExpr(std::move(converted.value));
1881	}
1882	} else if constexpr (TO::category == TypeCategory::Complex) {
1883	if constexpr (FromCat == TypeCategory::Complex) {
1884	return FoldOperation(ctx,
1885	ComplexConstructor<TO::kind>{
1886	AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
1887	Constant<typename Operand::Part>{value->REAL()})}),
1888	AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
1889	Constant<typename Operand::Part>{value->AIMAG()})})});
1890	}
1891	} else if constexpr (TO::category == TypeCategory::Character &&
1892	FromCat == TypeCategory::Character) {
1893	if (auto converted{ConvertString<Scalar<TO>>(std::move(*value))}) {
1894	return ScalarConstantToExpr(std::move(*converted));
1895	}
1896	} else if constexpr (TO::category == TypeCategory::Logical &&
1897	FromCat == TypeCategory::Logical) {
1898	return Expr<TO>{value->IsTrue()};
1899	}
1900	} else if constexpr (TO::category == FromCat &&
1901	FromCat != TypeCategory::Character) {
1902	// Conversion of non-constant in same type category
1903	if constexpr (std::is_same_v<Operand, TO>) {
1904	return std::move(kindExpr); // remove needless conversion
1905	} else if constexpr (TO::category == TypeCategory::Logical ||
1906	TO::category == TypeCategory::Integer) {
1907	if (auto *innerConv{
1908	std::get_if<Convert<Operand, TO::category>>(&kindExpr.u)}) {
1909	// Conversion of conversion of same category & kind
1910	if (auto *x{std::get_if<Expr<TO>>(&innerConv->left().u)}) {
1911	if constexpr (TO::category == TypeCategory::Logical ||
1912	TO::kind <= Operand::kind) {
1913	return std::move(*x); // no-op Logical or Integer
1914	// widening/narrowing conversion pair
1915	} else if constexpr (std::is_same_v<TO,
1916	DescriptorInquiry::Result>) {
1917	if (std::holds_alternative<DescriptorInquiry>(x->u) ||
1918	std::holds_alternative<TypeParamInquiry>(x->u)) {
1919	// int(int(size(...),kind=k),kind=8) -> size(...)
1920	return std::move(*x);
1921	}
1922	}
1923	}
1924	}
1925	}
1926	}
1927	return Expr<TO>{std::move(convert)};
1928	},
1929	convert.left().u);
1930	}
1931
1932	template <typename T>
1933	Expr<T> FoldOperation(FoldingContext &context, Parentheses<T> &&x) {
1934	auto &operand{x.left()};
1935	operand = Fold(context, std::move(operand));
1936	if (auto value{GetScalarConstantValue<T>(operand)}) {
1937	// Preserve parentheses, even around constants.
1938	return Expr<T>{Parentheses<T>{Expr<T>{Constant<T>{*value}}}};
1939	} else if (std::holds_alternative<Parentheses<T>>(operand.u)) {
1940	// ((x)) -> (x)
1941	return std::move(operand);
1942	} else {
1943	return Expr<T>{Parentheses<T>{std::move(operand)}};
1944	}
1945	}
1946
1947	template <typename T>
1948	Expr<T> FoldOperation(FoldingContext &context, Negate<T> &&x) {
1949	if (auto array{ApplyElementwise(context, x)}) {
1950	return *array;
1951	}
1952	auto &operand{x.left()};
1953	if (auto *nn{std::get_if<Negate<T>>(&x.left().u)}) {
1954	// -(-x) -> (x)
1955	if (IsVariable(nn->left())) {
1956	return FoldOperation(context, Parentheses<T>{std::move(nn->left())});
1957	} else {
1958	return std::move(nn->left());
1959	}
1960	} else if (auto value{GetScalarConstantValue<T>(operand)}) {
1961	if constexpr (T::category == TypeCategory::Integer) {
1962	auto negated{value->Negate()};
1963	if (negated.overflow &&
1964	context.languageFeatures().ShouldWarn(
1965	common::UsageWarning::FoldingException)) {
1966	context.messages().Say(common::UsageWarning::FoldingException,
1967	"INTEGER(%d) negation overflowed"_warn_en_US, T::kind);
1968	}
1969	return Expr<T>{Constant<T>{std::move(negated.value)}};
1970	} else if constexpr (T::category == TypeCategory::Unsigned) {
1971	return Expr<T>{Constant<T>{std::move(value->Negate().value)}};
1972	} else {
1973	// REAL & COMPLEX negation: no exceptions possible
1974	return Expr<T>{Constant<T>{value->Negate()}};
1975	}
1976	}
1977	return Expr<T>{std::move(x)};
1978	}
1979
1980	// Binary (dyadic) operations
1981
1982	template <typename LEFT, typename RIGHT>
1983	std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1984	const Expr<LEFT> &x, const Expr<RIGHT> &y) {
1985	if (auto xvalue{GetScalarConstantValue<LEFT>(x)}) {
1986	if (auto yvalue{GetScalarConstantValue<RIGHT>(y)}) {
1987	return {std::make_pair(*xvalue, *yvalue)};
1988	}
1989	}
1990	return std::nullopt;
1991	}
1992
1993	template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1994	std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1995	const Operation<DERIVED, RESULT, LEFT, RIGHT> &operation) {
1996	return OperandsAreConstants(operation.left(), operation.right());
1997	}
1998
1999	template <typename T>
2000	Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) {
2001	if (auto array{ApplyElementwise(context, x)}) {
2002	return *array;
2003	}
2004	if (auto folded{OperandsAreConstants(x)}) {
2005	if constexpr (T::category == TypeCategory::Integer) {
2006	auto sum{folded->first.AddSigned(folded->second)};
2007	if (sum.overflow &&
2008	context.languageFeatures().ShouldWarn(
2009	common::UsageWarning::FoldingException)) {
2010	context.messages().Say(common::UsageWarning::FoldingException,
2011	"INTEGER(%d) addition overflowed"_warn_en_US, T::kind);
2012	}
2013	return Expr<T>{Constant<T>{sum.value}};
2014	} else if constexpr (T::category == TypeCategory::Unsigned) {
2015	return Expr<T>{
2016	Constant<T>{folded->first.AddUnsigned(folded->second).value}};
2017	} else {
2018	auto sum{folded->first.Add(
2019	folded->second, context.targetCharacteristics().roundingMode())};
2020	RealFlagWarnings(context, sum.flags, "addition");
2021	if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2022	sum.value = sum.value.FlushSubnormalToZero();
2023	}
2024	return Expr<T>{Constant<T>{sum.value}};
2025	}
2026	}
2027	return Expr<T>{std::move(x)};
2028	}
2029
2030	template <typename T>
2031	Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) {
2032	if (auto array{ApplyElementwise(context, x)}) {
2033	return *array;
2034	}
2035	if (auto folded{OperandsAreConstants(x)}) {
2036	if constexpr (T::category == TypeCategory::Integer) {
2037	auto difference{folded->first.SubtractSigned(folded->second)};
2038	if (difference.overflow &&
2039	context.languageFeatures().ShouldWarn(
2040	common::UsageWarning::FoldingException)) {
2041	context.messages().Say(common::UsageWarning::FoldingException,
2042	"INTEGER(%d) subtraction overflowed"_warn_en_US, T::kind);
2043	}
2044	return Expr<T>{Constant<T>{difference.value}};
2045	} else if constexpr (T::category == TypeCategory::Unsigned) {
2046	return Expr<T>{
2047	Constant<T>{folded->first.SubtractSigned(folded->second).value}};
2048	} else {
2049	auto difference{folded->first.Subtract(
2050	folded->second, context.targetCharacteristics().roundingMode())};
2051	RealFlagWarnings(context, difference.flags, "subtraction");
2052	if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2053	difference.value = difference.value.FlushSubnormalToZero();
2054	}
2055	return Expr<T>{Constant<T>{difference.value}};
2056	}
2057	}
2058	return Expr<T>{std::move(x)};
2059	}
2060
2061	template <typename T>
2062	Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
2063	if (auto array{ApplyElementwise(context, x)}) {
2064	return *array;
2065	}
2066	if (auto folded{OperandsAreConstants(x)}) {
2067	if constexpr (T::category == TypeCategory::Integer) {
2068	auto product{folded->first.MultiplySigned(folded->second)};
2069	if (product.SignedMultiplicationOverflowed() &&
2070	context.languageFeatures().ShouldWarn(
2071	common::UsageWarning::FoldingException)) {
2072	context.messages().Say(common::UsageWarning::FoldingException,
2073	"INTEGER(%d) multiplication overflowed"_warn_en_US, T::kind);
2074	}
2075	return Expr<T>{Constant<T>{product.lower}};
2076	} else if constexpr (T::category == TypeCategory::Unsigned) {
2077	return Expr<T>{
2078	Constant<T>{folded->first.MultiplyUnsigned(folded->second).lower}};
2079	} else {
2080	auto product{folded->first.Multiply(
2081	folded->second, context.targetCharacteristics().roundingMode())};
2082	RealFlagWarnings(context, product.flags, "multiplication");
2083	if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2084	product.value = product.value.FlushSubnormalToZero();
2085	}
2086	return Expr<T>{Constant<T>{product.value}};
2087	}
2088	} else if constexpr (T::category == TypeCategory::Integer) {
2089	if (auto c{GetScalarConstantValue<T>(x.right())}) {
2090	x.right() = std::move(x.left());
2091	x.left() = Expr<T>{std::move(*c)};
2092	}
2093	if (auto c{GetScalarConstantValue<T>(x.left())}) {
2094	if (c->IsZero() && x.right().Rank() == 0) {
2095	return std::move(x.left());
2096	} else if (c->CompareSigned(Scalar<T>{1}) == Ordering::Equal) {
2097	if (IsVariable(x.right())) {
2098	return FoldOperation(context, Parentheses<T>{std::move(x.right())});
2099	} else {
2100	return std::move(x.right());
2101	}
2102	} else if (c->CompareSigned(Scalar<T>{-1}) == Ordering::Equal) {
2103	return FoldOperation(context, Negate<T>{std::move(x.right())});
2104	}
2105	}
2106	}
2107	return Expr<T>{std::move(x)};
2108	}
2109
2110	template <typename T>
2111	Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
2112	if (auto array{ApplyElementwise(context, x)}) {
2113	return *array;
2114	}
2115	if (auto folded{OperandsAreConstants(x)}) {
2116	if constexpr (T::category == TypeCategory::Integer) {
2117	auto quotAndRem{folded->first.DivideSigned(folded->second)};
2118	if (quotAndRem.divisionByZero) {
2119	if (context.languageFeatures().ShouldWarn(
2120	common::UsageWarning::FoldingException)) {
2121	context.messages().Say(common::UsageWarning::FoldingException,
2122	"INTEGER(%d) division by zero"_warn_en_US, T::kind);
2123	}
2124	return Expr<T>{std::move(x)};
2125	}
2126	if (quotAndRem.overflow &&
2127	context.languageFeatures().ShouldWarn(
2128	common::UsageWarning::FoldingException)) {
2129	context.messages().Say(common::UsageWarning::FoldingException,
2130	"INTEGER(%d) division overflowed"_warn_en_US, T::kind);
2131	}
2132	return Expr<T>{Constant<T>{quotAndRem.quotient}};
2133	} else if constexpr (T::category == TypeCategory::Unsigned) {
2134	auto quotAndRem{folded->first.DivideUnsigned(folded->second)};
2135	if (quotAndRem.divisionByZero) {
2136	if (context.languageFeatures().ShouldWarn(
2137	common::UsageWarning::FoldingException)) {
2138	context.messages().Say(common::UsageWarning::FoldingException,
2139	"UNSIGNED(%d) division by zero"_warn_en_US, T::kind);
2140	}
2141	return Expr<T>{std::move(x)};
2142	}
2143	return Expr<T>{Constant<T>{quotAndRem.quotient}};
2144	} else {
2145	auto quotient{folded->first.Divide(
2146	folded->second, context.targetCharacteristics().roundingMode())};
2147	// Don't warn about -1./0., 0./0., or 1./0. from a module file
2148	// they are interpreted as canonical Fortran representations of -Inf,
2149	// NaN, and Inf respectively.
2150	bool isCanonicalNaNOrInf{false};
2151	if constexpr (T::category == TypeCategory::Real) {
2152	if (folded->second.IsZero() && context.moduleFileName().has_value()) {
2153	using IntType = typename T::Scalar::Word;
2154	auto intNumerator{folded->first.template ToInteger<IntType>()};
2155	isCanonicalNaNOrInf = intNumerator.flags == RealFlags{} &&
2156	intNumerator.value >= IntType{-1} &&
2157	intNumerator.value <= IntType{1};
2158	}
2159	}
2160	if (!isCanonicalNaNOrInf) {
2161	RealFlagWarnings(context, quotient.flags, "division");
2162	}
2163	if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2164	quotient.value = quotient.value.FlushSubnormalToZero();
2165	}
2166	return Expr<T>{Constant<T>{quotient.value}};
2167	}
2168	}
2169	return Expr<T>{std::move(x)};
2170	}
2171
2172	template <typename T>
2173	Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
2174	if (auto array{ApplyElementwise(context, x)}) {
2175	return *array;
2176	}
2177	if (auto folded{OperandsAreConstants(x)}) {
2178	if constexpr (T::category == TypeCategory::Integer) {
2179	auto power{folded->first.Power(folded->second)};
2180	if (context.languageFeatures().ShouldWarn(
2181	common::UsageWarning::FoldingException)) {
2182	if (power.divisionByZero) {
2183	context.messages().Say(common::UsageWarning::FoldingException,
2184	"INTEGER(%d) zero to negative power"_warn_en_US, T::kind);
2185	} else if (power.overflow) {
2186	context.messages().Say(common::UsageWarning::FoldingException,
2187	"INTEGER(%d) power overflowed"_warn_en_US, T::kind);
2188	} else if (power.zeroToZero) {
2189	context.messages().Say(common::UsageWarning::FoldingException,
2190	"INTEGER(%d) 0**0 is not defined"_warn_en_US, T::kind);
2191	}
2192	}
2193	return Expr<T>{Constant<T>{power.power}};
2194	} else {
2195	if (folded->first.IsZero()) {
2196	if (folded->second.IsZero()) {
2197	context.messages().Say(common::UsageWarning::FoldingException,
2198	"REAL/COMPLEX 0**0 is not defined"_warn_en_US);
2199	} else {
2200	return Expr<T>(Constant<T>{folded->first}); // 0. ** nonzero -> 0.
2201	}
2202	} else if (auto callable{GetHostRuntimeWrapper<T, T, T>("pow")}) {
2203	return Expr<T>{
2204	Constant<T>{(*callable)(context, folded->first, folded->second)}};
2205	} else if (context.languageFeatures().ShouldWarn(
2206	common::UsageWarning::FoldingFailure)) {
2207	context.messages().Say(common::UsageWarning::FoldingFailure,
2208	"Power for %s cannot be folded on host"_warn_en_US,
2209	T{}.AsFortran());
2210	}
2211	}
2212	}
2213	return Expr<T>{std::move(x)};
2214	}
2215
2216	template <typename T>
2217	Expr<T> FoldOperation(FoldingContext &context, RealToIntPower<T> &&x) {
2218	if (auto array{ApplyElementwise(context, x)}) {
2219	return *array;
2220	}
2221	return common::visit(
2222	[&](auto &y) -> Expr<T> {
2223	if (auto folded{OperandsAreConstants(x.left(), y)}) {
2224	auto power{evaluate::IntPower(folded->first, folded->second)};
2225	RealFlagWarnings(context, power.flags, "power with INTEGER exponent");
2226	if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2227	power.value = power.value.FlushSubnormalToZero();
2228	}
2229	return Expr<T>{Constant<T>{power.value}};
2230	} else {
2231	return Expr<T>{std::move(x)};
2232	}
2233	},
2234	x.right().u);
2235	}
2236
2237	template <typename T>
2238	Expr<T> FoldOperation(FoldingContext &context, Extremum<T> &&x) {
2239	if (auto array{ApplyElementwise(context, x,
2240	std::function<Expr<T>(Expr<T> &&, Expr<T> &&)>{[=](Expr<T> &&l,
2241	Expr<T> &&r) {
2242	return Expr<T>{Extremum<T>{x.ordering, std::move(l), std::move(r)}};
2243	}})}) {
2244	return *array;
2245	}
2246	if (auto folded{OperandsAreConstants(x)}) {
2247	if constexpr (T::category == TypeCategory::Integer) {
2248	if (folded->first.CompareSigned(folded->second) == x.ordering) {
2249	return Expr<T>{Constant<T>{folded->first}};
2250	}
2251	} else if constexpr (T::category == TypeCategory::Unsigned) {
2252	if (folded->first.CompareUnsigned(folded->second) == x.ordering) {
2253	return Expr<T>{Constant<T>{folded->first}};
2254	}
2255	} else if constexpr (T::category == TypeCategory::Real) {
2256	if (folded->first.IsNotANumber() ||
2257	(folded->first.Compare(folded->second) == Relation::Less) ==
2258	(x.ordering == Ordering::Less)) {
2259	return Expr<T>{Constant<T>{folded->first}};
2260	}
2261	} else {
2262	static_assert(T::category == TypeCategory::Character);
2263	// Result of MIN and MAX on character has the length of
2264	// the longest argument.
2265	auto maxLen{std::max(folded->first.length(), folded->second.length())};
2266	bool isFirst{x.ordering == Compare(folded->first, folded->second)};
2267	auto res{isFirst ? std::move(folded->first) : std::move(folded->second)};
2268	res = res.length() == maxLen
2269	? std::move(res)
2270	: CharacterUtils<T::kind>::Resize(res, maxLen);
2271	return Expr<T>{Constant<T>{std::move(res)}};
2272	}
2273	return Expr<T>{Constant<T>{folded->second}};
2274	}
2275	return Expr<T>{std::move(x)};
2276	}
2277
2278	template <int KIND>
2279	Expr<Type<TypeCategory::Real, KIND>> ToReal(
2280	FoldingContext &context, Expr<SomeType> &&expr) {
2281	using Result = Type<TypeCategory::Real, KIND>;
2282	std::optional<Expr<Result>> result;
2283	common::visit(
2284	[&](auto &&x) {
2285	using From = std::decay_t<decltype(x)>;
2286	if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
2287	// Move the bits without any integer->real conversion
2288	From original{x};
2289	result = ConvertToType<Result>(std::move(x));
2290	const auto *constant{UnwrapExpr<Constant<Result>>(*result)};
2291	CHECK(constant);
2292	Scalar<Result> real{constant->GetScalarValue().value()};
2293	From converted{From::ConvertUnsigned(real.RawBits()).value};
2294	if (original != converted &&
2295	context.languageFeatures().ShouldWarn(
2296	common::UsageWarning::FoldingValueChecks)) { // C1601
2297	context.messages().Say(common::UsageWarning::FoldingValueChecks,
2298	"Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_warn_en_US);
2299	}
2300	} else if constexpr (IsNumericCategoryExpr<From>()) {
2301	result = Fold(context, ConvertToType<Result>(std::move(x)));
2302	} else {
2303	common::die("ToReal: bad argument expression");
2304	}
2305	},
2306	std::move(expr.u));
2307	return result.value();
2308	}
2309
2310	// REAL(z) and AIMAG(z)
2311	template <int KIND>
2312	Expr<Type<TypeCategory::Real, KIND>> FoldOperation(
2313	FoldingContext &context, ComplexComponent<KIND> &&x) {
2314	using Operand = Type<TypeCategory::Complex, KIND>;
2315	using Result = Type<TypeCategory::Real, KIND>;
2316	if (auto array{ApplyElementwise(context, x,
2317	std::function<Expr<Result>(Expr<Operand> &&)>{
2318	[=](Expr<Operand> &&operand) {
2319	return Expr<Result>{ComplexComponent<KIND>{
2320	x.isImaginaryPart, std::move(operand)}};
2321	}})}) {
2322	return *array;
2323	}
2324	auto &operand{x.left()};
2325	if (auto value{GetScalarConstantValue<Operand>(operand)}) {
2326	if (x.isImaginaryPart) {
2327	return Expr<Result>{Constant<Result>{value->AIMAG()}};
2328	} else {
2329	return Expr<Result>{Constant<Result>{value->REAL()}};
2330	}
2331	}
2332	return Expr<Result>{std::move(x)};
2333	}
2334
2335	template <typename T>
2336	Expr<T> ExpressionBase<T>::Rewrite(FoldingContext &context, Expr<T> &&expr) {
2337	return common::visit(
2338	[&](auto &&x) -> Expr<T> {
2339	if constexpr (IsSpecificIntrinsicType<T>) {
2340	return FoldOperation(context, std::move(x));
2341	} else if constexpr (std::is_same_v<T, SomeDerived>) {
2342	return FoldOperation(context, std::move(x));
2343	} else if constexpr (common::HasMember<decltype(x),
2344	TypelessExpression>) {
2345	return std::move(expr);
2346	} else {
2347	return Expr<T>{Fold(context, std::move(x))};
2348	}
2349	},
2350	std::move(expr.u));
2351	}
2352
2353	FOR_EACH_TYPE_AND_KIND(extern template class ExpressionBase, )
2354	} // namespace Fortran::evaluate
2355	#endif // FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
2356