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