1	//===-- lib/Semantics/expression.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/Semantics/expression.h"
10	#include "check-call.h"
11	#include "pointer-assignment.h"
12	#include "resolve-names-utils.h"
13	#include "resolve-names.h"
14	#include "flang/Common/idioms.h"
15	#include "flang/Common/type-kinds.h"
16	#include "flang/Evaluate/common.h"
17	#include "flang/Evaluate/fold.h"
18	#include "flang/Evaluate/tools.h"
19	#include "flang/Parser/characters.h"
20	#include "flang/Parser/dump-parse-tree.h"
21	#include "flang/Parser/parse-tree-visitor.h"
22	#include "flang/Parser/parse-tree.h"
23	#include "flang/Semantics/scope.h"
24	#include "flang/Semantics/semantics.h"
25	#include "flang/Semantics/symbol.h"
26	#include "flang/Semantics/tools.h"
27	#include "flang/Support/Fortran.h"
28	#include "llvm/Support/raw_ostream.h"
29	#include <algorithm>
30	#include <functional>
31	#include <optional>
32	#include <set>
33	#include <vector>
34
35	// Typedef for optional generic expressions (ubiquitous in this file)
36	using MaybeExpr =
37	std::optional<Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>;
38
39	// Much of the code that implements semantic analysis of expressions is
40	// tightly coupled with their typed representations in lib/Evaluate,
41	// and appears here in namespace Fortran::evaluate for convenience.
42	namespace Fortran::evaluate {
43
44	using common::LanguageFeature;
45	using common::NumericOperator;
46	using common::TypeCategory;
47
48	static inline std::string ToUpperCase(std::string_view str) {
49	return parser::ToUpperCaseLetters(str);
50	}
51
52	struct DynamicTypeWithLength : public DynamicType {
53	explicit DynamicTypeWithLength(const DynamicType &t) : DynamicType{t} {}
54	std::optional<Expr<SubscriptInteger>> LEN() const;
55	std::optional<Expr<SubscriptInteger>> length;
56	};
57
58	std::optional<Expr<SubscriptInteger>> DynamicTypeWithLength::LEN() const {
59	if (length) {
60	return length;
61	} else {
62	return GetCharLength();
63	}
64	}
65
66	static std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(
67	const std::optional<parser::TypeSpec> &spec, FoldingContext &context) {
68	if (spec) {
69	if (const semantics::DeclTypeSpec *typeSpec{spec->declTypeSpec}) {
70	// Name resolution sets TypeSpec::declTypeSpec only when it's valid
71	// (viz., an intrinsic type with valid known kind or a non-polymorphic
72	// & non-ABSTRACT derived type).
73	if (const semantics::IntrinsicTypeSpec *intrinsic{
74	typeSpec->AsIntrinsic()}) {
75	TypeCategory category{intrinsic->category()};
76	if (auto optKind{ToInt64(intrinsic->kind())}) {
77	int kind{static_cast<int>(*optKind)};
78	if (category == TypeCategory::Character) {
79	const semantics::CharacterTypeSpec &cts{
80	typeSpec->characterTypeSpec()};
81	const semantics::ParamValue &len{cts.length()};
82	if (len.isAssumed() || len.isDeferred()) {
83	context.messages().Say(
84	"A length specifier of '*' or ':' may not appear in the type of an array constructor"_err_en_US);
85	}
86	DynamicTypeWithLength type{DynamicType{kind, len}};
87	if (auto lenExpr{type.LEN()}) {
88	type.length = Fold(context,
89	AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,
90	Expr<SubscriptInteger>{0}, std::move(*lenExpr)}));
91	}
92	return type;
93	} else {
94	return DynamicTypeWithLength{DynamicType{category, kind}};
95	}
96	}
97	} else if (const semantics::DerivedTypeSpec *derived{
98	typeSpec->AsDerived()}) {
99	return DynamicTypeWithLength{DynamicType{*derived}};
100	}
101	}
102	}
103	return std::nullopt;
104	}
105
106	// Utilities to set a source location, if we have one, on an actual argument,
107	// when it is statically present.
108	static void SetArgSourceLocation(ActualArgument &x, parser::CharBlock at) {
109	x.set_sourceLocation(at);
110	}
111	static void SetArgSourceLocation(
112	std::optional<ActualArgument> &x, parser::CharBlock at) {
113	if (x) {
114	x->set_sourceLocation(at);
115	}
116	}
117	static void SetArgSourceLocation(
118	std::optional<ActualArgument> &x, std::optional<parser::CharBlock> at) {
119	if (x && at) {
120	x->set_sourceLocation(*at);
121	}
122	}
123
124	class ArgumentAnalyzer {
125	public:
126	explicit ArgumentAnalyzer(ExpressionAnalyzer &context)
127	: context_{context}, source_{context.GetContextualMessages().at()},
128	isProcedureCall_{false} {}
129	ArgumentAnalyzer(ExpressionAnalyzer &context, parser::CharBlock source,
130	bool isProcedureCall = false)
131	: context_{context}, source_{source}, isProcedureCall_{isProcedureCall} {}
132	bool fatalErrors() const { return fatalErrors_; }
133	ActualArguments &&GetActuals() {
134	CHECK(!fatalErrors_);
135	return std::move(actuals_);
136	}
137	const Expr<SomeType> &GetExpr(std::size_t i) const {
138	return DEREF(actuals_.at(i).value().UnwrapExpr());
139	}
140	Expr<SomeType> &&MoveExpr(std::size_t i) {
141	return std::move(DEREF(actuals_.at(i).value().UnwrapExpr()));
142	}
143	void Analyze(const common::Indirection<parser::Expr> &x) {
144	Analyze(x: x.value());
145	}
146	void Analyze(const parser::Expr &x) {
147	actuals_.emplace_back(AnalyzeExpr(x));
148	SetArgSourceLocation(actuals_.back(), x.source);
149	fatalErrors_ |= !actuals_.back();
150	}
151	void Analyze(const parser::Variable &);
152	void Analyze(const parser::ActualArgSpec &, bool isSubroutine);
153	void ConvertBOZOperand(std::optional<DynamicType> *thisType, std::size_t,
154	std::optional<DynamicType> otherType);
155	void ConvertBOZAssignmentRHS(const DynamicType &lhsType);
156
157	bool IsIntrinsicRelational(
158	RelationalOperator, const DynamicType &, const DynamicType &) const;
159	bool IsIntrinsicLogical() const;
160	bool IsIntrinsicNumeric(NumericOperator) const;
161	bool IsIntrinsicConcat() const;
162
163	bool CheckConformance();
164	bool CheckAssignmentConformance();
165	bool CheckForNullPointer(const char *where = "as an operand here");
166	bool CheckForAssumedRank(const char *where = "as an operand here");
167
168	// Find and return a user-defined operator or report an error.
169	// The provided message is used if there is no such operator.
170	// If a definedOpSymbolPtr is provided, the caller must check
171	// for its accessibility.
172	MaybeExpr TryDefinedOp(
173	const char *, parser::MessageFixedText, bool isUserOp = false);
174	template <typename E>
175	MaybeExpr TryDefinedOp(E opr, parser::MessageFixedText msg) {
176	return TryDefinedOp(
177	context_.context().languageFeatures().GetNames(opr), msg);
178	}
179	// Find and return a user-defined assignment
180	std::optional<ProcedureRef> TryDefinedAssignment();
181	std::optional<ProcedureRef> GetDefinedAssignmentProc();
182	std::optional<DynamicType> GetType(std::size_t) const;
183	void Dump(llvm::raw_ostream &);
184
185	private:
186	MaybeExpr TryDefinedOp(
187	const std::vector<const char *> &, parser::MessageFixedText);
188	MaybeExpr TryBoundOp(const Symbol &, int passIndex);
189	std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
190	std::optional<ActualArgument> AnalyzeVariable(const parser::Variable &);
191	MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);
192	bool AreConformable() const;
193	const Symbol *FindBoundOp(parser::CharBlock, int passIndex,
194	const Symbol *&generic, bool isSubroutine);
195	void AddAssignmentConversion(
196	const DynamicType &lhsType, const DynamicType &rhsType);
197	bool OkLogicalIntegerAssignment(TypeCategory lhs, TypeCategory rhs);
198	int GetRank(std::size_t) const;
199	bool IsBOZLiteral(std::size_t i) const {
200	return evaluate::IsBOZLiteral(GetExpr(i));
201	}
202	void SayNoMatch(const std::string &, bool isAssignment = false);
203	std::string TypeAsFortran(std::size_t);
204	bool AnyUntypedOrMissingOperand();
205
206	ExpressionAnalyzer &context_;
207	ActualArguments actuals_;
208	parser::CharBlock source_;
209	bool fatalErrors_{false};
210	const bool isProcedureCall_; // false for user-defined op or assignment
211	};
212
213	// Wraps a data reference in a typed Designator<>, and a procedure
214	// or procedure pointer reference in a ProcedureDesignator.
215	MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
216	const Symbol &last{ref.GetLastSymbol()};
217	const Symbol &specific{BypassGeneric(last)};
218	const Symbol &symbol{specific.GetUltimate()};
219	if (semantics::IsProcedure(symbol)) {
220	if (symbol.attrs().test(semantics::Attr::ABSTRACT)) {
221	Say("Abstract procedure interface '%s' may not be used as a designator"_err_en_US,
222	last.name());
223	}
224	if (auto *component{std::get_if<Component>(&ref.u)}) {
225	if (!CheckDataRef(ref)) {
226	return std::nullopt;
227	}
228	return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
229	} else if (!std::holds_alternative<SymbolRef>(ref.u)) {
230	DIE("unexpected alternative in DataRef");
231	} else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
232	if (symbol.has<semantics::GenericDetails>()) {
233	Say("'%s' is not a specific procedure"_err_en_US, last.name());
234	} else if (IsProcedurePointer(specific)) {
235	// For procedure pointers, retain associations so that data accesses
236	// from client modules will work.
237	return Expr<SomeType>{ProcedureDesignator{specific}};
238	} else {
239	return Expr<SomeType>{ProcedureDesignator{symbol}};
240	}
241	} else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
242	symbol.name().ToString())};
243	interface && !interface->isRestrictedSpecific) {
244	SpecificIntrinsic intrinsic{
245	symbol.name().ToString(), std::move(*interface)};
246	intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
247	return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
248	} else {
249	Say("'%s' is not an unrestricted specific intrinsic procedure"_err_en_US,
250	last.name());
251	}
252	return std::nullopt;
253	} else if (MaybeExpr result{AsGenericExpr(std::move(ref))}) {
254	return result;
255	} else if (semantics::HadUseError(
256	context_, GetContextualMessages().at(), &symbol)) {
257	return std::nullopt;
258	} else {
259	if (!context_.HasError(last) && !context_.HasError(symbol)) {
260	AttachDeclaration(
261	Say("'%s' is not an object that can appear in an expression"_err_en_US,
262	last.name()),
263	symbol);
264	context_.SetError(last);
265	}
266	return std::nullopt;
267	}
268	}
269
270	// Returns false if any dimension could be empty (e.g. A(1:0)) or has an error
271	static bool FoldSubscripts(semantics::SemanticsContext &context,
272	const Symbol &arraySymbol, std::vector<Subscript> &subscripts, Shape &lb,
273	Shape &ub) {
274	FoldingContext &foldingContext{context.foldingContext()};
275	lb = GetLBOUNDs(foldingContext, NamedEntity{arraySymbol});
276	CHECK(lb.size() >= subscripts.size());
277	ub = GetUBOUNDs(foldingContext, NamedEntity{arraySymbol});
278	CHECK(ub.size() >= subscripts.size());
279	bool anyPossiblyEmptyDim{false};
280	int dim{0};
281	for (Subscript &ss : subscripts) {
282	if (Triplet * triplet{std::get_if<Triplet>(&ss.u)}) {
283	auto expr{Fold(foldingContext, triplet->stride())};
284	auto stride{ToInt64(expr)};
285	triplet->set_stride(std::move(expr));
286	std::optional<ConstantSubscript> lower, upper;
287	if (auto expr{triplet->lower()}) {
288	*expr = Fold(foldingContext, std::move(*expr));
289	lower = ToInt64(*expr);
290	triplet->set_lower(std::move(*expr));
291	} else {
292	lower = ToInt64(lb[dim]);
293	}
294	if (auto expr{triplet->upper()}) {
295	*expr = Fold(foldingContext, std::move(*expr));
296	upper = ToInt64(*expr);
297	triplet->set_upper(std::move(*expr));
298	} else {
299	upper = ToInt64(ub[dim]);
300	}
301	if (stride) {
302	if (*stride == 0) {
303	foldingContext.messages().Say(
304	"Stride of triplet must not be zero"_err_en_US);
305	return false; // error
306	}
307	if (lower && upper) {
308	if (*stride > 0) {
309	anyPossiblyEmptyDim |= *lower > *upper;
310	} else {
311	anyPossiblyEmptyDim |= *lower < *upper;
312	}
313	} else {
314	anyPossiblyEmptyDim = true;
315	}
316	} else { // non-constant stride
317	if (lower && upper && *lower == *upper) {
318	// stride is not relevant
319	} else {
320	anyPossiblyEmptyDim = true;
321	}
322	}
323	} else { // not triplet
324	auto &expr{std::get<IndirectSubscriptIntegerExpr>(ss.u).value()};
325	expr = Fold(foldingContext, std::move(expr));
326	anyPossiblyEmptyDim |= expr.Rank() > 0; // vector subscript
327	}
328	++dim;
329	}
330	return !anyPossiblyEmptyDim;
331	}
332
333	static void ValidateSubscriptValue(parser::ContextualMessages &messages,
334	const Symbol &symbol, ConstantSubscript val,
335	std::optional<ConstantSubscript> lb, std::optional<ConstantSubscript> ub,
336	int dim, const char *co = "") {
337	std::optional<parser::MessageFixedText> msg;
338	std::optional<ConstantSubscript> bound;
339	if (lb && val < *lb) {
340	msg =
341	"%ssubscript %jd is less than lower %sbound %jd for %sdimension %d of array"_err_en_US;
342	bound = *lb;
343	} else if (ub && val > *ub) {
344	msg =
345	"%ssubscript %jd is greater than upper %sbound %jd for %sdimension %d of array"_err_en_US;
346	bound = *ub;
347	if (dim + 1 == symbol.Rank() && IsDummy(symbol) && *bound == 1) {
348	// Old-school overindexing of a dummy array isn't fatal when
349	// it's on the last dimension and the extent is 1.
350	msg->set_severity(parser::Severity::Warning);
351	}
352	}
353	if (msg) {
354	AttachDeclaration(
355	messages.Say(std::move(*msg), co, static_cast<std::intmax_t>(val), co,
356	static_cast<std::intmax_t>(bound.value()), co, dim + 1),
357	symbol);
358	}
359	}
360
361	static void ValidateSubscripts(semantics::SemanticsContext &context,
362	const Symbol &arraySymbol, const std::vector<Subscript> &subscripts,
363	const Shape &lb, const Shape &ub) {
364	int dim{0};
365	for (const Subscript &ss : subscripts) {
366	auto dimLB{ToInt64(lb[dim])};
367	auto dimUB{ToInt64(ub[dim])};
368	if (dimUB && dimLB && *dimUB < *dimLB) {
369	AttachDeclaration(
370	context.Warn(common::UsageWarning::SubscriptedEmptyArray,
371	context.foldingContext().messages().at(),
372	"Empty array dimension %d should not be subscripted as an element or non-empty array section"_err_en_US,
373	dim + 1),
374	arraySymbol);
375	break;
376	}
377	std::optional<ConstantSubscript> val[2];
378	int vals{0};
379	if (auto *triplet{std::get_if<Triplet>(&ss.u)}) {
380	auto stride{ToInt64(triplet->stride())};
381	std::optional<ConstantSubscript> lower, upper;
382	if (const auto *lowerExpr{triplet->GetLower()}) {
383	lower = ToInt64(*lowerExpr);
384	} else if (lb[dim]) {
385	lower = ToInt64(*lb[dim]);
386	}
387	if (const auto *upperExpr{triplet->GetUpper()}) {
388	upper = ToInt64(*upperExpr);
389	} else if (ub[dim]) {
390	upper = ToInt64(*ub[dim]);
391	}
392	if (lower) {
393	val[vals++] = *lower;
394	if (upper && *upper != lower && (stride && *stride != 0)) {
395	// Normalize upper bound for non-unit stride
396	// 1:10:2 -> 1:9:2, 10:1:-2 -> 10:2:-2
397	val[vals++] = *lower + *stride * ((*upper - *lower) / *stride);
398	}
399	}
400	} else {
401	val[vals++] =
402	ToInt64(std::get<IndirectSubscriptIntegerExpr>(ss.u).value());
403	}
404	for (int j{0}; j < vals; ++j) {
405	if (val[j]) {
406	ValidateSubscriptValue(context.foldingContext().messages(), arraySymbol,
407	*val[j], dimLB, dimUB, dim);
408	}
409	}
410	++dim;
411	}
412	}
413
414	static void CheckSubscripts(
415	semantics::SemanticsContext &context, ArrayRef &ref) {
416	const Symbol &arraySymbol{ref.base().GetLastSymbol()};
417	Shape lb, ub;
418	if (FoldSubscripts(context, arraySymbol, ref.subscript(), lb, ub)) {
419	ValidateSubscripts(context, arraySymbol, ref.subscript(), lb, ub);
420	}
421	}
422
423	static void CheckCosubscripts(
424	semantics::SemanticsContext &context, CoarrayRef &ref) {
425	const Symbol &coarraySymbol{ref.GetLastSymbol()};
426	FoldingContext &foldingContext{context.foldingContext()};
427	int dim{0};
428	for (auto &expr : ref.cosubscript()) {
429	expr = Fold(foldingContext, std::move(expr));
430	if (auto val{ToInt64(expr)}) {
431	ValidateSubscriptValue(foldingContext.messages(), coarraySymbol, *val,
432	ToInt64(GetLCOBOUND(coarraySymbol, dim)),
433	ToInt64(GetUCOBOUND(coarraySymbol, dim)), dim, "co");
434	}
435	++dim;
436	}
437	}
438
439	// Some subscript semantic checks must be deferred until all of the
440	// subscripts are in hand.
441	MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) {
442	const Symbol &symbol{ref.GetLastSymbol().GetUltimate()};
443	int symbolRank{symbol.Rank()};
444	int subscripts{static_cast<int>(ref.size())};
445	if (subscripts == 0) {
446	return std::nullopt; // error recovery
447	} else if (subscripts != symbolRank) {
448	if (symbolRank != 0) {
449	Say("Reference to rank-%d object '%s' has %d subscripts"_err_en_US,
450	symbolRank, symbol.name(), subscripts);
451	}
452	return std::nullopt;
453	} else if (symbol.has<semantics::ObjectEntityDetails>() ||
454	symbol.has<semantics::AssocEntityDetails>()) {
455	// C928 & C1002
456	if (Triplet * last{std::get_if<Triplet>(&ref.subscript().back().u)}) {
457	if (!last->upper() && IsAssumedSizeArray(symbol)) {
458	Say("Assumed-size array '%s' must have explicit final subscript upper bound value"_err_en_US,
459	symbol.name());
460	return std::nullopt;
461	}
462	}
463	} else {
464	// Shouldn't get here from Analyze(ArrayElement) without a valid base,
465	// which, if not an object, must be a construct entity from
466	// SELECT TYPE/RANK or ASSOCIATE.
467	CHECK(symbol.has<semantics::AssocEntityDetails>());
468	}
469	if (!semantics::IsNamedConstant(symbol) && !inDataStmtObject_) {
470	// Subscripts of named constants are checked in folding.
471	// Subscripts of DATA statement objects are checked in data statement
472	// conversion to initializers.
473	CheckSubscripts(context_, ref);
474	}
475	return Designate(DataRef{std::move(ref)});
476	}
477
478	// Applies subscripts to a data reference.
479	MaybeExpr ExpressionAnalyzer::ApplySubscripts(
480	DataRef &&dataRef, std::vector<Subscript> &&subscripts) {
481	if (subscripts.empty()) {
482	return std::nullopt; // error recovery
483	}
484	return common::visit(common::visitors{
485	[&](SymbolRef &&symbol) {
486	return CompleteSubscripts(
487	ArrayRef{symbol, std::move(subscripts)});
488	},
489	[&](Component &&c) {
490	return CompleteSubscripts(
491	ArrayRef{std::move(c), std::move(subscripts)});
492	},
493	[&](auto &&) -> MaybeExpr {
494	DIE("bad base for ArrayRef");
495	return std::nullopt;
496	},
497	},
498	std::move(dataRef.u));
499	}
500
501	// C919a - only one part-ref of a data-ref may have rank > 0
502	bool ExpressionAnalyzer::CheckRanks(const DataRef &dataRef) {
503	return common::visit(
504	common::visitors{
505	[this](const Component &component) {
506	const Symbol &symbol{component.GetLastSymbol()};
507	if (int componentRank{symbol.Rank()}; componentRank > 0) {
508	if (int baseRank{component.base().Rank()}; baseRank > 0) {
509	Say("Reference to whole rank-%d component '%s' of rank-%d array of derived type is not allowed"_err_en_US,
510	componentRank, symbol.name(), baseRank);
511	return false;
512	}
513	} else {
514	return CheckRanks(component.base());
515	}
516	return true;
517	},
518	[this](const ArrayRef &arrayRef) {
519	if (const auto *component{arrayRef.base().UnwrapComponent()}) {
520	int subscriptRank{0};
521	for (const Subscript &subscript : arrayRef.subscript()) {
522	subscriptRank += subscript.Rank();
523	}
524	if (subscriptRank > 0) {
525	if (int componentBaseRank{component->base().Rank()};
526	componentBaseRank > 0) {
527	Say("Subscripts of component '%s' of rank-%d derived type array have rank %d but must all be scalar"_err_en_US,
528	component->GetLastSymbol().name(), componentBaseRank,
529	subscriptRank);
530	return false;
531	}
532	} else {
533	return CheckRanks(component->base());
534	}
535	}
536	return true;
537	},
538	[](const SymbolRef &) { return true; },
539	[](const CoarrayRef &) { return true; },
540	},
541	dataRef.u);
542	}
543
544	// C911 - if the last name in a data-ref has an abstract derived type,
545	// it must also be polymorphic.
546	bool ExpressionAnalyzer::CheckPolymorphic(const DataRef &dataRef) {
547	if (auto type{DynamicType::From(dataRef.GetLastSymbol())}) {
548	if (type->category() == TypeCategory::Derived && !type->IsPolymorphic()) {
549	const Symbol &typeSymbol{
550	type->GetDerivedTypeSpec().typeSymbol().GetUltimate()};
551	if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) {
552	AttachDeclaration(
553	Say("Reference to object with abstract derived type '%s' must be polymorphic"_err_en_US,
554	typeSymbol.name()),
555	typeSymbol);
556	return false;
557	}
558	}
559	}
560	return true;
561	}
562
563	bool ExpressionAnalyzer::CheckDataRef(const DataRef &dataRef) {
564	// Always check both, don't short-circuit
565	bool ranksOk{CheckRanks(dataRef)};
566	bool polyOk{CheckPolymorphic(dataRef)};
567	return ranksOk && polyOk;
568	}
569
570	// Parse tree correction after a substring S(j:k) was misparsed as an
571	// array section. Fortran substrings must have a range, not a
572	// single index.
573	static std::optional<parser::Substring> FixMisparsedSubstringDataRef(
574	parser::DataRef &dataRef) {
575	if (auto *ae{
576	std::get_if<common::Indirection<parser::ArrayElement>>(&dataRef.u)}) {
577	// ...%a(j:k) and "a" is a character scalar
578	parser::ArrayElement &arrElement{ae->value()};
579	if (arrElement.subscripts.size() == 1) {
580	if (auto *triplet{std::get_if<parser::SubscriptTriplet>(
581	&arrElement.subscripts.front().u)}) {
582	if (!std::get<2 /*stride*/>(triplet->t).has_value()) {
583	if (const Symbol *symbol{
584	parser::GetLastName(arrElement.base).symbol}) {
585	const Symbol &ultimate{symbol->GetUltimate()};
586	if (const semantics::DeclTypeSpec *type{ultimate.GetType()}) {
587	if (ultimate.Rank() == 0 &&
588	type->category() == semantics::DeclTypeSpec::Character) {
589	// The ambiguous S(j:k) was parsed as an array section
590	// reference, but it's now clear that it's a substring.
591	// Fix the parse tree in situ.
592	return arrElement.ConvertToSubstring();
593	}
594	}
595	}
596	}
597	}
598	}
599	}
600	return std::nullopt;
601	}
602
603	// When a designator is a misparsed type-param-inquiry of a misparsed
604	// substring -- it looks like a structure component reference of an array
605	// slice -- fix the substring and then convert to an intrinsic function
606	// call to KIND() or LEN(). And when the designator is a misparsed
607	// substring, convert it into a substring reference in place.
608	MaybeExpr ExpressionAnalyzer::FixMisparsedSubstring(
609	const parser::Designator &d) {
610	auto &mutate{const_cast<parser::Designator &>(d)};
611	if (auto *dataRef{std::get_if<parser::DataRef>(&mutate.u)}) {
612	if (auto *sc{std::get_if<common::Indirection<parser::StructureComponent>>(
613	&dataRef->u)}) {
614	parser::StructureComponent &structComponent{sc->value()};
615	parser::CharBlock which{structComponent.component.source};
616	if (which == "kind" || which == "len") {
617	if (auto substring{
618	FixMisparsedSubstringDataRef(structComponent.base)}) {
619	// ...%a(j:k)%kind or %len and "a" is a character scalar
620	mutate.u = std::move(*substring);
621	if (MaybeExpr substringExpr{Analyze(d)}) {
622	return MakeFunctionRef(which,
623	ActualArguments{ActualArgument{std::move(*substringExpr)}});
624	}
625	}
626	}
627	} else if (auto substring{FixMisparsedSubstringDataRef(*dataRef)}) {
628	mutate.u = std::move(*substring);
629	}
630	}
631	return std::nullopt;
632	}
633
634	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {
635	auto restorer{GetContextualMessages().SetLocation(d.source)};
636	if (auto substringInquiry{FixMisparsedSubstring(d)}) {
637	return substringInquiry;
638	}
639	// These checks have to be deferred to these "top level" data-refs where
640	// we can be sure that there are no following subscripts (yet).
641	MaybeExpr result{Analyze(d.u)};
642	if (result) {
643	std::optional<DataRef> dataRef{ExtractDataRef(std::move(result))};
644	if (!dataRef) {
645	dataRef = ExtractDataRef(std::move(result), /*intoSubstring=*/true);
646	}
647	if (!dataRef) {
648	dataRef = ExtractDataRef(std::move(result),
649	/*intoSubstring=*/false, /*intoComplexPart=*/true);
650	}
651	if (dataRef) {
652	if (!CheckDataRef(*dataRef)) {
653	result.reset();
654	} else if (ExtractCoarrayRef(*dataRef).has_value()) {
655	if (auto dyType{result->GetType()};
656	dyType && dyType->category() == TypeCategory::Derived) {
657	if (!std::holds_alternative<CoarrayRef>(dataRef->u) &&
658	dyType->IsPolymorphic()) { // F'2023 C918
659	Say("The base of a polymorphic object may not be coindexed"_err_en_US);
660	}
661	if (const auto *derived{GetDerivedTypeSpec(*dyType)}) {
662	if (auto bad{FindPolymorphicAllocatablePotentialComponent(
663	*derived)}) { // F'2023 C917
664	Say("A coindexed designator may not have a type with the polymorphic potential subobject component '%s'"_err_en_US,
665	bad.BuildResultDesignatorName());
666	}
667	}
668	}
669	}
670	}
671	}
672	return result;
673	}
674
675	// A utility subroutine to repackage optional expressions of various levels
676	// of type specificity as fully general MaybeExpr values.
677	template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {
678	return AsGenericExpr(std::move(x));
679	}
680	template <typename A> MaybeExpr AsMaybeExpr(std::optional<A> &&x) {
681	if (x) {
682	return AsMaybeExpr(std::move(*x));
683	}
684	return std::nullopt;
685	}
686
687	// Type kind parameter values for literal constants.
688	int ExpressionAnalyzer::AnalyzeKindParam(
689	const std::optional<parser::KindParam> &kindParam, int defaultKind) {
690	if (!kindParam) {
691	return defaultKind;
692	}
693	std::int64_t kind{common::visit(
694	common::visitors{
695	[](std::uint64_t k) { return static_cast<std::int64_t>(k); },
696	[&](const parser::Scalar<
697	parser::Integer<parser::Constant<parser::Name>>> &n) {
698	if (MaybeExpr ie{Analyze(n)}) {
699	return ToInt64(*ie).value_or(defaultKind);
700	}
701	return static_cast<std::int64_t>(defaultKind);
702	},
703	},
704	kindParam->u)};
705	if (kind != static_cast<int>(kind)) {
706	Say("Unsupported type kind value (%jd)"_err_en_US,
707	static_cast<std::intmax_t>(kind));
708	kind = defaultKind;
709	}
710	return static_cast<int>(kind);
711	}
712
713	// Common handling of parser::IntLiteralConstant, SignedIntLiteralConstant,
714	// and UnsignedLiteralConstant
715	template <typename TYPES, TypeCategory CAT> struct IntTypeVisitor {
716	using Result = MaybeExpr;
717	using Types = TYPES;
718	template <typename T> Result Test() {
719	if (T::kind >= kind) {
720	const char *p{digits.begin()};
721	using Int = typename T::Scalar;
722	typename Int::ValueWithOverflow num{0, false};
723	const char *typeName{
724	CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
725	if (isNegated) {
726	auto unsignedNum{Int::Read(p, 10, false /*unsigned*/)};
727	num.value = unsignedNum.value.Negate().value;
728	num.overflow = unsignedNum.overflow ||
729	(CAT == TypeCategory::Integer && num.value > Int{0});
730	if (!num.overflow && num.value.Negate().overflow) {
731	analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
732	"negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);
733	}
734	} else {
735	num = Int::Read(p, 10, /*isSigned=*/CAT == TypeCategory::Integer);
736	}
737	if (num.overflow) {
738	if constexpr (CAT == TypeCategory::Unsigned) {
739	analyzer.Warn(common::UsageWarning::UnsignedLiteralTruncation,
740	"Unsigned literal too large for UNSIGNED(KIND=%d); truncated"_warn_en_US,
741	kind);
742	return Expr<SomeType>{
743	Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
744	}
745	} else {
746	if (T::kind > kind) {
747	if (!isDefaultKind ||
748	!analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
749	return std::nullopt;
750	} else {
751	analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
752	"Integer literal is too large for default %s(KIND=%d); "
753	"assuming %s(KIND=%d)"_port_en_US,
754	typeName, kind, typeName, T::kind);
755	}
756	}
757	return Expr<SomeType>{
758	Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
759	}
760	}
761	return std::nullopt;
762	}
763	ExpressionAnalyzer &analyzer;
764	parser::CharBlock digits;
765	std::int64_t kind;
766	bool isDefaultKind;
767	bool isNegated;
768	};
769
770	template <typename TYPES, TypeCategory CAT, typename PARSED>
771	MaybeExpr ExpressionAnalyzer::IntLiteralConstant(
772	const PARSED &x, bool isNegated) {
773	const auto &kindParam{std::get<std::optional<parser::KindParam>>(x.t)};
774	bool isDefaultKind{!kindParam};
775	int kind{AnalyzeKindParam(kindParam, GetDefaultKind(CAT))};
776	const char *typeName{CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
777	if (CheckIntrinsicKind(CAT, kind)) {
778	auto digits{std::get<parser::CharBlock>(x.t)};
779	if (MaybeExpr result{common::SearchTypes(IntTypeVisitor<TYPES, CAT>{
780	*this, digits, kind, isDefaultKind, isNegated})}) {
781	return result;
782	} else if (isDefaultKind) {
783	Say(digits,
784	"Integer literal is too large for any allowable kind of %s"_err_en_US,
785	typeName);
786	} else {
787	Say(digits, "Integer literal is too large for %s(KIND=%d)"_err_en_US,
788	typeName, kind);
789	}
790	}
791	return std::nullopt;
792	}
793
794	MaybeExpr ExpressionAnalyzer::Analyze(
795	const parser::IntLiteralConstant &x, bool isNegated) {
796	auto restorer{
797	GetContextualMessages().SetLocation(std::get<parser::CharBlock>(x.t))};
798	return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x, isNegated);
799	}
800
801	MaybeExpr ExpressionAnalyzer::Analyze(
802	const parser::SignedIntLiteralConstant &x) {
803	auto restorer{GetContextualMessages().SetLocation(x.source)};
804	return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x);
805	}
806
807	MaybeExpr ExpressionAnalyzer::Analyze(
808	const parser::UnsignedLiteralConstant &x) {
809	parser::CharBlock at{std::get<parser::CharBlock>(x.t)};
810	auto restorer{GetContextualMessages().SetLocation(at)};
811	if (!context().IsEnabled(common::LanguageFeature::Unsigned) &&
812	!context().AnyFatalError()) {
813	context().Say(
814	at, "-funsigned is required to enable UNSIGNED constants"_err_en_US);
815	}
816	return IntLiteralConstant<UnsignedTypes, TypeCategory::Unsigned>(x);
817	}
818
819	template <typename TYPE>
820	Constant<TYPE> ReadRealLiteral(
821	parser::CharBlock source, FoldingContext &context) {
822	const char *p{source.begin()};
823	auto valWithFlags{
824	Scalar<TYPE>::Read(p, context.targetCharacteristics().roundingMode())};
825	CHECK(p == source.end());
826	RealFlagWarnings(context, valWithFlags.flags, "conversion of REAL literal");
827	auto value{valWithFlags.value};
828	if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
829	value = value.FlushSubnormalToZero();
830	}
831	return {value};
832	}
833
834	struct RealTypeVisitor {
835	using Result = std::optional<Expr<SomeReal>>;
836	using Types = RealTypes;
837
838	RealTypeVisitor(int k, parser::CharBlock lit, FoldingContext &ctx)
839	: kind{k}, literal{lit}, context{ctx} {}
840
841	template <typename T> Result Test() {
842	if (kind == T::kind) {
843	return {AsCategoryExpr(ReadRealLiteral<T>(literal, context))};
844	}
845	return std::nullopt;
846	}
847
848	int kind;
849	parser::CharBlock literal;
850	FoldingContext &context;
851	};
852
853	// Reads a real literal constant and encodes it with the right kind.
854	MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
855	// Use a local message context around the real literal for better
856	// provenance on any messages.
857	auto restorer{GetContextualMessages().SetLocation(x.real.source)};
858	// If a kind parameter appears, it defines the kind of the literal and the
859	// letter used in an exponent part must be 'E' (e.g., the 'E' in
860	// "6.02214E+23"). In the absence of an explicit kind parameter, any
861	// exponent letter determines the kind. Otherwise, defaults apply.
862	auto &defaults{context_.defaultKinds()};
863	int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)};
864	const char *end{x.real.source.end()};
865	char expoLetter{' '};
866	std::optional<int> letterKind;
867	for (const char *p{x.real.source.begin()}; p < end; ++p) {
868	if (parser::IsLetter(*p)) {
869	expoLetter = *p;
870	switch (expoLetter) {
871	case 'e':
872	letterKind = defaults.GetDefaultKind(TypeCategory::Real);
873	break;
874	case 'd':
875	letterKind = defaults.doublePrecisionKind();
876	break;
877	case 'q':
878	letterKind = defaults.quadPrecisionKind();
879	break;
880	default:
881	Say("Unknown exponent letter '%c'"_err_en_US, expoLetter);
882	}
883	break;
884	}
885	}
886	if (letterKind) {
887	defaultKind = *letterKind;
888	}
889	// C716 requires 'E' as an exponent.
890	// Extension: allow exponent-letter matching the kind-param.
891	auto kind{AnalyzeKindParam(x.kind, defaultKind)};
892	if (letterKind && expoLetter != 'e') {
893	if (kind != *letterKind) {
894	Warn(common::LanguageFeature::ExponentMatchingKindParam,
895	"Explicit kind parameter on real constant disagrees with exponent letter '%c'"_warn_en_US,
896	expoLetter);
897	} else if (x.kind) {
898	Warn(common::LanguageFeature::ExponentMatchingKindParam,
899	"Explicit kind parameter together with non-'E' exponent letter is not standard"_port_en_US);
900	}
901	}
902	auto result{common::SearchTypes(
903	RealTypeVisitor{kind, x.real.source, GetFoldingContext()})};
904	if (!result) { // C717
905	Say("Unsupported REAL(KIND=%d)"_err_en_US, kind);
906	}
907	return AsMaybeExpr(std::move(result));
908	}
909
910	MaybeExpr ExpressionAnalyzer::Analyze(
911	const parser::SignedRealLiteralConstant &x) {
912	if (auto result{Analyze(std::get<parser::RealLiteralConstant>(x.t))}) {
913	auto &realExpr{std::get<Expr<SomeReal>>(result->u)};
914	if (auto sign{std::get<std::optional<parser::Sign>>(x.t)}) {
915	if (sign == parser::Sign::Negative) {
916	return AsGenericExpr(-std::move(realExpr));
917	}
918	}
919	return result;
920	}
921	return std::nullopt;
922	}
923
924	MaybeExpr ExpressionAnalyzer::Analyze(
925	const parser::SignedComplexLiteralConstant &x) {
926	auto result{Analyze(std::get<parser::ComplexLiteralConstant>(x.t))};
927	if (!result) {
928	return std::nullopt;
929	} else if (std::get<parser::Sign>(x.t) == parser::Sign::Negative) {
930	return AsGenericExpr(-std::move(std::get<Expr<SomeComplex>>(result->u)));
931	} else {
932	return result;
933	}
934	}
935
936	MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexPart &x) {
937	return Analyze(x.u);
938	}
939
940	MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexLiteralConstant &z) {
941	return AnalyzeComplex(Analyze(std::get<0>(z.t)), Analyze(std::get<1>(z.t)),
942	"complex literal constant");
943	}
944
945	// CHARACTER literal processing.
946	MaybeExpr ExpressionAnalyzer::AnalyzeString(std::string &&string, int kind) {
947	if (!CheckIntrinsicKind(TypeCategory::Character, kind)) {
948	return std::nullopt;
949	}
950	switch (kind) {
951	case 1:
952	return AsGenericExpr(Constant<Type<TypeCategory::Character, 1>>{
953	parser::DecodeString<std::string, parser::Encoding::LATIN_1>(
954	string, true)});
955	case 2:
956	return AsGenericExpr(Constant<Type<TypeCategory::Character, 2>>{
957	parser::DecodeString<std::u16string, parser::Encoding::UTF_8>(
958	string, true)});
959	case 4:
960	return AsGenericExpr(Constant<Type<TypeCategory::Character, 4>>{
961	parser::DecodeString<std::u32string, parser::Encoding::UTF_8>(
962	string, true)});
963	default:
964	CRASH_NO_CASE;
965	}
966	}
967
968	MaybeExpr ExpressionAnalyzer::Analyze(const parser::CharLiteralConstant &x) {
969	int kind{
970	AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t), 1)};
971	auto value{std::get<std::string>(x.t)};
972	return AnalyzeString(std::move(value), kind);
973	}
974
975	MaybeExpr ExpressionAnalyzer::Analyze(
976	const parser::HollerithLiteralConstant &x) {
977	int kind{GetDefaultKind(TypeCategory::Character)};
978	auto result{AnalyzeString(std::string{x.v}, kind)};
979	if (auto *constant{UnwrapConstantValue<Ascii>(result)}) {
980	constant->set_wasHollerith(true);
981	}
982	return result;
983	}
984
985	// .TRUE. and .FALSE. of various kinds
986	MaybeExpr ExpressionAnalyzer::Analyze(const parser::LogicalLiteralConstant &x) {
987	auto kind{AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t),
988	GetDefaultKind(TypeCategory::Logical))};
989	bool value{std::get<bool>(x.t)};
990	auto result{common::SearchTypes(
991	TypeKindVisitor<TypeCategory::Logical, Constant, bool>{
992	kind, std::move(value)})};
993	if (!result) {
994	Say("unsupported LOGICAL(KIND=%d)"_err_en_US, kind); // C728
995	}
996	return result;
997	}
998
999	// BOZ typeless literals
1000	MaybeExpr ExpressionAnalyzer::Analyze(const parser::BOZLiteralConstant &x) {
1001	const char *p{x.v.c_str()};
1002	std::uint64_t base{16};
1003	switch (*p++) {
1004	case 'b':
1005	base = 2;
1006	break;
1007	case 'o':
1008	base = 8;
1009	break;
1010	case 'z':
1011	break;
1012	case 'x':
1013	break;
1014	default:
1015	CRASH_NO_CASE;
1016	}
1017	CHECK(*p == '"');
1018	++p;
1019	auto value{BOZLiteralConstant::Read(p, base, false /*unsigned*/)};
1020	if (*p != '"') {
1021	Say("Invalid digit ('%c') in BOZ literal '%s'"_err_en_US, *p,
1022	x.v); // C7107, C7108
1023	return std::nullopt;
1024	}
1025	if (value.overflow) {
1026	Say("BOZ literal '%s' too large"_err_en_US, x.v);
1027	return std::nullopt;
1028	}
1029	return AsGenericExpr(std::move(value.value));
1030	}
1031
1032	// Names and named constants
1033	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
1034	auto restorer{GetContextualMessages().SetLocation(n.source)};
1035	if (std::optional<int> kind{IsImpliedDo(n.source)}) {
1036	return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(
1037	*kind, AsExpr(ImpliedDoIndex{n.source})));
1038	}
1039	if (context_.HasError(n.symbol)) { // includes case of no symbol
1040	return std::nullopt;
1041	} else {
1042	const Symbol &ultimate{n.symbol->GetUltimate()};
1043	if (ultimate.has<semantics::TypeParamDetails>()) {
1044	// A bare reference to a derived type parameter within a parameterized
1045	// derived type definition.
1046	auto dyType{DynamicType::From(ultimate)};
1047	if (!dyType) {
1048	// When the integer kind of this type parameter is not known now,
1049	// it's either an error or because it depends on earlier-declared kind
1050	// type parameters. So assume that it's a subscript integer for now
1051	// while processing other specification expressions in the PDT
1052	// definition; the right kind value will be used later in each of its
1053	// instantiations.
1054	int kind{SubscriptInteger::kind};
1055	if (const auto *typeSpec{ultimate.GetType()}) {
1056	if (const semantics::IntrinsicTypeSpec *
1057	intrinType{typeSpec->AsIntrinsic()}) {
1058	if (auto k{ToInt64(Fold(semantics::KindExpr{intrinType->kind()}))};
1059	k &&
1060	common::IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {
1061	kind = *k;
1062	}
1063	}
1064	}
1065	dyType = DynamicType{TypeCategory::Integer, kind};
1066	}
1067	return Fold(ConvertToType(
1068	*dyType, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
1069	} else {
1070	if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {
1071	if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(
1072	context_.FindScope(n.source))}) {
1073	SayAt(n,
1074	"VOLATILE variable '%s' may not be referenced in pure subprogram '%s'"_err_en_US,
1075	n.source, DEREF(pure->symbol()).name());
1076	n.symbol->attrs().reset(semantics::Attr::VOLATILE);
1077	}
1078	}
1079	CheckForWholeAssumedSizeArray(n.source, n.symbol);
1080	return Designate(DataRef{*n.symbol});
1081	}
1082	}
1083	}
1084
1085	void ExpressionAnalyzer::CheckForWholeAssumedSizeArray(
1086	parser::CharBlock at, const Symbol *symbol) {
1087	if (!isWholeAssumedSizeArrayOk_ && symbol &&
1088	semantics::IsAssumedSizeArray(ResolveAssociations(*symbol))) {
1089	AttachDeclaration(
1090	SayAt(at,
1091	"Whole assumed-size array '%s' may not appear here without subscripts"_err_en_US,
1092	symbol->name()),
1093	*symbol);
1094	}
1095	}
1096
1097	MaybeExpr ExpressionAnalyzer::Analyze(const parser::NamedConstant &n) {
1098	auto restorer{GetContextualMessages().SetLocation(n.v.source)};
1099	if (MaybeExpr value{Analyze(n.v)}) {
1100	Expr<SomeType> folded{Fold(std::move(*value))};
1101	if (IsConstantExpr(folded)) {
1102	return folded;
1103	}
1104	Say(n.v.source, "must be a constant"_err_en_US); // C718
1105	}
1106	return std::nullopt;
1107	}
1108
1109	MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &n) {
1110	auto restorer{AllowNullPointer()};
1111	if (MaybeExpr value{Analyze(n.v.value())}) {
1112	// Subtle: when the NullInit is a DataStmtConstant, it might
1113	// be a misparse of a structure constructor without parameters
1114	// or components (e.g., T()). Checking the result to ensure
1115	// that a "=>" data entity initializer actually resolved to
1116	// a null pointer has to be done by the caller.
1117	return Fold(std::move(*value));
1118	}
1119	return std::nullopt;
1120	}
1121
1122	MaybeExpr ExpressionAnalyzer::Analyze(
1123	const parser::StmtFunctionStmt &stmtFunc) {
1124	inStmtFunctionDefinition_ = true;
1125	return Analyze(std::get<parser::Scalar<parser::Expr>>(stmtFunc.t));
1126	}
1127
1128	MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {
1129	return Analyze(x.value());
1130	}
1131
1132	MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) {
1133	if (const auto &repeat{
1134	std::get<std::optional<parser::DataStmtRepeat>>(x.t)}) {
1135	x.repetitions = -1;
1136	if (MaybeExpr expr{Analyze(repeat->u)}) {
1137	Expr<SomeType> folded{Fold(std::move(*expr))};
1138	if (auto value{ToInt64(folded)}) {
1139	if (*value >= 0) { // C882
1140	x.repetitions = *value;
1141	} else {
1142	Say(FindSourceLocation(repeat),
1143	"Repeat count (%jd) for data value must not be negative"_err_en_US,
1144	*value);
1145	}
1146	}
1147	}
1148	}
1149	return Analyze(std::get<parser::DataStmtConstant>(x.t));
1150	}
1151
1152	// Substring references
1153	std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::GetSubstringBound(
1154	const std::optional<parser::ScalarIntExpr> &bound) {
1155	if (bound) {
1156	if (MaybeExpr expr{Analyze(*bound)}) {
1157	if (expr->Rank() > 1) {
1158	Say("substring bound expression has rank %d"_err_en_US, expr->Rank());
1159	}
1160	if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
1161	if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
1162	return {std::move(*ssIntExpr)};
1163	}
1164	return {Expr<SubscriptInteger>{
1165	Convert<SubscriptInteger, TypeCategory::Integer>{
1166	std::move(*intExpr)}}};
1167	} else {
1168	Say("substring bound expression is not INTEGER"_err_en_US);
1169	}
1170	}
1171	}
1172	return std::nullopt;
1173	}
1174
1175	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Substring &ss) {
1176	if (MaybeExpr baseExpr{Analyze(std::get<parser::DataRef>(ss.t))}) {
1177	if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(*baseExpr))}) {
1178	if (MaybeExpr newBaseExpr{Designate(std::move(*dataRef))}) {
1179	if (std::optional<DataRef> checked{
1180	ExtractDataRef(std::move(*newBaseExpr))}) {
1181	const parser::SubstringRange &range{
1182	std::get<parser::SubstringRange>(ss.t)};
1183	std::optional<Expr<SubscriptInteger>> first{
1184	Fold(GetSubstringBound(std::get<0>(range.t)))};
1185	std::optional<Expr<SubscriptInteger>> last{
1186	Fold(GetSubstringBound(std::get<1>(range.t)))};
1187	const Symbol &symbol{checked->GetLastSymbol()};
1188	if (std::optional<DynamicType> dynamicType{
1189	DynamicType::From(symbol)}) {
1190	if (dynamicType->category() == TypeCategory::Character) {
1191	auto lbValue{ToInt64(first)};
1192	if (!lbValue) {
1193	lbValue = 1;
1194	}
1195	auto ubValue{ToInt64(last)};
1196	auto len{dynamicType->knownLength()};
1197	if (!ubValue) {
1198	ubValue = len;
1199	}
1200	if (lbValue && ubValue && *lbValue > *ubValue) {
1201	// valid, substring is empty
1202	} else if (lbValue && *lbValue < 1 && (ubValue || !last)) {
1203	Say("Substring must begin at 1 or later, not %jd"_err_en_US,
1204	static_cast<std::intmax_t>(*lbValue));
1205	return std::nullopt;
1206	} else if (ubValue && len && *ubValue > *len &&
1207	(lbValue || !first)) {
1208	Say("Substring must end at %zd or earlier, not %jd"_err_en_US,
1209	static_cast<std::intmax_t>(*len),
1210	static_cast<std::intmax_t>(*ubValue));
1211	return std::nullopt;
1212	}
1213	return WrapperHelper<TypeCategory::Character, Designator,
1214	Substring>(dynamicType->kind(),
1215	Substring{std::move(checked.value()), std::move(first),
1216	std::move(last)});
1217	}
1218	}
1219	Say("substring may apply only to CHARACTER"_err_en_US);
1220	}
1221	}
1222	}
1223	}
1224	return std::nullopt;
1225	}
1226
1227	// CHARACTER literal substrings
1228	MaybeExpr ExpressionAnalyzer::Analyze(
1229	const parser::CharLiteralConstantSubstring &x) {
1230	const parser::SubstringRange &range{std::get<parser::SubstringRange>(x.t)};
1231	std::optional<Expr<SubscriptInteger>> lower{
1232	GetSubstringBound(std::get<0>(range.t))};
1233	std::optional<Expr<SubscriptInteger>> upper{
1234	GetSubstringBound(std::get<1>(range.t))};
1235	if (MaybeExpr string{Analyze(std::get<parser::CharLiteralConstant>(x.t))}) {
1236	if (auto *charExpr{std::get_if<Expr<SomeCharacter>>(&string->u)}) {
1237	Expr<SubscriptInteger> length{
1238	common::visit([](const auto &ckExpr) { return ckExpr.LEN().value(); },
1239	charExpr->u)};
1240	if (!lower) {
1241	lower = Expr<SubscriptInteger>{1};
1242	}
1243	if (!upper) {
1244	upper = Expr<SubscriptInteger>{
1245	static_cast<std::int64_t>(ToInt64(length).value())};
1246	}
1247	return common::visit(
1248	[&](auto &&ckExpr) -> MaybeExpr {
1249	using Result = ResultType<decltype(ckExpr)>;
1250	auto *cp{std::get_if<Constant<Result>>(&ckExpr.u)};
1251	CHECK(DEREF(cp).size() == 1);
1252	StaticDataObject::Pointer staticData{StaticDataObject::Create()};
1253	staticData->set_alignment(Result::kind)
1254	.set_itemBytes(Result::kind)
1255	.Push(cp->GetScalarValue().value(),
1256	foldingContext_.targetCharacteristics().isBigEndian());
1257	Substring substring{std::move(staticData), std::move(lower.value()),
1258	std::move(upper.value())};
1259	return AsGenericExpr(
1260	Expr<Result>{Designator<Result>{std::move(substring)}});
1261	},
1262	std::move(charExpr->u));
1263	}
1264	}
1265	return std::nullopt;
1266	}
1267
1268	// substring%KIND/LEN
1269	MaybeExpr ExpressionAnalyzer::Analyze(const parser::SubstringInquiry &x) {
1270	if (MaybeExpr substring{Analyze(x.v)}) {
1271	CHECK(x.source.size() >= 8);
1272	int nameLen{x.source.end()[-1] == 'n' ? 3 /*LEN*/ : 4 /*KIND*/};
1273	parser::CharBlock name{
1274	x.source.end() - nameLen, static_cast<std::size_t>(nameLen)};
1275	CHECK(name == "len" || name == "kind");
1276	return MakeFunctionRef(
1277	name, ActualArguments{ActualArgument{std::move(*substring)}});
1278	} else {
1279	return std::nullopt;
1280	}
1281	}
1282
1283	// Subscripted array references
1284	std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::AsSubscript(
1285	MaybeExpr &&expr) {
1286	if (expr) {
1287	if (expr->Rank() > 1) {
1288	Say("Subscript expression has rank %d greater than 1"_err_en_US,
1289	expr->Rank());
1290	}
1291	if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
1292	if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
1293	return std::move(*ssIntExpr);
1294	} else {
1295	return Expr<SubscriptInteger>{
1296	Convert<SubscriptInteger, TypeCategory::Integer>{
1297	std::move(*intExpr)}};
1298	}
1299	} else {
1300	Say("Subscript expression is not INTEGER"_err_en_US);
1301	}
1302	}
1303	return std::nullopt;
1304	}
1305
1306	std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::TripletPart(
1307	const std::optional<parser::Subscript> &s) {
1308	if (s) {
1309	return AsSubscript(Analyze(*s));
1310	} else {
1311	return std::nullopt;
1312	}
1313	}
1314
1315	std::optional<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscript(
1316	const parser::SectionSubscript &ss) {
1317	return common::visit(
1318	common::visitors{
1319	[&](const parser::SubscriptTriplet &t) -> std::optional<Subscript> {
1320	const auto &lower{std::get<0>(t.t)};
1321	const auto &upper{std::get<1>(t.t)};
1322	const auto &stride{std::get<2>(t.t)};
1323	auto result{Triplet{
1324	TripletPart(lower), TripletPart(upper), TripletPart(stride)}};
1325	if ((lower && !result.lower()) || (upper && !result.upper())) {
1326	return std::nullopt;
1327	} else {
1328	return std::make_optional<Subscript>(result);
1329	}
1330	},
1331	[&](const auto &s) -> std::optional<Subscript> {
1332	if (auto subscriptExpr{AsSubscript(Analyze(s))}) {
1333	return Subscript{std::move(*subscriptExpr)};
1334	} else {
1335	return std::nullopt;
1336	}
1337	},
1338	},
1339	ss.u);
1340	}
1341
1342	// Empty result means an error occurred
1343	std::vector<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscripts(
1344	const std::list<parser::SectionSubscript> &sss) {
1345	bool error{false};
1346	std::vector<Subscript> subscripts;
1347	for (const auto &s : sss) {
1348	if (auto subscript{AnalyzeSectionSubscript(s)}) {
1349	subscripts.emplace_back(std::move(*subscript));
1350	} else {
1351	error = true;
1352	}
1353	}
1354	return !error ? subscripts : std::vector<Subscript>{};
1355	}
1356
1357	MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayElement &ae) {
1358	MaybeExpr baseExpr;
1359	{
1360	auto restorer{AllowWholeAssumedSizeArray()};
1361	baseExpr = Analyze(ae.base);
1362	}
1363	if (baseExpr) {
1364	if (ae.subscripts.empty()) {
1365	// will be converted to function call later or error reported
1366	} else if (baseExpr->Rank() == 0) {
1367	if (const Symbol *symbol{GetLastSymbol(*baseExpr)}) {
1368	if (!context_.HasError(symbol)) {
1369	if (inDataStmtConstant_) {
1370	// Better error for NULL(X) with a MOLD= argument
1371	Say("'%s' must be an array or structure constructor if used with non-empty parentheses as a DATA statement constant"_err_en_US,
1372	symbol->name());
1373	} else {
1374	Say("'%s' is not an array"_err_en_US, symbol->name());
1375	}
1376	context_.SetError(*symbol);
1377	}
1378	}
1379	} else if (std::optional<DataRef> dataRef{
1380	ExtractDataRef(std::move(*baseExpr))}) {
1381	return ApplySubscripts(
1382	std::move(*dataRef), AnalyzeSectionSubscripts(ae.subscripts));
1383	} else {
1384	Say("Subscripts may be applied only to an object, component, or array constant"_err_en_US);
1385	}
1386	}
1387	// error was reported: analyze subscripts without reporting more errors
1388	auto restorer{GetContextualMessages().DiscardMessages()};
1389	AnalyzeSectionSubscripts(ae.subscripts);
1390	return std::nullopt;
1391	}
1392
1393	// Type parameter inquiries apply to data references, but don't depend
1394	// on any trailing (co)subscripts.
1395	static NamedEntity IgnoreAnySubscripts(Designator<SomeDerived> &&designator) {
1396	return common::visit(
1397	common::visitors{
1398	[](SymbolRef &&symbol) { return NamedEntity{symbol}; },
1399	[](Component &&component) {
1400	return NamedEntity{std::move(component)};
1401	},
1402	[](ArrayRef &&arrayRef) { return std::move(arrayRef.base()); },
1403	[](CoarrayRef &&coarrayRef) {
1404	return NamedEntity{coarrayRef.GetLastSymbol()};
1405	},
1406	},
1407	std::move(designator.u));
1408	}
1409
1410	// Components, but not bindings, of parent derived types are explicitly
1411	// represented as such.
1412	std::optional<Component> ExpressionAnalyzer::CreateComponent(DataRef &&base,
1413	const Symbol &component, const semantics::Scope &scope,
1414	bool C919bAlreadyEnforced) {
1415	if (!C919bAlreadyEnforced && IsAllocatableOrPointer(component) &&
1416	base.Rank() > 0) { // C919b
1417	Say("An allocatable or pointer component reference must be applied to a scalar base"_err_en_US);
1418	}
1419	if (&component.owner() == &scope ||
1420	component.has<semantics::ProcBindingDetails>()) {
1421	return Component{std::move(base), component};
1422	}
1423	if (const Symbol *typeSymbol{scope.GetSymbol()}) {
1424	if (const Symbol *parentComponent{typeSymbol->GetParentComponent(&scope)}) {
1425	if (const auto *object{
1426	parentComponent->detailsIf<semantics::ObjectEntityDetails>()}) {
1427	if (const auto *parentType{object->type()}) {
1428	if (const semantics::Scope *parentScope{
1429	parentType->derivedTypeSpec().scope()}) {
1430	return CreateComponent(
1431	DataRef{Component{std::move(base), *parentComponent}},
1432	component, *parentScope, C919bAlreadyEnforced);
1433	}
1434	}
1435	}
1436	}
1437	}
1438	return std::nullopt;
1439	}
1440
1441	// Derived type component references and type parameter inquiries
1442	MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
1443	Symbol *sym{sc.component.symbol};
1444	if (context_.HasError(sym)) {
1445	return std::nullopt;
1446	}
1447	const auto *misc{sym->detailsIf<semantics::MiscDetails>()};
1448	bool isTypeParamInquiry{sym->has<semantics::TypeParamDetails>() ||
1449	(misc &&
1450	(misc->kind() == semantics::MiscDetails::Kind::KindParamInquiry ||
1451	misc->kind() == semantics::MiscDetails::Kind::LenParamInquiry))};
1452	MaybeExpr base;
1453	if (isTypeParamInquiry) {
1454	auto restorer{AllowWholeAssumedSizeArray()};
1455	base = Analyze(sc.base);
1456	} else {
1457	base = Analyze(sc.base);
1458	}
1459	if (!base) {
1460	return std::nullopt;
1461	}
1462	const auto &name{sc.component.source};
1463	if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
1464	const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
1465	if (isTypeParamInquiry) {
1466	if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {
1467	if (std::optional<DynamicType> dyType{DynamicType::From(*sym)}) {
1468	if (dyType->category() == TypeCategory::Integer) {
1469	auto restorer{GetContextualMessages().SetLocation(name)};
1470	return Fold(ConvertToType(*dyType,
1471	AsGenericExpr(TypeParamInquiry{
1472	IgnoreAnySubscripts(std::move(*designator)), *sym})));
1473	}
1474	}
1475	Say(name, "Type parameter is not INTEGER"_err_en_US);
1476	} else {
1477	Say(name,
1478	"A type parameter inquiry must be applied to a designator"_err_en_US);
1479	}
1480	} else if (!dtSpec || !dtSpec->scope()) {
1481	CHECK(context_.AnyFatalError() || !foldingContext_.messages().empty());
1482	return std::nullopt;
1483	} else if (std::optional<DataRef> dataRef{
1484	ExtractDataRef(std::move(*dtExpr))}) {
1485	auto restorer{GetContextualMessages().SetLocation(name)};
1486	if (auto component{
1487	CreateComponent(std::move(*dataRef), *sym, *dtSpec->scope())}) {
1488	return Designate(DataRef{std::move(*component)});
1489	} else {
1490	Say(name, "Component is not in scope of derived TYPE(%s)"_err_en_US,
1491	dtSpec->typeSymbol().name());
1492	}
1493	} else {
1494	Say(name,
1495	"Base of component reference must be a data reference"_err_en_US);
1496	}
1497	} else if (auto *details{sym->detailsIf<semantics::MiscDetails>()}) {
1498	// special part-ref: %re, %im, %kind, %len
1499	// Type errors on the base of %re/%im/%len are detected and
1500	// reported in name resolution.
1501	using MiscKind = semantics::MiscDetails::Kind;
1502	MiscKind kind{details->kind()};
1503	if (kind == MiscKind::ComplexPartRe || kind == MiscKind::ComplexPartIm) {
1504	if (auto *zExpr{std::get_if<Expr<SomeComplex>>(&base->u)}) {
1505	if (std::optional<DataRef> dataRef{ExtractDataRef(*zExpr)}) {
1506	// Represent %RE/%IM as a designator
1507	Expr<SomeReal> realExpr{common::visit(
1508	[&](const auto &z) {
1509	using PartType = typename ResultType<decltype(z)>::Part;
1510	auto part{kind == MiscKind::ComplexPartRe
1511	? ComplexPart::Part::RE
1512	: ComplexPart::Part::IM};
1513	return AsCategoryExpr(Designator<PartType>{
1514	ComplexPart{std::move(*dataRef), part}});
1515	},
1516	zExpr->u)};
1517	return AsGenericExpr(std::move(realExpr));
1518	}
1519	}
1520	} else if (isTypeParamInquiry) { // %kind or %len
1521	ActualArgument arg{std::move(*base)};
1522	SetArgSourceLocation(arg, name);
1523	return MakeFunctionRef(name, ActualArguments{std::move(arg)});
1524	} else {
1525	DIE("unexpected MiscDetails::Kind");
1526	}
1527	} else {
1528	Say(name, "derived type required before component reference"_err_en_US);
1529	}
1530	return std::nullopt;
1531	}
1532
1533	MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
1534	if (auto dataRef{ExtractDataRef(Analyze(x.base))}) {
1535	if (!std::holds_alternative<ArrayRef>(dataRef->u) &&
1536	dataRef->GetLastSymbol().Rank() > 0) { // F'2023 C916
1537	Say("Subscripts must appear in a coindexed reference when its base is an array"_err_en_US);
1538	}
1539	std::vector<Expr<SubscriptInteger>> cosubscripts;
1540	bool cosubsOk{true};
1541	for (const auto &cosub :
1542	std::get<std::list<parser::Cosubscript>>(x.imageSelector.t)) {
1543	MaybeExpr coex{Analyze(cosub)};
1544	if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {
1545	cosubscripts.push_back(
1546	ConvertToType<SubscriptInteger>(std::move(*intExpr)));
1547	} else {
1548	cosubsOk = false;
1549	}
1550	}
1551	if (cosubsOk) {
1552	int numCosubscripts{static_cast<int>(cosubscripts.size())};
1553	const Symbol &symbol{dataRef->GetLastSymbol()};
1554	if (numCosubscripts != GetCorank(symbol)) {
1555	Say("'%s' has corank %d, but coindexed reference has %d cosubscripts"_err_en_US,
1556	symbol.name(), GetCorank(symbol), numCosubscripts);
1557	}
1558	}
1559	CoarrayRef coarrayRef{std::move(*dataRef), std::move(cosubscripts)};
1560	for (const auto &imageSelSpec :
1561	std::get<std::list<parser::ImageSelectorSpec>>(x.imageSelector.t)) {
1562	common::visit(
1563	common::visitors{
1564	[&](const parser::ImageSelectorSpec::Stat &x) {
1565	Analyze(x.v);
1566	if (const auto *expr{GetExpr(context_, x.v)}) {
1567	if (const auto *intExpr{
1568	std::get_if<Expr<SomeInteger>>(&expr->u)}) {
1569	if (coarrayRef.stat()) {
1570	Say("coindexed reference has multiple STAT= specifiers"_err_en_US);
1571	} else {
1572	coarrayRef.set_stat(Expr<SomeInteger>{*intExpr});
1573	}
1574	}
1575	}
1576	},
1577	[&](const parser::TeamValue &x) {
1578	Analyze(x.v);
1579	if (const auto *expr{GetExpr(context_, x.v)}) {
1580	if (coarrayRef.team()) {
1581	Say("coindexed reference has multiple TEAM= or TEAM_NUMBER= specifiers"_err_en_US);
1582	} else if (auto dyType{expr->GetType()};
1583	dyType && IsTeamType(GetDerivedTypeSpec(*dyType))) {
1584	coarrayRef.set_team(Expr<SomeType>{*expr});
1585	} else {
1586	Say("TEAM= specifier must have type TEAM_TYPE from ISO_FORTRAN_ENV"_err_en_US);
1587	}
1588	}
1589	},
1590	[&](const parser::ImageSelectorSpec::Team_Number &x) {
1591	Analyze(x.v);
1592	if (const auto *expr{GetExpr(context_, x.v)}) {
1593	if (coarrayRef.team()) {
1594	Say("coindexed reference has multiple TEAM= or TEAM_NUMBER= specifiers"_err_en_US);
1595	} else {
1596	coarrayRef.set_team(Expr<SomeType>{*expr});
1597	}
1598	}
1599	}},
1600	imageSelSpec.u);
1601	}
1602	CheckCosubscripts(context_, coarrayRef);
1603	return Designate(DataRef{std::move(coarrayRef)});
1604	}
1605	return std::nullopt;
1606	}
1607
1608	int ExpressionAnalyzer::IntegerTypeSpecKind(
1609	const parser::IntegerTypeSpec &spec) {
1610	Expr<SubscriptInteger> value{
1611	AnalyzeKindSelector(TypeCategory::Integer, spec.v)};
1612	if (auto kind{ToInt64(value)}) {
1613	return static_cast<int>(*kind);
1614	}
1615	SayAt(spec, "Constant INTEGER kind value required here"_err_en_US);
1616	return GetDefaultKind(TypeCategory::Integer);
1617	}
1618
1619	// Array constructors
1620
1621	// Inverts a collection of generic ArrayConstructorValues<SomeType> that
1622	// all happen to have the same actual type T into one ArrayConstructor<T>.
1623	template <typename T>
1624	ArrayConstructorValues<T> MakeSpecific(
1625	ArrayConstructorValues<SomeType> &&from) {
1626	ArrayConstructorValues<T> to;
1627	for (ArrayConstructorValue<SomeType> &x : from) {
1628	common::visit(
1629	common::visitors{
1630	[&](common::CopyableIndirection<Expr<SomeType>> &&expr) {
1631	auto *typed{UnwrapExpr<Expr<T>>(expr.value())};
1632	to.Push(std::move(DEREF(typed)));
1633	},
1634	[&](ImpliedDo<SomeType> &&impliedDo) {
1635	to.Push(ImpliedDo<T>{impliedDo.name(),
1636	std::move(impliedDo.lower()), std::move(impliedDo.upper()),
1637	std::move(impliedDo.stride()),
1638	MakeSpecific<T>(std::move(impliedDo.values()))});
1639	},
1640	},
1641	std::move(x.u));
1642	}
1643	return to;
1644	}
1645
1646	class ArrayConstructorContext {
1647	public:
1648	ArrayConstructorContext(
1649	ExpressionAnalyzer &c, std::optional<DynamicTypeWithLength> &&t)
1650	: exprAnalyzer_{c}, type_{std::move(t)} {}
1651
1652	void Add(const parser::AcValue &);
1653	MaybeExpr ToExpr();
1654
1655	// These interfaces allow *this to be used as a type visitor argument to
1656	// common::SearchTypes() to convert the array constructor to a typed
1657	// expression in ToExpr().
1658	using Result = MaybeExpr;
1659	using Types = AllTypes;
1660	template <typename T> Result Test() {
1661	if (type_ && type_->category() == T::category) {
1662	if constexpr (T::category == TypeCategory::Derived) {
1663	if (!type_->IsUnlimitedPolymorphic()) {
1664	return AsMaybeExpr(ArrayConstructor<T>{type_->GetDerivedTypeSpec(),
1665	MakeSpecific<T>(std::move(values_))});
1666	}
1667	} else if (type_->kind() == T::kind) {
1668	ArrayConstructor<T> result{MakeSpecific<T>(std::move(values_))};
1669	if constexpr (T::category == TypeCategory::Character) {
1670	if (auto len{LengthIfGood()}) {
1671	// The ac-do-variables may be treated as constant expressions,
1672	// if some conditions on ac-implied-do-control hold (10.1.12 (12)).
1673	// At the same time, they may be treated as constant expressions
1674	// only in the context of the ac-implied-do, but setting
1675	// the character length here may result in complete elimination
1676	// of the ac-implied-do. For example:
1677	// character(10) :: c
1678	// ... len([(c(i:i), integer(8)::i = 1,4)])
1679	// would be evaulated into:
1680	// ... int(max(0_8,i-i+1_8),kind=4)
1681	// with a dangling reference to the ac-do-variable.
1682	// Prevent this by checking for the ac-do-variable references
1683	// in the 'len' expression.
1684	result.set_LEN(std::move(*len));
1685	}
1686	}
1687	return AsMaybeExpr(std::move(result));
1688	}
1689	}
1690	return std::nullopt;
1691	}
1692
1693	private:
1694	using ImpliedDoIntType = ResultType<ImpliedDoIndex>;
1695
1696	std::optional<Expr<SubscriptInteger>> LengthIfGood() const {
1697	if (type_) {
1698	auto len{type_->LEN()};
1699	if (explicitType_ ||
1700	(len && IsConstantExpr(*len) && !ContainsAnyImpliedDoIndex(*len))) {
1701	return len;
1702	}
1703	}
1704	return std::nullopt;
1705	}
1706	bool NeedLength() const {
1707	return type_ && type_->category() == TypeCategory::Character &&
1708	!LengthIfGood();
1709	}
1710	void Push(MaybeExpr &&);
1711	void Add(const parser::AcValue::Triplet &);
1712	void Add(const parser::Expr &);
1713	void Add(const parser::AcImpliedDo &);
1714	void UnrollConstantImpliedDo(const parser::AcImpliedDo &,
1715	parser::CharBlock name, std::int64_t lower, std::int64_t upper,
1716	std::int64_t stride);
1717
1718	template <int KIND>
1719	std::optional<Expr<Type<TypeCategory::Integer, KIND>>> ToSpecificInt(
1720	MaybeExpr &&y) {
1721	if (y) {
1722	Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};
1723	return Fold(exprAnalyzer_.GetFoldingContext(),
1724	ConvertToType<Type<TypeCategory::Integer, KIND>>(
1725	std::move(DEREF(intExpr))));
1726	} else {
1727	return std::nullopt;
1728	}
1729	}
1730
1731	template <int KIND, typename A>
1732	std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(
1733	const A &x) {
1734	return ToSpecificInt<KIND>(exprAnalyzer_.Analyze(x));
1735	}
1736
1737	// Nested array constructors all reference the same ExpressionAnalyzer,
1738	// which represents the nest of active implied DO loop indices.
1739	ExpressionAnalyzer &exprAnalyzer_;
1740	std::optional<DynamicTypeWithLength> type_;
1741	bool explicitType_{type_.has_value()};
1742	std::optional<std::int64_t> constantLength_;
1743	ArrayConstructorValues<SomeType> values_;
1744	std::uint64_t messageDisplayedSet_{0};
1745	};
1746
1747	void ArrayConstructorContext::Push(MaybeExpr &&x) {
1748	if (!x) {
1749	return;
1750	}
1751	if (!type_) {
1752	if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
1753	// Treat an array constructor of BOZ as if default integer.
1754	exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,
1755	"BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
1756	x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
1757	exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
1758	std::move(*boz)));
1759	}
1760	}
1761	std::optional<DynamicType> dyType{x->GetType()};
1762	if (!dyType) {
1763	if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
1764	if (!type_) {
1765	// Treat an array constructor of BOZ as if default integer.
1766	exprAnalyzer_.Warn(common::LanguageFeature::BOZAsDefaultInteger,
1767	"BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_port_en_US);
1768	x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
1769	exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
1770	std::move(*boz)));
1771	dyType = x.value().GetType();
1772	} else if (auto cast{ConvertToType(*type_, std::move(*x))}) {
1773	x = std::move(cast);
1774	dyType = *type_;
1775	} else {
1776	if (!(messageDisplayedSet_ & 0x80)) {
1777	exprAnalyzer_.Say(
1778	"BOZ literal is not suitable for use in this array constructor"_err_en_US);
1779	messageDisplayedSet_ |= 0x80;
1780	}
1781	return;
1782	}
1783	} else { // procedure name, &c.
1784	if (!(messageDisplayedSet_ & 0x40)) {
1785	exprAnalyzer_.Say(
1786	"Item is not suitable for use in an array constructor"_err_en_US);
1787	messageDisplayedSet_ |= 0x40;
1788	}
1789	return;
1790	}
1791	} else if (dyType->IsUnlimitedPolymorphic()) {
1792	if (!(messageDisplayedSet_ & 8)) {
1793	exprAnalyzer_.Say("Cannot have an unlimited polymorphic value in an "
1794	"array constructor"_err_en_US); // C7113
1795	messageDisplayedSet_ |= 8;
1796	}
1797	return;
1798	} else if (dyType->category() == TypeCategory::Derived &&
1799	dyType->GetDerivedTypeSpec().typeSymbol().attrs().test(
1800	semantics::Attr::ABSTRACT)) { // F'2023 C7125
1801	if (!(messageDisplayedSet_ & 0x200)) {
1802	exprAnalyzer_.Say(
1803	"An item whose declared type is ABSTRACT may not appear in an array constructor"_err_en_US);
1804	messageDisplayedSet_ |= 0x200;
1805	}
1806	}
1807	DynamicTypeWithLength xType{dyType.value()};
1808	if (Expr<SomeCharacter> * charExpr{UnwrapExpr<Expr<SomeCharacter>>(*x)}) {
1809	CHECK(xType.category() == TypeCategory::Character);
1810	xType.length =
1811	common::visit([](const auto &kc) { return kc.LEN(); }, charExpr->u);
1812	}
1813	if (!type_) {
1814	// If there is no explicit type-spec in an array constructor, the type
1815	// of the array is the declared type of all of the elements, which must
1816	// be well-defined and all match.
1817	// TODO: Possible language extension: use the most general type of
1818	// the values as the type of a numeric constructed array, convert all
1819	// of the other values to that type. Alternative: let the first value
1820	// determine the type, and convert the others to that type.
1821	CHECK(!explicitType_);
1822	type_ = std::move(xType);
1823	constantLength_ = ToInt64(type_->length);
1824	values_.Push(std::move(*x));
1825	} else if (!explicitType_) {
1826	if (type_->IsTkCompatibleWith(xType) && xType.IsTkCompatibleWith(*type_)) {
1827	values_.Push(std::move(*x));
1828	auto xLen{xType.LEN()};
1829	if (auto thisLen{ToInt64(xLen)}) {
1830	if (constantLength_) {
1831	if (*thisLen != *constantLength_ && !(messageDisplayedSet_ & 1)) {
1832	exprAnalyzer_.Warn(
1833	common::LanguageFeature::DistinctArrayConstructorLengths,
1834	"Character literal in array constructor without explicit "
1835	"type has different length than earlier elements"_port_en_US);
1836	messageDisplayedSet_ |= 1;
1837	}
1838	if (*thisLen > *constantLength_) {
1839	// Language extension: use the longest literal to determine the
1840	// length of the array constructor's character elements, not the
1841	// first, when there is no explicit type.
1842	*constantLength_ = *thisLen;
1843	type_->length = std::move(xLen);
1844	}
1845	} else {
1846	constantLength_ = *thisLen;
1847	type_->length = std::move(xLen);
1848	}
1849	} else if (xLen && NeedLength()) {
1850	type_->length = std::move(xLen);
1851	}
1852	} else {
1853	if (!(messageDisplayedSet_ & 2)) {
1854	exprAnalyzer_.Say(
1855	"Values in array constructor must have the same declared type "
1856	"when no explicit type appears"_err_en_US); // C7110
1857	messageDisplayedSet_ |= 2;
1858	}
1859	}
1860	} else {
1861	if (auto cast{ConvertToType(*type_, std::move(*x))}) {
1862	values_.Push(std::move(*cast));
1863	} else if (!(messageDisplayedSet_ & 4)) {
1864	exprAnalyzer_.Say("Value in array constructor of type '%s' could not "
1865	"be converted to the type of the array '%s'"_err_en_US,
1866	x->GetType()->AsFortran(), type_->AsFortran()); // C7111, C7112
1867	messageDisplayedSet_ |= 4;
1868	}
1869	}
1870	}
1871
1872	void ArrayConstructorContext::Add(const parser::AcValue &x) {
1873	common::visit(
1874	common::visitors{
1875	[&](const parser::AcValue::Triplet &triplet) { Add(triplet); },
1876	[&](const common::Indirection<parser::Expr> &expr) {
1877	Add(expr.value());
1878	},
1879	[&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {
1880	Add(impliedDo.value());
1881	},
1882	},
1883	x.u);
1884	}
1885
1886	// Transforms l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'
1887	void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) {
1888	MaybeExpr lowerExpr{exprAnalyzer_.Analyze(std::get<0>(triplet.t))};
1889	MaybeExpr upperExpr{exprAnalyzer_.Analyze(std::get<1>(triplet.t))};
1890	MaybeExpr strideExpr{exprAnalyzer_.Analyze(std::get<2>(triplet.t))};
1891	if (lowerExpr && upperExpr) {
1892	auto lowerType{lowerExpr->GetType()};
1893	auto upperType{upperExpr->GetType()};
1894	auto strideType{strideExpr ? strideExpr->GetType() : lowerType};
1895	if (lowerType && upperType && strideType) {
1896	int kind{lowerType->kind()};
1897	if (upperType->kind() > kind) {
1898	kind = upperType->kind();
1899	}
1900	if (strideType->kind() > kind) {
1901	kind = strideType->kind();
1902	}
1903	auto lower{ToSpecificInt<ImpliedDoIntType::kind>(std::move(lowerExpr))};
1904	auto upper{ToSpecificInt<ImpliedDoIntType::kind>(std::move(upperExpr))};
1905	if (lower && upper) {
1906	auto stride{
1907	ToSpecificInt<ImpliedDoIntType::kind>(std::move(strideExpr))};
1908	if (!stride) {
1909	stride = Expr<ImpliedDoIntType>{1};
1910	}
1911	DynamicType type{TypeCategory::Integer, kind};
1912	if (!type_) {
1913	type_ = DynamicTypeWithLength{type};
1914	}
1915	parser::CharBlock anonymous;
1916	if (auto converted{ConvertToType(type,
1917	AsGenericExpr(
1918	Expr<ImpliedDoIntType>{ImpliedDoIndex{anonymous}}))}) {
1919	auto v{std::move(values_)};
1920	Push(std::move(converted));
1921	std::swap(v, values_);
1922	values_.Push(ImpliedDo<SomeType>{anonymous, std::move(*lower),
1923	std::move(*upper), std::move(*stride), std::move(v)});
1924	}
1925	}
1926	}
1927	}
1928	}
1929
1930	void ArrayConstructorContext::Add(const parser::Expr &expr) {
1931	auto restorer1{
1932	exprAnalyzer_.GetContextualMessages().SetLocation(expr.source)};
1933	auto restorer2{exprAnalyzer_.AllowWholeAssumedSizeArray(false)};
1934	Push(exprAnalyzer_.Analyze(expr));
1935	}
1936
1937	void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
1938	const auto &control{std::get<parser::AcImpliedDoControl>(impliedDo.t)};
1939	const auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)};
1940	exprAnalyzer_.Analyze(bounds.name);
1941	parser::CharBlock name{bounds.name.thing.thing.source};
1942	int kind{ImpliedDoIntType::kind};
1943	if (const Symbol * symbol{bounds.name.thing.thing.symbol}) {
1944	if (auto dynamicType{DynamicType::From(symbol)}) {
1945	if (dynamicType->category() == TypeCategory::Integer) {
1946	kind = dynamicType->kind();
1947	}
1948	}
1949	}
1950	std::optional<Expr<ImpliedDoIntType>> lower{
1951	GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.lower)};
1952	std::optional<Expr<ImpliedDoIntType>> upper{
1953	GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.upper)};
1954	if (lower && upper) {
1955	std::optional<Expr<ImpliedDoIntType>> stride{
1956	GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.step)};
1957	if (!stride) {
1958	stride = Expr<ImpliedDoIntType>{1};
1959	}
1960	if (exprAnalyzer_.AddImpliedDo(name, kind)) {
1961	// Check for constant bounds; the loop may require complete unrolling
1962	// of the parse tree if all bounds are constant in order to allow the
1963	// implied DO loop index to qualify as a constant expression.
1964	auto cLower{ToInt64(lower)};
1965	auto cUpper{ToInt64(upper)};
1966	auto cStride{ToInt64(stride)};
1967	if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {
1968	exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source,
1969	"The stride of an implied DO loop must not be zero"_err_en_US);
1970	messageDisplayedSet_ |= 0x10;
1971	}
1972	bool isConstant{cLower && cUpper && cStride && *cStride != 0};
1973	bool isNonemptyConstant{isConstant &&
1974	((*cStride > 0 && *cLower <= *cUpper) ||
1975	(*cStride < 0 && *cLower >= *cUpper))};
1976	bool isEmpty{isConstant && !isNonemptyConstant};
1977	bool unrollConstantLoop{false};
1978	parser::Messages buffer;
1979	auto saveMessagesDisplayed{messageDisplayedSet_};
1980	{
1981	auto messageRestorer{
1982	exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};
1983	auto v{std::move(values_)};
1984	for (const auto &value :
1985	std::get<std::list<parser::AcValue>>(impliedDo.t)) {
1986	Add(value);
1987	}
1988	std::swap(v, values_);
1989	if (isNonemptyConstant && buffer.AnyFatalError()) {
1990	unrollConstantLoop = true;
1991	} else {
1992	values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),
1993	std::move(*upper), std::move(*stride), std::move(v)});
1994	}
1995	}
1996	// F'2023 7.8 p5
1997	if (!(messageDisplayedSet_ & 0x100) && isEmpty && NeedLength()) {
1998	exprAnalyzer_.SayAt(name,
1999	"Array constructor implied DO loop has no iterations and indeterminate character length"_err_en_US);
2000	messageDisplayedSet_ |= 0x100;
2001	}
2002	if (unrollConstantLoop) {
2003	messageDisplayedSet_ = saveMessagesDisplayed;
2004	UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);
2005	} else if (auto *messages{
2006	exprAnalyzer_.GetContextualMessages().messages()}) {
2007	messages->Annex(std::move(buffer));
2008	}
2009	exprAnalyzer_.RemoveImpliedDo(name);
2010	} else if (!(messageDisplayedSet_ & 0x20)) {
2011	exprAnalyzer_.SayAt(name,
2012	"Implied DO index '%s' is active in a surrounding implied DO loop "
2013	"and may not have the same name"_err_en_US,
2014	name); // C7115
2015	messageDisplayedSet_ |= 0x20;
2016	}
2017	}
2018	}
2019
2020	// Fortran considers an implied DO index of an array constructor to be
2021	// a constant expression if the bounds of the implied DO loop are constant.
2022	// Usually this doesn't matter, but if we emitted spurious messages as a
2023	// result of not using constant values for the index while analyzing the
2024	// items, we need to do it again the "hard" way with multiple iterations over
2025	// the parse tree.
2026	void ArrayConstructorContext::UnrollConstantImpliedDo(
2027	const parser::AcImpliedDo &impliedDo, parser::CharBlock name,
2028	std::int64_t lower, std::int64_t upper, std::int64_t stride) {
2029	auto &foldingContext{exprAnalyzer_.GetFoldingContext()};
2030	auto restorer{exprAnalyzer_.DoNotUseSavedTypedExprs()};
2031	for (auto &at{foldingContext.StartImpliedDo(name, lower)};
2032	(stride > 0 && at <= upper) || (stride < 0 && at >= upper);
2033	at += stride) {
2034	for (const auto &value :
2035	std::get<std::list<parser::AcValue>>(impliedDo.t)) {
2036	Add(value);
2037	}
2038	}
2039	foldingContext.EndImpliedDo(name);
2040	}
2041
2042	MaybeExpr ArrayConstructorContext::ToExpr() {
2043	return common::SearchTypes(std::move(*this));
2044	}
2045
2046	MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayConstructor &array) {
2047	const parser::AcSpec &acSpec{array.v};
2048	ArrayConstructorContext acContext{
2049	*this, AnalyzeTypeSpec(acSpec.type, GetFoldingContext())};
2050	for (const parser::AcValue &value : acSpec.values) {
2051	acContext.Add(value);
2052	}
2053	return acContext.ToExpr();
2054	}
2055
2056	// Check if implicit conversion of expr to the symbol type is legal (if needed),
2057	// and make it explicit if requested.
2058	static MaybeExpr ImplicitConvertTo(const semantics::Symbol &sym,
2059	Expr<SomeType> &&expr, bool keepConvertImplicit) {
2060	if (!keepConvertImplicit) {
2061	return ConvertToType(sym, std::move(expr));
2062	} else {
2063	// Test if a convert could be inserted, but do not make it explicit to
2064	// preserve the information that expr is a variable.
2065	if (ConvertToType(sym, common::Clone(expr))) {
2066	return MaybeExpr{std::move(expr)};
2067	}
2068	}
2069	// Illegal implicit convert.
2070	return std::nullopt;
2071	}
2072
2073	MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(
2074	parser::CharBlock typeName, const semantics::DerivedTypeSpec &spec,
2075	std::list<ComponentSpec> &&componentSpecs) {
2076	const Symbol &typeSymbol{spec.typeSymbol()};
2077	if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {
2078	return std::nullopt; // error recovery
2079	}
2080	const semantics::Scope &scope{context_.FindScope(typeName)};
2081	const semantics::Scope *pureContext{FindPureProcedureContaining(scope)};
2082	const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
2083	const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
2084
2085	if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
2086	AttachDeclaration(
2087	Say(typeName,
2088	"ABSTRACT derived type '%s' may not be used in a structure constructor"_err_en_US,
2089	typeName),
2090	typeSymbol); // C7114
2091	}
2092
2093	// This iterator traverses all of the components in the derived type and its
2094	// parents. The symbols for whole parent components appear after their
2095	// own components and before the components of the types that extend them.
2096	// E.g., TYPE :: A; REAL X; END TYPE
2097	// TYPE, EXTENDS(A) :: B; REAL Y; END TYPE
2098	// produces the component list X, A, Y.
2099	// The order is important below because a structure constructor can
2100	// initialize X or A by name, but not both.
2101	auto components{semantics::OrderedComponentIterator{spec}};
2102	auto nextAnonymous{components.begin()};
2103	auto afterLastParentComponentIter{components.end()};
2104	if (parentComponent) {
2105	for (auto iter{components.begin()}; iter != components.end(); ++iter) {
2106	if (iter->test(Symbol::Flag::ParentComp)) {
2107	afterLastParentComponentIter = iter;
2108	++afterLastParentComponentIter;
2109	}
2110	}
2111	}
2112
2113	std::set<parser::CharBlock> unavailable;
2114	bool anyKeyword{false};
2115	StructureConstructor result{spec};
2116	bool checkConflicts{true}; // until we hit one
2117	auto &messages{GetContextualMessages()};
2118
2119	for (ComponentSpec &componentSpec : componentSpecs) {
2120	parser::CharBlock source{componentSpec.source};
2121	parser::CharBlock exprSource{componentSpec.exprSource};
2122	auto restorer{messages.SetLocation(source)};
2123	const Symbol *symbol{componentSpec.keywordSymbol};
2124	MaybeExpr &maybeValue{componentSpec.expr};
2125	if (!maybeValue.has_value()) {
2126	return std::nullopt;
2127	}
2128	Expr<SomeType> &value{*maybeValue};
2129	std::optional<DynamicType> valueType{DynamicType::From(value)};
2130	if (componentSpec.hasKeyword) {
2131	anyKeyword = true;
2132	if (!symbol) {
2133	// Skip overridden inaccessible parent components in favor of
2134	// their later overrides.
2135	for (const Symbol &sym : components) {
2136	if (sym.name() == source) {
2137	symbol = &sym;
2138	}
2139	}
2140	}
2141	if (!symbol) { // C7101
2142	Say(source,
2143	"Keyword '%s=' does not name a component of derived type '%s'"_err_en_US,
2144	source, typeName);
2145	}
2146	} else {
2147	if (anyKeyword) { // C7100
2148	Say(source,
2149	"Value in structure constructor lacks a component name"_err_en_US);
2150	checkConflicts = false; // stem cascade
2151	}
2152	// Here's a regrettably common extension of the standard: anonymous
2153	// initialization of parent components, e.g., T(PT(1)) rather than
2154	// T(1) or T(PT=PT(1)). There may be multiple parent components.
2155	if (nextAnonymous == components.begin() && parentComponent && valueType &&
2156	context().IsEnabled(LanguageFeature::AnonymousParents)) {
2157	for (auto parent{components.begin()};
2158	parent != afterLastParentComponentIter; ++parent) {
2159	if (auto parentType{DynamicType::From(*parent)}; parentType &&
2160	parent->test(Symbol::Flag::ParentComp) &&
2161	valueType->IsEquivalentTo(*parentType)) {
2162	symbol = &*parent;
2163	nextAnonymous = ++parent;
2164	Warn(LanguageFeature::AnonymousParents, source,
2165	"Whole parent component '%s' in structure constructor should not be anonymous"_port_en_US,
2166	symbol->name());
2167	break;
2168	}
2169	}
2170	}
2171	while (!symbol && nextAnonymous != components.end()) {
2172	const Symbol &next{*nextAnonymous};
2173	++nextAnonymous;
2174	if (!next.test(Symbol::Flag::ParentComp)) {
2175	symbol = &next;
2176	}
2177	}
2178	if (!symbol) {
2179	Say(source, "Unexpected value in structure constructor"_err_en_US);
2180	}
2181	}
2182	if (symbol) {
2183	const semantics::Scope &innermost{context_.FindScope(exprSource)};
2184	if (auto msg{CheckAccessibleSymbol(innermost, *symbol)}) {
2185	Say(exprSource, std::move(*msg));
2186	}
2187	if (checkConflicts) {
2188	auto componentIter{
2189	std::find(components.begin(), components.end(), *symbol)};
2190	if (unavailable.find(symbol->name()) != unavailable.cend()) {
2191	// C797, C798
2192	Say(source,
2193	"Component '%s' conflicts with another component earlier in this structure constructor"_err_en_US,
2194	symbol->name());
2195	} else if (symbol->test(Symbol::Flag::ParentComp)) {
2196	// Make earlier components unavailable once a whole parent appears.
2197	for (auto it{components.begin()}; it != componentIter; ++it) {
2198	unavailable.insert(it->name());
2199	}
2200	} else {
2201	// Make whole parent components unavailable after any of their
2202	// constituents appear.
2203	for (auto it{componentIter}; it != components.end(); ++it) {
2204	if (it->test(Symbol::Flag::ParentComp)) {
2205	unavailable.insert(it->name());
2206	}
2207	}
2208	}
2209	}
2210	unavailable.insert(symbol->name());
2211	if (symbol->has<semantics::TypeParamDetails>()) {
2212	Say(exprSource,
2213	"Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,
2214	symbol->name());
2215	}
2216	if (!(symbol->has<semantics::ProcEntityDetails>() ||
2217	symbol->has<semantics::ObjectEntityDetails>())) {
2218	continue; // recovery
2219	}
2220	if (IsPointer(*symbol)) { // C7104, C7105, C1594(4)
2221	semantics::CheckStructConstructorPointerComponent(
2222	context_, *symbol, value, innermost);
2223	result.Add(*symbol, Fold(std::move(value)));
2224	continue;
2225	}
2226	if (IsNullPointer(&value)) {
2227	if (IsAllocatable(*symbol)) {
2228	if (IsBareNullPointer(&value)) {
2229	// NULL() with no arguments allowed by 7.5.10 para 6 for
2230	// ALLOCATABLE.
2231	result.Add(*symbol, Expr<SomeType>{NullPointer{}});
2232	continue;
2233	}
2234	if (IsNullObjectPointer(&value)) {
2235	AttachDeclaration(
2236	Warn(common::LanguageFeature::NullMoldAllocatableComponentValue,
2237	exprSource,
2238	"NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
2239	symbol->name()),
2240	*symbol);
2241	// proceed to check type & shape
2242	} else {
2243	AttachDeclaration(
2244	Say(exprSource,
2245	"A NULL procedure pointer may not be used as the value for component '%s'"_err_en_US,
2246	symbol->name()),
2247	*symbol);
2248	continue;
2249	}
2250	} else {
2251	AttachDeclaration(
2252	Say(exprSource,
2253	"A NULL pointer may not be used as the value for component '%s'"_err_en_US,
2254	symbol->name()),
2255	*symbol);
2256	continue;
2257	}
2258	} else if (IsNullAllocatable(&value) && IsAllocatable(*symbol)) {
2259	result.Add(*symbol, Expr<SomeType>{NullPointer{}});
2260	continue;
2261	} else if (auto *derived{evaluate::GetDerivedTypeSpec(
2262	evaluate::DynamicType::From(*symbol))}) {
2263	if (auto iter{FindPointerPotentialComponent(*derived)};
2264	iter && pureContext) { // F'2023 C15104(4)
2265	if (const Symbol *
2266	visible{semantics::FindExternallyVisibleObject(
2267	value, *pureContext)}) {
2268	Say(exprSource,
2269	"The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
2270	visible->name(), symbol->name(),
2271	iter.BuildResultDesignatorName());
2272	} else if (ExtractCoarrayRef(value)) {
2273	Say(exprSource,
2274	"A coindexed object may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
2275	symbol->name(), iter.BuildResultDesignatorName());
2276	}
2277	}
2278	}
2279	// Make implicit conversion explicit to allow folding of the structure
2280	// constructors and help semantic checking, unless the component is
2281	// allocatable, in which case the value could be an unallocated
2282	// allocatable (see Fortran 2018 7.5.10 point 7). The explicit
2283	// convert would cause a segfault. Lowering will deal with
2284	// conditionally converting and preserving the lower bounds in this
2285	// case.
2286	if (MaybeExpr converted{ImplicitConvertTo(
2287	*symbol, std::move(value), IsAllocatable(*symbol))}) {
2288	if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
2289	if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
2290	if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
2291	AttachDeclaration(
2292	Say(exprSource,
2293	"Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
2294	GetRank(*valueShape), symbol->name()),
2295	*symbol);
2296	} else {
2297	auto checked{CheckConformance(messages, *componentShape,
2298	*valueShape, CheckConformanceFlags::RightIsExpandableDeferred,
2299	"component", "value")};
2300	if (checked && *checked && GetRank(*componentShape) > 0 &&
2301	GetRank(*valueShape) == 0 &&
2302	(IsDeferredShape(*symbol) ||
2303	!IsExpandableScalar(*converted, GetFoldingContext(),
2304	*componentShape, true /*admit PURE call*/))) {
2305	AttachDeclaration(
2306	Say(exprSource,
2307	"Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
2308	symbol->name()),
2309	*symbol);
2310	}
2311	if (checked.value_or(true)) {
2312	result.Add(*symbol, std::move(*converted));
2313	}
2314	}
2315	} else {
2316	Say(exprSource, "Shape of value cannot be determined"_err_en_US);
2317	}
2318	} else {
2319	AttachDeclaration(
2320	Say(exprSource,
2321	"Shape of component '%s' cannot be determined"_err_en_US,
2322	symbol->name()),
2323	*symbol);
2324	}
2325	} else if (auto symType{DynamicType::From(symbol)}) {
2326	if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() &&
2327	valueType) {
2328	// ok
2329	} else if (valueType) {
2330	AttachDeclaration(
2331	Say(exprSource,
2332	"Value in structure constructor of type '%s' is incompatible with component '%s' of type '%s'"_err_en_US,
2333	valueType->AsFortran(), symbol->name(), symType->AsFortran()),
2334	*symbol);
2335	} else {
2336	AttachDeclaration(
2337	Say(exprSource,
2338	"Value in structure constructor is incompatible with component '%s' of type %s"_err_en_US,
2339	symbol->name(), symType->AsFortran()),
2340	*symbol);
2341	}
2342	}
2343	}
2344	}
2345
2346	// Ensure that unmentioned component objects have default initializers.
2347	for (const Symbol &symbol : components) {
2348	if (!symbol.test(Symbol::Flag::ParentComp) &&
2349	unavailable.find(symbol.name()) == unavailable.cend()) {
2350	if (IsAllocatable(symbol)) {
2351	// Set all remaining allocatables to explicit NULL().
2352	result.Add(symbol, Expr<SomeType>{NullPointer{}});
2353	} else {
2354	const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
2355	if (object && object->init()) {
2356	result.Add(symbol, common::Clone(*object->init()));
2357	} else if (IsPointer(symbol)) {
2358	result.Add(symbol, Expr<SomeType>{NullPointer{}});
2359	} else if (object) { // C799
2360	AttachDeclaration(
2361	Say(typeName,
2362	"Structure constructor lacks a value for component '%s'"_err_en_US,
2363	symbol.name()),
2364	symbol);
2365	}
2366	}
2367	}
2368	}
2369
2370	return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
2371	}
2372
2373	MaybeExpr ExpressionAnalyzer::Analyze(
2374	const parser::StructureConstructor &structure) {
2375	const auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
2376	parser::Name structureType{std::get<parser::Name>(parsedType.t)};
2377	parser::CharBlock &typeName{structureType.source};
2378	if (semantics::Symbol * typeSymbol{structureType.symbol}) {
2379	if (typeSymbol->has<semantics::DerivedTypeDetails>()) {
2380	semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};
2381	if (!CheckIsValidForwardReference(dtSpec)) {
2382	return std::nullopt;
2383	}
2384	}
2385	}
2386	if (!parsedType.derivedTypeSpec) {
2387	return std::nullopt;
2388	}
2389	auto restorer{AllowNullPointer()}; // NULL() can be a valid component
2390	std::list<ComponentSpec> componentSpecs;
2391	for (const auto &component :
2392	std::get<std::list<parser::ComponentSpec>>(structure.t)) {
2393	const parser::Expr &expr{
2394	std::get<parser::ComponentDataSource>(component.t).v.value()};
2395	auto restorer{GetContextualMessages().SetLocation(expr.source)};
2396	ComponentSpec compSpec;
2397	compSpec.exprSource = expr.source;
2398	compSpec.expr = Analyze(expr);
2399	if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
2400	compSpec.source = kw->v.source;
2401	compSpec.hasKeyword = true;
2402	compSpec.keywordSymbol = kw->v.symbol;
2403	} else {
2404	compSpec.source = expr.source;
2405	}
2406	componentSpecs.emplace_back(std::move(compSpec));
2407	}
2408	return CheckStructureConstructor(
2409	typeName, DEREF(parsedType.derivedTypeSpec), std::move(componentSpecs));
2410	}
2411
2412	static std::optional<parser::CharBlock> GetPassName(
2413	const semantics::Symbol &proc) {
2414	return common::visit(
2415	[](const auto &details) {
2416	if constexpr (std::is_base_of_v<semantics::WithPassArg,
2417	std::decay_t<decltype(details)>>) {
2418	return details.passName();
2419	} else {
2420	return std::optional<parser::CharBlock>{};
2421	}
2422	},
2423	proc.details());
2424	}
2425
2426	static std::optional<int> GetPassIndex(const Symbol &proc) {
2427	CHECK(!proc.attrs().test(semantics::Attr::NOPASS));
2428	std::optional<parser::CharBlock> passName{GetPassName(proc)};
2429	const auto *interface {
2430	semantics::FindInterface(proc)
2431	};
2432	if (!passName || !interface) {
2433	return 0; // first argument is passed-object
2434	}
2435	const auto &subp{interface->get<semantics::SubprogramDetails>()};
2436	int index{0};
2437	for (const auto *arg : subp.dummyArgs()) {
2438	if (arg && arg->name() == passName) {
2439	return index;
2440	}
2441	++index;
2442	}
2443	return std::nullopt;
2444	}
2445
2446	// Injects an expression into an actual argument list as the "passed object"
2447	// for a type-bound procedure reference that is not NOPASS. Adds an
2448	// argument keyword if possible, but not when the passed object goes
2449	// before a positional argument.
2450	// e.g., obj%tbp(x) -> tbp(obj,x).
2451	static void AddPassArg(ActualArguments &actuals, const Expr<SomeDerived> &expr,
2452	const Symbol &component, bool isPassedObject = true) {
2453	if (component.attrs().test(semantics::Attr::NOPASS)) {
2454	return;
2455	}
2456	std::optional<int> passIndex{GetPassIndex(component)};
2457	if (!passIndex) {
2458	return; // error recovery
2459	}
2460	auto iter{actuals.begin()};
2461	int at{0};
2462	while (iter < actuals.end() && at < *passIndex) {
2463	if (*iter && (*iter)->keyword()) {
2464	iter = actuals.end();
2465	break;
2466	}
2467	++iter;
2468	++at;
2469	}
2470	ActualArgument passed{AsGenericExpr(common::Clone(expr))};
2471	passed.set_isPassedObject(isPassedObject);
2472	if (iter == actuals.end()) {
2473	if (auto passName{GetPassName(component)}) {
2474	passed.set_keyword(*passName);
2475	}
2476	}
2477	actuals.emplace(iter, std::move(passed));
2478	}
2479
2480	// Return the compile-time resolution of a procedure binding, if possible.
2481	static const Symbol *GetBindingResolution(
2482	const std::optional<DynamicType> &baseType, const Symbol &component) {
2483	const auto *binding{component.detailsIf<semantics::ProcBindingDetails>()};
2484	if (!binding) {
2485	return nullptr;
2486	}
2487	if (!component.attrs().test(semantics::Attr::NON_OVERRIDABLE) &&
2488	(!baseType || baseType->IsPolymorphic())) {
2489	return nullptr;
2490	}
2491	return &binding->symbol();
2492	}
2493
2494	auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
2495	const parser::ProcComponentRef &pcr, ActualArguments &&arguments,
2496	bool isSubroutine) -> std::optional<CalleeAndArguments> {
2497	const parser::StructureComponent &sc{pcr.v.thing};
2498	if (MaybeExpr base{Analyze(sc.base)}) {
2499	if (const Symbol *sym{sc.component.symbol}) {
2500	if (context_.HasError(sym)) {
2501	return std::nullopt;
2502	}
2503	if (!IsProcedure(*sym)) {
2504	AttachDeclaration(
2505	Say(sc.component.source, "'%s' is not a procedure"_err_en_US,
2506	sc.component.source),
2507	*sym);
2508	return std::nullopt;
2509	}
2510	if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
2511	if (sym->has<semantics::GenericDetails>()) {
2512	const Symbol &generic{*sym};
2513	auto dyType{dtExpr->GetType()};
2514	AdjustActuals adjustment{
2515	[&](const Symbol &proc, ActualArguments &actuals) {
2516	if (!proc.attrs().test(semantics::Attr::NOPASS)) {
2517	AddPassArg(actuals, std::move(*dtExpr), proc);
2518	}
2519	return true;
2520	}};
2521	auto pair{
2522	ResolveGeneric(generic, arguments, adjustment, isSubroutine)};
2523	sym = pair.first;
2524	if (!sym) {
2525	EmitGenericResolutionError(generic, pair.second, isSubroutine);
2526	return std::nullopt;
2527	}
2528	// re-resolve the name to the specific binding
2529	CHECK(sym->has<semantics::ProcBindingDetails>());
2530	// Use the most recent override of a binding, respecting
2531	// the rule that inaccessible bindings may not be overridden
2532	// outside their module. Fortran doesn't allow a PUBLIC
2533	// binding to be overridden by a PRIVATE one.
2534	CHECK(dyType && dyType->category() == TypeCategory::Derived &&
2535	!dyType->IsUnlimitedPolymorphic());
2536	if (const Symbol *
2537	latest{DEREF(dyType->GetDerivedTypeSpec().typeSymbol().scope())
2538	.FindComponent(sym->name())}) {
2539	if (sym->attrs().test(semantics::Attr::PRIVATE)) {
2540	const auto *bindingModule{FindModuleContaining(generic.owner())};
2541	const Symbol *s{latest};
2542	while (s && FindModuleContaining(s->owner()) != bindingModule) {
2543	if (const auto *parent{s->owner().GetDerivedTypeParent()}) {
2544	s = parent->FindComponent(sym->name());
2545	} else {
2546	s = nullptr;
2547	}
2548	}
2549	if (s && !s->attrs().test(semantics::Attr::PRIVATE)) {
2550	// The latest override in the same module as the binding
2551	// is public, so it can be overridden.
2552	} else {
2553	latest = s;
2554	}
2555	}
2556	if (latest) {
2557	sym = latest;
2558	}
2559	}
2560	sc.component.symbol = const_cast<Symbol *>(sym);
2561	}
2562	std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
2563	if (dataRef && !CheckDataRef(*dataRef)) {
2564	return std::nullopt;
2565	}
2566	if (dataRef && dataRef->Rank() > 0) {
2567	if (sym->has<semantics::ProcBindingDetails>() &&
2568	sym->attrs().test(semantics::Attr::NOPASS)) {
2569	// F'2023 C1529 seems unnecessary and most compilers don't
2570	// enforce it.
2571	AttachDeclaration(
2572	Warn(common::LanguageFeature::NopassScalarBase,
2573	sc.component.source,
2574	"Base of NOPASS type-bound procedure reference should be scalar"_port_en_US),
2575	*sym);
2576	} else if (IsProcedurePointer(*sym)) { // C919
2577	Say(sc.component.source,
2578	"Base of procedure component reference must be scalar"_err_en_US);
2579	}
2580	}
2581	if (const Symbol *resolution{
2582	GetBindingResolution(dtExpr->GetType(), *sym)}) {
2583	AddPassArg(arguments, std::move(*dtExpr), *sym, false);
2584	return CalleeAndArguments{
2585	ProcedureDesignator{*resolution}, std::move(arguments)};
2586	} else if (dataRef.has_value()) {
2587	if (ExtractCoarrayRef(*dataRef)) {
2588	if (IsProcedurePointer(*sym)) {
2589	Say(sc.component.source,
2590	"Base of procedure component reference may not be coindexed"_err_en_US);
2591	} else {
2592	Say(sc.component.source,
2593	"A procedure binding may not be coindexed unless it can be resolved at compilation time"_err_en_US);
2594	}
2595	}
2596	if (sym->attrs().test(semantics::Attr::NOPASS)) {
2597	const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
2598	if (dtSpec && dtSpec->scope()) {
2599	if (auto component{CreateComponent(std::move(*dataRef), *sym,
2600	*dtSpec->scope(), /*C919bAlreadyEnforced=*/true)}) {
2601	return CalleeAndArguments{
2602	ProcedureDesignator{std::move(*component)},
2603	std::move(arguments)};
2604	}
2605	}
2606	Say(sc.component.source,
2607	"Component is not in scope of base derived type"_err_en_US);
2608	return std::nullopt;
2609	} else {
2610	AddPassArg(arguments,
2611	Expr<SomeDerived>{Designator<SomeDerived>{std::move(*dataRef)}},
2612	*sym);
2613	return CalleeAndArguments{
2614	ProcedureDesignator{*sym}, std::move(arguments)};
2615	}
2616	}
2617	}
2618	Say(sc.component.source,
2619	"Base of procedure component reference is not a derived-type object"_err_en_US);
2620	}
2621	}
2622	CHECK(context_.AnyFatalError());
2623	return std::nullopt;
2624	}
2625
2626	// Can actual be argument associated with dummy?
2627	static bool CheckCompatibleArgument(bool isElemental,
2628	const ActualArgument &actual, const characteristics::DummyArgument &dummy,
2629	FoldingContext &foldingContext) {
2630	const auto *expr{actual.UnwrapExpr()};
2631	return common::visit(
2632	common::visitors{
2633	[&](const characteristics::DummyDataObject &x) {
2634	if ((x.attrs.test(
2635	characteristics::DummyDataObject::Attr::Pointer) ||
2636	x.attrs.test(
2637	characteristics::DummyDataObject::Attr::Allocatable)) &&
2638	IsBareNullPointer(expr)) {
2639	// NULL() without MOLD= is compatible with any dummy data pointer
2640	// or allocatable, but cannot be allowed to lead to ambiguity.
2641	return true;
2642	} else if (!isElemental && actual.Rank() != x.type.Rank() &&
2643	!x.type.attrs().test(
2644	characteristics::TypeAndShape::Attr::AssumedRank) &&
2645	!x.ignoreTKR.test(common::IgnoreTKR::Rank)) {
2646	return false;
2647	} else if (auto actualType{actual.GetType()}) {
2648	return x.type.type().IsTkCompatibleWith(*actualType, x.ignoreTKR);
2649	}
2650	return false;
2651	},
2652	[&](const characteristics::DummyProcedure &dummy) {
2653	if ((dummy.attrs.test(
2654	characteristics::DummyProcedure::Attr::Optional) ||
2655	dummy.attrs.test(
2656	characteristics::DummyProcedure::Attr::Pointer)) &&
2657	IsBareNullPointer(expr)) {
2658	// NULL() is compatible with any dummy pointer
2659	// or optional dummy procedure.
2660	return true;
2661	}
2662	if (!expr || !IsProcedurePointerTarget(*expr)) {
2663	return false;
2664	}
2665	if (auto actualProc{characteristics::Procedure::Characterize(
2666	*expr, foldingContext)}) {
2667	const auto &dummyResult{dummy.procedure.value().functionResult};
2668	const auto *dummyTypeAndShape{
2669	dummyResult ? dummyResult->GetTypeAndShape() : nullptr};
2670	const auto &actualResult{actualProc->functionResult};
2671	const auto *actualTypeAndShape{
2672	actualResult ? actualResult->GetTypeAndShape() : nullptr};
2673	if (dummyTypeAndShape && actualTypeAndShape) {
2674	// Return false when the function results' types are both
2675	// known and not compatible.
2676	return actualTypeAndShape->type().IsTkCompatibleWith(
2677	dummyTypeAndShape->type());
2678	}
2679	}
2680	return true;
2681	},
2682	[&](const characteristics::AlternateReturn &) {
2683	return actual.isAlternateReturn();
2684	},
2685	},
2686	dummy.u);
2687	}
2688
2689	// Are the actual arguments compatible with the dummy arguments of procedure?
2690	static bool CheckCompatibleArguments(
2691	const characteristics::Procedure &procedure, const ActualArguments &actuals,
2692	FoldingContext &foldingContext) {
2693	bool isElemental{procedure.IsElemental()};
2694	const auto &dummies{procedure.dummyArguments};
2695	CHECK(dummies.size() == actuals.size());
2696	for (std::size_t i{0}; i < dummies.size(); ++i) {
2697	const characteristics::DummyArgument &dummy{dummies[i]};
2698	const std::optional<ActualArgument> &actual{actuals[i]};
2699	if (actual &&
2700	!CheckCompatibleArgument(isElemental, *actual, dummy, foldingContext)) {
2701	return false;
2702	}
2703	}
2704	return true;
2705	}
2706
2707	static constexpr int cudaInfMatchingValue{std::numeric_limits<int>::max()};
2708
2709	// Compute the matching distance as described in section 3.2.3 of the CUDA
2710	// Fortran references.
2711	static int GetMatchingDistance(const common::LanguageFeatureControl &features,
2712	const characteristics::DummyArgument &dummy,
2713	const std::optional<ActualArgument> &actual) {
2714	bool isCudaManaged{features.IsEnabled(common::LanguageFeature::CudaManaged)};
2715	bool isCudaUnified{features.IsEnabled(common::LanguageFeature::CudaUnified)};
2716	CHECK(!(isCudaUnified && isCudaManaged) && "expect only one enabled.");
2717
2718	std::optional<common::CUDADataAttr> actualDataAttr, dummyDataAttr;
2719	if (actual) {
2720	if (auto *expr{actual->UnwrapExpr()}) {
2721	const auto *actualLastSymbol{evaluate::GetLastSymbol(*expr)};
2722	if (actualLastSymbol) {
2723	actualLastSymbol = &semantics::ResolveAssociations(*actualLastSymbol);
2724	if (const auto *actualObject{actualLastSymbol
2725	? actualLastSymbol
2726	->detailsIf<semantics::ObjectEntityDetails>()
2727	: nullptr}) {
2728	actualDataAttr = actualObject->cudaDataAttr();
2729	}
2730	}
2731	}
2732	}
2733
2734	common::visit(common::visitors{
2735	[&](const characteristics::DummyDataObject &object) {
2736	dummyDataAttr = object.cudaDataAttr;
2737	},
2738	[&](const auto &) {},
2739	},
2740	dummy.u);
2741
2742	if (!dummyDataAttr) {
2743	if (!actualDataAttr) {
2744	if (isCudaUnified || isCudaManaged) {
2745	return 3;
2746	}
2747	return 0;
2748	} else if (*actualDataAttr == common::CUDADataAttr::Device) {
2749	return cudaInfMatchingValue;
2750	} else if (*actualDataAttr == common::CUDADataAttr::Managed ||
2751	*actualDataAttr == common::CUDADataAttr::Unified) {
2752	return 3;
2753	}
2754	} else if (*dummyDataAttr == common::CUDADataAttr::Device) {
2755	if (!actualDataAttr) {
2756	if (isCudaUnified || isCudaManaged) {
2757	return 2;
2758	}
2759	return cudaInfMatchingValue;
2760	} else if (*actualDataAttr == common::CUDADataAttr::Device) {
2761	return 0;
2762	} else if (*actualDataAttr == common::CUDADataAttr::Managed ||
2763	*actualDataAttr == common::CUDADataAttr::Unified) {
2764	return 2;
2765	}
2766	} else if (*dummyDataAttr == common::CUDADataAttr::Managed) {
2767	if (!actualDataAttr) {
2768	return isCudaUnified ? 1 : isCudaManaged ? 0 : cudaInfMatchingValue;
2769	}
2770	if (*actualDataAttr == common::CUDADataAttr::Device) {
2771	return cudaInfMatchingValue;
2772	} else if (*actualDataAttr == common::CUDADataAttr::Managed) {
2773	return 0;
2774	} else if (*actualDataAttr == common::CUDADataAttr::Unified) {
2775	return 1;
2776	}
2777	} else if (*dummyDataAttr == common::CUDADataAttr::Unified) {
2778	if (!actualDataAttr) {
2779	return isCudaUnified ? 0 : isCudaManaged ? 1 : cudaInfMatchingValue;
2780	}
2781	if (*actualDataAttr == common::CUDADataAttr::Device) {
2782	return cudaInfMatchingValue;
2783	} else if (*actualDataAttr == common::CUDADataAttr::Managed) {
2784	return 1;
2785	} else if (*actualDataAttr == common::CUDADataAttr::Unified) {
2786	return 0;
2787	}
2788	}
2789	return cudaInfMatchingValue;
2790	}
2791
2792	static int ComputeCudaMatchingDistance(
2793	const common::LanguageFeatureControl &features,
2794	const characteristics::Procedure &procedure,
2795	const ActualArguments &actuals) {
2796	const auto &dummies{procedure.dummyArguments};
2797	CHECK(dummies.size() == actuals.size());
2798	int distance{0};
2799	for (std::size_t i{0}; i < dummies.size(); ++i) {
2800	const characteristics::DummyArgument &dummy{dummies[i]};
2801	const std::optional<ActualArgument> &actual{actuals[i]};
2802	int d{GetMatchingDistance(features, dummy, actual)};
2803	if (d == cudaInfMatchingValue)
2804	return d;
2805	distance += d;
2806	}
2807	return distance;
2808	}
2809
2810	// Handles a forward reference to a module function from what must
2811	// be a specification expression. Return false if the symbol is
2812	// an invalid forward reference.
2813	const Symbol *ExpressionAnalyzer::ResolveForward(const Symbol &symbol) {
2814	if (context_.HasError(symbol)) {
2815	return nullptr;
2816	}
2817	if (const auto *details{
2818	symbol.detailsIf<semantics::SubprogramNameDetails>()}) {
2819	if (details->kind() == semantics::SubprogramKind::Module) {
2820	// If this symbol is still a SubprogramNameDetails, we must be
2821	// checking a specification expression in a sibling module
2822	// procedure. Resolve its names now so that its interface
2823	// is known.
2824	const semantics::Scope &scope{symbol.owner()};
2825	semantics::ResolveSpecificationParts(context_, symbol);
2826	const Symbol *resolved{nullptr};
2827	if (auto iter{scope.find(symbol.name())}; iter != scope.cend()) {
2828	resolved = &*iter->second;
2829	}
2830	if (!resolved || resolved->has<semantics::SubprogramNameDetails>()) {
2831	// When the symbol hasn't had its details updated, we must have
2832	// already been in the process of resolving the function's
2833	// specification part; but recursive function calls are not
2834	// allowed in specification parts (10.1.11 para 5).
2835	Say("The module function '%s' may not be referenced recursively in a specification expression"_err_en_US,
2836	symbol.name());
2837	context_.SetError(symbol);
2838	}
2839	return resolved;
2840	} else if (inStmtFunctionDefinition_) {
2841	semantics::ResolveSpecificationParts(context_, symbol);
2842	CHECK(symbol.has<semantics::SubprogramDetails>());
2843	} else { // 10.1.11 para 4
2844	Say("The internal function '%s' may not be referenced in a specification expression"_err_en_US,
2845	symbol.name());
2846	context_.SetError(symbol);
2847	return nullptr;
2848	}
2849	}
2850	return &symbol;
2851	}
2852
2853	// Resolve a call to a generic procedure with given actual arguments.
2854	// adjustActuals is called on procedure bindings to handle pass arg.
2855	std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
2856	const Symbol &symbol, const ActualArguments &actuals,
2857	const AdjustActuals &adjustActuals, bool isSubroutine,
2858	bool mightBeStructureConstructor) {
2859	const Symbol &ultimate{symbol.GetUltimate()};
2860	// Check for a match with an explicit INTRINSIC
2861	const Symbol *explicitIntrinsic{nullptr};
2862	if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
2863	parser::Messages buffer;
2864	auto restorer{GetContextualMessages().SetMessages(buffer)};
2865	ActualArguments localActuals{actuals};
2866	if (context_.intrinsics().Probe(
2867	CallCharacteristics{ultimate.name().ToString(), isSubroutine},
2868	localActuals, foldingContext_) &&
2869	!buffer.AnyFatalError()) {
2870	explicitIntrinsic = &ultimate;
2871	}
2872	}
2873	const Symbol *elemental{nullptr}; // matching elemental specific proc
2874	const Symbol *nonElemental{nullptr}; // matching non-elemental specific
2875	const auto *genericDetails{ultimate.detailsIf<semantics::GenericDetails>()};
2876	if (genericDetails && !explicitIntrinsic) {
2877	int crtMatchingDistance{cudaInfMatchingValue};
2878	for (const Symbol &specific0 : genericDetails->specificProcs()) {
2879	const Symbol &specific1{BypassGeneric(specific0)};
2880	if (isSubroutine != !IsFunction(specific1)) {
2881	continue;
2882	}
2883	const Symbol *specific{ResolveForward(specific1)};
2884	if (!specific) {
2885	continue;
2886	}
2887	if (std::optional<characteristics::Procedure> procedure{
2888	characteristics::Procedure::Characterize(
2889	ProcedureDesignator{*specific}, context_.foldingContext(),
2890	/*emitError=*/false)}) {
2891	ActualArguments localActuals{actuals};
2892	if (specific->has<semantics::ProcBindingDetails>()) {
2893	if (!adjustActuals.value()(*specific, localActuals)) {
2894	continue;
2895	}
2896	}
2897	if (semantics::CheckInterfaceForGeneric(*procedure, localActuals,
2898	context_, false /* no integer conversions */) &&
2899	CheckCompatibleArguments(
2900	*procedure, localActuals, foldingContext_)) {
2901	if ((procedure->IsElemental() && elemental) ||
2902	(!procedure->IsElemental() && nonElemental)) {
2903	int d{ComputeCudaMatchingDistance(
2904	context_.languageFeatures(), *procedure, localActuals)};
2905	if (d != crtMatchingDistance) {
2906	if (d > crtMatchingDistance) {
2907	continue;
2908	}
2909	// Matching distance is smaller than the previously matched
2910	// specific. Let it go through so the current procedure is picked.
2911	} else {
2912	// 16.9.144(6): a bare NULL() is not allowed as an actual
2913	// argument to a generic procedure if the specific procedure
2914	// cannot be unambiguously distinguished
2915	// Underspecified external procedure actual arguments can
2916	// also lead to ambiguity.
2917	return {nullptr, true /* due to ambiguity */};
2918	}
2919	}
2920	if (!procedure->IsElemental()) {
2921	// takes priority over elemental match
2922	nonElemental = specific;
2923	} else {
2924	elemental = specific;
2925	}
2926	crtMatchingDistance = ComputeCudaMatchingDistance(
2927	context_.languageFeatures(), *procedure, localActuals);
2928	}
2929	}
2930	}
2931	}
2932	// Is there a derived type of the same name?
2933	const Symbol *derivedType{nullptr};
2934	if (mightBeStructureConstructor && !isSubroutine && genericDetails) {
2935	if (const Symbol * dt{genericDetails->derivedType()}) {
2936	const Symbol &ultimate{dt->GetUltimate()};
2937	if (ultimate.has<semantics::DerivedTypeDetails>()) {
2938	derivedType = &ultimate;
2939	}
2940	}
2941	}
2942	// F'2023 C7108 checking. No Fortran compiler actually enforces this
2943	// constraint, so it's just a portability warning here.
2944	if (derivedType && (explicitIntrinsic || nonElemental || elemental) &&
2945	context_.ShouldWarn(
2946	common::LanguageFeature::AmbiguousStructureConstructor)) {
2947	// See whethr there's ambiguity with a structure constructor.
2948	bool possiblyAmbiguous{true};
2949	if (const semantics::Scope * dtScope{derivedType->scope()}) {
2950	parser::Messages buffer;
2951	auto restorer{GetContextualMessages().SetMessages(buffer)};
2952	std::list<ComponentSpec> componentSpecs;
2953	for (const auto &actual : actuals) {
2954	if (actual) {
2955	ComponentSpec compSpec;
2956	if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {
2957	compSpec.expr = *expr;
2958	} else {
2959	possiblyAmbiguous = false;
2960	}
2961	if (auto loc{actual->sourceLocation()}) {
2962	compSpec.source = compSpec.exprSource = *loc;
2963	}
2964	if (auto kw{actual->keyword()}) {
2965	compSpec.hasKeyword = true;
2966	compSpec.keywordSymbol = dtScope->FindComponent(*kw);
2967	}
2968	componentSpecs.emplace_back(std::move(compSpec));
2969	} else {
2970	possiblyAmbiguous = false;
2971	}
2972	}
2973	semantics::DerivedTypeSpec dtSpec{derivedType->name(), *derivedType};
2974	dtSpec.set_scope(*dtScope);
2975	possiblyAmbiguous = possiblyAmbiguous &&
2976	CheckStructureConstructor(
2977	derivedType->name(), dtSpec, std::move(componentSpecs))
2978	.has_value() &&
2979	!buffer.AnyFatalError();
2980	}
2981	if (possiblyAmbiguous) {
2982	if (explicitIntrinsic) {
2983	Warn(common::LanguageFeature::AmbiguousStructureConstructor,
2984	"Reference to the intrinsic function '%s' is ambiguous with a structure constructor of the same name"_port_en_US,
2985	symbol.name());
2986	} else {
2987	Warn(common::LanguageFeature::AmbiguousStructureConstructor,
2988	"Reference to generic function '%s' (resolving to specific '%s') is ambiguous with a structure constructor of the same name"_port_en_US,
2989	symbol.name(),
2990	nonElemental ? nonElemental->name() : elemental->name());
2991	}
2992	}
2993	}
2994	// Return the right resolution, if there is one. Explicit intrinsics
2995	// are preferred, then non-elements specifics, then elementals, and
2996	// lastly structure constructors.
2997	if (explicitIntrinsic) {
2998	return {explicitIntrinsic, false};
2999	} else if (nonElemental) {
3000	return {&AccessSpecific(symbol, *nonElemental), false};
3001	} else if (elemental) {
3002	return {&AccessSpecific(symbol, *elemental), false};
3003	}
3004	// Check parent derived type
3005	if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
3006	if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
3007	auto pair{ResolveGeneric(
3008	*extended, actuals, adjustActuals, isSubroutine, false)};
3009	if (pair.first) {
3010	return pair;
3011	}
3012	}
3013	}
3014	// Structure constructor?
3015	if (derivedType) {
3016	return {derivedType, false};
3017	}
3018	// Check for generic or explicit INTRINSIC of the same name in outer scopes.
3019	// See 15.5.5.2 for details.
3020	if (!symbol.owner().IsGlobal() && !symbol.owner().IsDerivedType()) {
3021	if (const Symbol *
3022	outer{symbol.owner().parent().FindSymbol(symbol.name())}) {
3023	auto pair{ResolveGeneric(*outer, actuals, adjustActuals, isSubroutine,
3024	mightBeStructureConstructor)};
3025	if (pair.first) {
3026	return pair;
3027	}
3028	}
3029	}
3030	return {nullptr, false};
3031	}
3032
3033	const Symbol &ExpressionAnalyzer::AccessSpecific(
3034	const Symbol &originalGeneric, const Symbol &specific) {
3035	if (const auto *hosted{
3036	originalGeneric.detailsIf<semantics::HostAssocDetails>()}) {
3037	return AccessSpecific(hosted->symbol(), specific);
3038	} else if (const auto *used{
3039	originalGeneric.detailsIf<semantics::UseDetails>()}) {
3040	const auto &scope{originalGeneric.owner()};
3041	if (auto iter{scope.find(specific.name())}; iter != scope.end()) {
3042	if (const auto *useDetails{
3043	iter->second->detailsIf<semantics::UseDetails>()}) {
3044	const Symbol &usedSymbol{useDetails->symbol()};
3045	const auto *usedGeneric{
3046	usedSymbol.detailsIf<semantics::GenericDetails>()};
3047	if (&usedSymbol == &specific ||
3048	(usedGeneric && usedGeneric->specific() == &specific)) {
3049	return specific;
3050	}
3051	}
3052	}
3053	// Create a renaming USE of the specific procedure.
3054	auto rename{context_.SaveTempName(
3055	used->symbol().owner().GetName().value().ToString() + "$" +
3056	specific.owner().GetName().value().ToString() + "$" +
3057	specific.name().ToString())};
3058	return *const_cast<semantics::Scope &>(scope)
3059	.try_emplace(rename, specific.attrs(),
3060	semantics::UseDetails{rename, specific})
3061	.first->second;
3062	} else {
3063	return specific;
3064	}
3065	}
3066
3067	void ExpressionAnalyzer::EmitGenericResolutionError(
3068	const Symbol &symbol, bool dueToAmbiguity, bool isSubroutine) {
3069	Say(dueToAmbiguity
3070	? "The actual arguments to the generic procedure '%s' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface"_err_en_US
3071	: semantics::IsGenericDefinedOp(symbol)
3072	? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US
3073	: isSubroutine
3074	? "No specific subroutine of generic '%s' matches the actual arguments"_err_en_US
3075	: "No specific function of generic '%s' matches the actual arguments"_err_en_US,
3076	symbol.name());
3077	}
3078
3079	auto ExpressionAnalyzer::GetCalleeAndArguments(
3080	const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
3081	bool isSubroutine, bool mightBeStructureConstructor)
3082	-> std::optional<CalleeAndArguments> {
3083	return common::visit(common::visitors{
3084	[&](const parser::Name &name) {
3085	return GetCalleeAndArguments(name,
3086	std::move(arguments), isSubroutine,
3087	mightBeStructureConstructor);
3088	},
3089	[&](const parser::ProcComponentRef &pcr) {
3090	return AnalyzeProcedureComponentRef(
3091	pcr, std::move(arguments), isSubroutine);
3092	},
3093	},
3094	pd.u);
3095	}
3096
3097	auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
3098	ActualArguments &&arguments, bool isSubroutine,
3099	bool mightBeStructureConstructor) -> std::optional<CalleeAndArguments> {
3100	const Symbol *symbol{name.symbol};
3101	if (context_.HasError(symbol)) {
3102	return std::nullopt; // also handles null symbol
3103	}
3104	symbol = ResolveForward(*symbol);
3105	if (!symbol) {
3106	return std::nullopt;
3107	}
3108	name.symbol = const_cast<Symbol *>(symbol);
3109	const Symbol &ultimate{symbol->GetUltimate()};
3110	CheckForBadRecursion(name.source, ultimate);
3111	bool dueToAmbiguity{false};
3112	bool isGenericInterface{ultimate.has<semantics::GenericDetails>()};
3113	bool isExplicitIntrinsic{ultimate.attrs().test(semantics::Attr::INTRINSIC)};
3114	const Symbol *resolution{nullptr};
3115	if (isGenericInterface || isExplicitIntrinsic) {
3116	ExpressionAnalyzer::AdjustActuals noAdjustment;
3117	auto pair{ResolveGeneric(*symbol, arguments, noAdjustment, isSubroutine,
3118	mightBeStructureConstructor)};
3119	resolution = pair.first;
3120	dueToAmbiguity = pair.second;
3121	if (resolution) {
3122	if (context_.GetPPCBuiltinsScope() &&
3123	resolution->name().ToString().rfind("__ppc_", 0) == 0) {
3124	semantics::CheckPPCIntrinsic(
3125	*symbol, *resolution, arguments, GetFoldingContext());
3126	}
3127	// re-resolve name to the specific procedure
3128	name.symbol = const_cast<Symbol *>(resolution);
3129	}
3130	} else if (IsProcedure(ultimate) &&
3131	ultimate.attrs().test(semantics::Attr::ABSTRACT)) {
3132	Say("Abstract procedure interface '%s' may not be referenced"_err_en_US,
3133	name.source);
3134	} else {
3135	resolution = symbol;
3136	}
3137	if (resolution && context_.targetCharacteristics().isOSWindows()) {
3138	semantics::CheckWindowsIntrinsic(*resolution, GetFoldingContext());
3139	}
3140	if (!resolution || resolution->attrs().test(semantics::Attr::INTRINSIC)) {
3141	auto name{resolution ? resolution->name() : ultimate.name()};
3142	if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
3143	CallCharacteristics{name.ToString(), isSubroutine}, arguments,
3144	GetFoldingContext())}) {
3145	CheckBadExplicitType(*specificCall, *symbol);
3146	return CalleeAndArguments{
3147	ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
3148	std::move(specificCall->arguments)};
3149	} else {
3150	if (isGenericInterface) {
3151	EmitGenericResolutionError(*symbol, dueToAmbiguity, isSubroutine);
3152	}
3153	return std::nullopt;
3154	}
3155	}
3156	if (resolution->GetUltimate().has<semantics::DerivedTypeDetails>()) {
3157	if (mightBeStructureConstructor) {
3158	return CalleeAndArguments{
3159	semantics::SymbolRef{*resolution}, std::move(arguments)};
3160	}
3161	} else if (IsProcedure(*resolution)) {
3162	return CalleeAndArguments{
3163	ProcedureDesignator{*resolution}, std::move(arguments)};
3164	}
3165	if (!context_.HasError(*resolution)) {
3166	AttachDeclaration(
3167	Say(name.source, "'%s' is not a callable procedure"_err_en_US,
3168	name.source),
3169	*resolution);
3170	}
3171	return std::nullopt;
3172	}
3173
3174	// Fortran 2018 expressly states (8.2 p3) that any declared type for a
3175	// generic intrinsic function "has no effect" on the result type of a
3176	// call to that intrinsic. So one can declare "character*8 cos" and
3177	// still get a real result from "cos(1.)". This is a dangerous feature,
3178	// especially since implementations are free to extend their sets of
3179	// intrinsics, and in doing so might clash with a name in a program.
3180	// So we emit a warning in this situation, and perhaps it should be an
3181	// error -- any correctly working program can silence the message by
3182	// simply deleting the pointless type declaration.
3183	void ExpressionAnalyzer::CheckBadExplicitType(
3184	const SpecificCall &call, const Symbol &intrinsic) {
3185	if (intrinsic.GetUltimate().GetType()) {
3186	const auto &procedure{call.specificIntrinsic.characteristics.value()};
3187	if (const auto &result{procedure.functionResult}) {
3188	if (const auto *typeAndShape{result->GetTypeAndShape()}) {
3189	if (auto declared{
3190	typeAndShape->Characterize(intrinsic, GetFoldingContext())}) {
3191	if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) {
3192	if (auto *msg{Warn(
3193	common::UsageWarning::IgnoredIntrinsicFunctionType,
3194	"The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_warn_en_US,
3195	typeAndShape->AsFortran(), intrinsic.name(),
3196	declared->AsFortran())}) {
3197	msg->Attach(intrinsic.name(),
3198	"Ignored declaration of intrinsic function '%s'"_en_US,
3199	intrinsic.name());
3200	}
3201	}
3202	}
3203	}
3204	}
3205	}
3206	}
3207
3208	void ExpressionAnalyzer::CheckForBadRecursion(
3209	parser::CharBlock callSite, const semantics::Symbol &proc) {
3210	if (const auto *scope{proc.scope()}) {
3211	if (scope->sourceRange().Contains(callSite)) {
3212	parser::Message *msg{nullptr};
3213	if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)
3214	msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
3215	callSite);
3216	} else if (IsAssumedLengthCharacter(proc) && IsExternal(proc)) {
3217	// TODO: Also catch assumed PDT type parameters
3218	msg = Say( // 15.6.2.1(3)
3219	"Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
3220	callSite);
3221	} else if (FindCUDADeviceContext(scope)) {
3222	msg = Say(
3223	"Device subprogram '%s' cannot call itself"_err_en_US, callSite);
3224	}
3225	AttachDeclaration(msg, proc);
3226	}
3227	}
3228	}
3229
3230	template <typename A> static const Symbol *AssumedTypeDummy(const A &x) {
3231	if (const auto *designator{
3232	std::get_if<common::Indirection<parser::Designator>>(&x.u)}) {
3233	if (const auto *dataRef{
3234	std::get_if<parser::DataRef>(&designator->value().u)}) {
3235	if (const auto *name{std::get_if<parser::Name>(&dataRef->u)}) {
3236	return AssumedTypeDummy(*name);
3237	}
3238	}
3239	}
3240	return nullptr;
3241	}
3242	template <>
3243	const Symbol *AssumedTypeDummy<parser::Name>(const parser::Name &name) {
3244	if (const Symbol *symbol{name.symbol}) {
3245	if (const auto *type{symbol->GetType()}) {
3246	if (type->category() == semantics::DeclTypeSpec::TypeStar) {
3247	return symbol;
3248	}
3249	}
3250	}
3251	return nullptr;
3252	}
3253	template <typename A>
3254	static const Symbol *AssumedTypePointerOrAllocatableDummy(const A &object) {
3255	// It is illegal for allocatable of pointer objects to be TYPE(*), but at that
3256	// point it is not guaranteed that it has been checked the object has
3257	// POINTER or ALLOCATABLE attribute, so do not assume nullptr can be directly
3258	// returned.
3259	return common::visit(
3260	common::visitors{
3261	[&](const parser::StructureComponent &x) {
3262	return AssumedTypeDummy(x.component);
3263	},
3264	[&](const parser::Name &x) { return AssumedTypeDummy(x); },
3265	},
3266	object.u);
3267	}
3268	template <>
3269	const Symbol *AssumedTypeDummy<parser::AllocateObject>(
3270	const parser::AllocateObject &x) {
3271	return AssumedTypePointerOrAllocatableDummy(x);
3272	}
3273	template <>
3274	const Symbol *AssumedTypeDummy<parser::PointerObject>(
3275	const parser::PointerObject &x) {
3276	return AssumedTypePointerOrAllocatableDummy(x);
3277	}
3278
3279	bool ExpressionAnalyzer::CheckIsValidForwardReference(
3280	const semantics::DerivedTypeSpec &dtSpec) {
3281	if (dtSpec.IsForwardReferenced()) {
3282	Say("Cannot construct value for derived type '%s' before it is defined"_err_en_US,
3283	dtSpec.name());
3284	return false;
3285	}
3286	return true;
3287	}
3288
3289	std::optional<Chevrons> ExpressionAnalyzer::AnalyzeChevrons(
3290	const parser::CallStmt &call) {
3291	Chevrons result;
3292	auto checkLaunchArg{[&](const Expr<SomeType> &expr, const char *which) {
3293	if (auto dyType{expr.GetType()}) {
3294	if (dyType->category() == TypeCategory::Integer) {
3295	return true;
3296	}
3297	if (dyType->category() == TypeCategory::Derived &&
3298	!dyType->IsPolymorphic() &&
3299	IsBuiltinDerivedType(&dyType->GetDerivedTypeSpec(), "dim3")) {
3300	return true;
3301	}
3302	}
3303	Say("Kernel launch %s parameter must be either integer or TYPE(dim3)"_err_en_US,
3304	which);
3305	return false;
3306	}};
3307	if (const auto &chevrons{call.chevrons}) {
3308	auto &starOrExpr{std::get<0>(chevrons->t)};
3309	if (starOrExpr.v) {
3310	if (auto expr{Analyze(*starOrExpr.v)};
3311	expr && checkLaunchArg(*expr, "grid")) {
3312	result.emplace_back(*expr);
3313	} else {
3314	return std::nullopt;
3315	}
3316	} else {
3317	result.emplace_back(
3318	AsGenericExpr(evaluate::Constant<evaluate::CInteger>{-1}));
3319	}
3320	if (auto expr{Analyze(std::get<1>(chevrons->t))};
3321	expr && checkLaunchArg(*expr, "block")) {
3322	result.emplace_back(*expr);
3323	} else {
3324	return std::nullopt;
3325	}
3326	if (const auto &maybeExpr{std::get<2>(chevrons->t)}) {
3327	if (auto expr{Analyze(*maybeExpr)}) {
3328	result.emplace_back(*expr);
3329	} else {
3330	return std::nullopt;
3331	}
3332	}
3333	if (const auto &maybeExpr{std::get<3>(chevrons->t)}) {
3334	if (auto expr{Analyze(*maybeExpr)}) {
3335	result.emplace_back(*expr);
3336	} else {
3337	return std::nullopt;
3338	}
3339	}
3340	}
3341	return std::move(result);
3342	}
3343
3344	MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,
3345	std::optional<parser::StructureConstructor> *structureConstructor) {
3346	const parser::Call &call{funcRef.v};
3347	auto restorer{GetContextualMessages().SetLocation(funcRef.source)};
3348	ArgumentAnalyzer analyzer{*this, funcRef.source, true /* isProcedureCall */};
3349	for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
3350	analyzer.Analyze(arg, false /* not subroutine call */);
3351	}
3352	if (analyzer.fatalErrors()) {
3353	return std::nullopt;
3354	}
3355	bool mightBeStructureConstructor{structureConstructor != nullptr};
3356	if (std::optional<CalleeAndArguments> callee{GetCalleeAndArguments(
3357	std::get<parser::ProcedureDesignator>(call.t), analyzer.GetActuals(),
3358	false /* not subroutine */, mightBeStructureConstructor)}) {
3359	if (auto *proc{std::get_if<ProcedureDesignator>(&callee->u)}) {
3360	return MakeFunctionRef(
3361	funcRef.source, std::move(*proc), std::move(callee->arguments));
3362	}
3363	CHECK(std::holds_alternative<semantics::SymbolRef>(callee->u));
3364	const Symbol &symbol{*std::get<semantics::SymbolRef>(callee->u)};
3365	if (mightBeStructureConstructor) {
3366	// Structure constructor misparsed as function reference?
3367	const auto &designator{std::get<parser::ProcedureDesignator>(call.t)};
3368	if (const auto *name{std::get_if<parser::Name>(&designator.u)}) {
3369	semantics::Scope &scope{context_.FindScope(name->source)};
3370	semantics::DerivedTypeSpec dtSpec{name->source, symbol};
3371	if (!CheckIsValidForwardReference(dtSpec)) {
3372	return std::nullopt;
3373	}
3374	const semantics::DeclTypeSpec &type{
3375	semantics::FindOrInstantiateDerivedType(scope, std::move(dtSpec))};
3376	auto &mutableRef{const_cast<parser::FunctionReference &>(funcRef)};
3377	*structureConstructor =
3378	mutableRef.ConvertToStructureConstructor(type.derivedTypeSpec());
3379	// Don't use saved typed expressions left over from argument
3380	// analysis; they might not be valid structure components
3381	// (e.g., a TYPE(*) argument)
3382	auto restorer{DoNotUseSavedTypedExprs()};
3383	return Analyze(structureConstructor->value());
3384	}
3385	}
3386	if (!context_.HasError(symbol)) {
3387	AttachDeclaration(
3388	Say("'%s' is called like a function but is not a procedure"_err_en_US,
3389	symbol.name()),
3390	symbol);
3391	context_.SetError(symbol);
3392	}
3393	}
3394	return std::nullopt;
3395	}
3396
3397	static bool HasAlternateReturns(const evaluate::ActualArguments &args) {
3398	for (const auto &arg : args) {
3399	if (arg && arg->isAlternateReturn()) {
3400	return true;
3401	}
3402	}
3403	return false;
3404	}
3405
3406	void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
3407	const parser::Call &call{callStmt.call};
3408	auto restorer{GetContextualMessages().SetLocation(callStmt.source)};
3409	ArgumentAnalyzer analyzer{*this, callStmt.source, true /* isProcedureCall */};
3410	const auto &actualArgList{std::get<std::list<parser::ActualArgSpec>>(call.t)};
3411	for (const auto &arg : actualArgList) {
3412	analyzer.Analyze(arg, true /* is subroutine call */);
3413	}
3414	if (auto chevrons{AnalyzeChevrons(callStmt)};
3415	chevrons && !analyzer.fatalErrors()) {
3416	if (std::optional<CalleeAndArguments> callee{
3417	GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
3418	analyzer.GetActuals(), true /* subroutine */)}) {
3419	ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};
3420	CHECK(proc);
3421	bool isKernel{false};
3422	if (const Symbol * procSym{proc->GetSymbol()}) {
3423	const Symbol &ultimate{procSym->GetUltimate()};
3424	if (const auto *subpDetails{
3425	ultimate.detailsIf<semantics::SubprogramDetails>()}) {
3426	if (auto attrs{subpDetails->cudaSubprogramAttrs()}) {
3427	isKernel = *attrs == common::CUDASubprogramAttrs::Global ||
3428	*attrs == common::CUDASubprogramAttrs::Grid_Global;
3429	}
3430	} else if (const auto *procDetails{
3431	ultimate.detailsIf<semantics::ProcEntityDetails>()}) {
3432	isKernel = procDetails->isCUDAKernel();
3433	}
3434	if (isKernel && chevrons->empty()) {
3435	Say("'%s' is a kernel subroutine and must be called with kernel launch parameters in chevrons"_err_en_US,
3436	procSym->name());
3437	}
3438	}
3439	if (!isKernel && !chevrons->empty()) {
3440	Say("Kernel launch parameters in chevrons may not be used unless calling a kernel subroutine"_err_en_US);
3441	}
3442	if (CheckCall(callStmt.source, *proc, callee->arguments)) {
3443	callStmt.typedCall.Reset(
3444	new ProcedureRef{std::move(*proc), std::move(callee->arguments),
3445	HasAlternateReturns(callee->arguments)},
3446	ProcedureRef::Deleter);
3447	DEREF(callStmt.typedCall.get()).set_chevrons(std::move(*chevrons));
3448	return;
3449	}
3450	}
3451	if (!context_.AnyFatalError()) {
3452	std::string buf;
3453	llvm::raw_string_ostream dump{buf};
3454	parser::DumpTree(dump, callStmt);
3455	Say("Internal error: Expression analysis failed on CALL statement: %s"_err_en_US,
3456	buf);
3457	}
3458	}
3459	}
3460
3461	const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
3462	if (!x.typedAssignment) {
3463	ArgumentAnalyzer analyzer{*this};
3464	const auto &variable{std::get<parser::Variable>(x.t)};
3465	analyzer.Analyze(variable);
3466	const auto &rhsExpr{std::get<parser::Expr>(x.t)};
3467	analyzer.Analyze(rhsExpr);
3468	std::optional<Assignment> assignment;
3469	if (!analyzer.fatalErrors()) {
3470	auto restorer{GetContextualMessages().SetLocation(variable.GetSource())};
3471	std::optional<ProcedureRef> procRef{analyzer.TryDefinedAssignment()};
3472	if (!procRef) {
3473	analyzer.CheckForNullPointer(
3474	"in a non-pointer intrinsic assignment statement");
3475	analyzer.CheckForAssumedRank("in an assignment statement");
3476	const Expr<SomeType> &lhs{analyzer.GetExpr(0)};
3477	if (auto dyType{lhs.GetType()}) {
3478	if (dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
3479	const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)};
3480	const Symbol *lastWhole{
3481	lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
3482	if (!lastWhole || !IsAllocatable(*lastWhole)) {
3483	Say("Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
3484	} else if (evaluate::IsCoarray(*lastWhole)) {
3485	Say("Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray"_err_en_US);
3486	}
3487	}
3488	if (auto *derived{GetDerivedTypeSpec(*dyType)}) {
3489	if (auto iter{FindAllocatableUltimateComponent(*derived)}) {
3490	if (ExtractCoarrayRef(lhs)) {
3491	Say("Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
3492	iter.BuildResultDesignatorName());
3493	}
3494	}
3495	}
3496	}
3497	CheckForWholeAssumedSizeArray(
3498	rhsExpr.source, UnwrapWholeSymbolDataRef(analyzer.GetExpr(1)));
3499	}
3500	assignment.emplace(analyzer.MoveExpr(0), analyzer.MoveExpr(1));
3501	if (procRef) {
3502	assignment->u = std::move(*procRef);
3503	}
3504	}
3505	x.typedAssignment.Reset(new GenericAssignmentWrapper{std::move(assignment)},
3506	GenericAssignmentWrapper::Deleter);
3507	}
3508	return common::GetPtrFromOptional(x.typedAssignment->v);
3509	}
3510
3511	const Assignment *ExpressionAnalyzer::Analyze(
3512	const parser::PointerAssignmentStmt &x) {
3513	if (!x.typedAssignment) {
3514	MaybeExpr lhs{Analyze(std::get<parser::DataRef>(x.t))};
3515	MaybeExpr rhs;
3516	{
3517	auto restorer{AllowNullPointer()};
3518	rhs = Analyze(std::get<parser::Expr>(x.t));
3519	}
3520	if (!lhs || !rhs) {
3521	x.typedAssignment.Reset(
3522	new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);
3523	} else {
3524	Assignment assignment{std::move(*lhs), std::move(*rhs)};
3525	common::visit(
3526	common::visitors{
3527	[&](const std::list<parser::BoundsRemapping> &list) {
3528	Assignment::BoundsRemapping bounds;
3529	for (const auto &elem : list) {
3530	auto lower{AsSubscript(Analyze(std::get<0>(elem.t)))};
3531	auto upper{AsSubscript(Analyze(std::get<1>(elem.t)))};
3532	if (lower && upper) {
3533	bounds.emplace_back(
3534	Fold(std::move(*lower)), Fold(std::move(*upper)));
3535	}
3536	}
3537	assignment.u = std::move(bounds);
3538	},
3539	[&](const std::list<parser::BoundsSpec> &list) {
3540	Assignment::BoundsSpec bounds;
3541	for (const auto &bound : list) {
3542	if (auto lower{AsSubscript(Analyze(bound.v))}) {
3543	bounds.emplace_back(Fold(std::move(*lower)));
3544	}
3545	}
3546	assignment.u = std::move(bounds);
3547	},
3548	},
3549	std::get<parser::PointerAssignmentStmt::Bounds>(x.t).u);
3550	x.typedAssignment.Reset(
3551	new GenericAssignmentWrapper{std::move(assignment)},
3552	GenericAssignmentWrapper::Deleter);
3553	}
3554	}
3555	return common::GetPtrFromOptional(x.typedAssignment->v);
3556	}
3557
3558	static bool IsExternalCalledImplicitly(
3559	parser::CharBlock callSite, const Symbol *symbol) {
3560	return symbol && symbol->owner().IsGlobal() &&
3561	symbol->has<semantics::SubprogramDetails>() &&
3562	(!symbol->scope() /*ENTRY*/ ||
3563	!symbol->scope()->sourceRange().Contains(callSite));
3564	}
3565
3566	std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
3567	parser::CharBlock callSite, const ProcedureDesignator &proc,
3568	ActualArguments &arguments) {
3569	bool treatExternalAsImplicit{
3570	IsExternalCalledImplicitly(callSite, proc.GetSymbol())};
3571	const Symbol *procSymbol{proc.GetSymbol()};
3572	std::optional<characteristics::Procedure> chars;
3573	if (procSymbol && procSymbol->has<semantics::ProcEntityDetails>() &&
3574	procSymbol->owner().IsGlobal()) {
3575	// Unknown global external, implicit interface; assume
3576	// characteristics from the actual arguments, and check
3577	// for consistency with other references.
3578	chars = characteristics::Procedure::FromActuals(
3579	proc, arguments, context_.foldingContext());
3580	if (chars && procSymbol) {
3581	// Ensure calls over implicit interfaces are consistent
3582	auto name{procSymbol->name()};
3583	if (auto iter{implicitInterfaces_.find(name)};
3584	iter != implicitInterfaces_.end()) {
3585	std::string whyNot;
3586	if (!chars->IsCompatibleWith(iter->second.second,
3587	/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
3588	if (auto *msg{Warn(
3589	common::UsageWarning::IncompatibleImplicitInterfaces,
3590	callSite,
3591	"Reference to the procedure '%s' has an implicit interface that is distinct from another reference: %s"_warn_en_US,
3592	name, whyNot)}) {
3593	msg->Attach(
3594	iter->second.first, "previous reference to '%s'"_en_US, name);
3595	}
3596	}
3597	} else {
3598	implicitInterfaces_.insert(
3599	std::make_pair(name, std::make_pair(callSite, *chars)));
3600	}
3601	}
3602	}
3603	if (!chars) {
3604	chars = characteristics::Procedure::Characterize(
3605	proc, context_.foldingContext(), /*emitError=*/true);
3606	}
3607	bool ok{true};
3608	if (chars) {
3609	std::string whyNot;
3610	if (treatExternalAsImplicit &&
3611	!chars->CanBeCalledViaImplicitInterface(&whyNot)) {
3612	if (auto *msg{Say(callSite,
3613	"References to the procedure '%s' require an explicit interface"_err_en_US,
3614	DEREF(procSymbol).name())};
3615	msg && !whyNot.empty()) {
3616	msg->Attach(callSite, "%s"_because_en_US, whyNot);
3617	}
3618	}
3619	const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()};
3620	bool procIsDummy{procSymbol && IsDummy(*procSymbol)};
3621	if (chars->functionResult &&
3622	chars->functionResult->IsAssumedLengthCharacter() &&
3623	!specificIntrinsic && !procIsDummy) {
3624	Say(callSite,
3625	"Assumed-length character function must be defined with a length to be called"_err_en_US);
3626	}
3627	ok &= semantics::CheckArguments(*chars, arguments, context_,
3628	context_.FindScope(callSite), treatExternalAsImplicit,
3629	/*ignoreImplicitVsExplicit=*/false, specificIntrinsic);
3630	}
3631	if (procSymbol && !IsPureProcedure(*procSymbol)) {
3632	if (const semantics::Scope *
3633	pure{semantics::FindPureProcedureContaining(
3634	context_.FindScope(callSite))}) {
3635	Say(callSite,
3636	"Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US,
3637	procSymbol->name(), DEREF(pure->symbol()).name());
3638	}
3639	}
3640	if (ok && !treatExternalAsImplicit && procSymbol &&
3641	!(chars && chars->HasExplicitInterface())) {
3642	if (const Symbol *global{FindGlobal(*procSymbol)};
3643	global && global != procSymbol && IsProcedure(*global)) {
3644	// Check a known global definition behind a local interface
3645	if (auto globalChars{characteristics::Procedure::Characterize(
3646	*global, context_.foldingContext())}) {
3647	semantics::CheckArguments(*globalChars, arguments, context_,
3648	context_.FindScope(callSite), /*treatExternalAsImplicit=*/true,
3649	/*ignoreImplicitVsExplicit=*/false,
3650	nullptr /*not specific intrinsic*/);
3651	}
3652	}
3653	}
3654	return chars;
3655	}
3656
3657	// Unary operations
3658
3659	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
3660	if (MaybeExpr operand{Analyze(x.v.value())}) {
3661	if (const semantics::Symbol *symbol{GetLastSymbol(*operand)}) {
3662	if (const semantics::Symbol *result{FindFunctionResult(*symbol)}) {
3663	if (semantics::IsProcedurePointer(*result)) {
3664	Say("A function reference that returns a procedure "
3665	"pointer may not be parenthesized"_err_en_US); // C1003
3666	}
3667	}
3668	}
3669	return Parenthesize(std::move(*operand));
3670	}
3671	return std::nullopt;
3672	}
3673
3674	static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
3675	NumericOperator opr, const parser::Expr::IntrinsicUnary &x) {
3676	ArgumentAnalyzer analyzer{context};
3677	analyzer.Analyze(x: x.v);
3678	if (!analyzer.fatalErrors()) {
3679	if (analyzer.IsIntrinsicNumeric(opr)) {
3680	analyzer.CheckForNullPointer();
3681	analyzer.CheckForAssumedRank();
3682	if (opr == NumericOperator::Add) {
3683	return analyzer.MoveExpr(0);
3684	} else {
3685	return Negation(context.GetContextualMessages(), analyzer.MoveExpr(0));
3686	}
3687	} else {
3688	return analyzer.TryDefinedOp(AsFortran(opr),
3689	"Operand of unary %s must be numeric; have %s"_err_en_US);
3690	}
3691	}
3692	return std::nullopt;
3693	}
3694
3695	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
3696	return NumericUnaryHelper(*this, NumericOperator::Add, x);
3697	}
3698
3699	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Negate &x) {
3700	if (const auto *litConst{
3701	std::get_if<parser::LiteralConstant>(&x.v.value().u)}) {
3702	if (const auto *intConst{
3703	std::get_if<parser::IntLiteralConstant>(&litConst->u)}) {
3704	return Analyze(*intConst, true);
3705	}
3706	}
3707	return NumericUnaryHelper(*this, NumericOperator::Subtract, x);
3708	}
3709
3710	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
3711	ArgumentAnalyzer analyzer{*this};
3712	analyzer.Analyze(x.v);
3713	if (!analyzer.fatalErrors()) {
3714	if (analyzer.IsIntrinsicLogical()) {
3715	analyzer.CheckForNullPointer();
3716	analyzer.CheckForAssumedRank();
3717	return AsGenericExpr(
3718	LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));
3719	} else {
3720	return analyzer.TryDefinedOp(LogicalOperator::Not,
3721	"Operand of %s must be LOGICAL; have %s"_err_en_US);
3722	}
3723	}
3724	return std::nullopt;
3725	}
3726
3727	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
3728	// Represent %LOC() exactly as if it had been a call to the LOC() extension
3729	// intrinsic function.
3730	// Use the actual source for the name of the call for error reporting.
3731	std::optional<ActualArgument> arg;
3732	if (const Symbol *assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
3733	arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
3734	} else if (MaybeExpr argExpr{Analyze(x.v.value())}) {
3735	arg = ActualArgument{std::move(*argExpr)};
3736	} else {
3737	return std::nullopt;
3738	}
3739	parser::CharBlock at{GetContextualMessages().at()};
3740	CHECK(at.size() >= 4);
3741	parser::CharBlock loc{at.begin() + 1, 3};
3742	CHECK(loc == "loc");
3743	return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
3744	}
3745
3746	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
3747	const auto &name{std::get<parser::DefinedOpName>(x.t).v};
3748	ArgumentAnalyzer analyzer{*this, name.source};
3749	analyzer.Analyze(std::get<1>(x.t));
3750	return analyzer.TryDefinedOp(name.source.ToString().c_str(),
3751	"No operator %s defined for %s"_err_en_US, true);
3752	}
3753
3754	// Binary (dyadic) operations
3755
3756	template <template <typename> class OPR, NumericOperator opr>
3757	MaybeExpr NumericBinaryHelper(
3758	ExpressionAnalyzer &context, const parser::Expr::IntrinsicBinary &x) {
3759	ArgumentAnalyzer analyzer{context};
3760	analyzer.Analyze(x: std::get<0>(x.t));
3761	analyzer.Analyze(x: std::get<1>(x.t));
3762	if (!analyzer.fatalErrors()) {
3763	if (analyzer.IsIntrinsicNumeric(opr)) {
3764	analyzer.CheckForNullPointer();
3765	analyzer.CheckForAssumedRank();
3766	analyzer.CheckConformance();
3767	constexpr bool canBeUnsigned{opr != NumericOperator::Power};
3768	return NumericOperation<OPR, canBeUnsigned>(
3769	context.GetContextualMessages(), analyzer.MoveExpr(0),
3770	analyzer.MoveExpr(1), context.GetDefaultKind(TypeCategory::Real));
3771	} else {
3772	return analyzer.TryDefinedOp(AsFortran(opr),
3773	"Operands of %s must be numeric; have %s and %s"_err_en_US);
3774	}
3775	}
3776	return std::nullopt;
3777	}
3778
3779	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Power &x) {
3780	return NumericBinaryHelper<Power, NumericOperator::Power>(*this, x);
3781	}
3782
3783	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Multiply &x) {
3784	return NumericBinaryHelper<Multiply, NumericOperator::Multiply>(*this, x);
3785	}
3786
3787	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Divide &x) {
3788	return NumericBinaryHelper<Divide, NumericOperator::Divide>(*this, x);
3789	}
3790
3791	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Add &x) {
3792	return NumericBinaryHelper<Add, NumericOperator::Add>(*this, x);
3793	}
3794
3795	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {
3796	return NumericBinaryHelper<Subtract, NumericOperator::Subtract>(*this, x);
3797	}
3798
3799	MaybeExpr ExpressionAnalyzer::Analyze(
3800	const parser::Expr::ComplexConstructor &z) {
3801	Warn(common::LanguageFeature::ComplexConstructor,
3802	"nonstandard usage: generalized COMPLEX constructor"_port_en_US);
3803	return AnalyzeComplex(Analyze(std::get<0>(z.t).value()),
3804	Analyze(std::get<1>(z.t).value()), "complex constructor");
3805	}
3806
3807	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
3808	ArgumentAnalyzer analyzer{*this};
3809	analyzer.Analyze(std::get<0>(x.t));
3810	analyzer.Analyze(std::get<1>(x.t));
3811	if (!analyzer.fatalErrors()) {
3812	if (analyzer.IsIntrinsicConcat()) {
3813	analyzer.CheckForNullPointer();
3814	analyzer.CheckForAssumedRank();
3815	return common::visit(
3816	[&](auto &&x, auto &&y) -> MaybeExpr {
3817	using T = ResultType<decltype(x)>;
3818	if constexpr (std::is_same_v<T, ResultType<decltype(y)>>) {
3819	return AsGenericExpr(Concat<T::kind>{std::move(x), std::move(y)});
3820	} else {
3821	DIE("different types for intrinsic concat");
3822	}
3823	},
3824	std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(0).u).u),
3825	std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(1).u).u));
3826	} else {
3827	return analyzer.TryDefinedOp("//",
3828	"Operands of %s must be CHARACTER with the same kind; have %s and %s"_err_en_US);
3829	}
3830	}
3831	return std::nullopt;
3832	}
3833
3834	// The Name represents a user-defined intrinsic operator.
3835	// If the actuals match one of the specific procedures, return a function ref.
3836	// Otherwise report the error in messages.
3837	MaybeExpr ExpressionAnalyzer::AnalyzeDefinedOp(const parser::Name &name,
3838	ActualArguments &&actuals, const Symbol *&symbol) {
3839	if (auto callee{GetCalleeAndArguments(name, std::move(actuals))}) {
3840	auto &proc{std::get<evaluate::ProcedureDesignator>(callee->u)};
3841	symbol = proc.GetSymbol();
3842	return MakeFunctionRef(
3843	name.source, std::move(proc), std::move(callee->arguments));
3844	} else {
3845	return std::nullopt;
3846	}
3847	}
3848
3849	MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
3850	const parser::Expr::IntrinsicBinary &x) {
3851	ArgumentAnalyzer analyzer{context};
3852	analyzer.Analyze(x: std::get<0>(x.t));
3853	analyzer.Analyze(x: std::get<1>(x.t));
3854	if (!analyzer.fatalErrors()) {
3855	std::optional<DynamicType> leftType{analyzer.GetType(0)};
3856	std::optional<DynamicType> rightType{analyzer.GetType(1)};
3857	analyzer.ConvertBOZOperand(&leftType, 0, rightType);
3858	analyzer.ConvertBOZOperand(&rightType, 1, leftType);
3859	if (leftType && rightType &&
3860	analyzer.IsIntrinsicRelational(opr, *leftType, *rightType)) {
3861	analyzer.CheckForNullPointer(where: "as a relational operand");
3862	analyzer.CheckForAssumedRank(where: "as a relational operand");
3863	if (auto cmp{Relate(context.GetContextualMessages(), opr,
3864	analyzer.MoveExpr(0), analyzer.MoveExpr(1))}) {
3865	return AsMaybeExpr(ConvertToKind<TypeCategory::Logical>(
3866	context.GetDefaultKind(TypeCategory::Logical),
3867	AsExpr(std::move(*cmp))));
3868	}
3869	} else {
3870	return analyzer.TryDefinedOp(opr,
3871	leftType && leftType->category() == TypeCategory::Logical &&
3872	rightType && rightType->category() == TypeCategory::Logical
3873	? "LOGICAL operands must be compared using .EQV. or .NEQV."_err_en_US
3874	: "Operands of %s must have comparable types; have %s and %s"_err_en_US);
3875	}
3876	}
3877	return std::nullopt;
3878	}
3879
3880	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LT &x) {
3881	return RelationHelper(*this, RelationalOperator::LT, x);
3882	}
3883
3884	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LE &x) {
3885	return RelationHelper(*this, RelationalOperator::LE, x);
3886	}
3887
3888	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQ &x) {
3889	return RelationHelper(*this, RelationalOperator::EQ, x);
3890	}
3891
3892	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NE &x) {
3893	return RelationHelper(*this, RelationalOperator::NE, x);
3894	}
3895
3896	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GE &x) {
3897	return RelationHelper(*this, RelationalOperator::GE, x);
3898	}
3899
3900	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GT &x) {
3901	return RelationHelper(*this, RelationalOperator::GT, x);
3902	}
3903
3904	MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,
3905	const parser::Expr::IntrinsicBinary &x) {
3906	ArgumentAnalyzer analyzer{context};
3907	analyzer.Analyze(x: std::get<0>(x.t));
3908	analyzer.Analyze(x: std::get<1>(x.t));
3909	if (!analyzer.fatalErrors()) {
3910	if (analyzer.IsIntrinsicLogical()) {
3911	analyzer.CheckForNullPointer(where: "as a logical operand");
3912	analyzer.CheckForAssumedRank(where: "as a logical operand");
3913	return AsGenericExpr(BinaryLogicalOperation(opr,
3914	std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),
3915	std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));
3916	} else {
3917	return analyzer.TryDefinedOp(
3918	opr, "Operands of %s must be LOGICAL; have %s and %s"_err_en_US);
3919	}
3920	}
3921	return std::nullopt;
3922	}
3923
3924	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::AND &x) {
3925	return LogicalBinaryHelper(*this, LogicalOperator::And, x);
3926	}
3927
3928	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::OR &x) {
3929	return LogicalBinaryHelper(*this, LogicalOperator::Or, x);
3930	}
3931
3932	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQV &x) {
3933	return LogicalBinaryHelper(*this, LogicalOperator::Eqv, x);
3934	}
3935
3936	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NEQV &x) {
3937	return LogicalBinaryHelper(*this, LogicalOperator::Neqv, x);
3938	}
3939
3940	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
3941	const auto &name{std::get<parser::DefinedOpName>(x.t).v};
3942	ArgumentAnalyzer analyzer{*this, name.source};
3943	analyzer.Analyze(std::get<1>(x.t));
3944	analyzer.Analyze(std::get<2>(x.t));
3945	return analyzer.TryDefinedOp(name.source.ToString().c_str(),
3946	"No operator %s defined for %s and %s"_err_en_US, true);
3947	}
3948
3949	// Returns true if a parsed function reference should be converted
3950	// into an array element reference.
3951	static bool CheckFuncRefToArrayElement(semantics::SemanticsContext &context,
3952	const parser::FunctionReference &funcRef) {
3953	// Emit message if the function reference fix will end up an array element
3954	// reference with no subscripts, or subscripts on a scalar, because it will
3955	// not be possible to later distinguish in expressions between an empty
3956	// subscript list due to bad subscripts error recovery or because the
3957	// user did not put any.
3958	auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
3959	const auto *name{std::get_if<parser::Name>(&proc.u)};
3960	if (!name) {
3961	name = &std::get<parser::ProcComponentRef>(proc.u).v.thing.component;
3962	}
3963	if (!name->symbol) {
3964	return false;
3965	} else if (name->symbol->Rank() == 0) {
3966	if (const Symbol *function{
3967	semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)}) {
3968	auto &msg{context.Say(funcRef.source,
3969	function->flags().test(Symbol::Flag::StmtFunction)
3970	? "Recursive call to statement function '%s' is not allowed"_err_en_US
3971	: "Recursive call to '%s' requires a distinct RESULT in its declaration"_err_en_US,
3972	name->source)};
3973	AttachDeclaration(&msg, *function);
3974	name->symbol = const_cast<Symbol *>(function);
3975	}
3976	return false;
3977	} else {
3978	if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {
3979	auto &msg{context.Say(funcRef.source,
3980	"Reference to array '%s' with empty subscript list"_err_en_US,
3981	name->source)};
3982	if (name->symbol) {
3983	AttachDeclaration(&msg, *name->symbol);
3984	}
3985	}
3986	return true;
3987	}
3988	}
3989
3990	// Converts, if appropriate, an original misparse of ambiguous syntax like
3991	// A(1) as a function reference into an array reference.
3992	// Misparsed structure constructors are detected elsewhere after generic
3993	// function call resolution fails.
3994	template <typename... A>
3995	static void FixMisparsedFunctionReference(
3996	semantics::SemanticsContext &context, const std::variant<A...> &constU) {
3997	// The parse tree is updated in situ when resolving an ambiguous parse.
3998	using uType = std::decay_t<decltype(constU)>;
3999	auto &u{const_cast<uType &>(constU)};
4000	if (auto *func{
4001	std::get_if<common::Indirection<parser::FunctionReference>>(&u)}) {
4002	parser::FunctionReference &funcRef{func->value()};
4003	// Ensure that there are no argument keywords
4004	for (const auto &arg :
4005	std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t)) {
4006	if (std::get<std::optional<parser::Keyword>>(arg.t)) {
4007	return;
4008	}
4009	}
4010	auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
4011	if (Symbol *origSymbol{
4012	common::visit(common::visitors{
4013	[&](parser::Name &name) { return name.symbol; },
4014	[&](parser::ProcComponentRef &pcr) {
4015	return pcr.v.thing.component.symbol;
4016	},
4017	},
4018	proc.u)}) {
4019	Symbol &symbol{origSymbol->GetUltimate()};
4020	if (symbol.has<semantics::ObjectEntityDetails>() ||
4021	symbol.has<semantics::AssocEntityDetails>()) {
4022	// Note that expression in AssocEntityDetails cannot be a procedure
4023	// pointer as per C1105 so this cannot be a function reference.
4024	if constexpr (common::HasMember<common::Indirection<parser::Designator>,
4025	uType>) {
4026	if (CheckFuncRefToArrayElement(context, funcRef)) {
4027	u = common::Indirection{funcRef.ConvertToArrayElementRef()};
4028	}
4029	} else {
4030	DIE("can't fix misparsed function as array reference");
4031	}
4032	}
4033	}
4034	}
4035	}
4036
4037	// Common handling of parse tree node types that retain the
4038	// representation of the analyzed expression.
4039	template <typename PARSED>
4040	MaybeExpr ExpressionAnalyzer::ExprOrVariable(
4041	const PARSED &x, parser::CharBlock source) {
4042	auto restorer{GetContextualMessages().SetLocation(source)};
4043	if constexpr (std::is_same_v<PARSED, parser::Expr> ||
4044	std::is_same_v<PARSED, parser::Variable>) {
4045	FixMisparsedFunctionReference(context_, x.u);
4046	}
4047	if (AssumedTypeDummy(x)) { // C710
4048	Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
4049	ResetExpr(x);
4050	return std::nullopt;
4051	}
4052	MaybeExpr result;
4053	if constexpr (common::HasMember<parser::StructureConstructor,
4054	std::decay_t<decltype(x.u)>> &&
4055	common::HasMember<common::Indirection<parser::FunctionReference>,
4056	std::decay_t<decltype(x.u)>>) {
4057	if (const auto *funcRef{
4058	std::get_if<common::Indirection<parser::FunctionReference>>(
4059	&x.u)}) {
4060	// Function references in Exprs might turn out to be misparsed structure
4061	// constructors; we have to try generic procedure resolution
4062	// first to be sure.
4063	std::optional<parser::StructureConstructor> ctor;
4064	result = Analyze(funcRef->value(), &ctor);
4065	if (ctor) {
4066	// A misparsed function reference is really a structure
4067	// constructor. Repair the parse tree in situ.
4068	const_cast<PARSED &>(x).u = std::move(*ctor);
4069	}
4070	} else {
4071	result = Analyze(x.u);
4072	}
4073	} else {
4074	result = Analyze(x.u);
4075	}
4076	if (result) {
4077	if constexpr (std::is_same_v<PARSED, parser::Expr>) {
4078	if (!isNullPointerOk_ && IsNullPointerOrAllocatable(&*result)) {
4079	Say(source,
4080	"NULL() may not be used as an expression in this context"_err_en_US);
4081	}
4082	}
4083	SetExpr(x, Fold(std::move(*result)));
4084	return x.typedExpr->v;
4085	} else {
4086	ResetExpr(x);
4087	if (!context_.AnyFatalError()) {
4088	std::string buf;
4089	llvm::raw_string_ostream dump{buf};
4090	parser::DumpTree(dump, x);
4091	Say("Internal error: Expression analysis failed on: %s"_err_en_US, buf);
4092	}
4093	return std::nullopt;
4094	}
4095	}
4096
4097	// This is an optional preliminary pass over parser::Expr subtrees.
4098	// Given an expression tree, iteratively traverse it in a bottom-up order
4099	// to analyze all of its subexpressions. A later normal top-down analysis
4100	// will then be able to use the results that will have been saved in the
4101	// parse tree without having to recurse deeply. This technique keeps
4102	// absurdly deep expression parse trees from causing the analyzer to overflow
4103	// its stack.
4104	MaybeExpr ExpressionAnalyzer::IterativelyAnalyzeSubexpressions(
4105	const parser::Expr &top) {
4106	std::vector<const parser::Expr *> queue, finish;
4107	queue.push_back(&top);
4108	do {
4109	const parser::Expr &expr{*queue.back()};
4110	queue.pop_back();
4111	if (!expr.typedExpr) {
4112	const parser::Expr::IntrinsicUnary *unary{nullptr};
4113	const parser::Expr::IntrinsicBinary *binary{nullptr};
4114	common::visit(
4115	[&unary, &binary](auto &y) {
4116	if constexpr (std::is_convertible_v<decltype(&y),
4117	decltype(unary)>) {
4118	// Don't evaluate a constant operand to Negate
4119	if (!std::holds_alternative<parser::LiteralConstant>(
4120	y.v.value().u)) {
4121	unary = &y;
4122	}
4123	} else if constexpr (std::is_convertible_v<decltype(&y),
4124	decltype(binary)>) {
4125	binary = &y;
4126	}
4127	},
4128	expr.u);
4129	if (unary) {
4130	queue.push_back(&unary->v.value());
4131	} else if (binary) {
4132	queue.push_back(&std::get<0>(binary->t).value());
4133	queue.push_back(&std::get<1>(binary->t).value());
4134	}
4135	finish.push_back(&expr);
4136	}
4137	} while (!queue.empty());
4138	// Analyze the collected subexpressions in bottom-up order.
4139	// On an error, bail out and leave partial results in place.
4140	MaybeExpr result;
4141	for (auto riter{finish.rbegin()}; riter != finish.rend(); ++riter) {
4142	const parser::Expr &expr{**riter};
4143	result = ExprOrVariable(expr, expr.source);
4144	if (!result) {
4145	return result;
4146	}
4147	}
4148	return result; // last value was from analysis of "top"
4149	}
4150
4151	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {
4152	bool wasIterativelyAnalyzing{iterativelyAnalyzingSubexpressions_};
4153	MaybeExpr result;
4154	if (useSavedTypedExprs_) {
4155	if (expr.typedExpr) {
4156	return expr.typedExpr->v;
4157	}
4158	if (!wasIterativelyAnalyzing) {
4159	iterativelyAnalyzingSubexpressions_ = true;
4160	result = IterativelyAnalyzeSubexpressions(expr);
4161	}
4162	}
4163	if (!result) {
4164	result = ExprOrVariable(expr, expr.source);
4165	}
4166	iterativelyAnalyzingSubexpressions_ = wasIterativelyAnalyzing;
4167	return result;
4168	}
4169
4170	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Variable &variable) {
4171	if (useSavedTypedExprs_ && variable.typedExpr) {
4172	return variable.typedExpr->v;
4173	}
4174	return ExprOrVariable(variable, variable.GetSource());
4175	}
4176
4177	MaybeExpr ExpressionAnalyzer::Analyze(const parser::Selector &selector) {
4178	if (const auto *var{std::get_if<parser::Variable>(&selector.u)}) {
4179	if (!useSavedTypedExprs_ || !var->typedExpr) {
4180	parser::CharBlock source{var->GetSource()};
4181	auto restorer{GetContextualMessages().SetLocation(source)};
4182	FixMisparsedFunctionReference(context_, var->u);
4183	if (const auto *funcRef{
4184	std::get_if<common::Indirection<parser::FunctionReference>>(
4185	&var->u)}) {
4186	// A Selector that parsed as a Variable might turn out during analysis
4187	// to actually be a structure constructor. In that case, repair the
4188	// Variable parse tree node into an Expr
4189	std::optional<parser::StructureConstructor> ctor;
4190	if (MaybeExpr result{Analyze(funcRef->value(), &ctor)}) {
4191	if (ctor) {
4192	auto &writable{const_cast<parser::Selector &>(selector)};
4193	writable.u = parser::Expr{std::move(*ctor)};
4194	auto &expr{std::get<parser::Expr>(writable.u)};
4195	expr.source = source;
4196	SetExpr(expr, Fold(std::move(*result)));
4197	return expr.typedExpr->v;
4198	} else {
4199	SetExpr(*var, Fold(std::move(*result)));
4200	return var->typedExpr->v;
4201	}
4202	} else {
4203	ResetExpr(*var);
4204	if (context_.AnyFatalError()) {
4205	return std::nullopt;
4206	}
4207	}
4208	}
4209	}
4210	// Not a Variable -> FunctionReference
4211	auto restorer{AllowWholeAssumedSizeArray()};
4212	return Analyze(selector.u);
4213	} else { // Expr
4214	return Analyze(selector.u);
4215	}
4216	}
4217
4218	MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtConstant &x) {
4219	auto restorer{common::ScopedSet(inDataStmtConstant_, true)};
4220	return ExprOrVariable(x, x.source);
4221	}
4222
4223	MaybeExpr ExpressionAnalyzer::Analyze(const parser::AllocateObject &x) {
4224	return ExprOrVariable(x, parser::FindSourceLocation(x));
4225	}
4226
4227	MaybeExpr ExpressionAnalyzer::Analyze(const parser::PointerObject &x) {
4228	return ExprOrVariable(x, parser::FindSourceLocation(x));
4229	}
4230
4231	Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
4232	TypeCategory category,
4233	const std::optional<parser::KindSelector> &selector) {
4234	int defaultKind{GetDefaultKind(category)};
4235	if (!selector) {
4236	return Expr<SubscriptInteger>{defaultKind};
4237	}
4238	return common::visit(
4239	common::visitors{
4240	[&](const parser::ScalarIntConstantExpr &x) {
4241	if (MaybeExpr kind{Analyze(x)}) {
4242	if (std::optional<std::int64_t> code{ToInt64(*kind)}) {
4243	if (CheckIntrinsicKind(category, *code)) {
4244	return Expr<SubscriptInteger>{*code};
4245	}
4246	} else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(*kind)}) {
4247	return ConvertToType<SubscriptInteger>(std::move(*intExpr));
4248	}
4249	}
4250	return Expr<SubscriptInteger>{defaultKind};
4251	},
4252	[&](const parser::KindSelector::StarSize &x) {
4253	std::intmax_t size = x.v;
4254	if (!CheckIntrinsicSize(category, size)) {
4255	size = defaultKind;
4256	} else if (category == TypeCategory::Complex) {
4257	size /= 2;
4258	}
4259	return Expr<SubscriptInteger>{size};
4260	},
4261	},
4262	selector->u);
4263	}
4264
4265	int ExpressionAnalyzer::GetDefaultKind(common::TypeCategory category) {
4266	return context_.GetDefaultKind(category);
4267	}
4268
4269	DynamicType ExpressionAnalyzer::GetDefaultKindOfType(
4270	common::TypeCategory category) {
4271	return {category, GetDefaultKind(category)};
4272	}
4273
4274	bool ExpressionAnalyzer::CheckIntrinsicKind(
4275	TypeCategory category, std::int64_t kind) {
4276	if (foldingContext_.targetCharacteristics().IsTypeEnabled(
4277	category, kind)) { // C712, C714, C715, C727
4278	return true;
4279	} else if (foldingContext_.targetCharacteristics().CanSupportType(
4280	category, kind)) {
4281	Say("%s(KIND=%jd) is not an enabled type for this target"_err_en_US,
4282	ToUpperCase(EnumToString(category)), kind);
4283	return true;
4284	} else {
4285	Say("%s(KIND=%jd) is not a supported type"_err_en_US,
4286	ToUpperCase(EnumToString(category)), kind);
4287	return false;
4288	}
4289	}
4290
4291	bool ExpressionAnalyzer::CheckIntrinsicSize(
4292	TypeCategory category, std::int64_t size) {
4293	std::int64_t kind{size};
4294	if (category == TypeCategory::Complex) {
4295	// COMPLEX*16 == COMPLEX(KIND=8)
4296	if (size % 2 == 0) {
4297	kind = size / 2;
4298	} else {
4299	Say("COMPLEX*%jd is not a supported type"_err_en_US, size);
4300	return false;
4301	}
4302	}
4303	return CheckIntrinsicKind(category, kind);
4304	}
4305
4306	bool ExpressionAnalyzer::AddImpliedDo(parser::CharBlock name, int kind) {
4307	return impliedDos_.insert(std::make_pair(name, kind)).second;
4308	}
4309
4310	void ExpressionAnalyzer::RemoveImpliedDo(parser::CharBlock name) {
4311	auto iter{impliedDos_.find(name)};
4312	if (iter != impliedDos_.end()) {
4313	impliedDos_.erase(iter);
4314	}
4315	}
4316
4317	std::optional<int> ExpressionAnalyzer::IsImpliedDo(
4318	parser::CharBlock name) const {
4319	auto iter{impliedDos_.find(name)};
4320	if (iter != impliedDos_.cend()) {
4321	return {iter->second};
4322	} else {
4323	return std::nullopt;
4324	}
4325	}
4326
4327	bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
4328	const MaybeExpr &result, TypeCategory category, bool defaultKind) {
4329	if (result) {
4330	if (auto type{result->GetType()}) {
4331	if (type->category() != category) { // C885
4332	Say(at, "Must have %s type, but is %s"_err_en_US,
4333	ToUpperCase(EnumToString(category)),
4334	ToUpperCase(type->AsFortran()));
4335	return false;
4336	} else if (defaultKind) {
4337	int kind{context_.GetDefaultKind(category)};
4338	if (type->kind() != kind) {
4339	Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,
4340	kind, ToUpperCase(EnumToString(category)),
4341	ToUpperCase(type->AsFortran()));
4342	return false;
4343	}
4344	}
4345	} else {
4346	Say(at, "Must have %s type, but is typeless"_err_en_US,
4347	ToUpperCase(EnumToString(category)));
4348	return false;
4349	}
4350	}
4351	return true;
4352	}
4353
4354	MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,
4355	ProcedureDesignator &&proc, ActualArguments &&arguments) {
4356	if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc.u)}) {
4357	if (intrinsic->characteristics.value().attrs.test(
4358	characteristics::Procedure::Attr::NullPointer) &&
4359	arguments.empty()) {
4360	return Expr<SomeType>{NullPointer{}};
4361	}
4362	}
4363	if (const Symbol *symbol{proc.GetSymbol()}) {
4364	if (!ResolveForward(*symbol)) {
4365	return std::nullopt;
4366	}
4367	}
4368	if (auto chars{CheckCall(callSite, proc, arguments)}) {
4369	if (chars->functionResult) {
4370	const auto &result{*chars->functionResult};
4371	ProcedureRef procRef{std::move(proc), std::move(arguments)};
4372	if (result.IsProcedurePointer()) {
4373	return Expr<SomeType>{std::move(procRef)};
4374	} else {
4375	// Not a procedure pointer, so type and shape are known.
4376	return TypedWrapper<FunctionRef, ProcedureRef>(
4377	DEREF(result.GetTypeAndShape()).type(), std::move(procRef));
4378	}
4379	} else {
4380	Say("Function result characteristics are not known"_err_en_US);
4381	}
4382	}
4383	return std::nullopt;
4384	}
4385
4386	MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
4387	parser::CharBlock intrinsic, ActualArguments &&arguments) {
4388	if (std::optional<SpecificCall> specificCall{
4389	context_.intrinsics().Probe(CallCharacteristics{intrinsic.ToString()},
4390	arguments, GetFoldingContext())}) {
4391	return MakeFunctionRef(intrinsic,
4392	ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
4393	std::move(specificCall->arguments));
4394	} else {
4395	return std::nullopt;
4396	}
4397	}
4398
4399	MaybeExpr ExpressionAnalyzer::AnalyzeComplex(
4400	MaybeExpr &&re, MaybeExpr &&im, const char *what) {
4401	if (re && re->Rank() > 0) {
4402	Warn(common::LanguageFeature::ComplexConstructor,
4403	"Real part of %s is not scalar"_port_en_US, what);
4404	}
4405	if (im && im->Rank() > 0) {
4406	Warn(common::LanguageFeature::ComplexConstructor,
4407	"Imaginary part of %s is not scalar"_port_en_US, what);
4408	}
4409	if (re && im) {
4410	ConformabilityCheck(GetContextualMessages(), *re, *im);
4411	}
4412	return AsMaybeExpr(ConstructComplex(GetContextualMessages(), std::move(re),
4413	std::move(im), GetDefaultKind(TypeCategory::Real)));
4414	}
4415
4416	std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeVariable(
4417	const parser::Variable &x) {
4418	source_.ExtendToCover(x.GetSource());
4419	if (MaybeExpr expr{context_.Analyze(x)}) {
4420	if (!IsConstantExpr(*expr)) {
4421	ActualArgument actual{std::move(*expr)};
4422	SetArgSourceLocation(actual, x.GetSource());
4423	return actual;
4424	}
4425	const Symbol *symbol{GetLastSymbol(*expr)};
4426	if (!symbol) {
4427	context_.SayAt(x, "Assignment to constant '%s' is not allowed"_err_en_US,
4428	x.GetSource());
4429	} else if (IsProcedure(*symbol)) {
4430	if (auto *msg{context_.SayAt(x,
4431	"Assignment to procedure '%s' is not allowed"_err_en_US,
4432	symbol->name())}) {
4433	if (auto *subp{symbol->detailsIf<semantics::SubprogramDetails>()}) {
4434	if (subp->isFunction()) {
4435	const auto &result{subp->result().name()};
4436	msg->Attach(result, "Function result is '%s'"_en_US, result);
4437	}
4438	}
4439	}
4440	} else {
4441	context_.SayAt(
4442	x, "Assignment to '%s' is not allowed"_err_en_US, symbol->name());
4443	}
4444	}
4445	fatalErrors_ = true;
4446	return std::nullopt;
4447	}
4448
4449	void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
4450	if (auto actual = AnalyzeVariable(x)) {
4451	actuals_.emplace_back(std::move(actual));
4452	}
4453	}
4454
4455	void ArgumentAnalyzer::Analyze(
4456	const parser::ActualArgSpec &arg, bool isSubroutine) {
4457	// TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
4458	std::optional<ActualArgument> actual;
4459	auto restorer{context_.AllowWholeAssumedSizeArray()};
4460	common::visit(
4461	common::visitors{
4462	[&](const common::Indirection<parser::Expr> &x) {
4463	actual = AnalyzeExpr(x.value());
4464	},
4465	[&](const parser::AltReturnSpec &label) {
4466	if (!isSubroutine) {
4467	context_.Say(
4468	"alternate return specification may not appear on function reference"_err_en_US);
4469	}
4470	actual = ActualArgument(label.v);
4471	},
4472	[&](const parser::ActualArg::PercentRef &percentRef) {
4473	actual = AnalyzeExpr(percentRef.v);
4474	if (actual.has_value()) {
4475	actual->set_isPercentRef();
4476	}
4477	},
4478	[&](const parser::ActualArg::PercentVal &percentVal) {
4479	actual = AnalyzeExpr(percentVal.v);
4480	if (actual.has_value()) {
4481	actual->set_isPercentVal();
4482	}
4483	},
4484	},
4485	std::get<parser::ActualArg>(arg.t).u);
4486	if (actual) {
4487	if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {
4488	actual->set_keyword(argKW->v.source);
4489	}
4490	actuals_.emplace_back(std::move(*actual));
4491	} else {
4492	fatalErrors_ = true;
4493	}
4494	}
4495
4496	bool ArgumentAnalyzer::IsIntrinsicRelational(RelationalOperator opr,
4497	const DynamicType &leftType, const DynamicType &rightType) const {
4498	CHECK(actuals_.size() == 2);
4499	return semantics::IsIntrinsicRelational(
4500	opr, leftType, GetRank(0), rightType, GetRank(1));
4501	}
4502
4503	bool ArgumentAnalyzer::IsIntrinsicNumeric(NumericOperator opr) const {
4504	std::optional<DynamicType> leftType{GetType(0)};
4505	if (actuals_.size() == 1) {
4506	if (IsBOZLiteral(i: 0)) {
4507	return opr == NumericOperator::Add; // unary '+'
4508	} else {
4509	return leftType && semantics::IsIntrinsicNumeric(*leftType);
4510	}
4511	} else {
4512	std::optional<DynamicType> rightType{GetType(1)};
4513	if (IsBOZLiteral(i: 0) && rightType) { // BOZ opr Integer/Unsigned/Real
4514	auto cat1{rightType->category()};
4515	return cat1 == TypeCategory::Integer || cat1 == TypeCategory::Unsigned ||
4516	cat1 == TypeCategory::Real;
4517	} else if (IsBOZLiteral(i: 1) && leftType) { // Integer/Unsigned/Real opr BOZ
4518	auto cat0{leftType->category()};
4519	return cat0 == TypeCategory::Integer || cat0 == TypeCategory::Unsigned ||
4520	cat0 == TypeCategory::Real;
4521	} else {
4522	return leftType && rightType &&
4523	semantics::IsIntrinsicNumeric(
4524	*leftType, GetRank(0), *rightType, GetRank(1));
4525	}
4526	}
4527	}
4528
4529	bool ArgumentAnalyzer::IsIntrinsicLogical() const {
4530	if (std::optional<DynamicType> leftType{GetType(0)}) {
4531	if (actuals_.size() == 1) {
4532	return semantics::IsIntrinsicLogical(*leftType);
4533	} else if (std::optional<DynamicType> rightType{GetType(1)}) {
4534	return semantics::IsIntrinsicLogical(
4535	*leftType, GetRank(0), *rightType, GetRank(1));
4536	}
4537	}
4538	return false;
4539	}
4540
4541	bool ArgumentAnalyzer::IsIntrinsicConcat() const {
4542	if (std::optional<DynamicType> leftType{GetType(0)}) {
4543	if (std::optional<DynamicType> rightType{GetType(1)}) {
4544	return semantics::IsIntrinsicConcat(
4545	*leftType, GetRank(0), *rightType, GetRank(1));
4546	}
4547	}
4548	return false;
4549	}
4550
4551	bool ArgumentAnalyzer::CheckConformance() {
4552	if (actuals_.size() == 2) {
4553	const auto *lhs{actuals_.at(0).value().UnwrapExpr()};
4554	const auto *rhs{actuals_.at(1).value().UnwrapExpr()};
4555	if (lhs && rhs) {
4556	auto &foldingContext{context_.GetFoldingContext()};
4557	auto lhShape{GetShape(foldingContext, *lhs)};
4558	auto rhShape{GetShape(foldingContext, *rhs)};
4559	if (lhShape && rhShape) {
4560	if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,
4561	*rhShape, CheckConformanceFlags::EitherScalarExpandable,
4562	"left operand", "right operand")
4563	.value_or(false /*fail when conformance is not known now*/)) {
4564	fatalErrors_ = true;
4565	return false;
4566	}
4567	}
4568	}
4569	}
4570	return true; // no proven problem
4571	}
4572
4573	bool ArgumentAnalyzer::CheckAssignmentConformance() {
4574	if (actuals_.size() == 2 && actuals_[0] && actuals_[1]) {
4575	const auto *lhs{actuals_[0]->UnwrapExpr()};
4576	const auto *rhs{actuals_[1]->UnwrapExpr()};
4577	if (lhs && rhs) {
4578	auto &foldingContext{context_.GetFoldingContext()};
4579	auto lhShape{GetShape(foldingContext, *lhs)};
4580	auto rhShape{GetShape(foldingContext, *rhs)};
4581	if (lhShape && rhShape) {
4582	if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,
4583	*rhShape, CheckConformanceFlags::RightScalarExpandable,
4584	"left-hand side", "right-hand side")
4585	.value_or(true /*ok when conformance is not known now*/)) {
4586	fatalErrors_ = true;
4587	return false;
4588	}
4589	}
4590	}
4591	}
4592	return true; // no proven problem
4593	}
4594
4595	bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
4596	for (const std::optional<ActualArgument> &arg : actuals_) {
4597	if (arg && IsNullPointerOrAllocatable(arg->UnwrapExpr())) {
4598	context_.Say(
4599	source_, "A NULL() pointer is not allowed %s"_err_en_US, where);
4600	fatalErrors_ = true;
4601	return false;
4602	}
4603	}
4604	return true;
4605	}
4606
4607	bool ArgumentAnalyzer::CheckForAssumedRank(const char *where) {
4608	for (const std::optional<ActualArgument> &arg : actuals_) {
4609	if (arg && IsAssumedRank(arg->UnwrapExpr())) {
4610	context_.Say(source_,
4611	"An assumed-rank dummy argument is not allowed %s"_err_en_US, where);
4612	fatalErrors_ = true;
4613	return false;
4614	}
4615	}
4616	return true;
4617	}
4618
4619	MaybeExpr ArgumentAnalyzer::TryDefinedOp(
4620	const char *opr, parser::MessageFixedText error, bool isUserOp) {
4621	if (AnyUntypedOrMissingOperand()) {
4622	context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
4623	return std::nullopt;
4624	}
4625	MaybeExpr result;
4626	bool anyPossibilities{false};
4627	std::optional<parser::MessageFormattedText> inaccessible;
4628	std::vector<const Symbol *> hit;
4629	std::string oprNameString{
4630	isUserOp ? std::string{opr} : "operator("s + opr + ')'};
4631	parser::CharBlock oprName{oprNameString};
4632	parser::Messages hitBuffer;
4633	{
4634	parser::Messages buffer;
4635	auto restorer{context_.GetContextualMessages().SetMessages(buffer)};
4636	const auto &scope{context_.context().FindScope(source_)};
4637
4638	auto FoundOne{[&](MaybeExpr &&thisResult, const Symbol &generic,
4639	const Symbol *resolution) {
4640	anyPossibilities = true;
4641	if (thisResult) {
4642	if (auto thisInaccessible{CheckAccessibleSymbol(scope, generic)}) {
4643	inaccessible = thisInaccessible;
4644	} else {
4645	bool isElemental{IsElementalProcedure(DEREF(resolution))};
4646	bool hitsAreNonElemental{
4647	!hit.empty() && !IsElementalProcedure(DEREF(hit[0]))};
4648	if (isElemental && hitsAreNonElemental) {
4649	// ignore elemental resolutions in favor of a non-elemental one
4650	} else {
4651	if (!isElemental && !hitsAreNonElemental) {
4652	hit.clear();
4653	}
4654	result = std::move(thisResult);
4655	hit.push_back(resolution);
4656	hitBuffer = std::move(buffer);
4657	}
4658	}
4659	}
4660	}};
4661
4662	if (Symbol * generic{scope.FindSymbol(oprName)}; generic && !fatalErrors_) {
4663	parser::Name name{generic->name(), generic};
4664	const Symbol *resultSymbol{nullptr};
4665	MaybeExpr possibleResult{context_.AnalyzeDefinedOp(
4666	name, ActualArguments{actuals_}, resultSymbol)};
4667	FoundOne(std::move(possibleResult), *generic, resultSymbol);
4668	}
4669	for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
4670	buffer.clear();
4671	const Symbol *generic{nullptr};
4672	if (const Symbol *
4673	binding{FindBoundOp(
4674	oprName, passIndex, generic, /*isSubroutine=*/false)}) {
4675	FoundOne(TryBoundOp(*binding, passIndex), DEREF(generic), binding);
4676	}
4677	}
4678	}
4679	if (result) {
4680	if (hit.size() > 1) {
4681	if (auto *msg{context_.Say(
4682	"%zd matching accessible generic interfaces for %s were found"_err_en_US,
4683	hit.size(), ToUpperCase(opr))}) {
4684	for (const Symbol *symbol : hit) {
4685	AttachDeclaration(*msg, *symbol);
4686	}
4687	}
4688	}
4689	if (auto *msgs{context_.GetContextualMessages().messages()}) {
4690	msgs->Annex(std::move(hitBuffer));
4691	}
4692	} else if (inaccessible) {
4693	context_.Say(source_, std::move(*inaccessible));
4694	} else if (anyPossibilities) {
4695	SayNoMatch(ToUpperCase(str: oprNameString), isAssignment: false);
4696	} else if (actuals_.size() == 2 && !AreConformable()) {
4697	context_.Say(
4698	"Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,
4699	ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());
4700	} else if (CheckForNullPointer() && CheckForAssumedRank()) {
4701	context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
4702	}
4703	return result;
4704	}
4705
4706	MaybeExpr ArgumentAnalyzer::TryDefinedOp(
4707	const std::vector<const char *> &oprs, parser::MessageFixedText error) {
4708	if (oprs.size() == 1) {
4709	return TryDefinedOp(oprs[0], error);
4710	}
4711	MaybeExpr result;
4712	std::vector<const char *> hit;
4713	parser::Messages hitBuffer;
4714	{
4715	for (std::size_t i{0}; i < oprs.size(); ++i) {
4716	parser::Messages buffer;
4717	auto restorer{context_.GetContextualMessages().SetMessages(buffer)};
4718	if (MaybeExpr thisResult{TryDefinedOp(oprs[i], error)}) {
4719	result = std::move(thisResult);
4720	hit.push_back(x: oprs[i]);
4721	hitBuffer = std::move(buffer);
4722	}
4723	}
4724	}
4725	if (hit.empty()) { // for the error
4726	result = TryDefinedOp(oprs[0], error);
4727	} else if (hit.size() > 1) {
4728	context_.Say(
4729	"Matching accessible definitions were found with %zd variant spellings of the generic operator ('%s', '%s')"_err_en_US,
4730	hit.size(), ToUpperCase(hit[0]), ToUpperCase(hit[1]));
4731	} else { // one hit; preserve errors
4732	context_.context().messages().Annex(std::move(hitBuffer));
4733	}
4734	return result;
4735	}
4736
4737	MaybeExpr ArgumentAnalyzer::TryBoundOp(const Symbol &symbol, int passIndex) {
4738	ActualArguments localActuals{actuals_};
4739	const Symbol *proc{GetBindingResolution(GetType(passIndex), symbol)};
4740	if (!proc) {
4741	proc = &symbol;
4742	localActuals.at(passIndex).value().set_isPassedObject();
4743	}
4744	CheckConformance();
4745	return context_.MakeFunctionRef(
4746	source_, ProcedureDesignator{*proc}, std::move(localActuals));
4747	}
4748
4749	std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
4750	using semantics::Tristate;
4751	const Expr<SomeType> &lhs{GetExpr(0)};
4752	const Expr<SomeType> &rhs{GetExpr(1)};
4753	std::optional<DynamicType> lhsType{lhs.GetType()};
4754	std::optional<DynamicType> rhsType{rhs.GetType()};
4755	int lhsRank{lhs.Rank()};
4756	int rhsRank{rhs.Rank()};
4757	Tristate isDefined{
4758	semantics::IsDefinedAssignment(lhsType, lhsRank, rhsType, rhsRank)};
4759	if (isDefined == Tristate::No) {
4760	// Make implicit conversion explicit, unless it is an assignment to a whole
4761	// allocatable (the explicit conversion would prevent the propagation of the
4762	// right hand side if it is a variable). Lowering will deal with the
4763	// conversion in this case.
4764	if (lhsType) {
4765	if (rhsType) {
4766	if (!IsAllocatableDesignator(lhs) || context_.inWhereBody()) {
4767	AddAssignmentConversion(*lhsType, *rhsType);
4768	}
4769	} else if (IsBOZLiteral(i: 1)) {
4770	ConvertBOZAssignmentRHS(*lhsType);
4771	if (IsBOZLiteral(i: 1)) {
4772	context_.Say(
4773	"Right-hand side of this assignment may not be BOZ"_err_en_US);
4774	fatalErrors_ = true;
4775	}
4776	}
4777	}
4778	if (!fatalErrors_) {
4779	CheckAssignmentConformance();
4780	}
4781	return std::nullopt; // user-defined assignment not allowed for these args
4782	}
4783	auto restorer{context_.GetContextualMessages().SetLocation(source_)};
4784	if (std::optional<ProcedureRef> procRef{GetDefinedAssignmentProc()}) {
4785	if (context_.inWhereBody() && !procRef->proc().IsElemental()) { // C1032
4786	context_.Say(
4787	"Defined assignment in WHERE must be elemental, but '%s' is not"_err_en_US,
4788	DEREF(procRef->proc().GetSymbol()).name());
4789	}
4790	context_.CheckCall(source_, procRef->proc(), procRef->arguments());
4791	return std::move(*procRef);
4792	}
4793	if (isDefined == Tristate::Yes) {
4794	if (!lhsType || !rhsType || (lhsRank != rhsRank && rhsRank != 0) ||
4795	!OkLogicalIntegerAssignment(lhsType->category(), rhsType->category())) {
4796	SayNoMatch("ASSIGNMENT(=)", isAssignment: true);
4797	}
4798	} else if (!fatalErrors_) {
4799	CheckAssignmentConformance();
4800	}
4801	return std::nullopt;
4802	}
4803
4804	bool ArgumentAnalyzer::OkLogicalIntegerAssignment(
4805	TypeCategory lhs, TypeCategory rhs) {
4806	if (!context_.context().languageFeatures().IsEnabled(
4807	common::LanguageFeature::LogicalIntegerAssignment)) {
4808	return false;
4809	}
4810	std::optional<parser::MessageFixedText> msg;
4811	if (lhs == TypeCategory::Integer && rhs == TypeCategory::Logical) {
4812	// allow assignment to LOGICAL from INTEGER as a legacy extension
4813	msg = "assignment of LOGICAL to INTEGER"_port_en_US;
4814	} else if (lhs == TypeCategory::Logical && rhs == TypeCategory::Integer) {
4815	// ... and assignment to LOGICAL from INTEGER
4816	msg = "assignment of INTEGER to LOGICAL"_port_en_US;
4817	} else {
4818	return false;
4819	}
4820	context_.Warn(
4821	common::LanguageFeature::LogicalIntegerAssignment, std::move(*msg));
4822	return true;
4823	}
4824
4825	std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
4826	const Symbol *proc{nullptr};
4827	bool isProcElemental{false};
4828	std::optional<int> passedObjectIndex;
4829	std::string oprNameString{"assignment(=)"};
4830	parser::CharBlock oprName{oprNameString};
4831	const auto &scope{context_.context().FindScope(source_)};
4832	{
4833	auto restorer{context_.GetContextualMessages().DiscardMessages()};
4834	if (const Symbol *symbol{scope.FindSymbol(oprName)}) {
4835	ExpressionAnalyzer::AdjustActuals noAdjustment;
4836	proc =
4837	context_.ResolveGeneric(*symbol, actuals_, noAdjustment, true).first;
4838	if (proc) {
4839	isProcElemental = IsElementalProcedure(*proc);
4840	}
4841	}
4842	for (std::size_t i{0}; (!proc || isProcElemental) && i < actuals_.size();
4843	++i) {
4844	const Symbol *generic{nullptr};
4845	if (const Symbol *
4846	binding{FindBoundOp(oprName, i, generic, /*isSubroutine=*/true)}) {
4847	// ignore inaccessible type-bound ASSIGNMENT(=) generic
4848	if (!CheckAccessibleSymbol(scope, DEREF(generic))) {
4849	const Symbol *resolution{GetBindingResolution(GetType(i), *binding)};
4850	const Symbol &newProc{*(resolution ? resolution : binding)};
4851	bool isElemental{IsElementalProcedure(newProc)};
4852	if (!proc || !isElemental) {
4853	// Non-elemental resolution overrides elemental
4854	proc = &newProc;
4855	isProcElemental = isElemental;
4856	if (resolution) {
4857	passedObjectIndex.reset();
4858	} else {
4859	passedObjectIndex = i;
4860	}
4861	}
4862	}
4863	}
4864	}
4865	}
4866	if (!proc) {
4867	return std::nullopt;
4868	}
4869	ActualArguments actualsCopy{actuals_};
4870	// Ensure that the RHS argument is not passed as a variable unless
4871	// the dummy argument has the VALUE attribute.
4872	if (evaluate::IsVariable(actualsCopy.at(1).value().UnwrapExpr())) {
4873	auto chars{evaluate::characteristics::Procedure::Characterize(
4874	*proc, context_.GetFoldingContext())};
4875	const auto *rhsDummy{chars && chars->dummyArguments.size() == 2
4876	? std::get_if<evaluate::characteristics::DummyDataObject>(
4877	&chars->dummyArguments.at(1).u)
4878	: nullptr};
4879	if (!rhsDummy ||
4880	!rhsDummy->attrs.test(
4881	evaluate::characteristics::DummyDataObject::Attr::Value)) {
4882	actualsCopy.at(1).value().Parenthesize();
4883	}
4884	}
4885	if (passedObjectIndex) {
4886	actualsCopy[*passedObjectIndex]->set_isPassedObject();
4887	}
4888	return ProcedureRef{ProcedureDesignator{*proc}, std::move(actualsCopy)};
4889	}
4890
4891	void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {
4892	os << "source_: " << source_.ToString() << " fatalErrors_ = " << fatalErrors_
4893	<< '\n';
4894	for (const auto &actual : actuals_) {
4895	if (!actual.has_value()) {
4896	os << "- error\n";
4897	} else if (const Symbol *symbol{actual->GetAssumedTypeDummy()}) {
4898	os << "- assumed type: " << symbol->name().ToString() << '\n';
4899	} else if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {
4900	expr->AsFortran(os << "- expr: ") << '\n';
4901	} else {
4902	DIE("bad ActualArgument");
4903	}
4904	}
4905	}
4906
4907	std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
4908	const parser::Expr &expr) {
4909	source_.ExtendToCover(expr.source);
4910	if (const Symbol *assumedTypeDummy{AssumedTypeDummy(expr)}) {
4911	ResetExpr(expr);
4912	if (isProcedureCall_) {
4913	ActualArgument arg{ActualArgument::AssumedType{*assumedTypeDummy}};
4914	SetArgSourceLocation(arg, expr.source);
4915	return std::move(arg);
4916	}
4917	context_.SayAt(expr.source,
4918	"TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
4919	} else if (MaybeExpr argExpr{AnalyzeExprOrWholeAssumedSizeArray(expr)}) {
4920	if (isProcedureCall_ || !IsProcedureDesignator(*argExpr)) {
4921	// Pad Hollerith actual argument with spaces up to a multiple of 8
4922	// bytes, in case the data are interpreted as double precision
4923	// (or a smaller numeric type) by legacy code.
4924	if (auto hollerith{UnwrapExpr<Constant<Ascii>>(*argExpr)};
4925	hollerith && hollerith->wasHollerith()) {
4926	std::string bytes{hollerith->values()};
4927	while ((bytes.size() % 8) != 0) {
4928	bytes += ' ';
4929	}
4930	Constant<Ascii> c{std::move(bytes)};
4931	c.set_wasHollerith(true);
4932	argExpr = AsGenericExpr(std::move(c));
4933	}
4934	ActualArgument arg{std::move(*argExpr)};
4935	SetArgSourceLocation(arg, expr.source);
4936	return std::move(arg);
4937	}
4938	context_.SayAt(expr.source,
4939	IsFunctionDesignator(*argExpr)
4940	? "Function call must have argument list"_err_en_US
4941	: "Subroutine name is not allowed here"_err_en_US);
4942	}
4943	return std::nullopt;
4944	}
4945
4946	MaybeExpr ArgumentAnalyzer::AnalyzeExprOrWholeAssumedSizeArray(
4947	const parser::Expr &expr) {
4948	// If an expression's parse tree is a whole assumed-size array:
4949	// Expr -> Designator -> DataRef -> Name
4950	// treat it as a special case for argument passing and bypass
4951	// the C1002/C1014 constraint checking in expression semantics.
4952	if (const auto *name{parser::Unwrap<parser::Name>(expr)}) {
4953	if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) {
4954	auto restorer{context_.AllowWholeAssumedSizeArray()};
4955	return context_.Analyze(expr);
4956	}
4957	}
4958	auto restorer{context_.AllowNullPointer()};
4959	return context_.Analyze(expr);
4960	}
4961
4962	bool ArgumentAnalyzer::AreConformable() const {
4963	CHECK(actuals_.size() == 2);
4964	return actuals_[0] && actuals_[1] &&
4965	evaluate::AreConformable(*actuals_[0], *actuals_[1]);
4966	}
4967
4968	// Look for a type-bound operator in the type of arg number passIndex.
4969	const Symbol *ArgumentAnalyzer::FindBoundOp(parser::CharBlock oprName,
4970	int passIndex, const Symbol *&generic, bool isSubroutine) {
4971	const auto *type{GetDerivedTypeSpec(GetType(passIndex))};
4972	const semantics::Scope *scope{type ? type->scope() : nullptr};
4973	if (scope) {
4974	// Use the original type definition's scope, since PDT
4975	// instantiations don't have redundant copies of bindings or
4976	// generics.
4977	scope = DEREF(scope->derivedTypeSpec()).typeSymbol().scope();
4978	}
4979	generic = scope ? scope->FindComponent(oprName) : nullptr;
4980	if (generic) {
4981	ExpressionAnalyzer::AdjustActuals adjustment{
4982	[&](const Symbol &proc, ActualArguments &) {
4983	return passIndex == GetPassIndex(proc).value_or(-1);
4984	}};
4985	auto pair{
4986	context_.ResolveGeneric(*generic, actuals_, adjustment, isSubroutine)};
4987	if (const Symbol *binding{pair.first}) {
4988	CHECK(binding->has<semantics::ProcBindingDetails>());
4989	// Use the most recent override of the binding, if any
4990	return scope->FindComponent(binding->name());
4991	} else {
4992	context_.EmitGenericResolutionError(*generic, pair.second, isSubroutine);
4993	}
4994	}
4995	return nullptr;
4996	}
4997
4998	// If there is an implicit conversion between intrinsic types, make it explicit
4999	void ArgumentAnalyzer::AddAssignmentConversion(
5000	const DynamicType &lhsType, const DynamicType &rhsType) {
5001	if (lhsType.category() == rhsType.category() &&
5002	(lhsType.category() == TypeCategory::Derived ||
5003	lhsType.kind() == rhsType.kind())) {
5004	// no conversion necessary
5005	} else if (auto rhsExpr{evaluate::Fold(context_.GetFoldingContext(),
5006	evaluate::ConvertToType(lhsType, MoveExpr(1)))}) {
5007	std::optional<parser::CharBlock> source;
5008	if (actuals_[1]) {
5009	source = actuals_[1]->sourceLocation();
5010	}
5011	actuals_[1] = ActualArgument{*rhsExpr};
5012	SetArgSourceLocation(actuals_[1], source);
5013	} else {
5014	actuals_[1] = std::nullopt;
5015	}
5016	}
5017
5018	std::optional<DynamicType> ArgumentAnalyzer::GetType(std::size_t i) const {
5019	return i < actuals_.size() ? actuals_[i].value().GetType() : std::nullopt;
5020	}
5021	int ArgumentAnalyzer::GetRank(std::size_t i) const {
5022	return i < actuals_.size() ? actuals_[i].value().Rank() : 0;
5023	}
5024
5025	// If the argument at index i is a BOZ literal, convert its type to match the
5026	// otherType. If it's REAL, convert to REAL; if it's UNSIGNED, convert to
5027	// UNSIGNED; otherwise, convert to INTEGER.
5028	// Note that IBM supports comparing BOZ literals to CHARACTER operands. That
5029	// is not currently supported.
5030	void ArgumentAnalyzer::ConvertBOZOperand(std::optional<DynamicType> *thisType,
5031	std::size_t i, std::optional<DynamicType> otherType) {
5032	if (IsBOZLiteral(i)) {
5033	Expr<SomeType> &&argExpr{MoveExpr(i)};
5034	auto *boz{std::get_if<BOZLiteralConstant>(&argExpr.u)};
5035	if (otherType && otherType->category() == TypeCategory::Real) {
5036	int kind{context_.context().GetDefaultKind(TypeCategory::Real)};
5037	MaybeExpr realExpr{
5038	ConvertToKind<TypeCategory::Real>(kind, std::move(*boz))};
5039	actuals_[i] = std::move(realExpr.value());
5040	if (thisType) {
5041	thisType->emplace(TypeCategory::Real, kind);
5042	}
5043	} else if (otherType && otherType->category() == TypeCategory::Unsigned) {
5044	int kind{context_.context().GetDefaultKind(TypeCategory::Unsigned)};
5045	MaybeExpr unsignedExpr{
5046	ConvertToKind<TypeCategory::Unsigned>(kind, std::move(*boz))};
5047	actuals_[i] = std::move(unsignedExpr.value());
5048	if (thisType) {
5049	thisType->emplace(TypeCategory::Unsigned, kind);
5050	}
5051	} else {
5052	int kind{context_.context().GetDefaultKind(TypeCategory::Integer)};
5053	MaybeExpr intExpr{
5054	ConvertToKind<TypeCategory::Integer>(kind, std::move(*boz))};
5055	actuals_[i] = std::move(*intExpr);
5056	if (thisType) {
5057	thisType->emplace(TypeCategory::Integer, kind);
5058	}
5059	}
5060	}
5061	}
5062
5063	void ArgumentAnalyzer::ConvertBOZAssignmentRHS(const DynamicType &lhsType) {
5064	if (lhsType.category() == TypeCategory::Integer ||
5065	lhsType.category() == TypeCategory::Unsigned ||
5066	lhsType.category() == TypeCategory::Real) {
5067	Expr<SomeType> rhs{MoveExpr(1)};
5068	if (MaybeExpr converted{ConvertToType(lhsType, std::move(rhs))}) {
5069	actuals_[1] = std::move(*converted);
5070	}
5071	}
5072	}
5073
5074	// Report error resolving opr when there is a user-defined one available
5075	void ArgumentAnalyzer::SayNoMatch(const std::string &opr, bool isAssignment) {
5076	std::string type0{TypeAsFortran(0)};
5077	auto rank0{actuals_[0]->Rank()};
5078	if (actuals_.size() == 1) {
5079	if (rank0 > 0) {
5080	context_.Say("No intrinsic or user-defined %s matches "
5081	"rank %d array of %s"_err_en_US,
5082	opr, rank0, type0);
5083	} else {
5084	context_.Say("No intrinsic or user-defined %s matches "
5085	"operand type %s"_err_en_US,
5086	opr, type0);
5087	}
5088	} else {
5089	std::string type1{TypeAsFortran(1)};
5090	auto rank1{actuals_[1]->Rank()};
5091	if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {
5092	context_.Say("No intrinsic or user-defined %s matches "
5093	"rank %d array of %s and rank %d array of %s"_err_en_US,
5094	opr, rank0, type0, rank1, type1);
5095	} else if (isAssignment && rank0 != rank1) {
5096	if (rank0 == 0) {
5097	context_.Say("No intrinsic or user-defined %s matches "
5098	"scalar %s and rank %d array of %s"_err_en_US,
5099	opr, type0, rank1, type1);
5100	} else {
5101	context_.Say("No intrinsic or user-defined %s matches "
5102	"rank %d array of %s and scalar %s"_err_en_US,
5103	opr, rank0, type0, type1);
5104	}
5105	} else {
5106	context_.Say("No intrinsic or user-defined %s matches "
5107	"operand types %s and %s"_err_en_US,
5108	opr, type0, type1);
5109	}
5110	}
5111	}
5112
5113	std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
5114	if (i >= actuals_.size() || !actuals_[i]) {
5115	return "missing argument";
5116	} else if (std::optional<DynamicType> type{GetType(i)}) {
5117	return type->IsAssumedType() ? "TYPE(*)"s
5118	: type->IsUnlimitedPolymorphic() ? "CLASS(*)"s
5119	: type->IsPolymorphic() ? type->AsFortran()
5120	: type->category() == TypeCategory::Derived
5121	? "TYPE("s + type->AsFortran() + ')'
5122	: type->category() == TypeCategory::Character
5123	? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
5124	: ToUpperCase(type->AsFortran());
5125	} else {
5126	return "untyped";
5127	}
5128	}
5129
5130	bool ArgumentAnalyzer::AnyUntypedOrMissingOperand() {
5131	for (const auto &actual : actuals_) {
5132	if (!actual ||
5133	(!actual->GetType() && !IsBareNullPointer(actual->UnwrapExpr()))) {
5134	return true;
5135	}
5136	}
5137	return false;
5138	}
5139	} // namespace Fortran::evaluate
5140
5141	namespace Fortran::semantics {
5142	evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
5143	SemanticsContext &context, common::TypeCategory category,
5144	const std::optional<parser::KindSelector> &selector) {
5145	evaluate::ExpressionAnalyzer analyzer{context};
5146	CHECK(context.location().has_value());
5147	auto restorer{
5148	analyzer.GetContextualMessages().SetLocation(*context.location())};
5149	return analyzer.AnalyzeKindSelector(category, selector);
5150	}
5151
5152	ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}
5153
5154	bool ExprChecker::Pre(const parser::DataStmtObject &obj) {
5155	exprAnalyzer_.set_inDataStmtObject(true);
5156	return true;
5157	}
5158
5159	void ExprChecker::Post(const parser::DataStmtObject &obj) {
5160	exprAnalyzer_.set_inDataStmtObject(false);
5161	}
5162
5163	bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {
5164	parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);
5165	const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};
5166	auto name{bounds.name.thing.thing};
5167	int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
5168	if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
5169	if (dynamicType->category() == TypeCategory::Integer) {
5170	kind = dynamicType->kind();
5171	}
5172	}
5173	exprAnalyzer_.AddImpliedDo(name.source, kind);
5174	parser::Walk(std::get<std::list<parser::DataIDoObject>>(ido.t), *this);
5175	exprAnalyzer_.RemoveImpliedDo(name.source);
5176	return false;
5177	}
5178
5179	bool ExprChecker::Walk(const parser::Program &program) {
5180	parser::Walk(program, *this);
5181	return !context_.AnyFatalError();
5182	}
5183	} // namespace Fortran::semantics
5184