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