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.h"
13 #include "flang/Common/Fortran.h"
14 #include "flang/Common/idioms.h"
15 #include "flang/Evaluate/common.h"
16 #include "flang/Evaluate/fold.h"
17 #include "flang/Evaluate/tools.h"
18 #include "flang/Parser/characters.h"
19 #include "flang/Parser/dump-parse-tree.h"
20 #include "flang/Parser/parse-tree-visitor.h"
21 #include "flang/Parser/parse-tree.h"
22 #include "flang/Semantics/scope.h"
23 #include "flang/Semantics/semantics.h"
24 #include "flang/Semantics/symbol.h"
25 #include "flang/Semantics/tools.h"
26 #include "llvm/Support/raw_ostream.h"
27 #include <algorithm>
28 #include <functional>
29 #include <optional>
30 #include <set>
31 
32 // Typedef for optional generic expressions (ubiquitous in this file)
33 using MaybeExpr =
34     std::optional<Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>;
35 
36 // Much of the code that implements semantic analysis of expressions is
37 // tightly coupled with their typed representations in lib/Evaluate,
38 // and appears here in namespace Fortran::evaluate for convenience.
39 namespace Fortran::evaluate {
40 
41 using common::LanguageFeature;
42 using common::NumericOperator;
43 using common::TypeCategory;
44 
45 static inline std::string ToUpperCase(const std::string &str) {
46   return parser::ToUpperCaseLetters(str);
47 }
48 
49 struct DynamicTypeWithLength : public DynamicType {
50   explicit DynamicTypeWithLength(const DynamicType &t) : DynamicType{t} {}
51   std::optional<Expr<SubscriptInteger>> LEN() const;
52   std::optional<Expr<SubscriptInteger>> length;
53 };
54 
55 std::optional<Expr<SubscriptInteger>> DynamicTypeWithLength::LEN() const {
56   if (length) {
57     return length;
58   }
59   if (auto *lengthParam{charLength()}) {
60     if (const auto &len{lengthParam->GetExplicit()}) {
61       return ConvertToType<SubscriptInteger>(common::Clone(*len));
62     }
63   }
64   return std::nullopt; // assumed or deferred length
65 }
66 
67 static std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(
68     const std::optional<parser::TypeSpec> &spec) {
69   if (spec) {
70     if (const semantics::DeclTypeSpec * typeSpec{spec->declTypeSpec}) {
71       // Name resolution sets TypeSpec::declTypeSpec only when it's valid
72       // (viz., an intrinsic type with valid known kind or a non-polymorphic
73       // & non-ABSTRACT derived type).
74       if (const semantics::IntrinsicTypeSpec *
75           intrinsic{typeSpec->AsIntrinsic()}) {
76         TypeCategory category{intrinsic->category()};
77         if (auto optKind{ToInt64(intrinsic->kind())}) {
78           int kind{static_cast<int>(*optKind)};
79           if (category == TypeCategory::Character) {
80             const semantics::CharacterTypeSpec &cts{
81                 typeSpec->characterTypeSpec()};
82             const semantics::ParamValue &len{cts.length()};
83             // N.B. CHARACTER(LEN=*) is allowed in type-specs in ALLOCATE() &
84             // type guards, but not in array constructors.
85             return DynamicTypeWithLength{DynamicType{kind, len}};
86           } else {
87             return DynamicTypeWithLength{DynamicType{category, kind}};
88           }
89         }
90       } else if (const semantics::DerivedTypeSpec *
91           derived{typeSpec->AsDerived()}) {
92         return DynamicTypeWithLength{DynamicType{*derived}};
93       }
94     }
95   }
96   return std::nullopt;
97 }
98 
99 class ArgumentAnalyzer {
100 public:
101   explicit ArgumentAnalyzer(ExpressionAnalyzer &context)
102       : context_{context}, source_{context.GetContextualMessages().at()},
103         isProcedureCall_{false} {}
104   ArgumentAnalyzer(ExpressionAnalyzer &context, parser::CharBlock source,
105       bool isProcedureCall = false)
106       : context_{context}, source_{source}, isProcedureCall_{isProcedureCall} {}
107   bool fatalErrors() const { return fatalErrors_; }
108   ActualArguments &&GetActuals() {
109     CHECK(!fatalErrors_);
110     return std::move(actuals_);
111   }
112   const Expr<SomeType> &GetExpr(std::size_t i) const {
113     return DEREF(actuals_.at(i).value().UnwrapExpr());
114   }
115   Expr<SomeType> &&MoveExpr(std::size_t i) {
116     return std::move(DEREF(actuals_.at(i).value().UnwrapExpr()));
117   }
118   void Analyze(const common::Indirection<parser::Expr> &x) {
119     Analyze(x.value());
120   }
121   void Analyze(const parser::Expr &x) {
122     actuals_.emplace_back(AnalyzeExpr(x));
123     fatalErrors_ |= !actuals_.back();
124   }
125   void Analyze(const parser::Variable &);
126   void Analyze(const parser::ActualArgSpec &, bool isSubroutine);
127   void ConvertBOZ(std::size_t i, std::optional<DynamicType> otherType);
128 
129   bool IsIntrinsicRelational(RelationalOperator) const;
130   bool IsIntrinsicLogical() const;
131   bool IsIntrinsicNumeric(NumericOperator) const;
132   bool IsIntrinsicConcat() const;
133 
134   bool CheckConformance() const;
135 
136   // Find and return a user-defined operator or report an error.
137   // The provided message is used if there is no such operator.
138   MaybeExpr TryDefinedOp(
139       const char *, parser::MessageFixedText &&, bool isUserOp = false);
140   template <typename E>
141   MaybeExpr TryDefinedOp(E opr, parser::MessageFixedText &&msg) {
142     return TryDefinedOp(
143         context_.context().languageFeatures().GetNames(opr), std::move(msg));
144   }
145   // Find and return a user-defined assignment
146   std::optional<ProcedureRef> TryDefinedAssignment();
147   std::optional<ProcedureRef> GetDefinedAssignmentProc();
148   std::optional<DynamicType> GetType(std::size_t) const;
149   void Dump(llvm::raw_ostream &);
150 
151 private:
152   MaybeExpr TryDefinedOp(
153       std::vector<const char *>, parser::MessageFixedText &&);
154   MaybeExpr TryBoundOp(const Symbol &, int passIndex);
155   std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
156   MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);
157   bool AreConformable() const;
158   const Symbol *FindBoundOp(parser::CharBlock, int passIndex);
159   void AddAssignmentConversion(
160       const DynamicType &lhsType, const DynamicType &rhsType);
161   bool OkLogicalIntegerAssignment(TypeCategory lhs, TypeCategory rhs);
162   int GetRank(std::size_t) const;
163   bool IsBOZLiteral(std::size_t i) const {
164     return std::holds_alternative<BOZLiteralConstant>(GetExpr(i).u);
165   }
166   void SayNoMatch(const std::string &, bool isAssignment = false);
167   std::string TypeAsFortran(std::size_t);
168   bool AnyUntypedOrMissingOperand();
169 
170   ExpressionAnalyzer &context_;
171   ActualArguments actuals_;
172   parser::CharBlock source_;
173   bool fatalErrors_{false};
174   const bool isProcedureCall_; // false for user-defined op or assignment
175   const Symbol *sawDefinedOp_{nullptr};
176 };
177 
178 // Wraps a data reference in a typed Designator<>, and a procedure
179 // or procedure pointer reference in a ProcedureDesignator.
180 MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
181   const Symbol &symbol{ref.GetLastSymbol().GetUltimate()};
182   if (semantics::IsProcedure(symbol)) {
183     if (auto *component{std::get_if<Component>(&ref.u)}) {
184       return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
185     } else if (!std::holds_alternative<SymbolRef>(ref.u)) {
186       DIE("unexpected alternative in DataRef");
187     } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
188       return Expr<SomeType>{ProcedureDesignator{symbol}};
189     } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
190                    symbol.name().ToString())}) {
191       SpecificIntrinsic intrinsic{
192           symbol.name().ToString(), std::move(*interface)};
193       intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
194       return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
195     } else {
196       Say("'%s' is not a specific intrinsic procedure"_err_en_US,
197           symbol.name());
198       return std::nullopt;
199     }
200   } else if (auto dyType{DynamicType::From(symbol)}) {
201     return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));
202   }
203   return std::nullopt;
204 }
205 
206 // Some subscript semantic checks must be deferred until all of the
207 // subscripts are in hand.
208 MaybeExpr ExpressionAnalyzer::CompleteSubscripts(ArrayRef &&ref) {
209   const Symbol &symbol{ref.GetLastSymbol().GetUltimate()};
210   int symbolRank{symbol.Rank()};
211   int subscripts{static_cast<int>(ref.size())};
212   if (subscripts == 0) {
213     return std::nullopt; // error recovery
214   } else if (subscripts != symbolRank) {
215     if (symbolRank != 0) {
216       Say("Reference to rank-%d object '%s' has %d subscripts"_err_en_US,
217           symbolRank, symbol.name(), subscripts);
218     }
219     return std::nullopt;
220   } else if (Component * component{ref.base().UnwrapComponent()}) {
221     int baseRank{component->base().Rank()};
222     if (baseRank > 0) {
223       int subscriptRank{0};
224       for (const auto &expr : ref.subscript()) {
225         subscriptRank += expr.Rank();
226       }
227       if (subscriptRank > 0) {
228         Say("Subscripts of component '%s' of rank-%d derived type "
229             "array have rank %d but must all be scalar"_err_en_US,
230             symbol.name(), baseRank, subscriptRank);
231         return std::nullopt;
232       }
233     }
234   } else if (const auto *object{
235                  symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
236     // C928 & C1002
237     if (Triplet * last{std::get_if<Triplet>(&ref.subscript().back().u)}) {
238       if (!last->upper() && object->IsAssumedSize()) {
239         Say("Assumed-size array '%s' must have explicit final "
240             "subscript upper bound value"_err_en_US,
241             symbol.name());
242         return std::nullopt;
243       }
244     }
245   } else {
246     // Shouldn't get here from Analyze(ArrayElement) without a valid base,
247     // which, if not an object, must be a construct entity from
248     // SELECT TYPE/RANK or ASSOCIATE.
249     CHECK(symbol.has<semantics::AssocEntityDetails>());
250   }
251   return Designate(DataRef{std::move(ref)});
252 }
253 
254 // Applies subscripts to a data reference.
255 MaybeExpr ExpressionAnalyzer::ApplySubscripts(
256     DataRef &&dataRef, std::vector<Subscript> &&subscripts) {
257   if (subscripts.empty()) {
258     return std::nullopt; // error recovery
259   }
260   return std::visit(
261       common::visitors{
262           [&](SymbolRef &&symbol) {
263             return CompleteSubscripts(ArrayRef{symbol, std::move(subscripts)});
264           },
265           [&](Component &&c) {
266             return CompleteSubscripts(
267                 ArrayRef{std::move(c), std::move(subscripts)});
268           },
269           [&](auto &&) -> MaybeExpr {
270             DIE("bad base for ArrayRef");
271             return std::nullopt;
272           },
273       },
274       std::move(dataRef.u));
275 }
276 
277 // Top-level checks for data references.
278 MaybeExpr ExpressionAnalyzer::TopLevelChecks(DataRef &&dataRef) {
279   if (Component * component{std::get_if<Component>(&dataRef.u)}) {
280     const Symbol &symbol{component->GetLastSymbol()};
281     int componentRank{symbol.Rank()};
282     if (componentRank > 0) {
283       int baseRank{component->base().Rank()};
284       if (baseRank > 0) {
285         Say("Reference to whole rank-%d component '%%%s' of "
286             "rank-%d array of derived type is not allowed"_err_en_US,
287             componentRank, symbol.name(), baseRank);
288       }
289     }
290   }
291   return Designate(std::move(dataRef));
292 }
293 
294 // Parse tree correction after a substring S(j:k) was misparsed as an
295 // array section.  N.B. Fortran substrings have to have a range, not a
296 // single index.
297 static void FixMisparsedSubstring(const parser::Designator &d) {
298   auto &mutate{const_cast<parser::Designator &>(d)};
299   if (auto *dataRef{std::get_if<parser::DataRef>(&mutate.u)}) {
300     if (auto *ae{std::get_if<common::Indirection<parser::ArrayElement>>(
301             &dataRef->u)}) {
302       parser::ArrayElement &arrElement{ae->value()};
303       if (!arrElement.subscripts.empty()) {
304         auto iter{arrElement.subscripts.begin()};
305         if (auto *triplet{std::get_if<parser::SubscriptTriplet>(&iter->u)}) {
306           if (!std::get<2>(triplet->t) /* no stride */ &&
307               ++iter == arrElement.subscripts.end() /* one subscript */) {
308             if (Symbol *
309                 symbol{std::visit(
310                     common::visitors{
311                         [](parser::Name &n) { return n.symbol; },
312                         [](common::Indirection<parser::StructureComponent>
313                                 &sc) { return sc.value().component.symbol; },
314                         [](auto &) -> Symbol * { return nullptr; },
315                     },
316                     arrElement.base.u)}) {
317               const Symbol &ultimate{symbol->GetUltimate()};
318               if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
319                 if (!ultimate.IsObjectArray() &&
320                     type->category() == semantics::DeclTypeSpec::Character) {
321                   // The ambiguous S(j:k) was parsed as an array section
322                   // reference, but it's now clear that it's a substring.
323                   // Fix the parse tree in situ.
324                   mutate.u = arrElement.ConvertToSubstring();
325                 }
326               }
327             }
328           }
329         }
330       }
331     }
332   }
333 }
334 
335 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {
336   auto restorer{GetContextualMessages().SetLocation(d.source)};
337   FixMisparsedSubstring(d);
338   // These checks have to be deferred to these "top level" data-refs where
339   // we can be sure that there are no following subscripts (yet).
340   // Substrings have already been run through TopLevelChecks() and
341   // won't be returned by ExtractDataRef().
342   if (MaybeExpr result{Analyze(d.u)}) {
343     if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(result))}) {
344       return TopLevelChecks(std::move(*dataRef));
345     }
346     return result;
347   }
348   return std::nullopt;
349 }
350 
351 // A utility subroutine to repackage optional expressions of various levels
352 // of type specificity as fully general MaybeExpr values.
353 template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {
354   return AsGenericExpr(std::move(x));
355 }
356 template <typename A> MaybeExpr AsMaybeExpr(std::optional<A> &&x) {
357   if (x) {
358     return AsMaybeExpr(std::move(*x));
359   }
360   return std::nullopt;
361 }
362 
363 // Type kind parameter values for literal constants.
364 int ExpressionAnalyzer::AnalyzeKindParam(
365     const std::optional<parser::KindParam> &kindParam, int defaultKind) {
366   if (!kindParam) {
367     return defaultKind;
368   }
369   return std::visit(
370       common::visitors{
371           [](std::uint64_t k) { return static_cast<int>(k); },
372           [&](const parser::Scalar<
373               parser::Integer<parser::Constant<parser::Name>>> &n) {
374             if (MaybeExpr ie{Analyze(n)}) {
375               if (std::optional<std::int64_t> i64{ToInt64(*ie)}) {
376                 int iv = *i64;
377                 if (iv == *i64) {
378                   return iv;
379                 }
380               }
381             }
382             return defaultKind;
383           },
384       },
385       kindParam->u);
386 }
387 
388 // Common handling of parser::IntLiteralConstant and SignedIntLiteralConstant
389 struct IntTypeVisitor {
390   using Result = MaybeExpr;
391   using Types = IntegerTypes;
392   template <typename T> Result Test() {
393     if (T::kind >= kind) {
394       const char *p{digits.begin()};
395       auto value{T::Scalar::Read(p, 10, true /*signed*/)};
396       if (!value.overflow) {
397         if (T::kind > kind) {
398           if (!isDefaultKind ||
399               !analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
400             return std::nullopt;
401           } else if (analyzer.context().ShouldWarn(
402                          LanguageFeature::BigIntLiterals)) {
403             analyzer.Say(digits,
404                 "Integer literal is too large for default INTEGER(KIND=%d); "
405                 "assuming INTEGER(KIND=%d)"_en_US,
406                 kind, T::kind);
407           }
408         }
409         return Expr<SomeType>{
410             Expr<SomeInteger>{Expr<T>{Constant<T>{std::move(value.value)}}}};
411       }
412     }
413     return std::nullopt;
414   }
415   ExpressionAnalyzer &analyzer;
416   parser::CharBlock digits;
417   int kind;
418   bool isDefaultKind;
419 };
420 
421 template <typename PARSED>
422 MaybeExpr ExpressionAnalyzer::IntLiteralConstant(const PARSED &x) {
423   const auto &kindParam{std::get<std::optional<parser::KindParam>>(x.t)};
424   bool isDefaultKind{!kindParam};
425   int kind{AnalyzeKindParam(kindParam, GetDefaultKind(TypeCategory::Integer))};
426   if (CheckIntrinsicKind(TypeCategory::Integer, kind)) {
427     auto digits{std::get<parser::CharBlock>(x.t)};
428     if (MaybeExpr result{common::SearchTypes(
429             IntTypeVisitor{*this, digits, kind, isDefaultKind})}) {
430       return result;
431     } else if (isDefaultKind) {
432       Say(digits,
433           "Integer literal is too large for any allowable "
434           "kind of INTEGER"_err_en_US);
435     } else {
436       Say(digits, "Integer literal is too large for INTEGER(KIND=%d)"_err_en_US,
437           kind);
438     }
439   }
440   return std::nullopt;
441 }
442 
443 MaybeExpr ExpressionAnalyzer::Analyze(const parser::IntLiteralConstant &x) {
444   auto restorer{
445       GetContextualMessages().SetLocation(std::get<parser::CharBlock>(x.t))};
446   return IntLiteralConstant(x);
447 }
448 
449 MaybeExpr ExpressionAnalyzer::Analyze(
450     const parser::SignedIntLiteralConstant &x) {
451   auto restorer{GetContextualMessages().SetLocation(x.source)};
452   return IntLiteralConstant(x);
453 }
454 
455 template <typename TYPE>
456 Constant<TYPE> ReadRealLiteral(
457     parser::CharBlock source, FoldingContext &context) {
458   const char *p{source.begin()};
459   auto valWithFlags{Scalar<TYPE>::Read(p, context.rounding())};
460   CHECK(p == source.end());
461   RealFlagWarnings(context, valWithFlags.flags, "conversion of REAL literal");
462   auto value{valWithFlags.value};
463   if (context.flushSubnormalsToZero()) {
464     value = value.FlushSubnormalToZero();
465   }
466   return {value};
467 }
468 
469 struct RealTypeVisitor {
470   using Result = std::optional<Expr<SomeReal>>;
471   using Types = RealTypes;
472 
473   RealTypeVisitor(int k, parser::CharBlock lit, FoldingContext &ctx)
474       : kind{k}, literal{lit}, context{ctx} {}
475 
476   template <typename T> Result Test() {
477     if (kind == T::kind) {
478       return {AsCategoryExpr(ReadRealLiteral<T>(literal, context))};
479     }
480     return std::nullopt;
481   }
482 
483   int kind;
484   parser::CharBlock literal;
485   FoldingContext &context;
486 };
487 
488 // Reads a real literal constant and encodes it with the right kind.
489 MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
490   // Use a local message context around the real literal for better
491   // provenance on any messages.
492   auto restorer{GetContextualMessages().SetLocation(x.real.source)};
493   // If a kind parameter appears, it defines the kind of the literal and the
494   // letter used in an exponent part must be 'E' (e.g., the 'E' in
495   // "6.02214E+23").  In the absence of an explicit kind parameter, any
496   // exponent letter determines the kind.  Otherwise, defaults apply.
497   auto &defaults{context_.defaultKinds()};
498   int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)};
499   const char *end{x.real.source.end()};
500   char expoLetter{' '};
501   std::optional<int> letterKind;
502   for (const char *p{x.real.source.begin()}; p < end; ++p) {
503     if (parser::IsLetter(*p)) {
504       expoLetter = *p;
505       switch (expoLetter) {
506       case 'e':
507         letterKind = defaults.GetDefaultKind(TypeCategory::Real);
508         break;
509       case 'd':
510         letterKind = defaults.doublePrecisionKind();
511         break;
512       case 'q':
513         letterKind = defaults.quadPrecisionKind();
514         break;
515       default:
516         Say("Unknown exponent letter '%c'"_err_en_US, expoLetter);
517       }
518       break;
519     }
520   }
521   if (letterKind) {
522     defaultKind = *letterKind;
523   }
524   // C716 requires 'E' as an exponent, but this is more useful
525   auto kind{AnalyzeKindParam(x.kind, defaultKind)};
526   if (letterKind && kind != *letterKind && expoLetter != 'e') {
527     Say("Explicit kind parameter on real constant disagrees with "
528         "exponent letter '%c'"_en_US,
529         expoLetter);
530   }
531   auto result{common::SearchTypes(
532       RealTypeVisitor{kind, x.real.source, GetFoldingContext()})};
533   if (!result) { // C717
534     Say("Unsupported REAL(KIND=%d)"_err_en_US, kind);
535   }
536   return AsMaybeExpr(std::move(result));
537 }
538 
539 MaybeExpr ExpressionAnalyzer::Analyze(
540     const parser::SignedRealLiteralConstant &x) {
541   if (auto result{Analyze(std::get<parser::RealLiteralConstant>(x.t))}) {
542     auto &realExpr{std::get<Expr<SomeReal>>(result->u)};
543     if (auto sign{std::get<std::optional<parser::Sign>>(x.t)}) {
544       if (sign == parser::Sign::Negative) {
545         return AsGenericExpr(-std::move(realExpr));
546       }
547     }
548     return result;
549   }
550   return std::nullopt;
551 }
552 
553 MaybeExpr ExpressionAnalyzer::Analyze(
554     const parser::SignedComplexLiteralConstant &x) {
555   auto result{Analyze(std::get<parser::ComplexLiteralConstant>(x.t))};
556   if (!result) {
557     return std::nullopt;
558   } else if (std::get<parser::Sign>(x.t) == parser::Sign::Negative) {
559     return AsGenericExpr(-std::move(std::get<Expr<SomeComplex>>(result->u)));
560   } else {
561     return result;
562   }
563 }
564 
565 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexPart &x) {
566   return Analyze(x.u);
567 }
568 
569 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexLiteralConstant &z) {
570   return AsMaybeExpr(
571       ConstructComplex(GetContextualMessages(), Analyze(std::get<0>(z.t)),
572           Analyze(std::get<1>(z.t)), GetDefaultKind(TypeCategory::Real)));
573 }
574 
575 // CHARACTER literal processing.
576 MaybeExpr ExpressionAnalyzer::AnalyzeString(std::string &&string, int kind) {
577   if (!CheckIntrinsicKind(TypeCategory::Character, kind)) {
578     return std::nullopt;
579   }
580   switch (kind) {
581   case 1:
582     return AsGenericExpr(Constant<Type<TypeCategory::Character, 1>>{
583         parser::DecodeString<std::string, parser::Encoding::LATIN_1>(
584             string, true)});
585   case 2:
586     return AsGenericExpr(Constant<Type<TypeCategory::Character, 2>>{
587         parser::DecodeString<std::u16string, parser::Encoding::UTF_8>(
588             string, true)});
589   case 4:
590     return AsGenericExpr(Constant<Type<TypeCategory::Character, 4>>{
591         parser::DecodeString<std::u32string, parser::Encoding::UTF_8>(
592             string, true)});
593   default:
594     CRASH_NO_CASE;
595   }
596 }
597 
598 MaybeExpr ExpressionAnalyzer::Analyze(const parser::CharLiteralConstant &x) {
599   int kind{
600       AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t), 1)};
601   auto value{std::get<std::string>(x.t)};
602   return AnalyzeString(std::move(value), kind);
603 }
604 
605 MaybeExpr ExpressionAnalyzer::Analyze(
606     const parser::HollerithLiteralConstant &x) {
607   int kind{GetDefaultKind(TypeCategory::Character)};
608   auto value{x.v};
609   return AnalyzeString(std::move(value), kind);
610 }
611 
612 // .TRUE. and .FALSE. of various kinds
613 MaybeExpr ExpressionAnalyzer::Analyze(const parser::LogicalLiteralConstant &x) {
614   auto kind{AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t),
615       GetDefaultKind(TypeCategory::Logical))};
616   bool value{std::get<bool>(x.t)};
617   auto result{common::SearchTypes(
618       TypeKindVisitor<TypeCategory::Logical, Constant, bool>{
619           kind, std::move(value)})};
620   if (!result) {
621     Say("unsupported LOGICAL(KIND=%d)"_err_en_US, kind); // C728
622   }
623   return result;
624 }
625 
626 // BOZ typeless literals
627 MaybeExpr ExpressionAnalyzer::Analyze(const parser::BOZLiteralConstant &x) {
628   const char *p{x.v.c_str()};
629   std::uint64_t base{16};
630   switch (*p++) {
631   case 'b':
632     base = 2;
633     break;
634   case 'o':
635     base = 8;
636     break;
637   case 'z':
638     break;
639   case 'x':
640     break;
641   default:
642     CRASH_NO_CASE;
643   }
644   CHECK(*p == '"');
645   ++p;
646   auto value{BOZLiteralConstant::Read(p, base, false /*unsigned*/)};
647   if (*p != '"') {
648     Say("Invalid digit ('%c') in BOZ literal '%s'"_err_en_US, *p,
649         x.v); // C7107, C7108
650     return std::nullopt;
651   }
652   if (value.overflow) {
653     Say("BOZ literal '%s' too large"_err_en_US, x.v);
654     return std::nullopt;
655   }
656   return AsGenericExpr(std::move(value.value));
657 }
658 
659 // Names and named constants
660 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
661   auto restorer{GetContextualMessages().SetLocation(n.source)};
662   if (std::optional<int> kind{IsImpliedDo(n.source)}) {
663     return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(
664         *kind, AsExpr(ImpliedDoIndex{n.source})));
665   } else if (context_.HasError(n)) {
666     return std::nullopt;
667   } else if (!n.symbol) {
668     SayAt(n, "Internal error: unresolved name '%s'"_err_en_US, n.source);
669     return std::nullopt;
670   } else {
671     const Symbol &ultimate{n.symbol->GetUltimate()};
672     if (ultimate.has<semantics::TypeParamDetails>()) {
673       // A bare reference to a derived type parameter (within a parameterized
674       // derived type definition)
675       return Fold(ConvertToType(
676           ultimate, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
677     } else {
678       if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {
679         if (const semantics::Scope *
680             pure{semantics::FindPureProcedureContaining(
681                 context_.FindScope(n.source))}) {
682           SayAt(n,
683               "VOLATILE variable '%s' may not be referenced in pure subprogram '%s'"_err_en_US,
684               n.source, DEREF(pure->symbol()).name());
685           n.symbol->attrs().reset(semantics::Attr::VOLATILE);
686         }
687       }
688       if (!isWholeAssumedSizeArrayOk_ &&
689           semantics::IsAssumedSizeArray(*n.symbol)) { // C1002, C1014, C1231
690         AttachDeclaration(
691             SayAt(n,
692                 "Whole assumed-size array '%s' may not appear here without subscripts"_err_en_US,
693                 n.source),
694             *n.symbol);
695       }
696       return Designate(DataRef{*n.symbol});
697     }
698   }
699 }
700 
701 MaybeExpr ExpressionAnalyzer::Analyze(const parser::NamedConstant &n) {
702   auto restorer{GetContextualMessages().SetLocation(n.v.source)};
703   if (MaybeExpr value{Analyze(n.v)}) {
704     Expr<SomeType> folded{Fold(std::move(*value))};
705     if (IsConstantExpr(folded)) {
706       return folded;
707     }
708     Say(n.v.source, "must be a constant"_err_en_US); // C718
709   }
710   return std::nullopt;
711 }
712 
713 MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &n) {
714   if (MaybeExpr value{Analyze(n.v)}) {
715     // Subtle: when the NullInit is a DataStmtConstant, it might
716     // be a misparse of a structure constructor without parameters
717     // or components (e.g., T()).  Checking the result to ensure
718     // that a "=>" data entity initializer actually resolved to
719     // a null pointer has to be done by the caller.
720     return Fold(std::move(*value));
721   }
722   return std::nullopt;
723 }
724 
725 MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {
726   return Analyze(x.value());
727 }
728 
729 MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) {
730   if (const auto &repeat{
731           std::get<std::optional<parser::DataStmtRepeat>>(x.t)}) {
732     x.repetitions = -1;
733     if (MaybeExpr expr{Analyze(repeat->u)}) {
734       Expr<SomeType> folded{Fold(std::move(*expr))};
735       if (auto value{ToInt64(folded)}) {
736         if (*value >= 0) { // C882
737           x.repetitions = *value;
738         } else {
739           Say(FindSourceLocation(repeat),
740               "Repeat count (%jd) for data value must not be negative"_err_en_US,
741               *value);
742         }
743       }
744     }
745   }
746   return Analyze(std::get<parser::DataStmtConstant>(x.t));
747 }
748 
749 // Substring references
750 std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::GetSubstringBound(
751     const std::optional<parser::ScalarIntExpr> &bound) {
752   if (bound) {
753     if (MaybeExpr expr{Analyze(*bound)}) {
754       if (expr->Rank() > 1) {
755         Say("substring bound expression has rank %d"_err_en_US, expr->Rank());
756       }
757       if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
758         if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
759           return {std::move(*ssIntExpr)};
760         }
761         return {Expr<SubscriptInteger>{
762             Convert<SubscriptInteger, TypeCategory::Integer>{
763                 std::move(*intExpr)}}};
764       } else {
765         Say("substring bound expression is not INTEGER"_err_en_US);
766       }
767     }
768   }
769   return std::nullopt;
770 }
771 
772 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Substring &ss) {
773   if (MaybeExpr baseExpr{Analyze(std::get<parser::DataRef>(ss.t))}) {
774     if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(*baseExpr))}) {
775       if (MaybeExpr newBaseExpr{TopLevelChecks(std::move(*dataRef))}) {
776         if (std::optional<DataRef> checked{
777                 ExtractDataRef(std::move(*newBaseExpr))}) {
778           const parser::SubstringRange &range{
779               std::get<parser::SubstringRange>(ss.t)};
780           std::optional<Expr<SubscriptInteger>> first{
781               GetSubstringBound(std::get<0>(range.t))};
782           std::optional<Expr<SubscriptInteger>> last{
783               GetSubstringBound(std::get<1>(range.t))};
784           const Symbol &symbol{checked->GetLastSymbol()};
785           if (std::optional<DynamicType> dynamicType{
786                   DynamicType::From(symbol)}) {
787             if (dynamicType->category() == TypeCategory::Character) {
788               return WrapperHelper<TypeCategory::Character, Designator,
789                   Substring>(dynamicType->kind(),
790                   Substring{std::move(checked.value()), std::move(first),
791                       std::move(last)});
792             }
793           }
794           Say("substring may apply only to CHARACTER"_err_en_US);
795         }
796       }
797     }
798   }
799   return std::nullopt;
800 }
801 
802 // CHARACTER literal substrings
803 MaybeExpr ExpressionAnalyzer::Analyze(
804     const parser::CharLiteralConstantSubstring &x) {
805   const parser::SubstringRange &range{std::get<parser::SubstringRange>(x.t)};
806   std::optional<Expr<SubscriptInteger>> lower{
807       GetSubstringBound(std::get<0>(range.t))};
808   std::optional<Expr<SubscriptInteger>> upper{
809       GetSubstringBound(std::get<1>(range.t))};
810   if (MaybeExpr string{Analyze(std::get<parser::CharLiteralConstant>(x.t))}) {
811     if (auto *charExpr{std::get_if<Expr<SomeCharacter>>(&string->u)}) {
812       Expr<SubscriptInteger> length{
813           std::visit([](const auto &ckExpr) { return ckExpr.LEN().value(); },
814               charExpr->u)};
815       if (!lower) {
816         lower = Expr<SubscriptInteger>{1};
817       }
818       if (!upper) {
819         upper = Expr<SubscriptInteger>{
820             static_cast<std::int64_t>(ToInt64(length).value())};
821       }
822       return std::visit(
823           [&](auto &&ckExpr) -> MaybeExpr {
824             using Result = ResultType<decltype(ckExpr)>;
825             auto *cp{std::get_if<Constant<Result>>(&ckExpr.u)};
826             CHECK(DEREF(cp).size() == 1);
827             StaticDataObject::Pointer staticData{StaticDataObject::Create()};
828             staticData->set_alignment(Result::kind)
829                 .set_itemBytes(Result::kind)
830                 .Push(cp->GetScalarValue().value());
831             Substring substring{std::move(staticData), std::move(lower.value()),
832                 std::move(upper.value())};
833             return AsGenericExpr(
834                 Expr<Result>{Designator<Result>{std::move(substring)}});
835           },
836           std::move(charExpr->u));
837     }
838   }
839   return std::nullopt;
840 }
841 
842 // Subscripted array references
843 std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::AsSubscript(
844     MaybeExpr &&expr) {
845   if (expr) {
846     if (expr->Rank() > 1) {
847       Say("Subscript expression has rank %d greater than 1"_err_en_US,
848           expr->Rank());
849     }
850     if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
851       if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
852         return std::move(*ssIntExpr);
853       } else {
854         return Expr<SubscriptInteger>{
855             Convert<SubscriptInteger, TypeCategory::Integer>{
856                 std::move(*intExpr)}};
857       }
858     } else {
859       Say("Subscript expression is not INTEGER"_err_en_US);
860     }
861   }
862   return std::nullopt;
863 }
864 
865 std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::TripletPart(
866     const std::optional<parser::Subscript> &s) {
867   if (s) {
868     return AsSubscript(Analyze(*s));
869   } else {
870     return std::nullopt;
871   }
872 }
873 
874 std::optional<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscript(
875     const parser::SectionSubscript &ss) {
876   return std::visit(
877       common::visitors{
878           [&](const parser::SubscriptTriplet &t) -> std::optional<Subscript> {
879             const auto &lower{std::get<0>(t.t)};
880             const auto &upper{std::get<1>(t.t)};
881             const auto &stride{std::get<2>(t.t)};
882             auto result{Triplet{
883                 TripletPart(lower), TripletPart(upper), TripletPart(stride)}};
884             if ((lower && !result.lower()) || (upper && !result.upper())) {
885               return std::nullopt;
886             } else {
887               return std::make_optional<Subscript>(result);
888             }
889           },
890           [&](const auto &s) -> std::optional<Subscript> {
891             if (auto subscriptExpr{AsSubscript(Analyze(s))}) {
892               return Subscript{std::move(*subscriptExpr)};
893             } else {
894               return std::nullopt;
895             }
896           },
897       },
898       ss.u);
899 }
900 
901 // Empty result means an error occurred
902 std::vector<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscripts(
903     const std::list<parser::SectionSubscript> &sss) {
904   bool error{false};
905   std::vector<Subscript> subscripts;
906   for (const auto &s : sss) {
907     if (auto subscript{AnalyzeSectionSubscript(s)}) {
908       subscripts.emplace_back(std::move(*subscript));
909     } else {
910       error = true;
911     }
912   }
913   return !error ? subscripts : std::vector<Subscript>{};
914 }
915 
916 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayElement &ae) {
917   MaybeExpr baseExpr;
918   {
919     auto restorer{AllowWholeAssumedSizeArray()};
920     baseExpr = Analyze(ae.base);
921   }
922   if (baseExpr) {
923     if (ae.subscripts.empty()) {
924       // will be converted to function call later or error reported
925     } else if (baseExpr->Rank() == 0) {
926       if (const Symbol * symbol{GetLastSymbol(*baseExpr)}) {
927         if (!context_.HasError(symbol)) {
928           Say("'%s' is not an array"_err_en_US, symbol->name());
929           context_.SetError(*symbol);
930         }
931       }
932     } else if (std::optional<DataRef> dataRef{
933                    ExtractDataRef(std::move(*baseExpr))}) {
934       return ApplySubscripts(
935           std::move(*dataRef), AnalyzeSectionSubscripts(ae.subscripts));
936     } else {
937       Say("Subscripts may be applied only to an object, component, or array constant"_err_en_US);
938     }
939   }
940   // error was reported: analyze subscripts without reporting more errors
941   auto restorer{GetContextualMessages().DiscardMessages()};
942   AnalyzeSectionSubscripts(ae.subscripts);
943   return std::nullopt;
944 }
945 
946 // Type parameter inquiries apply to data references, but don't depend
947 // on any trailing (co)subscripts.
948 static NamedEntity IgnoreAnySubscripts(Designator<SomeDerived> &&designator) {
949   return std::visit(
950       common::visitors{
951           [](SymbolRef &&symbol) { return NamedEntity{symbol}; },
952           [](Component &&component) {
953             return NamedEntity{std::move(component)};
954           },
955           [](ArrayRef &&arrayRef) { return std::move(arrayRef.base()); },
956           [](CoarrayRef &&coarrayRef) {
957             return NamedEntity{coarrayRef.GetLastSymbol()};
958           },
959       },
960       std::move(designator.u));
961 }
962 
963 // Components of parent derived types are explicitly represented as such.
964 static std::optional<Component> CreateComponent(
965     DataRef &&base, const Symbol &component, const semantics::Scope &scope) {
966   if (&component.owner() == &scope) {
967     return Component{std::move(base), component};
968   }
969   if (const semantics::Scope * parentScope{scope.GetDerivedTypeParent()}) {
970     if (const Symbol * parentComponent{parentScope->GetSymbol()}) {
971       return CreateComponent(
972           DataRef{Component{std::move(base), *parentComponent}}, component,
973           *parentScope);
974     }
975   }
976   return std::nullopt;
977 }
978 
979 // Derived type component references and type parameter inquiries
980 MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
981   MaybeExpr base{Analyze(sc.base)};
982   Symbol *sym{sc.component.symbol};
983   if (!base || !sym || context_.HasError(sym)) {
984     return std::nullopt;
985   }
986   const auto &name{sc.component.source};
987   if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
988     const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
989     if (sym->detailsIf<semantics::TypeParamDetails>()) {
990       if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {
991         if (std::optional<DynamicType> dyType{DynamicType::From(*sym)}) {
992           if (dyType->category() == TypeCategory::Integer) {
993             auto restorer{GetContextualMessages().SetLocation(name)};
994             return Fold(ConvertToType(*dyType,
995                 AsGenericExpr(TypeParamInquiry{
996                     IgnoreAnySubscripts(std::move(*designator)), *sym})));
997           }
998         }
999         Say(name, "Type parameter is not INTEGER"_err_en_US);
1000       } else {
1001         Say(name,
1002             "A type parameter inquiry must be applied to "
1003             "a designator"_err_en_US);
1004       }
1005     } else if (!dtSpec || !dtSpec->scope()) {
1006       CHECK(context_.AnyFatalError() || !foldingContext_.messages().empty());
1007       return std::nullopt;
1008     } else if (std::optional<DataRef> dataRef{
1009                    ExtractDataRef(std::move(*dtExpr))}) {
1010       if (auto component{
1011               CreateComponent(std::move(*dataRef), *sym, *dtSpec->scope())}) {
1012         return Designate(DataRef{std::move(*component)});
1013       } else {
1014         Say(name, "Component is not in scope of derived TYPE(%s)"_err_en_US,
1015             dtSpec->typeSymbol().name());
1016       }
1017     } else {
1018       Say(name,
1019           "Base of component reference must be a data reference"_err_en_US);
1020     }
1021   } else if (auto *details{sym->detailsIf<semantics::MiscDetails>()}) {
1022     // special part-ref: %re, %im, %kind, %len
1023     // Type errors are detected and reported in semantics.
1024     using MiscKind = semantics::MiscDetails::Kind;
1025     MiscKind kind{details->kind()};
1026     if (kind == MiscKind::ComplexPartRe || kind == MiscKind::ComplexPartIm) {
1027       if (auto *zExpr{std::get_if<Expr<SomeComplex>>(&base->u)}) {
1028         if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(*zExpr))}) {
1029           Expr<SomeReal> realExpr{std::visit(
1030               [&](const auto &z) {
1031                 using PartType = typename ResultType<decltype(z)>::Part;
1032                 auto part{kind == MiscKind::ComplexPartRe
1033                         ? ComplexPart::Part::RE
1034                         : ComplexPart::Part::IM};
1035                 return AsCategoryExpr(Designator<PartType>{
1036                     ComplexPart{std::move(*dataRef), part}});
1037               },
1038               zExpr->u)};
1039           return AsGenericExpr(std::move(realExpr));
1040         }
1041       }
1042     } else if (kind == MiscKind::KindParamInquiry ||
1043         kind == MiscKind::LenParamInquiry) {
1044       // Convert x%KIND -> intrinsic KIND(x), x%LEN -> intrinsic LEN(x)
1045       return MakeFunctionRef(
1046           name, ActualArguments{ActualArgument{std::move(*base)}});
1047     } else {
1048       DIE("unexpected MiscDetails::Kind");
1049     }
1050   } else {
1051     Say(name, "derived type required before component reference"_err_en_US);
1052   }
1053   return std::nullopt;
1054 }
1055 
1056 MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
1057   if (auto maybeDataRef{ExtractDataRef(Analyze(x.base))}) {
1058     DataRef *dataRef{&*maybeDataRef};
1059     std::vector<Subscript> subscripts;
1060     SymbolVector reversed;
1061     if (auto *aRef{std::get_if<ArrayRef>(&dataRef->u)}) {
1062       subscripts = std::move(aRef->subscript());
1063       reversed.push_back(aRef->GetLastSymbol());
1064       if (Component * component{aRef->base().UnwrapComponent()}) {
1065         dataRef = &component->base();
1066       } else {
1067         dataRef = nullptr;
1068       }
1069     }
1070     if (dataRef) {
1071       while (auto *component{std::get_if<Component>(&dataRef->u)}) {
1072         reversed.push_back(component->GetLastSymbol());
1073         dataRef = &component->base();
1074       }
1075       if (auto *baseSym{std::get_if<SymbolRef>(&dataRef->u)}) {
1076         reversed.push_back(*baseSym);
1077       } else {
1078         Say("Base of coindexed named object has subscripts or cosubscripts"_err_en_US);
1079       }
1080     }
1081     std::vector<Expr<SubscriptInteger>> cosubscripts;
1082     bool cosubsOk{true};
1083     for (const auto &cosub :
1084         std::get<std::list<parser::Cosubscript>>(x.imageSelector.t)) {
1085       MaybeExpr coex{Analyze(cosub)};
1086       if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {
1087         cosubscripts.push_back(
1088             ConvertToType<SubscriptInteger>(std::move(*intExpr)));
1089       } else {
1090         cosubsOk = false;
1091       }
1092     }
1093     if (cosubsOk && !reversed.empty()) {
1094       int numCosubscripts{static_cast<int>(cosubscripts.size())};
1095       const Symbol &symbol{reversed.front()};
1096       if (numCosubscripts != symbol.Corank()) {
1097         Say("'%s' has corank %d, but coindexed reference has %d cosubscripts"_err_en_US,
1098             symbol.name(), symbol.Corank(), numCosubscripts);
1099       }
1100     }
1101     for (const auto &imageSelSpec :
1102         std::get<std::list<parser::ImageSelectorSpec>>(x.imageSelector.t)) {
1103       std::visit(
1104           common::visitors{
1105               [&](const auto &x) { Analyze(x.v); },
1106           },
1107           imageSelSpec.u);
1108     }
1109     // Reverse the chain of symbols so that the base is first and coarray
1110     // ultimate component is last.
1111     if (cosubsOk) {
1112       return Designate(
1113           DataRef{CoarrayRef{SymbolVector{reversed.crbegin(), reversed.crend()},
1114               std::move(subscripts), std::move(cosubscripts)}});
1115     }
1116   }
1117   return std::nullopt;
1118 }
1119 
1120 int ExpressionAnalyzer::IntegerTypeSpecKind(
1121     const parser::IntegerTypeSpec &spec) {
1122   Expr<SubscriptInteger> value{
1123       AnalyzeKindSelector(TypeCategory::Integer, spec.v)};
1124   if (auto kind{ToInt64(value)}) {
1125     return static_cast<int>(*kind);
1126   }
1127   SayAt(spec, "Constant INTEGER kind value required here"_err_en_US);
1128   return GetDefaultKind(TypeCategory::Integer);
1129 }
1130 
1131 // Array constructors
1132 
1133 // Inverts a collection of generic ArrayConstructorValues<SomeType> that
1134 // all happen to have the same actual type T into one ArrayConstructor<T>.
1135 template <typename T>
1136 ArrayConstructorValues<T> MakeSpecific(
1137     ArrayConstructorValues<SomeType> &&from) {
1138   ArrayConstructorValues<T> to;
1139   for (ArrayConstructorValue<SomeType> &x : from) {
1140     std::visit(
1141         common::visitors{
1142             [&](common::CopyableIndirection<Expr<SomeType>> &&expr) {
1143               auto *typed{UnwrapExpr<Expr<T>>(expr.value())};
1144               to.Push(std::move(DEREF(typed)));
1145             },
1146             [&](ImpliedDo<SomeType> &&impliedDo) {
1147               to.Push(ImpliedDo<T>{impliedDo.name(),
1148                   std::move(impliedDo.lower()), std::move(impliedDo.upper()),
1149                   std::move(impliedDo.stride()),
1150                   MakeSpecific<T>(std::move(impliedDo.values()))});
1151             },
1152         },
1153         std::move(x.u));
1154   }
1155   return to;
1156 }
1157 
1158 class ArrayConstructorContext {
1159 public:
1160   ArrayConstructorContext(
1161       ExpressionAnalyzer &c, std::optional<DynamicTypeWithLength> &&t)
1162       : exprAnalyzer_{c}, type_{std::move(t)} {}
1163 
1164   void Add(const parser::AcValue &);
1165   MaybeExpr ToExpr();
1166 
1167   // These interfaces allow *this to be used as a type visitor argument to
1168   // common::SearchTypes() to convert the array constructor to a typed
1169   // expression in ToExpr().
1170   using Result = MaybeExpr;
1171   using Types = AllTypes;
1172   template <typename T> Result Test() {
1173     if (type_ && type_->category() == T::category) {
1174       if constexpr (T::category == TypeCategory::Derived) {
1175         if (type_->IsUnlimitedPolymorphic()) {
1176           return std::nullopt;
1177         } else {
1178           return AsMaybeExpr(ArrayConstructor<T>{type_->GetDerivedTypeSpec(),
1179               MakeSpecific<T>(std::move(values_))});
1180         }
1181       } else if (type_->kind() == T::kind) {
1182         if constexpr (T::category == TypeCategory::Character) {
1183           if (auto len{type_->LEN()}) {
1184             return AsMaybeExpr(ArrayConstructor<T>{
1185                 *std::move(len), MakeSpecific<T>(std::move(values_))});
1186           }
1187         } else {
1188           return AsMaybeExpr(
1189               ArrayConstructor<T>{MakeSpecific<T>(std::move(values_))});
1190         }
1191       }
1192     }
1193     return std::nullopt;
1194   }
1195 
1196 private:
1197   using ImpliedDoIntType = ResultType<ImpliedDoIndex>;
1198 
1199   void Push(MaybeExpr &&);
1200   void Add(const parser::AcValue::Triplet &);
1201   void Add(const parser::Expr &);
1202   void Add(const parser::AcImpliedDo &);
1203   void UnrollConstantImpliedDo(const parser::AcImpliedDo &,
1204       parser::CharBlock name, std::int64_t lower, std::int64_t upper,
1205       std::int64_t stride);
1206 
1207   template <int KIND, typename A>
1208   std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(
1209       const A &x) {
1210     if (MaybeExpr y{exprAnalyzer_.Analyze(x)}) {
1211       Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};
1212       return Fold(exprAnalyzer_.GetFoldingContext(),
1213           ConvertToType<Type<TypeCategory::Integer, KIND>>(
1214               std::move(DEREF(intExpr))));
1215     }
1216     return std::nullopt;
1217   }
1218 
1219   // Nested array constructors all reference the same ExpressionAnalyzer,
1220   // which represents the nest of active implied DO loop indices.
1221   ExpressionAnalyzer &exprAnalyzer_;
1222   std::optional<DynamicTypeWithLength> type_;
1223   bool explicitType_{type_.has_value()};
1224   std::optional<std::int64_t> constantLength_;
1225   ArrayConstructorValues<SomeType> values_;
1226   std::uint64_t messageDisplayedSet_{0};
1227 };
1228 
1229 void ArrayConstructorContext::Push(MaybeExpr &&x) {
1230   if (!x) {
1231     return;
1232   }
1233   if (auto dyType{x->GetType()}) {
1234     DynamicTypeWithLength xType{*dyType};
1235     if (Expr<SomeCharacter> * charExpr{UnwrapExpr<Expr<SomeCharacter>>(*x)}) {
1236       CHECK(xType.category() == TypeCategory::Character);
1237       xType.length =
1238           std::visit([](const auto &kc) { return kc.LEN(); }, charExpr->u);
1239     }
1240     if (!type_) {
1241       // If there is no explicit type-spec in an array constructor, the type
1242       // of the array is the declared type of all of the elements, which must
1243       // be well-defined and all match.
1244       // TODO: Possible language extension: use the most general type of
1245       // the values as the type of a numeric constructed array, convert all
1246       // of the other values to that type.  Alternative: let the first value
1247       // determine the type, and convert the others to that type.
1248       CHECK(!explicitType_);
1249       type_ = std::move(xType);
1250       constantLength_ = ToInt64(type_->length);
1251       values_.Push(std::move(*x));
1252     } else if (!explicitType_) {
1253       if (static_cast<const DynamicType &>(*type_) ==
1254           static_cast<const DynamicType &>(xType)) {
1255         values_.Push(std::move(*x));
1256         if (auto thisLen{ToInt64(xType.LEN())}) {
1257           if (constantLength_) {
1258             if (exprAnalyzer_.context().warnOnNonstandardUsage() &&
1259                 *thisLen != *constantLength_) {
1260               if (!(messageDisplayedSet_ & 1)) {
1261                 exprAnalyzer_.Say(
1262                     "Character literal in array constructor without explicit "
1263                     "type has different length than earlier elements"_en_US);
1264                 messageDisplayedSet_ |= 1;
1265               }
1266             }
1267             if (*thisLen > *constantLength_) {
1268               // Language extension: use the longest literal to determine the
1269               // length of the array constructor's character elements, not the
1270               // first, when there is no explicit type.
1271               *constantLength_ = *thisLen;
1272               type_->length = xType.LEN();
1273             }
1274           } else {
1275             constantLength_ = *thisLen;
1276             type_->length = xType.LEN();
1277           }
1278         }
1279       } else {
1280         if (!(messageDisplayedSet_ & 2)) {
1281           exprAnalyzer_.Say(
1282               "Values in array constructor must have the same declared type "
1283               "when no explicit type appears"_err_en_US); // C7110
1284           messageDisplayedSet_ |= 2;
1285         }
1286       }
1287     } else {
1288       if (auto cast{ConvertToType(*type_, std::move(*x))}) {
1289         values_.Push(std::move(*cast));
1290       } else if (!(messageDisplayedSet_ & 4)) {
1291         exprAnalyzer_.Say(
1292             "Value in array constructor of type '%s' could not "
1293             "be converted to the type of the array '%s'"_err_en_US,
1294             x->GetType()->AsFortran(), type_->AsFortran()); // C7111, C7112
1295         messageDisplayedSet_ |= 4;
1296       }
1297     }
1298   }
1299 }
1300 
1301 void ArrayConstructorContext::Add(const parser::AcValue &x) {
1302   std::visit(
1303       common::visitors{
1304           [&](const parser::AcValue::Triplet &triplet) { Add(triplet); },
1305           [&](const common::Indirection<parser::Expr> &expr) {
1306             Add(expr.value());
1307           },
1308           [&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {
1309             Add(impliedDo.value());
1310           },
1311       },
1312       x.u);
1313 }
1314 
1315 // Transforms l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'
1316 void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) {
1317   std::optional<Expr<ImpliedDoIntType>> lower{
1318       GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<0>(triplet.t))};
1319   std::optional<Expr<ImpliedDoIntType>> upper{
1320       GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<1>(triplet.t))};
1321   std::optional<Expr<ImpliedDoIntType>> stride{
1322       GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<2>(triplet.t))};
1323   if (lower && upper) {
1324     if (!stride) {
1325       stride = Expr<ImpliedDoIntType>{1};
1326     }
1327     if (!type_) {
1328       type_ = DynamicTypeWithLength{ImpliedDoIntType::GetType()};
1329     }
1330     auto v{std::move(values_)};
1331     parser::CharBlock anonymous;
1332     Push(Expr<SomeType>{
1333         Expr<SomeInteger>{Expr<ImpliedDoIntType>{ImpliedDoIndex{anonymous}}}});
1334     std::swap(v, values_);
1335     values_.Push(ImpliedDo<SomeType>{anonymous, std::move(*lower),
1336         std::move(*upper), std::move(*stride), std::move(v)});
1337   }
1338 }
1339 
1340 void ArrayConstructorContext::Add(const parser::Expr &expr) {
1341   auto restorer{exprAnalyzer_.GetContextualMessages().SetLocation(expr.source)};
1342   if (MaybeExpr v{exprAnalyzer_.Analyze(expr)}) {
1343     if (auto exprType{v->GetType()}) {
1344       if (!(messageDisplayedSet_ & 8) && exprType->IsUnlimitedPolymorphic()) {
1345         exprAnalyzer_.Say("Cannot have an unlimited polymorphic value in an "
1346                           "array constructor"_err_en_US); // C7113
1347         messageDisplayedSet_ |= 8;
1348       }
1349     }
1350     Push(std::move(*v));
1351   }
1352 }
1353 
1354 void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
1355   const auto &control{std::get<parser::AcImpliedDoControl>(impliedDo.t)};
1356   const auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)};
1357   exprAnalyzer_.Analyze(bounds.name);
1358   parser::CharBlock name{bounds.name.thing.thing.source};
1359   const Symbol *symbol{bounds.name.thing.thing.symbol};
1360   int kind{ImpliedDoIntType::kind};
1361   if (const auto dynamicType{DynamicType::From(symbol)}) {
1362     kind = dynamicType->kind();
1363   }
1364   if (!exprAnalyzer_.AddImpliedDo(name, kind)) {
1365     if (!(messageDisplayedSet_ & 0x20)) {
1366       exprAnalyzer_.SayAt(name,
1367           "Implied DO index is active in surrounding implied DO loop "
1368           "and may not have the same name"_err_en_US); // C7115
1369       messageDisplayedSet_ |= 0x20;
1370     }
1371     return;
1372   }
1373   std::optional<Expr<ImpliedDoIntType>> lower{
1374       GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.lower)};
1375   std::optional<Expr<ImpliedDoIntType>> upper{
1376       GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.upper)};
1377   if (lower && upper) {
1378     std::optional<Expr<ImpliedDoIntType>> stride{
1379         GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.step)};
1380     if (!stride) {
1381       stride = Expr<ImpliedDoIntType>{1};
1382     }
1383     // Check for constant bounds; the loop may require complete unrolling
1384     // of the parse tree if all bounds are constant in order to allow the
1385     // implied DO loop index to qualify as a constant expression.
1386     auto cLower{ToInt64(lower)};
1387     auto cUpper{ToInt64(upper)};
1388     auto cStride{ToInt64(stride)};
1389     if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {
1390       exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source,
1391           "The stride of an implied DO loop must not be zero"_err_en_US);
1392       messageDisplayedSet_ |= 0x10;
1393     }
1394     bool isConstant{cLower && cUpper && cStride && *cStride != 0};
1395     bool isNonemptyConstant{isConstant &&
1396         ((*cStride > 0 && *cLower <= *cUpper) ||
1397             (*cStride < 0 && *cLower >= *cUpper))};
1398     bool unrollConstantLoop{false};
1399     parser::Messages buffer;
1400     auto saveMessagesDisplayed{messageDisplayedSet_};
1401     {
1402       auto messageRestorer{
1403           exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};
1404       auto v{std::move(values_)};
1405       for (const auto &value :
1406           std::get<std::list<parser::AcValue>>(impliedDo.t)) {
1407         Add(value);
1408       }
1409       std::swap(v, values_);
1410       if (isNonemptyConstant && buffer.AnyFatalError()) {
1411         unrollConstantLoop = true;
1412       } else {
1413         values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),
1414             std::move(*upper), std::move(*stride), std::move(v)});
1415       }
1416     }
1417     if (unrollConstantLoop) {
1418       messageDisplayedSet_ = saveMessagesDisplayed;
1419       UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);
1420     } else if (auto *messages{
1421                    exprAnalyzer_.GetContextualMessages().messages()}) {
1422       messages->Annex(std::move(buffer));
1423     }
1424   }
1425   exprAnalyzer_.RemoveImpliedDo(name);
1426 }
1427 
1428 // Fortran considers an implied DO index of an array constructor to be
1429 // a constant expression if the bounds of the implied DO loop are constant.
1430 // Usually this doesn't matter, but if we emitted spurious messages as a
1431 // result of not using constant values for the index while analyzing the
1432 // items, we need to do it again the "hard" way with multiple iterations over
1433 // the parse tree.
1434 void ArrayConstructorContext::UnrollConstantImpliedDo(
1435     const parser::AcImpliedDo &impliedDo, parser::CharBlock name,
1436     std::int64_t lower, std::int64_t upper, std::int64_t stride) {
1437   auto &foldingContext{exprAnalyzer_.GetFoldingContext()};
1438   auto restorer{exprAnalyzer_.DoNotUseSavedTypedExprs()};
1439   for (auto &at{foldingContext.StartImpliedDo(name, lower)};
1440        (stride > 0 && at <= upper) || (stride < 0 && at >= upper);
1441        at += stride) {
1442     for (const auto &value :
1443         std::get<std::list<parser::AcValue>>(impliedDo.t)) {
1444       Add(value);
1445     }
1446   }
1447   foldingContext.EndImpliedDo(name);
1448 }
1449 
1450 MaybeExpr ArrayConstructorContext::ToExpr() {
1451   return common::SearchTypes(std::move(*this));
1452 }
1453 
1454 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayConstructor &array) {
1455   const parser::AcSpec &acSpec{array.v};
1456   ArrayConstructorContext acContext{*this, AnalyzeTypeSpec(acSpec.type)};
1457   for (const parser::AcValue &value : acSpec.values) {
1458     acContext.Add(value);
1459   }
1460   return acContext.ToExpr();
1461 }
1462 
1463 MaybeExpr ExpressionAnalyzer::Analyze(
1464     const parser::StructureConstructor &structure) {
1465   auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
1466   parser::Name structureType{std::get<parser::Name>(parsedType.t)};
1467   parser::CharBlock &typeName{structureType.source};
1468   if (semantics::Symbol * typeSymbol{structureType.symbol}) {
1469     if (typeSymbol->has<semantics::DerivedTypeDetails>()) {
1470       semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};
1471       if (!CheckIsValidForwardReference(dtSpec)) {
1472         return std::nullopt;
1473       }
1474     }
1475   }
1476   if (!parsedType.derivedTypeSpec) {
1477     return std::nullopt;
1478   }
1479   const auto &spec{*parsedType.derivedTypeSpec};
1480   const Symbol &typeSymbol{spec.typeSymbol()};
1481   if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {
1482     return std::nullopt; // error recovery
1483   }
1484   const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
1485   const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
1486 
1487   if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
1488     AttachDeclaration(Say(typeName,
1489                           "ABSTRACT derived type '%s' may not be used in a "
1490                           "structure constructor"_err_en_US,
1491                           typeName),
1492         typeSymbol); // C7114
1493   }
1494 
1495   // This iterator traverses all of the components in the derived type and its
1496   // parents.  The symbols for whole parent components appear after their
1497   // own components and before the components of the types that extend them.
1498   // E.g., TYPE :: A; REAL X; END TYPE
1499   //       TYPE, EXTENDS(A) :: B; REAL Y; END TYPE
1500   // produces the component list X, A, Y.
1501   // The order is important below because a structure constructor can
1502   // initialize X or A by name, but not both.
1503   auto components{semantics::OrderedComponentIterator{spec}};
1504   auto nextAnonymous{components.begin()};
1505 
1506   std::set<parser::CharBlock> unavailable;
1507   bool anyKeyword{false};
1508   StructureConstructor result{spec};
1509   bool checkConflicts{true}; // until we hit one
1510   auto &messages{GetContextualMessages()};
1511 
1512   for (const auto &component :
1513       std::get<std::list<parser::ComponentSpec>>(structure.t)) {
1514     const parser::Expr &expr{
1515         std::get<parser::ComponentDataSource>(component.t).v.value()};
1516     parser::CharBlock source{expr.source};
1517     auto restorer{messages.SetLocation(source)};
1518     const Symbol *symbol{nullptr};
1519     MaybeExpr value{Analyze(expr)};
1520     std::optional<DynamicType> valueType{DynamicType::From(value)};
1521     if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
1522       anyKeyword = true;
1523       source = kw->v.source;
1524       symbol = kw->v.symbol;
1525       if (!symbol) {
1526         auto componentIter{std::find_if(components.begin(), components.end(),
1527             [=](const Symbol &symbol) { return symbol.name() == source; })};
1528         if (componentIter != components.end()) {
1529           symbol = &*componentIter;
1530         }
1531       }
1532       if (!symbol) { // C7101
1533         Say(source,
1534             "Keyword '%s=' does not name a component of derived type '%s'"_err_en_US,
1535             source, typeName);
1536       }
1537     } else {
1538       if (anyKeyword) { // C7100
1539         Say(source,
1540             "Value in structure constructor lacks a component name"_err_en_US);
1541         checkConflicts = false; // stem cascade
1542       }
1543       // Here's a regrettably common extension of the standard: anonymous
1544       // initialization of parent components, e.g., T(PT(1)) rather than
1545       // T(1) or T(PT=PT(1)).
1546       if (nextAnonymous == components.begin() && parentComponent &&
1547           valueType == DynamicType::From(*parentComponent) &&
1548           context().IsEnabled(LanguageFeature::AnonymousParents)) {
1549         auto iter{
1550             std::find(components.begin(), components.end(), *parentComponent)};
1551         if (iter != components.end()) {
1552           symbol = parentComponent;
1553           nextAnonymous = ++iter;
1554           if (context().ShouldWarn(LanguageFeature::AnonymousParents)) {
1555             Say(source,
1556                 "Whole parent component '%s' in structure "
1557                 "constructor should not be anonymous"_en_US,
1558                 symbol->name());
1559           }
1560         }
1561       }
1562       while (!symbol && nextAnonymous != components.end()) {
1563         const Symbol &next{*nextAnonymous};
1564         ++nextAnonymous;
1565         if (!next.test(Symbol::Flag::ParentComp)) {
1566           symbol = &next;
1567         }
1568       }
1569       if (!symbol) {
1570         Say(source, "Unexpected value in structure constructor"_err_en_US);
1571       }
1572     }
1573     if (symbol) {
1574       if (const auto *currScope{context_.globalScope().FindScope(source)}) {
1575         if (auto msg{CheckAccessibleComponent(*currScope, *symbol)}) {
1576           Say(source, *msg);
1577         }
1578       }
1579       if (checkConflicts) {
1580         auto componentIter{
1581             std::find(components.begin(), components.end(), *symbol)};
1582         if (unavailable.find(symbol->name()) != unavailable.cend()) {
1583           // C797, C798
1584           Say(source,
1585               "Component '%s' conflicts with another component earlier in "
1586               "this structure constructor"_err_en_US,
1587               symbol->name());
1588         } else if (symbol->test(Symbol::Flag::ParentComp)) {
1589           // Make earlier components unavailable once a whole parent appears.
1590           for (auto it{components.begin()}; it != componentIter; ++it) {
1591             unavailable.insert(it->name());
1592           }
1593         } else {
1594           // Make whole parent components unavailable after any of their
1595           // constituents appear.
1596           for (auto it{componentIter}; it != components.end(); ++it) {
1597             if (it->test(Symbol::Flag::ParentComp)) {
1598               unavailable.insert(it->name());
1599             }
1600           }
1601         }
1602       }
1603       unavailable.insert(symbol->name());
1604       if (value) {
1605         if (symbol->has<semantics::ProcEntityDetails>()) {
1606           CHECK(IsPointer(*symbol));
1607         } else if (symbol->has<semantics::ObjectEntityDetails>()) {
1608           // C1594(4)
1609           const auto &innermost{context_.FindScope(expr.source)};
1610           if (const auto *pureProc{FindPureProcedureContaining(innermost)}) {
1611             if (const Symbol * pointer{FindPointerComponent(*symbol)}) {
1612               if (const Symbol *
1613                   object{FindExternallyVisibleObject(*value, *pureProc)}) {
1614                 if (auto *msg{Say(expr.source,
1615                         "Externally visible object '%s' may not be "
1616                         "associated with pointer component '%s' in a "
1617                         "pure procedure"_err_en_US,
1618                         object->name(), pointer->name())}) {
1619                   msg->Attach(object->name(), "Object declaration"_en_US)
1620                       .Attach(pointer->name(), "Pointer declaration"_en_US);
1621                 }
1622               }
1623             }
1624           }
1625         } else if (symbol->has<semantics::TypeParamDetails>()) {
1626           Say(expr.source,
1627               "Type parameter '%s' may not appear as a component "
1628               "of a structure constructor"_err_en_US,
1629               symbol->name());
1630           continue;
1631         } else {
1632           Say(expr.source,
1633               "Component '%s' is neither a procedure pointer "
1634               "nor a data object"_err_en_US,
1635               symbol->name());
1636           continue;
1637         }
1638         if (IsPointer(*symbol)) {
1639           semantics::CheckPointerAssignment(
1640               GetFoldingContext(), *symbol, *value); // C7104, C7105
1641           result.Add(*symbol, Fold(std::move(*value)));
1642         } else if (MaybeExpr converted{
1643                        ConvertToType(*symbol, std::move(*value))}) {
1644           if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
1645             if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
1646               if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
1647                 AttachDeclaration(
1648                     Say(expr.source,
1649                         "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
1650                         GetRank(*valueShape), symbol->name()),
1651                     *symbol);
1652               } else if (CheckConformance(messages, *componentShape,
1653                              *valueShape, "component", "value", false,
1654                              true /* can expand scalar value */)) {
1655                 if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0 &&
1656                     !IsExpandableScalar(*converted)) {
1657                   AttachDeclaration(
1658                       Say(expr.source,
1659                           "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
1660                           symbol->name()),
1661                       *symbol);
1662                 } else {
1663                   result.Add(*symbol, std::move(*converted));
1664                 }
1665               }
1666             } else {
1667               Say(expr.source, "Shape of value cannot be determined"_err_en_US);
1668             }
1669           } else {
1670             AttachDeclaration(
1671                 Say(expr.source,
1672                     "Shape of component '%s' cannot be determined"_err_en_US,
1673                     symbol->name()),
1674                 *symbol);
1675           }
1676         } else if (IsAllocatable(*symbol) &&
1677             std::holds_alternative<NullPointer>(value->u)) {
1678           // NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE
1679         } else if (auto symType{DynamicType::From(symbol)}) {
1680           if (valueType) {
1681             AttachDeclaration(
1682                 Say(expr.source,
1683                     "Value in structure constructor of type %s is "
1684                     "incompatible with component '%s' of type %s"_err_en_US,
1685                     valueType->AsFortran(), symbol->name(),
1686                     symType->AsFortran()),
1687                 *symbol);
1688           } else {
1689             AttachDeclaration(
1690                 Say(expr.source,
1691                     "Value in structure constructor is incompatible with "
1692                     " component '%s' of type %s"_err_en_US,
1693                     symbol->name(), symType->AsFortran()),
1694                 *symbol);
1695           }
1696         }
1697       }
1698     }
1699   }
1700 
1701   // Ensure that unmentioned component objects have default initializers.
1702   for (const Symbol &symbol : components) {
1703     if (!symbol.test(Symbol::Flag::ParentComp) &&
1704         unavailable.find(symbol.name()) == unavailable.cend() &&
1705         !IsAllocatable(symbol)) {
1706       if (const auto *details{
1707               symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
1708         if (details->init()) {
1709           result.Add(symbol, common::Clone(*details->init()));
1710         } else { // C799
1711           AttachDeclaration(Say(typeName,
1712                                 "Structure constructor lacks a value for "
1713                                 "component '%s'"_err_en_US,
1714                                 symbol.name()),
1715               symbol);
1716         }
1717       }
1718     }
1719   }
1720 
1721   return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
1722 }
1723 
1724 static std::optional<parser::CharBlock> GetPassName(
1725     const semantics::Symbol &proc) {
1726   return std::visit(
1727       [](const auto &details) {
1728         if constexpr (std::is_base_of_v<semantics::WithPassArg,
1729                           std::decay_t<decltype(details)>>) {
1730           return details.passName();
1731         } else {
1732           return std::optional<parser::CharBlock>{};
1733         }
1734       },
1735       proc.details());
1736 }
1737 
1738 static int GetPassIndex(const Symbol &proc) {
1739   CHECK(!proc.attrs().test(semantics::Attr::NOPASS));
1740   std::optional<parser::CharBlock> passName{GetPassName(proc)};
1741   const auto *interface{semantics::FindInterface(proc)};
1742   if (!passName || !interface) {
1743     return 0; // first argument is passed-object
1744   }
1745   const auto &subp{interface->get<semantics::SubprogramDetails>()};
1746   int index{0};
1747   for (const auto *arg : subp.dummyArgs()) {
1748     if (arg && arg->name() == passName) {
1749       return index;
1750     }
1751     ++index;
1752   }
1753   DIE("PASS argument name not in dummy argument list");
1754 }
1755 
1756 // Injects an expression into an actual argument list as the "passed object"
1757 // for a type-bound procedure reference that is not NOPASS.  Adds an
1758 // argument keyword if possible, but not when the passed object goes
1759 // before a positional argument.
1760 // e.g., obj%tbp(x) -> tbp(obj,x).
1761 static void AddPassArg(ActualArguments &actuals, const Expr<SomeDerived> &expr,
1762     const Symbol &component, bool isPassedObject = true) {
1763   if (component.attrs().test(semantics::Attr::NOPASS)) {
1764     return;
1765   }
1766   int passIndex{GetPassIndex(component)};
1767   auto iter{actuals.begin()};
1768   int at{0};
1769   while (iter < actuals.end() && at < passIndex) {
1770     if (*iter && (*iter)->keyword()) {
1771       iter = actuals.end();
1772       break;
1773     }
1774     ++iter;
1775     ++at;
1776   }
1777   ActualArgument passed{AsGenericExpr(common::Clone(expr))};
1778   passed.set_isPassedObject(isPassedObject);
1779   if (iter == actuals.end()) {
1780     if (auto passName{GetPassName(component)}) {
1781       passed.set_keyword(*passName);
1782     }
1783   }
1784   actuals.emplace(iter, std::move(passed));
1785 }
1786 
1787 // Return the compile-time resolution of a procedure binding, if possible.
1788 static const Symbol *GetBindingResolution(
1789     const std::optional<DynamicType> &baseType, const Symbol &component) {
1790   const auto *binding{component.detailsIf<semantics::ProcBindingDetails>()};
1791   if (!binding) {
1792     return nullptr;
1793   }
1794   if (!component.attrs().test(semantics::Attr::NON_OVERRIDABLE) &&
1795       (!baseType || baseType->IsPolymorphic())) {
1796     return nullptr;
1797   }
1798   return &binding->symbol();
1799 }
1800 
1801 auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
1802     const parser::ProcComponentRef &pcr, ActualArguments &&arguments)
1803     -> std::optional<CalleeAndArguments> {
1804   const parser::StructureComponent &sc{pcr.v.thing};
1805   if (MaybeExpr base{Analyze(sc.base)}) {
1806     if (const Symbol * sym{sc.component.symbol}) {
1807       if (context_.HasError(sym)) {
1808         return std::nullopt;
1809       }
1810       if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
1811         if (sym->has<semantics::GenericDetails>()) {
1812           AdjustActuals adjustment{
1813               [&](const Symbol &proc, ActualArguments &actuals) {
1814                 if (!proc.attrs().test(semantics::Attr::NOPASS)) {
1815                   AddPassArg(actuals, std::move(*dtExpr), proc);
1816                 }
1817                 return true;
1818               }};
1819           sym = ResolveGeneric(*sym, arguments, adjustment);
1820           if (!sym) {
1821             EmitGenericResolutionError(*sc.component.symbol);
1822             return std::nullopt;
1823           }
1824         }
1825         if (const Symbol *
1826             resolution{GetBindingResolution(dtExpr->GetType(), *sym)}) {
1827           AddPassArg(arguments, std::move(*dtExpr), *sym, false);
1828           return CalleeAndArguments{
1829               ProcedureDesignator{*resolution}, std::move(arguments)};
1830         } else if (std::optional<DataRef> dataRef{
1831                        ExtractDataRef(std::move(*dtExpr))}) {
1832           if (sym->attrs().test(semantics::Attr::NOPASS)) {
1833             return CalleeAndArguments{
1834                 ProcedureDesignator{Component{std::move(*dataRef), *sym}},
1835                 std::move(arguments)};
1836           } else {
1837             AddPassArg(arguments,
1838                 Expr<SomeDerived>{Designator<SomeDerived>{std::move(*dataRef)}},
1839                 *sym);
1840             return CalleeAndArguments{
1841                 ProcedureDesignator{*sym}, std::move(arguments)};
1842           }
1843         }
1844       }
1845       Say(sc.component.source,
1846           "Base of procedure component reference is not a derived-type object"_err_en_US);
1847     }
1848   }
1849   CHECK(!GetContextualMessages().empty());
1850   return std::nullopt;
1851 }
1852 
1853 // Can actual be argument associated with dummy?
1854 static bool CheckCompatibleArgument(bool isElemental,
1855     const ActualArgument &actual, const characteristics::DummyArgument &dummy) {
1856   return std::visit(
1857       common::visitors{
1858           [&](const characteristics::DummyDataObject &x) {
1859             if (!isElemental && actual.Rank() != x.type.Rank() &&
1860                 !x.type.attrs().test(
1861                     characteristics::TypeAndShape::Attr::AssumedRank)) {
1862               return false;
1863             } else if (auto actualType{actual.GetType()}) {
1864               return x.type.type().IsTkCompatibleWith(*actualType);
1865             } else {
1866               return false;
1867             }
1868           },
1869           [&](const characteristics::DummyProcedure &) {
1870             const auto *expr{actual.UnwrapExpr()};
1871             return expr && IsProcedurePointerTarget(*expr);
1872           },
1873           [&](const characteristics::AlternateReturn &) {
1874             return actual.isAlternateReturn();
1875           },
1876       },
1877       dummy.u);
1878 }
1879 
1880 // Are the actual arguments compatible with the dummy arguments of procedure?
1881 static bool CheckCompatibleArguments(
1882     const characteristics::Procedure &procedure,
1883     const ActualArguments &actuals) {
1884   bool isElemental{procedure.IsElemental()};
1885   const auto &dummies{procedure.dummyArguments};
1886   CHECK(dummies.size() == actuals.size());
1887   for (std::size_t i{0}; i < dummies.size(); ++i) {
1888     const characteristics::DummyArgument &dummy{dummies[i]};
1889     const std::optional<ActualArgument> &actual{actuals[i]};
1890     if (actual && !CheckCompatibleArgument(isElemental, *actual, dummy)) {
1891       return false;
1892     }
1893   }
1894   return true;
1895 }
1896 
1897 // Handles a forward reference to a module function from what must
1898 // be a specification expression.  Return false if the symbol is
1899 // an invalid forward reference.
1900 bool ExpressionAnalyzer::ResolveForward(const Symbol &symbol) {
1901   if (context_.HasError(symbol)) {
1902     return false;
1903   }
1904   if (const auto *details{
1905           symbol.detailsIf<semantics::SubprogramNameDetails>()}) {
1906     if (details->kind() == semantics::SubprogramKind::Module) {
1907       // If this symbol is still a SubprogramNameDetails, we must be
1908       // checking a specification expression in a sibling module
1909       // procedure.  Resolve its names now so that its interface
1910       // is known.
1911       semantics::ResolveSpecificationParts(context_, symbol);
1912       if (symbol.has<semantics::SubprogramNameDetails>()) {
1913         // When the symbol hasn't had its details updated, we must have
1914         // already been in the process of resolving the function's
1915         // specification part; but recursive function calls are not
1916         // allowed in specification parts (10.1.11 para 5).
1917         Say("The module function '%s' may not be referenced recursively in a specification expression"_err_en_US,
1918             symbol.name());
1919         context_.SetError(symbol);
1920         return false;
1921       }
1922     } else { // 10.1.11 para 4
1923       Say("The internal function '%s' may not be referenced in a specification expression"_err_en_US,
1924           symbol.name());
1925       context_.SetError(symbol);
1926       return false;
1927     }
1928   }
1929   return true;
1930 }
1931 
1932 // Resolve a call to a generic procedure with given actual arguments.
1933 // adjustActuals is called on procedure bindings to handle pass arg.
1934 const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
1935     const ActualArguments &actuals, const AdjustActuals &adjustActuals,
1936     bool mightBeStructureConstructor) {
1937   const Symbol *elemental{nullptr}; // matching elemental specific proc
1938   const auto &details{symbol.GetUltimate().get<semantics::GenericDetails>()};
1939   for (const Symbol &specific : details.specificProcs()) {
1940     if (!ResolveForward(specific)) {
1941       continue;
1942     }
1943     if (std::optional<characteristics::Procedure> procedure{
1944             characteristics::Procedure::Characterize(
1945                 ProcedureDesignator{specific}, context_.foldingContext())}) {
1946       ActualArguments localActuals{actuals};
1947       if (specific.has<semantics::ProcBindingDetails>()) {
1948         if (!adjustActuals.value()(specific, localActuals)) {
1949           continue;
1950         }
1951       }
1952       if (semantics::CheckInterfaceForGeneric(
1953               *procedure, localActuals, GetFoldingContext())) {
1954         if (CheckCompatibleArguments(*procedure, localActuals)) {
1955           if (!procedure->IsElemental()) {
1956             // takes priority over elemental match
1957             return &AccessSpecific(symbol, specific);
1958           }
1959           elemental = &specific;
1960         }
1961       }
1962     }
1963   }
1964   if (elemental) {
1965     return &AccessSpecific(symbol, *elemental);
1966   }
1967   // Check parent derived type
1968   if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
1969     if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
1970       if (extended->GetUltimate().has<semantics::GenericDetails>()) {
1971         if (const Symbol *
1972             result{ResolveGeneric(*extended, actuals, adjustActuals, false)}) {
1973           return result;
1974         }
1975       }
1976     }
1977   }
1978   if (mightBeStructureConstructor && details.derivedType()) {
1979     return details.derivedType();
1980   }
1981   return nullptr;
1982 }
1983 
1984 const Symbol &ExpressionAnalyzer::AccessSpecific(
1985     const Symbol &originalGeneric, const Symbol &specific) {
1986   if (const auto *hosted{
1987           originalGeneric.detailsIf<semantics::HostAssocDetails>()}) {
1988     return AccessSpecific(hosted->symbol(), specific);
1989   } else if (const auto *used{
1990                  originalGeneric.detailsIf<semantics::UseDetails>()}) {
1991     const auto &scope{originalGeneric.owner()};
1992     if (auto iter{scope.find(specific.name())}; iter != scope.end()) {
1993       if (const auto *useDetails{
1994               iter->second->detailsIf<semantics::UseDetails>()}) {
1995         const Symbol &usedSymbol{useDetails->symbol()};
1996         const auto *usedGeneric{
1997             usedSymbol.detailsIf<semantics::GenericDetails>()};
1998         if (&usedSymbol == &specific ||
1999             (usedGeneric && usedGeneric->specific() == &specific)) {
2000           return specific;
2001         }
2002       }
2003     }
2004     // Create a renaming USE of the specific procedure.
2005     auto rename{context_.SaveTempName(
2006         used->symbol().owner().GetName().value().ToString() + "$" +
2007         specific.name().ToString())};
2008     return *const_cast<semantics::Scope &>(scope)
2009                 .try_emplace(rename, specific.attrs(),
2010                     semantics::UseDetails{rename, specific})
2011                 .first->second;
2012   } else {
2013     return specific;
2014   }
2015 }
2016 
2017 void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol) {
2018   if (semantics::IsGenericDefinedOp(symbol)) {
2019     Say("No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US,
2020         symbol.name());
2021   } else {
2022     Say("No specific procedure of generic '%s' matches the actual arguments"_err_en_US,
2023         symbol.name());
2024   }
2025 }
2026 
2027 auto ExpressionAnalyzer::GetCalleeAndArguments(
2028     const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
2029     bool isSubroutine, bool mightBeStructureConstructor)
2030     -> std::optional<CalleeAndArguments> {
2031   return std::visit(
2032       common::visitors{
2033           [&](const parser::Name &name) {
2034             return GetCalleeAndArguments(name, std::move(arguments),
2035                 isSubroutine, mightBeStructureConstructor);
2036           },
2037           [&](const parser::ProcComponentRef &pcr) {
2038             return AnalyzeProcedureComponentRef(pcr, std::move(arguments));
2039           },
2040       },
2041       pd.u);
2042 }
2043 
2044 auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
2045     ActualArguments &&arguments, bool isSubroutine,
2046     bool mightBeStructureConstructor) -> std::optional<CalleeAndArguments> {
2047   const Symbol *symbol{name.symbol};
2048   if (context_.HasError(symbol)) {
2049     return std::nullopt; // also handles null symbol
2050   }
2051   const Symbol &ultimate{DEREF(symbol).GetUltimate()};
2052   if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
2053     if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
2054             CallCharacteristics{ultimate.name().ToString(), isSubroutine},
2055             arguments, GetFoldingContext())}) {
2056       CheckBadExplicitType(*specificCall, *symbol);
2057       return CalleeAndArguments{
2058           ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
2059           std::move(specificCall->arguments)};
2060     }
2061   } else {
2062     CheckForBadRecursion(name.source, ultimate);
2063     if (ultimate.has<semantics::GenericDetails>()) {
2064       ExpressionAnalyzer::AdjustActuals noAdjustment;
2065       symbol = ResolveGeneric(
2066           *symbol, arguments, noAdjustment, mightBeStructureConstructor);
2067     }
2068     if (symbol) {
2069       if (symbol->GetUltimate().has<semantics::DerivedTypeDetails>()) {
2070         if (mightBeStructureConstructor) {
2071           return CalleeAndArguments{
2072               semantics::SymbolRef{*symbol}, std::move(arguments)};
2073         }
2074       } else {
2075         return CalleeAndArguments{
2076             ProcedureDesignator{*symbol}, std::move(arguments)};
2077       }
2078     } else if (std::optional<SpecificCall> specificCall{
2079                    context_.intrinsics().Probe(
2080                        CallCharacteristics{
2081                            ultimate.name().ToString(), isSubroutine},
2082                        arguments, GetFoldingContext())}) {
2083       // Generics can extend intrinsics
2084       return CalleeAndArguments{
2085           ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
2086           std::move(specificCall->arguments)};
2087     } else {
2088       EmitGenericResolutionError(*name.symbol);
2089     }
2090   }
2091   return std::nullopt;
2092 }
2093 
2094 // Fortran 2018 expressly states (8.2 p3) that any declared type for a
2095 // generic intrinsic function "has no effect" on the result type of a
2096 // call to that intrinsic.  So one can declare "character*8 cos" and
2097 // still get a real result from "cos(1.)".  This is a dangerous feature,
2098 // especially since implementations are free to extend their sets of
2099 // intrinsics, and in doing so might clash with a name in a program.
2100 // So we emit a warning in this situation, and perhaps it should be an
2101 // error -- any correctly working program can silence the message by
2102 // simply deleting the pointless type declaration.
2103 void ExpressionAnalyzer::CheckBadExplicitType(
2104     const SpecificCall &call, const Symbol &intrinsic) {
2105   if (intrinsic.GetUltimate().GetType()) {
2106     const auto &procedure{call.specificIntrinsic.characteristics.value()};
2107     if (const auto &result{procedure.functionResult}) {
2108       if (const auto *typeAndShape{result->GetTypeAndShape()}) {
2109         if (auto declared{
2110                 typeAndShape->Characterize(intrinsic, GetFoldingContext())}) {
2111           if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) {
2112             if (auto *msg{Say(
2113                     "The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_en_US,
2114                     typeAndShape->AsFortran(), intrinsic.name(),
2115                     declared->AsFortran())}) {
2116               msg->Attach(intrinsic.name(),
2117                   "Ignored declaration of intrinsic function '%s'"_en_US,
2118                   intrinsic.name());
2119             }
2120           }
2121         }
2122       }
2123     }
2124   }
2125 }
2126 
2127 void ExpressionAnalyzer::CheckForBadRecursion(
2128     parser::CharBlock callSite, const semantics::Symbol &proc) {
2129   if (const auto *scope{proc.scope()}) {
2130     if (scope->sourceRange().Contains(callSite)) {
2131       parser::Message *msg{nullptr};
2132       if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)
2133         msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
2134             callSite);
2135       } else if (IsAssumedLengthCharacter(proc) && IsExternal(proc)) {
2136         msg = Say( // 15.6.2.1(3)
2137             "Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
2138             callSite);
2139       }
2140       AttachDeclaration(msg, proc);
2141     }
2142   }
2143 }
2144 
2145 template <typename A> static const Symbol *AssumedTypeDummy(const A &x) {
2146   if (const auto *designator{
2147           std::get_if<common::Indirection<parser::Designator>>(&x.u)}) {
2148     if (const auto *dataRef{
2149             std::get_if<parser::DataRef>(&designator->value().u)}) {
2150       if (const auto *name{std::get_if<parser::Name>(&dataRef->u)}) {
2151         return AssumedTypeDummy(*name);
2152       }
2153     }
2154   }
2155   return nullptr;
2156 }
2157 template <>
2158 const Symbol *AssumedTypeDummy<parser::Name>(const parser::Name &name) {
2159   if (const Symbol * symbol{name.symbol}) {
2160     if (const auto *type{symbol->GetType()}) {
2161       if (type->category() == semantics::DeclTypeSpec::TypeStar) {
2162         return symbol;
2163       }
2164     }
2165   }
2166   return nullptr;
2167 }
2168 template <typename A>
2169 static const Symbol *AssumedTypePointerOrAllocatableDummy(const A &object) {
2170   // It is illegal for allocatable of pointer objects to be TYPE(*), but at that
2171   // point it is is not guaranteed that it has been checked the object has
2172   // POINTER or ALLOCATABLE attribute, so do not assume nullptr can be directly
2173   // returned.
2174   return std::visit(
2175       common::visitors{
2176           [&](const parser::StructureComponent &x) {
2177             return AssumedTypeDummy(x.component);
2178           },
2179           [&](const parser::Name &x) { return AssumedTypeDummy(x); },
2180       },
2181       object.u);
2182 }
2183 template <>
2184 const Symbol *AssumedTypeDummy<parser::AllocateObject>(
2185     const parser::AllocateObject &x) {
2186   return AssumedTypePointerOrAllocatableDummy(x);
2187 }
2188 template <>
2189 const Symbol *AssumedTypeDummy<parser::PointerObject>(
2190     const parser::PointerObject &x) {
2191   return AssumedTypePointerOrAllocatableDummy(x);
2192 }
2193 
2194 bool ExpressionAnalyzer::CheckIsValidForwardReference(
2195     const semantics::DerivedTypeSpec &dtSpec) {
2196   if (dtSpec.IsForwardReferenced()) {
2197     Say("Cannot construct value for derived type '%s' "
2198         "before it is defined"_err_en_US,
2199         dtSpec.name());
2200     return false;
2201   }
2202   return true;
2203 }
2204 
2205 MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,
2206     std::optional<parser::StructureConstructor> *structureConstructor) {
2207   const parser::Call &call{funcRef.v};
2208   auto restorer{GetContextualMessages().SetLocation(call.source)};
2209   ArgumentAnalyzer analyzer{*this, call.source, true /* isProcedureCall */};
2210   for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
2211     analyzer.Analyze(arg, false /* not subroutine call */);
2212   }
2213   if (analyzer.fatalErrors()) {
2214     return std::nullopt;
2215   }
2216   if (std::optional<CalleeAndArguments> callee{
2217           GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
2218               analyzer.GetActuals(), false /* not subroutine */,
2219               true /* might be structure constructor */)}) {
2220     if (auto *proc{std::get_if<ProcedureDesignator>(&callee->u)}) {
2221       return MakeFunctionRef(
2222           call.source, std::move(*proc), std::move(callee->arguments));
2223     } else if (structureConstructor) {
2224       // Structure constructor misparsed as function reference?
2225       CHECK(std::holds_alternative<semantics::SymbolRef>(callee->u));
2226       const Symbol &derivedType{*std::get<semantics::SymbolRef>(callee->u)};
2227       const auto &designator{std::get<parser::ProcedureDesignator>(call.t)};
2228       if (const auto *name{std::get_if<parser::Name>(&designator.u)}) {
2229         semantics::Scope &scope{context_.FindScope(name->source)};
2230         semantics::DerivedTypeSpec dtSpec{
2231             name->source, derivedType.GetUltimate()};
2232         if (!CheckIsValidForwardReference(dtSpec)) {
2233           return std::nullopt;
2234         }
2235         const semantics::DeclTypeSpec &type{
2236             semantics::FindOrInstantiateDerivedType(scope, std::move(dtSpec))};
2237         auto &mutableRef{const_cast<parser::FunctionReference &>(funcRef)};
2238         *structureConstructor =
2239             mutableRef.ConvertToStructureConstructor(type.derivedTypeSpec());
2240         return Analyze(structureConstructor->value());
2241       }
2242     }
2243   }
2244   return std::nullopt;
2245 }
2246 
2247 static bool HasAlternateReturns(const evaluate::ActualArguments &args) {
2248   for (const auto &arg : args) {
2249     if (arg && arg->isAlternateReturn()) {
2250       return true;
2251     }
2252   }
2253   return false;
2254 }
2255 
2256 void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
2257   const parser::Call &call{callStmt.v};
2258   auto restorer{GetContextualMessages().SetLocation(call.source)};
2259   ArgumentAnalyzer analyzer{*this, call.source, true /* isProcedureCall */};
2260   const auto &actualArgList{std::get<std::list<parser::ActualArgSpec>>(call.t)};
2261   for (const auto &arg : actualArgList) {
2262     analyzer.Analyze(arg, true /* is subroutine call */);
2263   }
2264   if (!analyzer.fatalErrors()) {
2265     if (std::optional<CalleeAndArguments> callee{
2266             GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
2267                 analyzer.GetActuals(), true /* subroutine */)}) {
2268       ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};
2269       CHECK(proc);
2270       if (CheckCall(call.source, *proc, callee->arguments)) {
2271         bool hasAlternateReturns{HasAlternateReturns(callee->arguments)};
2272         callStmt.typedCall.Reset(
2273             new ProcedureRef{std::move(*proc), std::move(callee->arguments),
2274                 hasAlternateReturns},
2275             ProcedureRef::Deleter);
2276       }
2277     }
2278   }
2279 }
2280 
2281 const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
2282   if (!x.typedAssignment) {
2283     ArgumentAnalyzer analyzer{*this};
2284     analyzer.Analyze(std::get<parser::Variable>(x.t));
2285     analyzer.Analyze(std::get<parser::Expr>(x.t));
2286     if (analyzer.fatalErrors()) {
2287       x.typedAssignment.Reset(
2288           new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);
2289     } else {
2290       std::optional<ProcedureRef> procRef{analyzer.TryDefinedAssignment()};
2291       Assignment assignment{analyzer.MoveExpr(0), analyzer.MoveExpr(1)};
2292       if (procRef) {
2293         assignment.u = std::move(*procRef);
2294       }
2295       x.typedAssignment.Reset(
2296           new GenericAssignmentWrapper{std::move(assignment)},
2297           GenericAssignmentWrapper::Deleter);
2298     }
2299   }
2300   return common::GetPtrFromOptional(x.typedAssignment->v);
2301 }
2302 
2303 const Assignment *ExpressionAnalyzer::Analyze(
2304     const parser::PointerAssignmentStmt &x) {
2305   if (!x.typedAssignment) {
2306     MaybeExpr lhs{Analyze(std::get<parser::DataRef>(x.t))};
2307     MaybeExpr rhs{Analyze(std::get<parser::Expr>(x.t))};
2308     if (!lhs || !rhs) {
2309       x.typedAssignment.Reset(
2310           new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);
2311     } else {
2312       Assignment assignment{std::move(*lhs), std::move(*rhs)};
2313       std::visit(common::visitors{
2314                      [&](const std::list<parser::BoundsRemapping> &list) {
2315                        Assignment::BoundsRemapping bounds;
2316                        for (const auto &elem : list) {
2317                          auto lower{AsSubscript(Analyze(std::get<0>(elem.t)))};
2318                          auto upper{AsSubscript(Analyze(std::get<1>(elem.t)))};
2319                          if (lower && upper) {
2320                            bounds.emplace_back(Fold(std::move(*lower)),
2321                                Fold(std::move(*upper)));
2322                          }
2323                        }
2324                        assignment.u = std::move(bounds);
2325                      },
2326                      [&](const std::list<parser::BoundsSpec> &list) {
2327                        Assignment::BoundsSpec bounds;
2328                        for (const auto &bound : list) {
2329                          if (auto lower{AsSubscript(Analyze(bound.v))}) {
2330                            bounds.emplace_back(Fold(std::move(*lower)));
2331                          }
2332                        }
2333                        assignment.u = std::move(bounds);
2334                      },
2335                  },
2336           std::get<parser::PointerAssignmentStmt::Bounds>(x.t).u);
2337       x.typedAssignment.Reset(
2338           new GenericAssignmentWrapper{std::move(assignment)},
2339           GenericAssignmentWrapper::Deleter);
2340     }
2341   }
2342   return common::GetPtrFromOptional(x.typedAssignment->v);
2343 }
2344 
2345 static bool IsExternalCalledImplicitly(
2346     parser::CharBlock callSite, const ProcedureDesignator &proc) {
2347   if (const auto *symbol{proc.GetSymbol()}) {
2348     return symbol->has<semantics::SubprogramDetails>() &&
2349         symbol->owner().IsGlobal() &&
2350         (!symbol->scope() /*ENTRY*/ ||
2351             !symbol->scope()->sourceRange().Contains(callSite));
2352   } else {
2353     return false;
2354   }
2355 }
2356 
2357 std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
2358     parser::CharBlock callSite, const ProcedureDesignator &proc,
2359     ActualArguments &arguments) {
2360   auto chars{characteristics::Procedure::Characterize(
2361       proc, context_.foldingContext())};
2362   if (chars) {
2363     bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
2364     if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) {
2365       Say(callSite,
2366           "References to the procedure '%s' require an explicit interface"_en_US,
2367           DEREF(proc.GetSymbol()).name());
2368     }
2369     // Checks for ASSOCIATED() are done in intrinsic table processing
2370     bool procIsAssociated{false};
2371     if (const SpecificIntrinsic *
2372         specificIntrinsic{proc.GetSpecificIntrinsic()}) {
2373       if (specificIntrinsic->name == "associated") {
2374         procIsAssociated = true;
2375       }
2376     }
2377     if (!procIsAssociated) {
2378       semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
2379           context_.FindScope(callSite), treatExternalAsImplicit,
2380           proc.GetSpecificIntrinsic());
2381       const Symbol *procSymbol{proc.GetSymbol()};
2382       if (procSymbol && !IsPureProcedure(*procSymbol)) {
2383         if (const semantics::Scope *
2384             pure{semantics::FindPureProcedureContaining(
2385                 context_.FindScope(callSite))}) {
2386           Say(callSite,
2387               "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US,
2388               procSymbol->name(), DEREF(pure->symbol()).name());
2389         }
2390       }
2391     }
2392   }
2393   return chars;
2394 }
2395 
2396 // Unary operations
2397 
2398 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
2399   if (MaybeExpr operand{Analyze(x.v.value())}) {
2400     if (const semantics::Symbol * symbol{GetLastSymbol(*operand)}) {
2401       if (const semantics::Symbol * result{FindFunctionResult(*symbol)}) {
2402         if (semantics::IsProcedurePointer(*result)) {
2403           Say("A function reference that returns a procedure "
2404               "pointer may not be parenthesized"_err_en_US); // C1003
2405         }
2406       }
2407     }
2408     return Parenthesize(std::move(*operand));
2409   }
2410   return std::nullopt;
2411 }
2412 
2413 static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
2414     NumericOperator opr, const parser::Expr::IntrinsicUnary &x) {
2415   ArgumentAnalyzer analyzer{context};
2416   analyzer.Analyze(x.v);
2417   if (analyzer.fatalErrors()) {
2418     return std::nullopt;
2419   } else if (analyzer.IsIntrinsicNumeric(opr)) {
2420     if (opr == NumericOperator::Add) {
2421       return analyzer.MoveExpr(0);
2422     } else {
2423       return Negation(context.GetContextualMessages(), analyzer.MoveExpr(0));
2424     }
2425   } else {
2426     return analyzer.TryDefinedOp(AsFortran(opr),
2427         "Operand of unary %s must be numeric; have %s"_err_en_US);
2428   }
2429 }
2430 
2431 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
2432   return NumericUnaryHelper(*this, NumericOperator::Add, x);
2433 }
2434 
2435 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Negate &x) {
2436   return NumericUnaryHelper(*this, NumericOperator::Subtract, x);
2437 }
2438 
2439 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
2440   ArgumentAnalyzer analyzer{*this};
2441   analyzer.Analyze(x.v);
2442   if (analyzer.fatalErrors()) {
2443     return std::nullopt;
2444   } else if (analyzer.IsIntrinsicLogical()) {
2445     return AsGenericExpr(
2446         LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));
2447   } else {
2448     return analyzer.TryDefinedOp(LogicalOperator::Not,
2449         "Operand of %s must be LOGICAL; have %s"_err_en_US);
2450   }
2451 }
2452 
2453 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
2454   // Represent %LOC() exactly as if it had been a call to the LOC() extension
2455   // intrinsic function.
2456   // Use the actual source for the name of the call for error reporting.
2457   std::optional<ActualArgument> arg;
2458   if (const Symbol * assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
2459     arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
2460   } else if (MaybeExpr argExpr{Analyze(x.v.value())}) {
2461     arg = ActualArgument{std::move(*argExpr)};
2462   } else {
2463     return std::nullopt;
2464   }
2465   parser::CharBlock at{GetContextualMessages().at()};
2466   CHECK(at.size() >= 4);
2467   parser::CharBlock loc{at.begin() + 1, 3};
2468   CHECK(loc == "loc");
2469   return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
2470 }
2471 
2472 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
2473   const auto &name{std::get<parser::DefinedOpName>(x.t).v};
2474   ArgumentAnalyzer analyzer{*this, name.source};
2475   analyzer.Analyze(std::get<1>(x.t));
2476   return analyzer.TryDefinedOp(name.source.ToString().c_str(),
2477       "No operator %s defined for %s"_err_en_US, true);
2478 }
2479 
2480 // Binary (dyadic) operations
2481 
2482 template <template <typename> class OPR>
2483 MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
2484     const parser::Expr::IntrinsicBinary &x) {
2485   ArgumentAnalyzer analyzer{context};
2486   analyzer.Analyze(std::get<0>(x.t));
2487   analyzer.Analyze(std::get<1>(x.t));
2488   if (analyzer.fatalErrors()) {
2489     return std::nullopt;
2490   } else if (analyzer.IsIntrinsicNumeric(opr)) {
2491     analyzer.CheckConformance();
2492     return NumericOperation<OPR>(context.GetContextualMessages(),
2493         analyzer.MoveExpr(0), analyzer.MoveExpr(1),
2494         context.GetDefaultKind(TypeCategory::Real));
2495   } else {
2496     return analyzer.TryDefinedOp(AsFortran(opr),
2497         "Operands of %s must be numeric; have %s and %s"_err_en_US);
2498   }
2499 }
2500 
2501 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Power &x) {
2502   return NumericBinaryHelper<Power>(*this, NumericOperator::Power, x);
2503 }
2504 
2505 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Multiply &x) {
2506   return NumericBinaryHelper<Multiply>(*this, NumericOperator::Multiply, x);
2507 }
2508 
2509 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Divide &x) {
2510   return NumericBinaryHelper<Divide>(*this, NumericOperator::Divide, x);
2511 }
2512 
2513 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Add &x) {
2514   return NumericBinaryHelper<Add>(*this, NumericOperator::Add, x);
2515 }
2516 
2517 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {
2518   return NumericBinaryHelper<Subtract>(*this, NumericOperator::Subtract, x);
2519 }
2520 
2521 MaybeExpr ExpressionAnalyzer::Analyze(
2522     const parser::Expr::ComplexConstructor &x) {
2523   auto re{Analyze(std::get<0>(x.t).value())};
2524   auto im{Analyze(std::get<1>(x.t).value())};
2525   if (re && im) {
2526     ConformabilityCheck(GetContextualMessages(), *re, *im);
2527   }
2528   return AsMaybeExpr(ConstructComplex(GetContextualMessages(), std::move(re),
2529       std::move(im), GetDefaultKind(TypeCategory::Real)));
2530 }
2531 
2532 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
2533   ArgumentAnalyzer analyzer{*this};
2534   analyzer.Analyze(std::get<0>(x.t));
2535   analyzer.Analyze(std::get<1>(x.t));
2536   if (analyzer.fatalErrors()) {
2537     return std::nullopt;
2538   } else if (analyzer.IsIntrinsicConcat()) {
2539     return std::visit(
2540         [&](auto &&x, auto &&y) -> MaybeExpr {
2541           using T = ResultType<decltype(x)>;
2542           if constexpr (std::is_same_v<T, ResultType<decltype(y)>>) {
2543             return AsGenericExpr(Concat<T::kind>{std::move(x), std::move(y)});
2544           } else {
2545             DIE("different types for intrinsic concat");
2546           }
2547         },
2548         std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(0).u).u),
2549         std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(1).u).u));
2550   } else {
2551     return analyzer.TryDefinedOp("//",
2552         "Operands of %s must be CHARACTER with the same kind; have %s and %s"_err_en_US);
2553   }
2554 }
2555 
2556 // The Name represents a user-defined intrinsic operator.
2557 // If the actuals match one of the specific procedures, return a function ref.
2558 // Otherwise report the error in messages.
2559 MaybeExpr ExpressionAnalyzer::AnalyzeDefinedOp(
2560     const parser::Name &name, ActualArguments &&actuals) {
2561   if (auto callee{GetCalleeAndArguments(name, std::move(actuals))}) {
2562     CHECK(std::holds_alternative<ProcedureDesignator>(callee->u));
2563     return MakeFunctionRef(name.source,
2564         std::move(std::get<ProcedureDesignator>(callee->u)),
2565         std::move(callee->arguments));
2566   } else {
2567     return std::nullopt;
2568   }
2569 }
2570 
2571 MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
2572     const parser::Expr::IntrinsicBinary &x) {
2573   ArgumentAnalyzer analyzer{context};
2574   analyzer.Analyze(std::get<0>(x.t));
2575   analyzer.Analyze(std::get<1>(x.t));
2576   if (analyzer.fatalErrors()) {
2577     return std::nullopt;
2578   } else {
2579     if (IsNullPointer(analyzer.GetExpr(0)) ||
2580         IsNullPointer(analyzer.GetExpr(1))) {
2581       context.Say("NULL() not allowed as an operand of a relational "
2582                   "operator"_err_en_US);
2583       return std::nullopt;
2584     }
2585     std::optional<DynamicType> leftType{analyzer.GetType(0)};
2586     std::optional<DynamicType> rightType{analyzer.GetType(1)};
2587     analyzer.ConvertBOZ(0, rightType);
2588     analyzer.ConvertBOZ(1, leftType);
2589     if (analyzer.IsIntrinsicRelational(opr)) {
2590       return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
2591           analyzer.MoveExpr(0), analyzer.MoveExpr(1)));
2592     } else if (leftType && leftType->category() == TypeCategory::Logical &&
2593         rightType && rightType->category() == TypeCategory::Logical) {
2594       context.Say("LOGICAL operands must be compared using .EQV. or "
2595                   ".NEQV."_err_en_US);
2596       return std::nullopt;
2597     } else {
2598       return analyzer.TryDefinedOp(opr,
2599           "Operands of %s must have comparable types; have %s and %s"_err_en_US);
2600     }
2601   }
2602 }
2603 
2604 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LT &x) {
2605   return RelationHelper(*this, RelationalOperator::LT, x);
2606 }
2607 
2608 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LE &x) {
2609   return RelationHelper(*this, RelationalOperator::LE, x);
2610 }
2611 
2612 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQ &x) {
2613   return RelationHelper(*this, RelationalOperator::EQ, x);
2614 }
2615 
2616 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NE &x) {
2617   return RelationHelper(*this, RelationalOperator::NE, x);
2618 }
2619 
2620 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GE &x) {
2621   return RelationHelper(*this, RelationalOperator::GE, x);
2622 }
2623 
2624 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GT &x) {
2625   return RelationHelper(*this, RelationalOperator::GT, x);
2626 }
2627 
2628 MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,
2629     const parser::Expr::IntrinsicBinary &x) {
2630   ArgumentAnalyzer analyzer{context};
2631   analyzer.Analyze(std::get<0>(x.t));
2632   analyzer.Analyze(std::get<1>(x.t));
2633   if (analyzer.fatalErrors()) {
2634     return std::nullopt;
2635   } else if (analyzer.IsIntrinsicLogical()) {
2636     return AsGenericExpr(BinaryLogicalOperation(opr,
2637         std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),
2638         std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));
2639   } else {
2640     return analyzer.TryDefinedOp(
2641         opr, "Operands of %s must be LOGICAL; have %s and %s"_err_en_US);
2642   }
2643 }
2644 
2645 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::AND &x) {
2646   return LogicalBinaryHelper(*this, LogicalOperator::And, x);
2647 }
2648 
2649 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::OR &x) {
2650   return LogicalBinaryHelper(*this, LogicalOperator::Or, x);
2651 }
2652 
2653 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQV &x) {
2654   return LogicalBinaryHelper(*this, LogicalOperator::Eqv, x);
2655 }
2656 
2657 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NEQV &x) {
2658   return LogicalBinaryHelper(*this, LogicalOperator::Neqv, x);
2659 }
2660 
2661 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
2662   const auto &name{std::get<parser::DefinedOpName>(x.t).v};
2663   ArgumentAnalyzer analyzer{*this, name.source};
2664   analyzer.Analyze(std::get<1>(x.t));
2665   analyzer.Analyze(std::get<2>(x.t));
2666   return analyzer.TryDefinedOp(name.source.ToString().c_str(),
2667       "No operator %s defined for %s and %s"_err_en_US, true);
2668 }
2669 
2670 static void CheckFuncRefToArrayElementRefHasSubscripts(
2671     semantics::SemanticsContext &context,
2672     const parser::FunctionReference &funcRef) {
2673   // Emit message if the function reference fix will end up an array element
2674   // reference with no subscripts because it will not be possible to later tell
2675   // the difference in expressions between empty subscript list due to bad
2676   // subscripts error recovery or because the user did not put any.
2677   if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {
2678     auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
2679     const auto *name{std::get_if<parser::Name>(&proc.u)};
2680     if (!name) {
2681       name = &std::get<parser::ProcComponentRef>(proc.u).v.thing.component;
2682     }
2683     auto &msg{context.Say(funcRef.v.source,
2684         name->symbol && name->symbol->Rank() == 0
2685             ? "'%s' is not a function"_err_en_US
2686             : "Reference to array '%s' with empty subscript list"_err_en_US,
2687         name->source)};
2688     if (name->symbol) {
2689       if (semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)) {
2690         msg.Attach(name->source,
2691             "A result variable must be declared with RESULT to allow recursive "
2692             "function calls"_en_US);
2693       } else {
2694         AttachDeclaration(&msg, *name->symbol);
2695       }
2696     }
2697   }
2698 }
2699 
2700 // Converts, if appropriate, an original misparse of ambiguous syntax like
2701 // A(1) as a function reference into an array reference.
2702 // Misparse structure constructors are detected elsewhere after generic
2703 // function call resolution fails.
2704 template <typename... A>
2705 static void FixMisparsedFunctionReference(
2706     semantics::SemanticsContext &context, const std::variant<A...> &constU) {
2707   // The parse tree is updated in situ when resolving an ambiguous parse.
2708   using uType = std::decay_t<decltype(constU)>;
2709   auto &u{const_cast<uType &>(constU)};
2710   if (auto *func{
2711           std::get_if<common::Indirection<parser::FunctionReference>>(&u)}) {
2712     parser::FunctionReference &funcRef{func->value()};
2713     auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
2714     if (Symbol *
2715         origSymbol{
2716             std::visit(common::visitors{
2717                            [&](parser::Name &name) { return name.symbol; },
2718                            [&](parser::ProcComponentRef &pcr) {
2719                              return pcr.v.thing.component.symbol;
2720                            },
2721                        },
2722                 proc.u)}) {
2723       Symbol &symbol{origSymbol->GetUltimate()};
2724       if (symbol.has<semantics::ObjectEntityDetails>() ||
2725           symbol.has<semantics::AssocEntityDetails>()) {
2726         // Note that expression in AssocEntityDetails cannot be a procedure
2727         // pointer as per C1105 so this cannot be a function reference.
2728         if constexpr (common::HasMember<common::Indirection<parser::Designator>,
2729                           uType>) {
2730           CheckFuncRefToArrayElementRefHasSubscripts(context, funcRef);
2731           u = common::Indirection{funcRef.ConvertToArrayElementRef()};
2732         } else {
2733           DIE("can't fix misparsed function as array reference");
2734         }
2735       }
2736     }
2737   }
2738 }
2739 
2740 // Common handling of parse tree node types that retain the
2741 // representation of the analyzed expression.
2742 template <typename PARSED>
2743 MaybeExpr ExpressionAnalyzer::ExprOrVariable(
2744     const PARSED &x, parser::CharBlock source) {
2745   if (useSavedTypedExprs_ && x.typedExpr) {
2746     return x.typedExpr->v;
2747   }
2748   auto restorer{GetContextualMessages().SetLocation(source)};
2749   if constexpr (std::is_same_v<PARSED, parser::Expr> ||
2750       std::is_same_v<PARSED, parser::Variable>) {
2751     FixMisparsedFunctionReference(context_, x.u);
2752   }
2753   if (AssumedTypeDummy(x)) { // C710
2754     Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
2755   } else if (MaybeExpr result{Analyze(x.u)}) {
2756     SetExpr(x, Fold(std::move(*result)));
2757     return x.typedExpr->v;
2758   }
2759   ResetExpr(x);
2760   if (!context_.AnyFatalError()) {
2761     std::string buf;
2762     llvm::raw_string_ostream dump{buf};
2763     parser::DumpTree(dump, x);
2764     Say("Internal error: Expression analysis failed on: %s"_err_en_US,
2765         dump.str());
2766   }
2767   return std::nullopt;
2768 }
2769 
2770 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {
2771   auto restorer{GetContextualMessages().SetLocation(expr.source)};
2772   return ExprOrVariable(expr, expr.source);
2773 }
2774 
2775 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Variable &variable) {
2776   auto restorer{GetContextualMessages().SetLocation(variable.GetSource())};
2777   return ExprOrVariable(variable, variable.GetSource());
2778 }
2779 
2780 MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtConstant &x) {
2781   auto restorer{GetContextualMessages().SetLocation(x.source)};
2782   return ExprOrVariable(x, x.source);
2783 }
2784 
2785 MaybeExpr ExpressionAnalyzer::Analyze(const parser::AllocateObject &x) {
2786   parser::CharBlock source{parser::FindSourceLocation(x)};
2787   auto restorer{GetContextualMessages().SetLocation(source)};
2788   return ExprOrVariable(x, source);
2789 }
2790 
2791 MaybeExpr ExpressionAnalyzer::Analyze(const parser::PointerObject &x) {
2792   parser::CharBlock source{parser::FindSourceLocation(x)};
2793   auto restorer{GetContextualMessages().SetLocation(source)};
2794   return ExprOrVariable(x, source);
2795 }
2796 
2797 Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
2798     TypeCategory category,
2799     const std::optional<parser::KindSelector> &selector) {
2800   int defaultKind{GetDefaultKind(category)};
2801   if (!selector) {
2802     return Expr<SubscriptInteger>{defaultKind};
2803   }
2804   return std::visit(
2805       common::visitors{
2806           [&](const parser::ScalarIntConstantExpr &x) {
2807             if (MaybeExpr kind{Analyze(x)}) {
2808               if (std::optional<std::int64_t> code{ToInt64(*kind)}) {
2809                 if (CheckIntrinsicKind(category, *code)) {
2810                   return Expr<SubscriptInteger>{*code};
2811                 }
2812               } else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(*kind)}) {
2813                 return ConvertToType<SubscriptInteger>(std::move(*intExpr));
2814               }
2815             }
2816             return Expr<SubscriptInteger>{defaultKind};
2817           },
2818           [&](const parser::KindSelector::StarSize &x) {
2819             std::intmax_t size = x.v;
2820             if (!CheckIntrinsicSize(category, size)) {
2821               size = defaultKind;
2822             } else if (category == TypeCategory::Complex) {
2823               size /= 2;
2824             }
2825             return Expr<SubscriptInteger>{size};
2826           },
2827       },
2828       selector->u);
2829 }
2830 
2831 int ExpressionAnalyzer::GetDefaultKind(common::TypeCategory category) {
2832   return context_.GetDefaultKind(category);
2833 }
2834 
2835 DynamicType ExpressionAnalyzer::GetDefaultKindOfType(
2836     common::TypeCategory category) {
2837   return {category, GetDefaultKind(category)};
2838 }
2839 
2840 bool ExpressionAnalyzer::CheckIntrinsicKind(
2841     TypeCategory category, std::int64_t kind) {
2842   if (IsValidKindOfIntrinsicType(category, kind)) { // C712, C714, C715, C727
2843     return true;
2844   } else {
2845     Say("%s(KIND=%jd) is not a supported type"_err_en_US,
2846         ToUpperCase(EnumToString(category)), kind);
2847     return false;
2848   }
2849 }
2850 
2851 bool ExpressionAnalyzer::CheckIntrinsicSize(
2852     TypeCategory category, std::int64_t size) {
2853   if (category == TypeCategory::Complex) {
2854     // COMPLEX*16 == COMPLEX(KIND=8)
2855     if (size % 2 == 0 && IsValidKindOfIntrinsicType(category, size / 2)) {
2856       return true;
2857     }
2858   } else if (IsValidKindOfIntrinsicType(category, size)) {
2859     return true;
2860   }
2861   Say("%s*%jd is not a supported type"_err_en_US,
2862       ToUpperCase(EnumToString(category)), size);
2863   return false;
2864 }
2865 
2866 bool ExpressionAnalyzer::AddImpliedDo(parser::CharBlock name, int kind) {
2867   return impliedDos_.insert(std::make_pair(name, kind)).second;
2868 }
2869 
2870 void ExpressionAnalyzer::RemoveImpliedDo(parser::CharBlock name) {
2871   auto iter{impliedDos_.find(name)};
2872   if (iter != impliedDos_.end()) {
2873     impliedDos_.erase(iter);
2874   }
2875 }
2876 
2877 std::optional<int> ExpressionAnalyzer::IsImpliedDo(
2878     parser::CharBlock name) const {
2879   auto iter{impliedDos_.find(name)};
2880   if (iter != impliedDos_.cend()) {
2881     return {iter->second};
2882   } else {
2883     return std::nullopt;
2884   }
2885 }
2886 
2887 bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
2888     const MaybeExpr &result, TypeCategory category, bool defaultKind) {
2889   if (result) {
2890     if (auto type{result->GetType()}) {
2891       if (type->category() != category) { // C885
2892         Say(at, "Must have %s type, but is %s"_err_en_US,
2893             ToUpperCase(EnumToString(category)),
2894             ToUpperCase(type->AsFortran()));
2895         return false;
2896       } else if (defaultKind) {
2897         int kind{context_.GetDefaultKind(category)};
2898         if (type->kind() != kind) {
2899           Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,
2900               kind, ToUpperCase(EnumToString(category)),
2901               ToUpperCase(type->AsFortran()));
2902           return false;
2903         }
2904       }
2905     } else {
2906       Say(at, "Must have %s type, but is typeless"_err_en_US,
2907           ToUpperCase(EnumToString(category)));
2908       return false;
2909     }
2910   }
2911   return true;
2912 }
2913 
2914 MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,
2915     ProcedureDesignator &&proc, ActualArguments &&arguments) {
2916   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc.u)}) {
2917     if (intrinsic->name == "null" && arguments.empty()) {
2918       return Expr<SomeType>{NullPointer{}};
2919     }
2920   }
2921   if (const Symbol * symbol{proc.GetSymbol()}) {
2922     if (!ResolveForward(*symbol)) {
2923       return std::nullopt;
2924     }
2925   }
2926   if (auto chars{CheckCall(callSite, proc, arguments)}) {
2927     if (chars->functionResult) {
2928       const auto &result{*chars->functionResult};
2929       if (result.IsProcedurePointer()) {
2930         return Expr<SomeType>{
2931             ProcedureRef{std::move(proc), std::move(arguments)}};
2932       } else {
2933         // Not a procedure pointer, so type and shape are known.
2934         return TypedWrapper<FunctionRef, ProcedureRef>(
2935             DEREF(result.GetTypeAndShape()).type(),
2936             ProcedureRef{std::move(proc), std::move(arguments)});
2937       }
2938     }
2939   }
2940   return std::nullopt;
2941 }
2942 
2943 MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
2944     parser::CharBlock intrinsic, ActualArguments &&arguments) {
2945   if (std::optional<SpecificCall> specificCall{
2946           context_.intrinsics().Probe(CallCharacteristics{intrinsic.ToString()},
2947               arguments, context_.foldingContext())}) {
2948     return MakeFunctionRef(intrinsic,
2949         ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
2950         std::move(specificCall->arguments));
2951   } else {
2952     return std::nullopt;
2953   }
2954 }
2955 
2956 void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
2957   source_.ExtendToCover(x.GetSource());
2958   if (MaybeExpr expr{context_.Analyze(x)}) {
2959     if (!IsConstantExpr(*expr)) {
2960       actuals_.emplace_back(std::move(*expr));
2961       return;
2962     }
2963     const Symbol *symbol{GetLastSymbol(*expr)};
2964     if (!symbol) {
2965       context_.SayAt(x, "Assignment to constant '%s' is not allowed"_err_en_US,
2966           x.GetSource());
2967     } else if (auto *subp{symbol->detailsIf<semantics::SubprogramDetails>()}) {
2968       auto *msg{context_.SayAt(x,
2969           "Assignment to subprogram '%s' is not allowed"_err_en_US,
2970           symbol->name())};
2971       if (subp->isFunction()) {
2972         const auto &result{subp->result().name()};
2973         msg->Attach(result, "Function result is '%s'"_err_en_US, result);
2974       }
2975     } else {
2976       context_.SayAt(x, "Assignment to constant '%s' is not allowed"_err_en_US,
2977           symbol->name());
2978     }
2979   }
2980   fatalErrors_ = true;
2981 }
2982 
2983 void ArgumentAnalyzer::Analyze(
2984     const parser::ActualArgSpec &arg, bool isSubroutine) {
2985   // TODO: Actual arguments that are procedures and procedure pointers need to
2986   // be detected and represented (they're not expressions).
2987   // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
2988   std::optional<ActualArgument> actual;
2989   std::visit(common::visitors{
2990                  [&](const common::Indirection<parser::Expr> &x) {
2991                    // TODO: Distinguish & handle procedure name and
2992                    // proc-component-ref
2993                    actual = AnalyzeExpr(x.value());
2994                  },
2995                  [&](const parser::AltReturnSpec &label) {
2996                    if (!isSubroutine) {
2997                      context_.Say(
2998                          "alternate return specification may not appear on"
2999                          " function reference"_err_en_US);
3000                    }
3001                    actual = ActualArgument(label.v);
3002                  },
3003                  [&](const parser::ActualArg::PercentRef &) {
3004                    context_.Say("TODO: %REF() argument"_err_en_US);
3005                  },
3006                  [&](const parser::ActualArg::PercentVal &) {
3007                    context_.Say("TODO: %VAL() argument"_err_en_US);
3008                  },
3009              },
3010       std::get<parser::ActualArg>(arg.t).u);
3011   if (actual) {
3012     if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {
3013       actual->set_keyword(argKW->v.source);
3014     }
3015     actuals_.emplace_back(std::move(*actual));
3016   } else {
3017     fatalErrors_ = true;
3018   }
3019 }
3020 
3021 bool ArgumentAnalyzer::IsIntrinsicRelational(RelationalOperator opr) const {
3022   CHECK(actuals_.size() == 2);
3023   return semantics::IsIntrinsicRelational(
3024       opr, *GetType(0), GetRank(0), *GetType(1), GetRank(1));
3025 }
3026 
3027 bool ArgumentAnalyzer::IsIntrinsicNumeric(NumericOperator opr) const {
3028   std::optional<DynamicType> type0{GetType(0)};
3029   if (actuals_.size() == 1) {
3030     if (IsBOZLiteral(0)) {
3031       return opr == NumericOperator::Add;
3032     } else {
3033       return type0 && semantics::IsIntrinsicNumeric(*type0);
3034     }
3035   } else {
3036     std::optional<DynamicType> type1{GetType(1)};
3037     if (IsBOZLiteral(0) && type1) {
3038       auto cat1{type1->category()};
3039       return cat1 == TypeCategory::Integer || cat1 == TypeCategory::Real;
3040     } else if (IsBOZLiteral(1) && type0) { // Integer/Real opr BOZ
3041       auto cat0{type0->category()};
3042       return cat0 == TypeCategory::Integer || cat0 == TypeCategory::Real;
3043     } else {
3044       return type0 && type1 &&
3045           semantics::IsIntrinsicNumeric(*type0, GetRank(0), *type1, GetRank(1));
3046     }
3047   }
3048 }
3049 
3050 bool ArgumentAnalyzer::IsIntrinsicLogical() const {
3051   if (actuals_.size() == 1) {
3052     return semantics::IsIntrinsicLogical(*GetType(0));
3053     return GetType(0)->category() == TypeCategory::Logical;
3054   } else {
3055     return semantics::IsIntrinsicLogical(
3056         *GetType(0), GetRank(0), *GetType(1), GetRank(1));
3057   }
3058 }
3059 
3060 bool ArgumentAnalyzer::IsIntrinsicConcat() const {
3061   return semantics::IsIntrinsicConcat(
3062       *GetType(0), GetRank(0), *GetType(1), GetRank(1));
3063 }
3064 
3065 bool ArgumentAnalyzer::CheckConformance() const {
3066   if (actuals_.size() == 2) {
3067     const auto *lhs{actuals_.at(0).value().UnwrapExpr()};
3068     const auto *rhs{actuals_.at(1).value().UnwrapExpr()};
3069     if (lhs && rhs) {
3070       auto &foldingContext{context_.GetFoldingContext()};
3071       auto lhShape{GetShape(foldingContext, *lhs)};
3072       auto rhShape{GetShape(foldingContext, *rhs)};
3073       if (lhShape && rhShape) {
3074         return evaluate::CheckConformance(foldingContext.messages(), *lhShape,
3075             *rhShape, "left operand", "right operand", true,
3076             true /* scalar expansion is allowed */);
3077       }
3078     }
3079   }
3080   return true; // no proven problem
3081 }
3082 
3083 MaybeExpr ArgumentAnalyzer::TryDefinedOp(
3084     const char *opr, parser::MessageFixedText &&error, bool isUserOp) {
3085   if (AnyUntypedOrMissingOperand()) {
3086     context_.Say(
3087         std::move(error), ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
3088     return std::nullopt;
3089   }
3090   {
3091     auto restorer{context_.GetContextualMessages().DiscardMessages()};
3092     std::string oprNameString{
3093         isUserOp ? std::string{opr} : "operator("s + opr + ')'};
3094     parser::CharBlock oprName{oprNameString};
3095     const auto &scope{context_.context().FindScope(source_)};
3096     if (Symbol * symbol{scope.FindSymbol(oprName)}) {
3097       parser::Name name{symbol->name(), symbol};
3098       if (auto result{context_.AnalyzeDefinedOp(name, GetActuals())}) {
3099         return result;
3100       }
3101       sawDefinedOp_ = symbol;
3102     }
3103     for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
3104       if (const Symbol * symbol{FindBoundOp(oprName, passIndex)}) {
3105         if (MaybeExpr result{TryBoundOp(*symbol, passIndex)}) {
3106           return result;
3107         }
3108       }
3109     }
3110   }
3111   if (sawDefinedOp_) {
3112     SayNoMatch(ToUpperCase(sawDefinedOp_->name().ToString()));
3113   } else if (actuals_.size() == 1 || AreConformable()) {
3114     context_.Say(
3115         std::move(error), ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
3116   } else {
3117     context_.Say(
3118         "Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,
3119         ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());
3120   }
3121   return std::nullopt;
3122 }
3123 
3124 MaybeExpr ArgumentAnalyzer::TryDefinedOp(
3125     std::vector<const char *> oprs, parser::MessageFixedText &&error) {
3126   for (std::size_t i{1}; i < oprs.size(); ++i) {
3127     auto restorer{context_.GetContextualMessages().DiscardMessages()};
3128     if (auto result{TryDefinedOp(oprs[i], std::move(error))}) {
3129       return result;
3130     }
3131   }
3132   return TryDefinedOp(oprs[0], std::move(error));
3133 }
3134 
3135 MaybeExpr ArgumentAnalyzer::TryBoundOp(const Symbol &symbol, int passIndex) {
3136   ActualArguments localActuals{actuals_};
3137   const Symbol *proc{GetBindingResolution(GetType(passIndex), symbol)};
3138   if (!proc) {
3139     proc = &symbol;
3140     localActuals.at(passIndex).value().set_isPassedObject();
3141   }
3142   CheckConformance();
3143   return context_.MakeFunctionRef(
3144       source_, ProcedureDesignator{*proc}, std::move(localActuals));
3145 }
3146 
3147 std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
3148   using semantics::Tristate;
3149   const Expr<SomeType> &lhs{GetExpr(0)};
3150   const Expr<SomeType> &rhs{GetExpr(1)};
3151   std::optional<DynamicType> lhsType{lhs.GetType()};
3152   std::optional<DynamicType> rhsType{rhs.GetType()};
3153   int lhsRank{lhs.Rank()};
3154   int rhsRank{rhs.Rank()};
3155   Tristate isDefined{
3156       semantics::IsDefinedAssignment(lhsType, lhsRank, rhsType, rhsRank)};
3157   if (isDefined == Tristate::No) {
3158     if (lhsType && rhsType) {
3159       AddAssignmentConversion(*lhsType, *rhsType);
3160     }
3161     return std::nullopt; // user-defined assignment not allowed for these args
3162   }
3163   auto restorer{context_.GetContextualMessages().SetLocation(source_)};
3164   if (std::optional<ProcedureRef> procRef{GetDefinedAssignmentProc()}) {
3165     context_.CheckCall(source_, procRef->proc(), procRef->arguments());
3166     return std::move(*procRef);
3167   }
3168   if (isDefined == Tristate::Yes) {
3169     if (!lhsType || !rhsType || (lhsRank != rhsRank && rhsRank != 0) ||
3170         !OkLogicalIntegerAssignment(lhsType->category(), rhsType->category())) {
3171       SayNoMatch("ASSIGNMENT(=)", true);
3172     }
3173   }
3174   return std::nullopt;
3175 }
3176 
3177 bool ArgumentAnalyzer::OkLogicalIntegerAssignment(
3178     TypeCategory lhs, TypeCategory rhs) {
3179   if (!context_.context().languageFeatures().IsEnabled(
3180           common::LanguageFeature::LogicalIntegerAssignment)) {
3181     return false;
3182   }
3183   std::optional<parser::MessageFixedText> msg;
3184   if (lhs == TypeCategory::Integer && rhs == TypeCategory::Logical) {
3185     // allow assignment to LOGICAL from INTEGER as a legacy extension
3186     msg = "nonstandard usage: assignment of LOGICAL to INTEGER"_en_US;
3187   } else if (lhs == TypeCategory::Logical && rhs == TypeCategory::Integer) {
3188     // ... and assignment to LOGICAL from INTEGER
3189     msg = "nonstandard usage: assignment of INTEGER to LOGICAL"_en_US;
3190   } else {
3191     return false;
3192   }
3193   if (context_.context().languageFeatures().ShouldWarn(
3194           common::LanguageFeature::LogicalIntegerAssignment)) {
3195     context_.Say(std::move(*msg));
3196   }
3197   return true;
3198 }
3199 
3200 std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
3201   auto restorer{context_.GetContextualMessages().DiscardMessages()};
3202   std::string oprNameString{"assignment(=)"};
3203   parser::CharBlock oprName{oprNameString};
3204   const Symbol *proc{nullptr};
3205   const auto &scope{context_.context().FindScope(source_)};
3206   if (const Symbol * symbol{scope.FindSymbol(oprName)}) {
3207     ExpressionAnalyzer::AdjustActuals noAdjustment;
3208     if (const Symbol *
3209         specific{context_.ResolveGeneric(*symbol, actuals_, noAdjustment)}) {
3210       proc = specific;
3211     } else {
3212       context_.EmitGenericResolutionError(*symbol);
3213     }
3214   }
3215   int passedObjectIndex{-1};
3216   for (std::size_t i{0}; i < actuals_.size(); ++i) {
3217     if (const Symbol * specific{FindBoundOp(oprName, i)}) {
3218       if (const Symbol *
3219           resolution{GetBindingResolution(GetType(i), *specific)}) {
3220         proc = resolution;
3221       } else {
3222         proc = specific;
3223         passedObjectIndex = i;
3224       }
3225     }
3226   }
3227   if (!proc) {
3228     return std::nullopt;
3229   }
3230   ActualArguments actualsCopy{actuals_};
3231   if (passedObjectIndex >= 0) {
3232     actualsCopy[passedObjectIndex]->set_isPassedObject();
3233   }
3234   return ProcedureRef{ProcedureDesignator{*proc}, std::move(actualsCopy)};
3235 }
3236 
3237 void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {
3238   os << "source_: " << source_.ToString() << " fatalErrors_ = " << fatalErrors_
3239      << '\n';
3240   for (const auto &actual : actuals_) {
3241     if (!actual.has_value()) {
3242       os << "- error\n";
3243     } else if (const Symbol * symbol{actual->GetAssumedTypeDummy()}) {
3244       os << "- assumed type: " << symbol->name().ToString() << '\n';
3245     } else if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {
3246       expr->AsFortran(os << "- expr: ") << '\n';
3247     } else {
3248       DIE("bad ActualArgument");
3249     }
3250   }
3251 }
3252 
3253 std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
3254     const parser::Expr &expr) {
3255   source_.ExtendToCover(expr.source);
3256   if (const Symbol * assumedTypeDummy{AssumedTypeDummy(expr)}) {
3257     expr.typedExpr.Reset(new GenericExprWrapper{}, GenericExprWrapper::Deleter);
3258     if (isProcedureCall_) {
3259       return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
3260     }
3261     context_.SayAt(expr.source,
3262         "TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
3263   } else if (MaybeExpr argExpr{AnalyzeExprOrWholeAssumedSizeArray(expr)}) {
3264     if (isProcedureCall_ || !IsProcedure(*argExpr)) {
3265       return ActualArgument{std::move(*argExpr)};
3266     }
3267     context_.SayAt(expr.source,
3268         IsFunction(*argExpr) ? "Function call must have argument list"_err_en_US
3269                              : "Subroutine name is not allowed here"_err_en_US);
3270   }
3271   return std::nullopt;
3272 }
3273 
3274 MaybeExpr ArgumentAnalyzer::AnalyzeExprOrWholeAssumedSizeArray(
3275     const parser::Expr &expr) {
3276   // If an expression's parse tree is a whole assumed-size array:
3277   //   Expr -> Designator -> DataRef -> Name
3278   // treat it as a special case for argument passing and bypass
3279   // the C1002/C1014 constraint checking in expression semantics.
3280   if (const auto *name{parser::Unwrap<parser::Name>(expr)}) {
3281     if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) {
3282       auto restorer{context_.AllowWholeAssumedSizeArray()};
3283       return context_.Analyze(expr);
3284     }
3285   }
3286   return context_.Analyze(expr);
3287 }
3288 
3289 bool ArgumentAnalyzer::AreConformable() const {
3290   CHECK(!fatalErrors_ && actuals_.size() == 2);
3291   return evaluate::AreConformable(*actuals_[0], *actuals_[1]);
3292 }
3293 
3294 // Look for a type-bound operator in the type of arg number passIndex.
3295 const Symbol *ArgumentAnalyzer::FindBoundOp(
3296     parser::CharBlock oprName, int passIndex) {
3297   const auto *type{GetDerivedTypeSpec(GetType(passIndex))};
3298   if (!type || !type->scope()) {
3299     return nullptr;
3300   }
3301   const Symbol *symbol{type->scope()->FindComponent(oprName)};
3302   if (!symbol) {
3303     return nullptr;
3304   }
3305   sawDefinedOp_ = symbol;
3306   ExpressionAnalyzer::AdjustActuals adjustment{
3307       [&](const Symbol &proc, ActualArguments &) {
3308         return passIndex == GetPassIndex(proc);
3309       }};
3310   const Symbol *result{context_.ResolveGeneric(*symbol, actuals_, adjustment)};
3311   if (!result) {
3312     context_.EmitGenericResolutionError(*symbol);
3313   }
3314   return result;
3315 }
3316 
3317 // If there is an implicit conversion between intrinsic types, make it explicit
3318 void ArgumentAnalyzer::AddAssignmentConversion(
3319     const DynamicType &lhsType, const DynamicType &rhsType) {
3320   if (lhsType.category() == rhsType.category() &&
3321       lhsType.kind() == rhsType.kind()) {
3322     // no conversion necessary
3323   } else if (auto rhsExpr{evaluate::ConvertToType(lhsType, MoveExpr(1))}) {
3324     actuals_[1] = ActualArgument{*rhsExpr};
3325   } else {
3326     actuals_[1] = std::nullopt;
3327   }
3328 }
3329 
3330 std::optional<DynamicType> ArgumentAnalyzer::GetType(std::size_t i) const {
3331   return i < actuals_.size() ? actuals_[i].value().GetType() : std::nullopt;
3332 }
3333 int ArgumentAnalyzer::GetRank(std::size_t i) const {
3334   return i < actuals_.size() ? actuals_[i].value().Rank() : 0;
3335 }
3336 
3337 // If the argument at index i is a BOZ literal, convert its type to match the
3338 // otherType.  It it's REAL convert to REAL, otherwise convert to INTEGER.
3339 // Note that IBM supports comparing BOZ literals to CHARACTER operands.  That
3340 // is not currently supported.
3341 void ArgumentAnalyzer::ConvertBOZ(
3342     std::size_t i, std::optional<DynamicType> otherType) {
3343   if (IsBOZLiteral(i)) {
3344     Expr<SomeType> &&argExpr{MoveExpr(i)};
3345     auto *boz{std::get_if<BOZLiteralConstant>(&argExpr.u)};
3346     if (otherType && otherType->category() == TypeCategory::Real) {
3347       MaybeExpr realExpr{ConvertToKind<TypeCategory::Real>(
3348           context_.context().GetDefaultKind(TypeCategory::Real),
3349           std::move(*boz))};
3350       actuals_[i] = std::move(*realExpr);
3351     } else {
3352       MaybeExpr intExpr{ConvertToKind<TypeCategory::Integer>(
3353           context_.context().GetDefaultKind(TypeCategory::Integer),
3354           std::move(*boz))};
3355       actuals_[i] = std::move(*intExpr);
3356     }
3357   }
3358 }
3359 
3360 // Report error resolving opr when there is a user-defined one available
3361 void ArgumentAnalyzer::SayNoMatch(const std::string &opr, bool isAssignment) {
3362   std::string type0{TypeAsFortran(0)};
3363   auto rank0{actuals_[0]->Rank()};
3364   if (actuals_.size() == 1) {
3365     if (rank0 > 0) {
3366       context_.Say("No intrinsic or user-defined %s matches "
3367                    "rank %d array of %s"_err_en_US,
3368           opr, rank0, type0);
3369     } else {
3370       context_.Say("No intrinsic or user-defined %s matches "
3371                    "operand type %s"_err_en_US,
3372           opr, type0);
3373     }
3374   } else {
3375     std::string type1{TypeAsFortran(1)};
3376     auto rank1{actuals_[1]->Rank()};
3377     if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {
3378       context_.Say("No intrinsic or user-defined %s matches "
3379                    "rank %d array of %s and rank %d array of %s"_err_en_US,
3380           opr, rank0, type0, rank1, type1);
3381     } else if (isAssignment && rank0 != rank1) {
3382       if (rank0 == 0) {
3383         context_.Say("No intrinsic or user-defined %s matches "
3384                      "scalar %s and rank %d array of %s"_err_en_US,
3385             opr, type0, rank1, type1);
3386       } else {
3387         context_.Say("No intrinsic or user-defined %s matches "
3388                      "rank %d array of %s and scalar %s"_err_en_US,
3389             opr, rank0, type0, type1);
3390       }
3391     } else {
3392       context_.Say("No intrinsic or user-defined %s matches "
3393                    "operand types %s and %s"_err_en_US,
3394           opr, type0, type1);
3395     }
3396   }
3397 }
3398 
3399 std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
3400   if (i >= actuals_.size() || !actuals_[i]) {
3401     return "missing argument";
3402   } else if (std::optional<DynamicType> type{GetType(i)}) {
3403     return type->category() == TypeCategory::Derived
3404         ? "TYPE("s + type->AsFortran() + ')'
3405         : type->category() == TypeCategory::Character
3406         ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
3407         : ToUpperCase(type->AsFortran());
3408   } else {
3409     return "untyped";
3410   }
3411 }
3412 
3413 bool ArgumentAnalyzer::AnyUntypedOrMissingOperand() {
3414   for (const auto &actual : actuals_) {
3415     if (!actual || !actual->GetType()) {
3416       return true;
3417     }
3418   }
3419   return false;
3420 }
3421 
3422 } // namespace Fortran::evaluate
3423 
3424 namespace Fortran::semantics {
3425 evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
3426     SemanticsContext &context, common::TypeCategory category,
3427     const std::optional<parser::KindSelector> &selector) {
3428   evaluate::ExpressionAnalyzer analyzer{context};
3429   auto restorer{
3430       analyzer.GetContextualMessages().SetLocation(context.location().value())};
3431   return analyzer.AnalyzeKindSelector(category, selector);
3432 }
3433 
3434 void AnalyzeCallStmt(SemanticsContext &context, const parser::CallStmt &call) {
3435   evaluate::ExpressionAnalyzer{context}.Analyze(call);
3436 }
3437 
3438 const evaluate::Assignment *AnalyzeAssignmentStmt(
3439     SemanticsContext &context, const parser::AssignmentStmt &stmt) {
3440   return evaluate::ExpressionAnalyzer{context}.Analyze(stmt);
3441 }
3442 const evaluate::Assignment *AnalyzePointerAssignmentStmt(
3443     SemanticsContext &context, const parser::PointerAssignmentStmt &stmt) {
3444   return evaluate::ExpressionAnalyzer{context}.Analyze(stmt);
3445 }
3446 
3447 ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}
3448 
3449 bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {
3450   parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);
3451   const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};
3452   auto name{bounds.name.thing.thing};
3453   int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
3454   if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
3455     if (dynamicType->category() == TypeCategory::Integer) {
3456       kind = dynamicType->kind();
3457     }
3458   }
3459   exprAnalyzer_.AddImpliedDo(name.source, kind);
3460   parser::Walk(std::get<std::list<parser::DataIDoObject>>(ido.t), *this);
3461   exprAnalyzer_.RemoveImpliedDo(name.source);
3462   return false;
3463 }
3464 
3465 bool ExprChecker::Walk(const parser::Program &program) {
3466   parser::Walk(program, *this);
3467   return !context_.AnyFatalError();
3468 }
3469 } // namespace Fortran::semantics
3470