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