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