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
ToUpperCase(const std::string & str)45 static inline std::string ToUpperCase(const std::string &str) {
46 return parser::ToUpperCaseLetters(str);
47 }
48
49 struct DynamicTypeWithLength : public DynamicType {
DynamicTypeWithLengthFortran::evaluate::DynamicTypeWithLength50 explicit DynamicTypeWithLength(const DynamicType &t) : DynamicType{t} {}
51 std::optional<Expr<SubscriptInteger>> LEN() const;
52 std::optional<Expr<SubscriptInteger>> length;
53 };
54
LEN() const55 std::optional<Expr<SubscriptInteger>> DynamicTypeWithLength::LEN() const {
56 if (length) {
57 return length;
58 } else {
59 return GetCharLength();
60 }
61 }
62
AnalyzeTypeSpec(const std::optional<parser::TypeSpec> & spec)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:
ArgumentAnalyzer(ExpressionAnalyzer & context)97 explicit ArgumentAnalyzer(ExpressionAnalyzer &context)
98 : context_{context}, source_{context.GetContextualMessages().at()},
99 isProcedureCall_{false} {}
ArgumentAnalyzer(ExpressionAnalyzer & context,parser::CharBlock source,bool isProcedureCall=false)100 ArgumentAnalyzer(ExpressionAnalyzer &context, parser::CharBlock source,
101 bool isProcedureCall = false)
102 : context_{context}, source_{source}, isProcedureCall_{isProcedureCall} {}
fatalErrors() const103 bool fatalErrors() const { return fatalErrors_; }
GetActuals()104 ActualArguments &&GetActuals() {
105 CHECK(!fatalErrors_);
106 return std::move(actuals_);
107 }
GetExpr(std::size_t i) const108 const Expr<SomeType> &GetExpr(std::size_t i) const {
109 return DEREF(actuals_.at(i).value().UnwrapExpr());
110 }
MoveExpr(std::size_t i)111 Expr<SomeType> &&MoveExpr(std::size_t i) {
112 return std::move(DEREF(actuals_.at(i).value().UnwrapExpr()));
113 }
Analyze(const common::Indirection<parser::Expr> & x)114 void Analyze(const common::Indirection<parser::Expr> &x) {
115 Analyze(x.value());
116 }
Analyze(const parser::Expr & x)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");
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>
TryDefinedOp(E opr,parser::MessageFixedText msg)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;
IsBOZLiteral(std::size_t i) const162 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 bool CheckForUntypedNullPointer();
169
170 ExpressionAnalyzer &context_;
171 ActualArguments actuals_;
172 parser::CharBlock source_;
173 bool fatalErrors_{false};
174 const bool isProcedureCall_; // false for user-defined op or assignment
175 };
176
177 // Wraps a data reference in a typed Designator<>, and a procedure
178 // or procedure pointer reference in a ProcedureDesignator.
Designate(DataRef && ref)179 MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
180 const Symbol &last{ref.GetLastSymbol()};
181 const Symbol &symbol{BypassGeneric(last).GetUltimate()};
182 if (semantics::IsProcedure(symbol)) {
183 if (auto *component{std::get_if<Component>(&ref.u)}) {
184 return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
185 } else if (!std::holds_alternative<SymbolRef>(ref.u)) {
186 DIE("unexpected alternative in DataRef");
187 } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
188 if (symbol.has<semantics::GenericDetails>()) {
189 Say("'%s' is not a specific procedure"_err_en_US, symbol.name());
190 } else {
191 return Expr<SomeType>{ProcedureDesignator{symbol}};
192 }
193 } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
194 symbol.name().ToString())}) {
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 a 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.
CompleteSubscripts(ArrayRef && ref)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) {
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.
ApplySubscripts(DataRef && dataRef,std::vector<Subscript> && subscripts)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.
TopLevelChecks(DataRef && dataRef)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) {
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.
FixMisparsedSubstring(const parser::Designator & d)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
Analyze(const parser::Designator & d)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.
AsMaybeExpr(A && x)365 template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {
366 return AsGenericExpr(std::move(x));
367 }
AsMaybeExpr(std::optional<A> && x)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.
AnalyzeKindParam(const std::optional<parser::KindParam> & kindParam,int defaultKind)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;
TestFortran::evaluate::IntTypeVisitor404 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>
IntLiteralConstant(const PARSED & x)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
Analyze(const parser::IntLiteralConstant & x)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
Analyze(const parser::SignedIntLiteralConstant & x)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>
ReadRealLiteral(parser::CharBlock source,FoldingContext & context)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
RealTypeVisitorFortran::evaluate::RealTypeVisitor485 RealTypeVisitor(int k, parser::CharBlock lit, FoldingContext &ctx)
486 : kind{k}, literal{lit}, context{ctx} {}
487
TestFortran::evaluate::RealTypeVisitor488 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.
Analyze(const parser::RealLiteralConstant & x)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
Analyze(const parser::SignedRealLiteralConstant & x)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
Analyze(const parser::SignedComplexLiteralConstant & x)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
Analyze(const parser::ComplexPart & x)577 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ComplexPart &x) {
578 return Analyze(x.u);
579 }
580
Analyze(const parser::ComplexLiteralConstant & z)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.
AnalyzeString(std::string && string,int kind)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
Analyze(const parser::CharLiteralConstant & x)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
Analyze(const parser::HollerithLiteralConstant & x)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
Analyze(const parser::LogicalLiteralConstant & x)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
Analyze(const parser::BOZLiteralConstant & x)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
Analyze(const parser::Name & n)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
Analyze(const parser::NamedConstant & n)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
Analyze(const parser::NullInit & n)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
Analyze(const parser::InitialDataTarget & x)737 MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {
738 return Analyze(x.value());
739 }
740
Analyze(const parser::DataStmtValue & x)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
GetSubstringBound(const std::optional<parser::ScalarIntExpr> & bound)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
Analyze(const parser::Substring & ss)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
Analyze(const parser::CharLiteralConstantSubstring & x)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
AsSubscript(MaybeExpr && expr)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
TripletPart(const std::optional<parser::Subscript> & s)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
AnalyzeSectionSubscript(const parser::SectionSubscript & ss)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
AnalyzeSectionSubscripts(const std::list<parser::SectionSubscript> & sss)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
Analyze(const parser::ArrayElement & ae)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 Say("'%s' is not an array"_err_en_US, symbol->name());
941 context_.SetError(*symbol);
942 }
943 }
944 } else if (std::optional<DataRef> dataRef{
945 ExtractDataRef(std::move(*baseExpr))}) {
946 return ApplySubscripts(
947 std::move(*dataRef), AnalyzeSectionSubscripts(ae.subscripts));
948 } else {
949 Say("Subscripts may be applied only to an object, component, or array constant"_err_en_US);
950 }
951 }
952 // error was reported: analyze subscripts without reporting more errors
953 auto restorer{GetContextualMessages().DiscardMessages()};
954 AnalyzeSectionSubscripts(ae.subscripts);
955 return std::nullopt;
956 }
957
958 // Type parameter inquiries apply to data references, but don't depend
959 // on any trailing (co)subscripts.
IgnoreAnySubscripts(Designator<SomeDerived> && designator)960 static NamedEntity IgnoreAnySubscripts(Designator<SomeDerived> &&designator) {
961 return std::visit(
962 common::visitors{
963 [](SymbolRef &&symbol) { return NamedEntity{symbol}; },
964 [](Component &&component) {
965 return NamedEntity{std::move(component)};
966 },
967 [](ArrayRef &&arrayRef) { return std::move(arrayRef.base()); },
968 [](CoarrayRef &&coarrayRef) {
969 return NamedEntity{coarrayRef.GetLastSymbol()};
970 },
971 },
972 std::move(designator.u));
973 }
974
975 // Components of parent derived types are explicitly represented as such.
CreateComponent(DataRef && base,const Symbol & component,const semantics::Scope & scope)976 static std::optional<Component> CreateComponent(
977 DataRef &&base, const Symbol &component, const semantics::Scope &scope) {
978 if (&component.owner() == &scope) {
979 return Component{std::move(base), component};
980 }
981 if (const semantics::Scope * parentScope{scope.GetDerivedTypeParent()}) {
982 if (const Symbol * parentComponent{parentScope->GetSymbol()}) {
983 return CreateComponent(
984 DataRef{Component{std::move(base), *parentComponent}}, component,
985 *parentScope);
986 }
987 }
988 return std::nullopt;
989 }
990
991 // Derived type component references and type parameter inquiries
Analyze(const parser::StructureComponent & sc)992 MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
993 MaybeExpr base{Analyze(sc.base)};
994 Symbol *sym{sc.component.symbol};
995 if (!base || !sym || context_.HasError(sym)) {
996 return std::nullopt;
997 }
998 const auto &name{sc.component.source};
999 if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
1000 const auto *dtSpec{GetDerivedTypeSpec(dtExpr->GetType())};
1001 if (sym->detailsIf<semantics::TypeParamDetails>()) {
1002 if (auto *designator{UnwrapExpr<Designator<SomeDerived>>(*dtExpr)}) {
1003 if (std::optional<DynamicType> dyType{DynamicType::From(*sym)}) {
1004 if (dyType->category() == TypeCategory::Integer) {
1005 auto restorer{GetContextualMessages().SetLocation(name)};
1006 return Fold(ConvertToType(*dyType,
1007 AsGenericExpr(TypeParamInquiry{
1008 IgnoreAnySubscripts(std::move(*designator)), *sym})));
1009 }
1010 }
1011 Say(name, "Type parameter is not INTEGER"_err_en_US);
1012 } else {
1013 Say(name,
1014 "A type parameter inquiry must be applied to "
1015 "a designator"_err_en_US);
1016 }
1017 } else if (!dtSpec || !dtSpec->scope()) {
1018 CHECK(context_.AnyFatalError() || !foldingContext_.messages().empty());
1019 return std::nullopt;
1020 } else if (std::optional<DataRef> dataRef{
1021 ExtractDataRef(std::move(*dtExpr))}) {
1022 if (auto component{
1023 CreateComponent(std::move(*dataRef), *sym, *dtSpec->scope())}) {
1024 return Designate(DataRef{std::move(*component)});
1025 } else {
1026 Say(name, "Component is not in scope of derived TYPE(%s)"_err_en_US,
1027 dtSpec->typeSymbol().name());
1028 }
1029 } else {
1030 Say(name,
1031 "Base of component reference must be a data reference"_err_en_US);
1032 }
1033 } else if (auto *details{sym->detailsIf<semantics::MiscDetails>()}) {
1034 // special part-ref: %re, %im, %kind, %len
1035 // Type errors are detected and reported in semantics.
1036 using MiscKind = semantics::MiscDetails::Kind;
1037 MiscKind kind{details->kind()};
1038 if (kind == MiscKind::ComplexPartRe || kind == MiscKind::ComplexPartIm) {
1039 if (auto *zExpr{std::get_if<Expr<SomeComplex>>(&base->u)}) {
1040 if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(*zExpr))}) {
1041 Expr<SomeReal> realExpr{std::visit(
1042 [&](const auto &z) {
1043 using PartType = typename ResultType<decltype(z)>::Part;
1044 auto part{kind == MiscKind::ComplexPartRe
1045 ? ComplexPart::Part::RE
1046 : ComplexPart::Part::IM};
1047 return AsCategoryExpr(Designator<PartType>{
1048 ComplexPart{std::move(*dataRef), part}});
1049 },
1050 zExpr->u)};
1051 return AsGenericExpr(std::move(realExpr));
1052 }
1053 }
1054 } else if (kind == MiscKind::KindParamInquiry ||
1055 kind == MiscKind::LenParamInquiry) {
1056 // Convert x%KIND -> intrinsic KIND(x), x%LEN -> intrinsic LEN(x)
1057 return MakeFunctionRef(
1058 name, ActualArguments{ActualArgument{std::move(*base)}});
1059 } else {
1060 DIE("unexpected MiscDetails::Kind");
1061 }
1062 } else {
1063 Say(name, "derived type required before component reference"_err_en_US);
1064 }
1065 return std::nullopt;
1066 }
1067
Analyze(const parser::CoindexedNamedObject & x)1068 MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
1069 if (auto maybeDataRef{ExtractDataRef(Analyze(x.base))}) {
1070 DataRef *dataRef{&*maybeDataRef};
1071 std::vector<Subscript> subscripts;
1072 SymbolVector reversed;
1073 if (auto *aRef{std::get_if<ArrayRef>(&dataRef->u)}) {
1074 subscripts = std::move(aRef->subscript());
1075 reversed.push_back(aRef->GetLastSymbol());
1076 if (Component * component{aRef->base().UnwrapComponent()}) {
1077 dataRef = &component->base();
1078 } else {
1079 dataRef = nullptr;
1080 }
1081 }
1082 if (dataRef) {
1083 while (auto *component{std::get_if<Component>(&dataRef->u)}) {
1084 reversed.push_back(component->GetLastSymbol());
1085 dataRef = &component->base();
1086 }
1087 if (auto *baseSym{std::get_if<SymbolRef>(&dataRef->u)}) {
1088 reversed.push_back(*baseSym);
1089 } else {
1090 Say("Base of coindexed named object has subscripts or cosubscripts"_err_en_US);
1091 }
1092 }
1093 std::vector<Expr<SubscriptInteger>> cosubscripts;
1094 bool cosubsOk{true};
1095 for (const auto &cosub :
1096 std::get<std::list<parser::Cosubscript>>(x.imageSelector.t)) {
1097 MaybeExpr coex{Analyze(cosub)};
1098 if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {
1099 cosubscripts.push_back(
1100 ConvertToType<SubscriptInteger>(std::move(*intExpr)));
1101 } else {
1102 cosubsOk = false;
1103 }
1104 }
1105 if (cosubsOk && !reversed.empty()) {
1106 int numCosubscripts{static_cast<int>(cosubscripts.size())};
1107 const Symbol &symbol{reversed.front()};
1108 if (numCosubscripts != symbol.Corank()) {
1109 Say("'%s' has corank %d, but coindexed reference has %d cosubscripts"_err_en_US,
1110 symbol.name(), symbol.Corank(), numCosubscripts);
1111 }
1112 }
1113 for (const auto &imageSelSpec :
1114 std::get<std::list<parser::ImageSelectorSpec>>(x.imageSelector.t)) {
1115 std::visit(
1116 common::visitors{
1117 [&](const auto &x) { Analyze(x.v); },
1118 },
1119 imageSelSpec.u);
1120 }
1121 // Reverse the chain of symbols so that the base is first and coarray
1122 // ultimate component is last.
1123 if (cosubsOk) {
1124 return Designate(
1125 DataRef{CoarrayRef{SymbolVector{reversed.crbegin(), reversed.crend()},
1126 std::move(subscripts), std::move(cosubscripts)}});
1127 }
1128 }
1129 return std::nullopt;
1130 }
1131
IntegerTypeSpecKind(const parser::IntegerTypeSpec & spec)1132 int ExpressionAnalyzer::IntegerTypeSpecKind(
1133 const parser::IntegerTypeSpec &spec) {
1134 Expr<SubscriptInteger> value{
1135 AnalyzeKindSelector(TypeCategory::Integer, spec.v)};
1136 if (auto kind{ToInt64(value)}) {
1137 return static_cast<int>(*kind);
1138 }
1139 SayAt(spec, "Constant INTEGER kind value required here"_err_en_US);
1140 return GetDefaultKind(TypeCategory::Integer);
1141 }
1142
1143 // Array constructors
1144
1145 // Inverts a collection of generic ArrayConstructorValues<SomeType> that
1146 // all happen to have the same actual type T into one ArrayConstructor<T>.
1147 template <typename T>
MakeSpecific(ArrayConstructorValues<SomeType> && from)1148 ArrayConstructorValues<T> MakeSpecific(
1149 ArrayConstructorValues<SomeType> &&from) {
1150 ArrayConstructorValues<T> to;
1151 for (ArrayConstructorValue<SomeType> &x : from) {
1152 std::visit(
1153 common::visitors{
1154 [&](common::CopyableIndirection<Expr<SomeType>> &&expr) {
1155 auto *typed{UnwrapExpr<Expr<T>>(expr.value())};
1156 to.Push(std::move(DEREF(typed)));
1157 },
1158 [&](ImpliedDo<SomeType> &&impliedDo) {
1159 to.Push(ImpliedDo<T>{impliedDo.name(),
1160 std::move(impliedDo.lower()), std::move(impliedDo.upper()),
1161 std::move(impliedDo.stride()),
1162 MakeSpecific<T>(std::move(impliedDo.values()))});
1163 },
1164 },
1165 std::move(x.u));
1166 }
1167 return to;
1168 }
1169
1170 class ArrayConstructorContext {
1171 public:
ArrayConstructorContext(ExpressionAnalyzer & c,std::optional<DynamicTypeWithLength> && t)1172 ArrayConstructorContext(
1173 ExpressionAnalyzer &c, std::optional<DynamicTypeWithLength> &&t)
1174 : exprAnalyzer_{c}, type_{std::move(t)} {}
1175
1176 void Add(const parser::AcValue &);
1177 MaybeExpr ToExpr();
1178
1179 // These interfaces allow *this to be used as a type visitor argument to
1180 // common::SearchTypes() to convert the array constructor to a typed
1181 // expression in ToExpr().
1182 using Result = MaybeExpr;
1183 using Types = AllTypes;
Test()1184 template <typename T> Result Test() {
1185 if (type_ && type_->category() == T::category) {
1186 if constexpr (T::category == TypeCategory::Derived) {
1187 if (!type_->IsUnlimitedPolymorphic()) {
1188 return AsMaybeExpr(ArrayConstructor<T>{type_->GetDerivedTypeSpec(),
1189 MakeSpecific<T>(std::move(values_))});
1190 }
1191 } else if (type_->kind() == T::kind) {
1192 if constexpr (T::category == TypeCategory::Character) {
1193 if (auto len{type_->LEN()}) {
1194 return AsMaybeExpr(ArrayConstructor<T>{
1195 *std::move(len), MakeSpecific<T>(std::move(values_))});
1196 }
1197 } else {
1198 return AsMaybeExpr(
1199 ArrayConstructor<T>{MakeSpecific<T>(std::move(values_))});
1200 }
1201 }
1202 }
1203 return std::nullopt;
1204 }
1205
1206 private:
1207 using ImpliedDoIntType = ResultType<ImpliedDoIndex>;
1208
1209 void Push(MaybeExpr &&);
1210 void Add(const parser::AcValue::Triplet &);
1211 void Add(const parser::Expr &);
1212 void Add(const parser::AcImpliedDo &);
1213 void UnrollConstantImpliedDo(const parser::AcImpliedDo &,
1214 parser::CharBlock name, std::int64_t lower, std::int64_t upper,
1215 std::int64_t stride);
1216
1217 template <int KIND, typename A>
GetSpecificIntExpr(const A & x)1218 std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(
1219 const A &x) {
1220 if (MaybeExpr y{exprAnalyzer_.Analyze(x)}) {
1221 Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};
1222 return Fold(exprAnalyzer_.GetFoldingContext(),
1223 ConvertToType<Type<TypeCategory::Integer, KIND>>(
1224 std::move(DEREF(intExpr))));
1225 }
1226 return std::nullopt;
1227 }
1228
1229 // Nested array constructors all reference the same ExpressionAnalyzer,
1230 // which represents the nest of active implied DO loop indices.
1231 ExpressionAnalyzer &exprAnalyzer_;
1232 std::optional<DynamicTypeWithLength> type_;
1233 bool explicitType_{type_.has_value()};
1234 std::optional<std::int64_t> constantLength_;
1235 ArrayConstructorValues<SomeType> values_;
1236 std::uint64_t messageDisplayedSet_{0};
1237 };
1238
Push(MaybeExpr && x)1239 void ArrayConstructorContext::Push(MaybeExpr &&x) {
1240 if (!x) {
1241 return;
1242 }
1243 if (!type_) {
1244 if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
1245 // Treat an array constructor of BOZ as if default integer.
1246 if (exprAnalyzer_.context().ShouldWarn(
1247 common::LanguageFeature::BOZAsDefaultInteger)) {
1248 exprAnalyzer_.Say(
1249 "BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_en_US);
1250 }
1251 x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
1252 exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
1253 std::move(*boz)));
1254 }
1255 }
1256 std::optional<DynamicType> dyType{x->GetType()};
1257 if (!dyType) {
1258 if (auto *boz{std::get_if<BOZLiteralConstant>(&x->u)}) {
1259 if (!type_) {
1260 // Treat an array constructor of BOZ as if default integer.
1261 if (exprAnalyzer_.context().ShouldWarn(
1262 common::LanguageFeature::BOZAsDefaultInteger)) {
1263 exprAnalyzer_.Say(
1264 "BOZ literal in array constructor without explicit type is assumed to be default INTEGER"_en_US);
1265 }
1266 x = AsGenericExpr(ConvertToKind<TypeCategory::Integer>(
1267 exprAnalyzer_.GetDefaultKind(TypeCategory::Integer),
1268 std::move(*boz)));
1269 dyType = x.value().GetType();
1270 } else if (auto cast{ConvertToType(*type_, std::move(*x))}) {
1271 x = std::move(cast);
1272 dyType = *type_;
1273 } else {
1274 if (!(messageDisplayedSet_ & 0x80)) {
1275 exprAnalyzer_.Say(
1276 "BOZ literal is not suitable for use in this array constructor"_err_en_US);
1277 messageDisplayedSet_ |= 0x80;
1278 }
1279 return;
1280 }
1281 } else { // procedure name, &c.
1282 if (!(messageDisplayedSet_ & 0x40)) {
1283 exprAnalyzer_.Say(
1284 "Item is not suitable for use in an array constructor"_err_en_US);
1285 messageDisplayedSet_ |= 0x40;
1286 }
1287 return;
1288 }
1289 } else if (dyType->IsUnlimitedPolymorphic()) {
1290 if (!(messageDisplayedSet_ & 8)) {
1291 exprAnalyzer_.Say("Cannot have an unlimited polymorphic value in an "
1292 "array constructor"_err_en_US); // C7113
1293 messageDisplayedSet_ |= 8;
1294 }
1295 return;
1296 }
1297 DynamicTypeWithLength xType{dyType.value()};
1298 if (Expr<SomeCharacter> * charExpr{UnwrapExpr<Expr<SomeCharacter>>(*x)}) {
1299 CHECK(xType.category() == TypeCategory::Character);
1300 xType.length =
1301 std::visit([](const auto &kc) { return kc.LEN(); }, charExpr->u);
1302 }
1303 if (!type_) {
1304 // If there is no explicit type-spec in an array constructor, the type
1305 // of the array is the declared type of all of the elements, which must
1306 // be well-defined and all match.
1307 // TODO: Possible language extension: use the most general type of
1308 // the values as the type of a numeric constructed array, convert all
1309 // of the other values to that type. Alternative: let the first value
1310 // determine the type, and convert the others to that type.
1311 CHECK(!explicitType_);
1312 type_ = std::move(xType);
1313 constantLength_ = ToInt64(type_->length);
1314 values_.Push(std::move(*x));
1315 } else if (!explicitType_) {
1316 if (type_->IsTkCompatibleWith(xType) && xType.IsTkCompatibleWith(*type_)) {
1317 values_.Push(std::move(*x));
1318 if (auto thisLen{ToInt64(xType.LEN())}) {
1319 if (constantLength_) {
1320 if (exprAnalyzer_.context().warnOnNonstandardUsage() &&
1321 *thisLen != *constantLength_) {
1322 if (!(messageDisplayedSet_ & 1)) {
1323 exprAnalyzer_.Say(
1324 "Character literal in array constructor without explicit "
1325 "type has different length than earlier elements"_en_US);
1326 messageDisplayedSet_ |= 1;
1327 }
1328 }
1329 if (*thisLen > *constantLength_) {
1330 // Language extension: use the longest literal to determine the
1331 // length of the array constructor's character elements, not the
1332 // first, when there is no explicit type.
1333 *constantLength_ = *thisLen;
1334 type_->length = xType.LEN();
1335 }
1336 } else {
1337 constantLength_ = *thisLen;
1338 type_->length = xType.LEN();
1339 }
1340 }
1341 } else {
1342 if (!(messageDisplayedSet_ & 2)) {
1343 exprAnalyzer_.Say(
1344 "Values in array constructor must have the same declared type "
1345 "when no explicit type appears"_err_en_US); // C7110
1346 messageDisplayedSet_ |= 2;
1347 }
1348 }
1349 } else {
1350 if (auto cast{ConvertToType(*type_, std::move(*x))}) {
1351 values_.Push(std::move(*cast));
1352 } else if (!(messageDisplayedSet_ & 4)) {
1353 exprAnalyzer_.Say("Value in array constructor of type '%s' could not "
1354 "be converted to the type of the array '%s'"_err_en_US,
1355 x->GetType()->AsFortran(), type_->AsFortran()); // C7111, C7112
1356 messageDisplayedSet_ |= 4;
1357 }
1358 }
1359 }
1360
Add(const parser::AcValue & x)1361 void ArrayConstructorContext::Add(const parser::AcValue &x) {
1362 std::visit(
1363 common::visitors{
1364 [&](const parser::AcValue::Triplet &triplet) { Add(triplet); },
1365 [&](const common::Indirection<parser::Expr> &expr) {
1366 Add(expr.value());
1367 },
1368 [&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {
1369 Add(impliedDo.value());
1370 },
1371 },
1372 x.u);
1373 }
1374
1375 // Transforms l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'
Add(const parser::AcValue::Triplet & triplet)1376 void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) {
1377 std::optional<Expr<ImpliedDoIntType>> lower{
1378 GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<0>(triplet.t))};
1379 std::optional<Expr<ImpliedDoIntType>> upper{
1380 GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<1>(triplet.t))};
1381 std::optional<Expr<ImpliedDoIntType>> stride{
1382 GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<2>(triplet.t))};
1383 if (lower && upper) {
1384 if (!stride) {
1385 stride = Expr<ImpliedDoIntType>{1};
1386 }
1387 if (!type_) {
1388 type_ = DynamicTypeWithLength{ImpliedDoIntType::GetType()};
1389 }
1390 auto v{std::move(values_)};
1391 parser::CharBlock anonymous;
1392 Push(Expr<SomeType>{
1393 Expr<SomeInteger>{Expr<ImpliedDoIntType>{ImpliedDoIndex{anonymous}}}});
1394 std::swap(v, values_);
1395 values_.Push(ImpliedDo<SomeType>{anonymous, std::move(*lower),
1396 std::move(*upper), std::move(*stride), std::move(v)});
1397 }
1398 }
1399
Add(const parser::Expr & expr)1400 void ArrayConstructorContext::Add(const parser::Expr &expr) {
1401 auto restorer{exprAnalyzer_.GetContextualMessages().SetLocation(expr.source)};
1402 Push(exprAnalyzer_.Analyze(expr));
1403 }
1404
Add(const parser::AcImpliedDo & impliedDo)1405 void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
1406 const auto &control{std::get<parser::AcImpliedDoControl>(impliedDo.t)};
1407 const auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)};
1408 exprAnalyzer_.Analyze(bounds.name);
1409 parser::CharBlock name{bounds.name.thing.thing.source};
1410 const Symbol *symbol{bounds.name.thing.thing.symbol};
1411 int kind{ImpliedDoIntType::kind};
1412 if (const auto dynamicType{DynamicType::From(symbol)}) {
1413 kind = dynamicType->kind();
1414 }
1415 std::optional<Expr<ImpliedDoIntType>> lower{
1416 GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.lower)};
1417 std::optional<Expr<ImpliedDoIntType>> upper{
1418 GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.upper)};
1419 if (lower && upper) {
1420 std::optional<Expr<ImpliedDoIntType>> stride{
1421 GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.step)};
1422 if (!stride) {
1423 stride = Expr<ImpliedDoIntType>{1};
1424 }
1425 if (exprAnalyzer_.AddImpliedDo(name, kind)) {
1426 // Check for constant bounds; the loop may require complete unrolling
1427 // of the parse tree if all bounds are constant in order to allow the
1428 // implied DO loop index to qualify as a constant expression.
1429 auto cLower{ToInt64(lower)};
1430 auto cUpper{ToInt64(upper)};
1431 auto cStride{ToInt64(stride)};
1432 if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {
1433 exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source,
1434 "The stride of an implied DO loop must not be zero"_err_en_US);
1435 messageDisplayedSet_ |= 0x10;
1436 }
1437 bool isConstant{cLower && cUpper && cStride && *cStride != 0};
1438 bool isNonemptyConstant{isConstant &&
1439 ((*cStride > 0 && *cLower <= *cUpper) ||
1440 (*cStride < 0 && *cLower >= *cUpper))};
1441 bool unrollConstantLoop{false};
1442 parser::Messages buffer;
1443 auto saveMessagesDisplayed{messageDisplayedSet_};
1444 {
1445 auto messageRestorer{
1446 exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};
1447 auto v{std::move(values_)};
1448 for (const auto &value :
1449 std::get<std::list<parser::AcValue>>(impliedDo.t)) {
1450 Add(value);
1451 }
1452 std::swap(v, values_);
1453 if (isNonemptyConstant && buffer.AnyFatalError()) {
1454 unrollConstantLoop = true;
1455 } else {
1456 values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),
1457 std::move(*upper), std::move(*stride), std::move(v)});
1458 }
1459 }
1460 if (unrollConstantLoop) {
1461 messageDisplayedSet_ = saveMessagesDisplayed;
1462 UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);
1463 } else if (auto *messages{
1464 exprAnalyzer_.GetContextualMessages().messages()}) {
1465 messages->Annex(std::move(buffer));
1466 }
1467 exprAnalyzer_.RemoveImpliedDo(name);
1468 } else if (!(messageDisplayedSet_ & 0x20)) {
1469 exprAnalyzer_.SayAt(name,
1470 "Implied DO index '%s' is active in a surrounding implied DO loop "
1471 "and may not have the same name"_err_en_US,
1472 name); // C7115
1473 messageDisplayedSet_ |= 0x20;
1474 }
1475 }
1476 }
1477
1478 // Fortran considers an implied DO index of an array constructor to be
1479 // a constant expression if the bounds of the implied DO loop are constant.
1480 // Usually this doesn't matter, but if we emitted spurious messages as a
1481 // result of not using constant values for the index while analyzing the
1482 // items, we need to do it again the "hard" way with multiple iterations over
1483 // the parse tree.
UnrollConstantImpliedDo(const parser::AcImpliedDo & impliedDo,parser::CharBlock name,std::int64_t lower,std::int64_t upper,std::int64_t stride)1484 void ArrayConstructorContext::UnrollConstantImpliedDo(
1485 const parser::AcImpliedDo &impliedDo, parser::CharBlock name,
1486 std::int64_t lower, std::int64_t upper, std::int64_t stride) {
1487 auto &foldingContext{exprAnalyzer_.GetFoldingContext()};
1488 auto restorer{exprAnalyzer_.DoNotUseSavedTypedExprs()};
1489 for (auto &at{foldingContext.StartImpliedDo(name, lower)};
1490 (stride > 0 && at <= upper) || (stride < 0 && at >= upper);
1491 at += stride) {
1492 for (const auto &value :
1493 std::get<std::list<parser::AcValue>>(impliedDo.t)) {
1494 Add(value);
1495 }
1496 }
1497 foldingContext.EndImpliedDo(name);
1498 }
1499
ToExpr()1500 MaybeExpr ArrayConstructorContext::ToExpr() {
1501 return common::SearchTypes(std::move(*this));
1502 }
1503
Analyze(const parser::ArrayConstructor & array)1504 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayConstructor &array) {
1505 const parser::AcSpec &acSpec{array.v};
1506 ArrayConstructorContext acContext{*this, AnalyzeTypeSpec(acSpec.type)};
1507 for (const parser::AcValue &value : acSpec.values) {
1508 acContext.Add(value);
1509 }
1510 return acContext.ToExpr();
1511 }
1512
Analyze(const parser::StructureConstructor & structure)1513 MaybeExpr ExpressionAnalyzer::Analyze(
1514 const parser::StructureConstructor &structure) {
1515 auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
1516 parser::Name structureType{std::get<parser::Name>(parsedType.t)};
1517 parser::CharBlock &typeName{structureType.source};
1518 if (semantics::Symbol * typeSymbol{structureType.symbol}) {
1519 if (typeSymbol->has<semantics::DerivedTypeDetails>()) {
1520 semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};
1521 if (!CheckIsValidForwardReference(dtSpec)) {
1522 return std::nullopt;
1523 }
1524 }
1525 }
1526 if (!parsedType.derivedTypeSpec) {
1527 return std::nullopt;
1528 }
1529 const auto &spec{*parsedType.derivedTypeSpec};
1530 const Symbol &typeSymbol{spec.typeSymbol()};
1531 if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {
1532 return std::nullopt; // error recovery
1533 }
1534 const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
1535 const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
1536
1537 if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
1538 AttachDeclaration(Say(typeName,
1539 "ABSTRACT derived type '%s' may not be used in a "
1540 "structure constructor"_err_en_US,
1541 typeName),
1542 typeSymbol); // C7114
1543 }
1544
1545 // This iterator traverses all of the components in the derived type and its
1546 // parents. The symbols for whole parent components appear after their
1547 // own components and before the components of the types that extend them.
1548 // E.g., TYPE :: A; REAL X; END TYPE
1549 // TYPE, EXTENDS(A) :: B; REAL Y; END TYPE
1550 // produces the component list X, A, Y.
1551 // The order is important below because a structure constructor can
1552 // initialize X or A by name, but not both.
1553 auto components{semantics::OrderedComponentIterator{spec}};
1554 auto nextAnonymous{components.begin()};
1555
1556 std::set<parser::CharBlock> unavailable;
1557 bool anyKeyword{false};
1558 StructureConstructor result{spec};
1559 bool checkConflicts{true}; // until we hit one
1560 auto &messages{GetContextualMessages()};
1561
1562 for (const auto &component :
1563 std::get<std::list<parser::ComponentSpec>>(structure.t)) {
1564 const parser::Expr &expr{
1565 std::get<parser::ComponentDataSource>(component.t).v.value()};
1566 parser::CharBlock source{expr.source};
1567 auto restorer{messages.SetLocation(source)};
1568 const Symbol *symbol{nullptr};
1569 MaybeExpr value{Analyze(expr)};
1570 std::optional<DynamicType> valueType{DynamicType::From(value)};
1571 if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
1572 anyKeyword = true;
1573 source = kw->v.source;
1574 symbol = kw->v.symbol;
1575 if (!symbol) {
1576 auto componentIter{std::find_if(components.begin(), components.end(),
1577 [=](const Symbol &symbol) { return symbol.name() == source; })};
1578 if (componentIter != components.end()) {
1579 symbol = &*componentIter;
1580 }
1581 }
1582 if (!symbol) { // C7101
1583 Say(source,
1584 "Keyword '%s=' does not name a component of derived type '%s'"_err_en_US,
1585 source, typeName);
1586 }
1587 } else {
1588 if (anyKeyword) { // C7100
1589 Say(source,
1590 "Value in structure constructor lacks a component name"_err_en_US);
1591 checkConflicts = false; // stem cascade
1592 }
1593 // Here's a regrettably common extension of the standard: anonymous
1594 // initialization of parent components, e.g., T(PT(1)) rather than
1595 // T(1) or T(PT=PT(1)).
1596 if (nextAnonymous == components.begin() && parentComponent &&
1597 valueType == DynamicType::From(*parentComponent) &&
1598 context().IsEnabled(LanguageFeature::AnonymousParents)) {
1599 auto iter{
1600 std::find(components.begin(), components.end(), *parentComponent)};
1601 if (iter != components.end()) {
1602 symbol = parentComponent;
1603 nextAnonymous = ++iter;
1604 if (context().ShouldWarn(LanguageFeature::AnonymousParents)) {
1605 Say(source,
1606 "Whole parent component '%s' in structure "
1607 "constructor should not be anonymous"_en_US,
1608 symbol->name());
1609 }
1610 }
1611 }
1612 while (!symbol && nextAnonymous != components.end()) {
1613 const Symbol &next{*nextAnonymous};
1614 ++nextAnonymous;
1615 if (!next.test(Symbol::Flag::ParentComp)) {
1616 symbol = &next;
1617 }
1618 }
1619 if (!symbol) {
1620 Say(source, "Unexpected value in structure constructor"_err_en_US);
1621 }
1622 }
1623 if (symbol) {
1624 if (const auto *currScope{context_.globalScope().FindScope(source)}) {
1625 if (auto msg{CheckAccessibleComponent(*currScope, *symbol)}) {
1626 Say(source, *msg);
1627 }
1628 }
1629 if (checkConflicts) {
1630 auto componentIter{
1631 std::find(components.begin(), components.end(), *symbol)};
1632 if (unavailable.find(symbol->name()) != unavailable.cend()) {
1633 // C797, C798
1634 Say(source,
1635 "Component '%s' conflicts with another component earlier in "
1636 "this structure constructor"_err_en_US,
1637 symbol->name());
1638 } else if (symbol->test(Symbol::Flag::ParentComp)) {
1639 // Make earlier components unavailable once a whole parent appears.
1640 for (auto it{components.begin()}; it != componentIter; ++it) {
1641 unavailable.insert(it->name());
1642 }
1643 } else {
1644 // Make whole parent components unavailable after any of their
1645 // constituents appear.
1646 for (auto it{componentIter}; it != components.end(); ++it) {
1647 if (it->test(Symbol::Flag::ParentComp)) {
1648 unavailable.insert(it->name());
1649 }
1650 }
1651 }
1652 }
1653 unavailable.insert(symbol->name());
1654 if (value) {
1655 if (symbol->has<semantics::ProcEntityDetails>()) {
1656 CHECK(IsPointer(*symbol));
1657 } else if (symbol->has<semantics::ObjectEntityDetails>()) {
1658 // C1594(4)
1659 const auto &innermost{context_.FindScope(expr.source)};
1660 if (const auto *pureProc{FindPureProcedureContaining(innermost)}) {
1661 if (const Symbol * pointer{FindPointerComponent(*symbol)}) {
1662 if (const Symbol *
1663 object{FindExternallyVisibleObject(*value, *pureProc)}) {
1664 if (auto *msg{Say(expr.source,
1665 "Externally visible object '%s' may not be "
1666 "associated with pointer component '%s' in a "
1667 "pure procedure"_err_en_US,
1668 object->name(), pointer->name())}) {
1669 msg->Attach(object->name(), "Object declaration"_en_US)
1670 .Attach(pointer->name(), "Pointer declaration"_en_US);
1671 }
1672 }
1673 }
1674 }
1675 } else if (symbol->has<semantics::TypeParamDetails>()) {
1676 Say(expr.source,
1677 "Type parameter '%s' may not appear as a component "
1678 "of a structure constructor"_err_en_US,
1679 symbol->name());
1680 continue;
1681 } else {
1682 Say(expr.source,
1683 "Component '%s' is neither a procedure pointer "
1684 "nor a data object"_err_en_US,
1685 symbol->name());
1686 continue;
1687 }
1688 if (IsPointer(*symbol)) {
1689 semantics::CheckPointerAssignment(
1690 GetFoldingContext(), *symbol, *value); // C7104, C7105
1691 result.Add(*symbol, Fold(std::move(*value)));
1692 } else if (MaybeExpr converted{
1693 ConvertToType(*symbol, std::move(*value))}) {
1694 if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
1695 if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
1696 if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
1697 AttachDeclaration(
1698 Say(expr.source,
1699 "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
1700 GetRank(*valueShape), symbol->name()),
1701 *symbol);
1702 } else {
1703 auto checked{
1704 CheckConformance(messages, *componentShape, *valueShape,
1705 CheckConformanceFlags::RightIsExpandableDeferred,
1706 "component", "value")};
1707 if (checked && *checked && GetRank(*componentShape) > 0 &&
1708 GetRank(*valueShape) == 0 &&
1709 !IsExpandableScalar(*converted)) {
1710 AttachDeclaration(
1711 Say(expr.source,
1712 "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
1713 symbol->name()),
1714 *symbol);
1715 }
1716 if (checked.value_or(true)) {
1717 result.Add(*symbol, std::move(*converted));
1718 }
1719 }
1720 } else {
1721 Say(expr.source, "Shape of value cannot be determined"_err_en_US);
1722 }
1723 } else {
1724 AttachDeclaration(
1725 Say(expr.source,
1726 "Shape of component '%s' cannot be determined"_err_en_US,
1727 symbol->name()),
1728 *symbol);
1729 }
1730 } else if (IsAllocatable(*symbol) &&
1731 std::holds_alternative<NullPointer>(value->u)) {
1732 // NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE
1733 } else if (auto symType{DynamicType::From(symbol)}) {
1734 if (valueType) {
1735 AttachDeclaration(
1736 Say(expr.source,
1737 "Value in structure constructor of type %s is "
1738 "incompatible with component '%s' of type %s"_err_en_US,
1739 valueType->AsFortran(), symbol->name(),
1740 symType->AsFortran()),
1741 *symbol);
1742 } else {
1743 AttachDeclaration(
1744 Say(expr.source,
1745 "Value in structure constructor is incompatible with "
1746 " component '%s' of type %s"_err_en_US,
1747 symbol->name(), symType->AsFortran()),
1748 *symbol);
1749 }
1750 }
1751 }
1752 }
1753 }
1754
1755 // Ensure that unmentioned component objects have default initializers.
1756 for (const Symbol &symbol : components) {
1757 if (!symbol.test(Symbol::Flag::ParentComp) &&
1758 unavailable.find(symbol.name()) == unavailable.cend() &&
1759 !IsAllocatable(symbol)) {
1760 if (const auto *details{
1761 symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
1762 if (details->init()) {
1763 result.Add(symbol, common::Clone(*details->init()));
1764 } else { // C799
1765 AttachDeclaration(Say(typeName,
1766 "Structure constructor lacks a value for "
1767 "component '%s'"_err_en_US,
1768 symbol.name()),
1769 symbol);
1770 }
1771 }
1772 }
1773 }
1774
1775 return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
1776 }
1777
GetPassName(const semantics::Symbol & proc)1778 static std::optional<parser::CharBlock> GetPassName(
1779 const semantics::Symbol &proc) {
1780 return std::visit(
1781 [](const auto &details) {
1782 if constexpr (std::is_base_of_v<semantics::WithPassArg,
1783 std::decay_t<decltype(details)>>) {
1784 return details.passName();
1785 } else {
1786 return std::optional<parser::CharBlock>{};
1787 }
1788 },
1789 proc.details());
1790 }
1791
GetPassIndex(const Symbol & proc)1792 static int GetPassIndex(const Symbol &proc) {
1793 CHECK(!proc.attrs().test(semantics::Attr::NOPASS));
1794 std::optional<parser::CharBlock> passName{GetPassName(proc)};
1795 const auto *interface{semantics::FindInterface(proc)};
1796 if (!passName || !interface) {
1797 return 0; // first argument is passed-object
1798 }
1799 const auto &subp{interface->get<semantics::SubprogramDetails>()};
1800 int index{0};
1801 for (const auto *arg : subp.dummyArgs()) {
1802 if (arg && arg->name() == passName) {
1803 return index;
1804 }
1805 ++index;
1806 }
1807 DIE("PASS argument name not in dummy argument list");
1808 }
1809
1810 // Injects an expression into an actual argument list as the "passed object"
1811 // for a type-bound procedure reference that is not NOPASS. Adds an
1812 // argument keyword if possible, but not when the passed object goes
1813 // before a positional argument.
1814 // e.g., obj%tbp(x) -> tbp(obj,x).
AddPassArg(ActualArguments & actuals,const Expr<SomeDerived> & expr,const Symbol & component,bool isPassedObject=true)1815 static void AddPassArg(ActualArguments &actuals, const Expr<SomeDerived> &expr,
1816 const Symbol &component, bool isPassedObject = true) {
1817 if (component.attrs().test(semantics::Attr::NOPASS)) {
1818 return;
1819 }
1820 int passIndex{GetPassIndex(component)};
1821 auto iter{actuals.begin()};
1822 int at{0};
1823 while (iter < actuals.end() && at < passIndex) {
1824 if (*iter && (*iter)->keyword()) {
1825 iter = actuals.end();
1826 break;
1827 }
1828 ++iter;
1829 ++at;
1830 }
1831 ActualArgument passed{AsGenericExpr(common::Clone(expr))};
1832 passed.set_isPassedObject(isPassedObject);
1833 if (iter == actuals.end()) {
1834 if (auto passName{GetPassName(component)}) {
1835 passed.set_keyword(*passName);
1836 }
1837 }
1838 actuals.emplace(iter, std::move(passed));
1839 }
1840
1841 // Return the compile-time resolution of a procedure binding, if possible.
GetBindingResolution(const std::optional<DynamicType> & baseType,const Symbol & component)1842 static const Symbol *GetBindingResolution(
1843 const std::optional<DynamicType> &baseType, const Symbol &component) {
1844 const auto *binding{component.detailsIf<semantics::ProcBindingDetails>()};
1845 if (!binding) {
1846 return nullptr;
1847 }
1848 if (!component.attrs().test(semantics::Attr::NON_OVERRIDABLE) &&
1849 (!baseType || baseType->IsPolymorphic())) {
1850 return nullptr;
1851 }
1852 return &binding->symbol();
1853 }
1854
AnalyzeProcedureComponentRef(const parser::ProcComponentRef & pcr,ActualArguments && arguments)1855 auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
1856 const parser::ProcComponentRef &pcr, ActualArguments &&arguments)
1857 -> std::optional<CalleeAndArguments> {
1858 const parser::StructureComponent &sc{pcr.v.thing};
1859 if (MaybeExpr base{Analyze(sc.base)}) {
1860 if (const Symbol * sym{sc.component.symbol}) {
1861 if (context_.HasError(sym)) {
1862 return std::nullopt;
1863 }
1864 if (!IsProcedure(*sym)) {
1865 AttachDeclaration(
1866 Say(sc.component.source, "'%s' is not a procedure"_err_en_US,
1867 sc.component.source),
1868 *sym);
1869 return std::nullopt;
1870 }
1871 if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
1872 if (sym->has<semantics::GenericDetails>()) {
1873 AdjustActuals adjustment{
1874 [&](const Symbol &proc, ActualArguments &actuals) {
1875 if (!proc.attrs().test(semantics::Attr::NOPASS)) {
1876 AddPassArg(actuals, std::move(*dtExpr), proc);
1877 }
1878 return true;
1879 }};
1880 sym = ResolveGeneric(*sym, arguments, adjustment);
1881 if (!sym) {
1882 EmitGenericResolutionError(*sc.component.symbol);
1883 return std::nullopt;
1884 }
1885 }
1886 if (const Symbol *
1887 resolution{GetBindingResolution(dtExpr->GetType(), *sym)}) {
1888 AddPassArg(arguments, std::move(*dtExpr), *sym, false);
1889 return CalleeAndArguments{
1890 ProcedureDesignator{*resolution}, std::move(arguments)};
1891 } else if (std::optional<DataRef> dataRef{
1892 ExtractDataRef(std::move(*dtExpr))}) {
1893 if (sym->attrs().test(semantics::Attr::NOPASS)) {
1894 return CalleeAndArguments{
1895 ProcedureDesignator{Component{std::move(*dataRef), *sym}},
1896 std::move(arguments)};
1897 } else {
1898 AddPassArg(arguments,
1899 Expr<SomeDerived>{Designator<SomeDerived>{std::move(*dataRef)}},
1900 *sym);
1901 return CalleeAndArguments{
1902 ProcedureDesignator{*sym}, std::move(arguments)};
1903 }
1904 }
1905 }
1906 Say(sc.component.source,
1907 "Base of procedure component reference is not a derived-type object"_err_en_US);
1908 }
1909 }
1910 CHECK(!GetContextualMessages().empty());
1911 return std::nullopt;
1912 }
1913
1914 // Can actual be argument associated with dummy?
CheckCompatibleArgument(bool isElemental,const ActualArgument & actual,const characteristics::DummyArgument & dummy)1915 static bool CheckCompatibleArgument(bool isElemental,
1916 const ActualArgument &actual, const characteristics::DummyArgument &dummy) {
1917 return std::visit(
1918 common::visitors{
1919 [&](const characteristics::DummyDataObject &x) {
1920 if (!isElemental && actual.Rank() != x.type.Rank() &&
1921 !x.type.attrs().test(
1922 characteristics::TypeAndShape::Attr::AssumedRank)) {
1923 return false;
1924 } else if (auto actualType{actual.GetType()}) {
1925 return x.type.type().IsTkCompatibleWith(*actualType);
1926 } else {
1927 return false;
1928 }
1929 },
1930 [&](const characteristics::DummyProcedure &) {
1931 const auto *expr{actual.UnwrapExpr()};
1932 return expr && IsProcedurePointerTarget(*expr);
1933 },
1934 [&](const characteristics::AlternateReturn &) {
1935 return actual.isAlternateReturn();
1936 },
1937 },
1938 dummy.u);
1939 }
1940
1941 // Are the actual arguments compatible with the dummy arguments of procedure?
CheckCompatibleArguments(const characteristics::Procedure & procedure,const ActualArguments & actuals)1942 static bool CheckCompatibleArguments(
1943 const characteristics::Procedure &procedure,
1944 const ActualArguments &actuals) {
1945 bool isElemental{procedure.IsElemental()};
1946 const auto &dummies{procedure.dummyArguments};
1947 CHECK(dummies.size() == actuals.size());
1948 for (std::size_t i{0}; i < dummies.size(); ++i) {
1949 const characteristics::DummyArgument &dummy{dummies[i]};
1950 const std::optional<ActualArgument> &actual{actuals[i]};
1951 if (actual && !CheckCompatibleArgument(isElemental, *actual, dummy)) {
1952 return false;
1953 }
1954 }
1955 return true;
1956 }
1957
1958 // Handles a forward reference to a module function from what must
1959 // be a specification expression. Return false if the symbol is
1960 // an invalid forward reference.
ResolveForward(const Symbol & symbol)1961 bool ExpressionAnalyzer::ResolveForward(const Symbol &symbol) {
1962 if (context_.HasError(symbol)) {
1963 return false;
1964 }
1965 if (const auto *details{
1966 symbol.detailsIf<semantics::SubprogramNameDetails>()}) {
1967 if (details->kind() == semantics::SubprogramKind::Module) {
1968 // If this symbol is still a SubprogramNameDetails, we must be
1969 // checking a specification expression in a sibling module
1970 // procedure. Resolve its names now so that its interface
1971 // is known.
1972 semantics::ResolveSpecificationParts(context_, symbol);
1973 if (symbol.has<semantics::SubprogramNameDetails>()) {
1974 // When the symbol hasn't had its details updated, we must have
1975 // already been in the process of resolving the function's
1976 // specification part; but recursive function calls are not
1977 // allowed in specification parts (10.1.11 para 5).
1978 Say("The module function '%s' may not be referenced recursively in a specification expression"_err_en_US,
1979 symbol.name());
1980 context_.SetError(symbol);
1981 return false;
1982 }
1983 } else { // 10.1.11 para 4
1984 Say("The internal function '%s' may not be referenced in a specification expression"_err_en_US,
1985 symbol.name());
1986 context_.SetError(symbol);
1987 return false;
1988 }
1989 }
1990 return true;
1991 }
1992
1993 // Resolve a call to a generic procedure with given actual arguments.
1994 // adjustActuals is called on procedure bindings to handle pass arg.
ResolveGeneric(const Symbol & symbol,const ActualArguments & actuals,const AdjustActuals & adjustActuals,bool mightBeStructureConstructor)1995 const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
1996 const ActualArguments &actuals, const AdjustActuals &adjustActuals,
1997 bool mightBeStructureConstructor) {
1998 const Symbol *elemental{nullptr}; // matching elemental specific proc
1999 const auto &details{symbol.GetUltimate().get<semantics::GenericDetails>()};
2000 for (const Symbol &specific : details.specificProcs()) {
2001 if (!ResolveForward(specific)) {
2002 continue;
2003 }
2004 if (std::optional<characteristics::Procedure> procedure{
2005 characteristics::Procedure::Characterize(
2006 ProcedureDesignator{specific}, context_.foldingContext())}) {
2007 ActualArguments localActuals{actuals};
2008 if (specific.has<semantics::ProcBindingDetails>()) {
2009 if (!adjustActuals.value()(specific, localActuals)) {
2010 continue;
2011 }
2012 }
2013 if (semantics::CheckInterfaceForGeneric(
2014 *procedure, localActuals, GetFoldingContext())) {
2015 if (CheckCompatibleArguments(*procedure, localActuals)) {
2016 if (!procedure->IsElemental()) {
2017 // takes priority over elemental match
2018 return &AccessSpecific(symbol, specific);
2019 }
2020 elemental = &specific;
2021 }
2022 }
2023 }
2024 }
2025 if (elemental) {
2026 return &AccessSpecific(symbol, *elemental);
2027 }
2028 // Check parent derived type
2029 if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
2030 if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
2031 if (extended->GetUltimate().has<semantics::GenericDetails>()) {
2032 if (const Symbol *
2033 result{ResolveGeneric(*extended, actuals, adjustActuals, false)}) {
2034 return result;
2035 }
2036 }
2037 }
2038 }
2039 if (mightBeStructureConstructor && details.derivedType()) {
2040 return details.derivedType();
2041 }
2042 return nullptr;
2043 }
2044
AccessSpecific(const Symbol & originalGeneric,const Symbol & specific)2045 const Symbol &ExpressionAnalyzer::AccessSpecific(
2046 const Symbol &originalGeneric, const Symbol &specific) {
2047 if (const auto *hosted{
2048 originalGeneric.detailsIf<semantics::HostAssocDetails>()}) {
2049 return AccessSpecific(hosted->symbol(), specific);
2050 } else if (const auto *used{
2051 originalGeneric.detailsIf<semantics::UseDetails>()}) {
2052 const auto &scope{originalGeneric.owner()};
2053 if (auto iter{scope.find(specific.name())}; iter != scope.end()) {
2054 if (const auto *useDetails{
2055 iter->second->detailsIf<semantics::UseDetails>()}) {
2056 const Symbol &usedSymbol{useDetails->symbol()};
2057 const auto *usedGeneric{
2058 usedSymbol.detailsIf<semantics::GenericDetails>()};
2059 if (&usedSymbol == &specific ||
2060 (usedGeneric && usedGeneric->specific() == &specific)) {
2061 return specific;
2062 }
2063 }
2064 }
2065 // Create a renaming USE of the specific procedure.
2066 auto rename{context_.SaveTempName(
2067 used->symbol().owner().GetName().value().ToString() + "$" +
2068 specific.name().ToString())};
2069 return *const_cast<semantics::Scope &>(scope)
2070 .try_emplace(rename, specific.attrs(),
2071 semantics::UseDetails{rename, specific})
2072 .first->second;
2073 } else {
2074 return specific;
2075 }
2076 }
2077
EmitGenericResolutionError(const Symbol & symbol)2078 void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol) {
2079 if (semantics::IsGenericDefinedOp(symbol)) {
2080 Say("No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US,
2081 symbol.name());
2082 } else {
2083 Say("No specific procedure of generic '%s' matches the actual arguments"_err_en_US,
2084 symbol.name());
2085 }
2086 }
2087
GetCalleeAndArguments(const parser::ProcedureDesignator & pd,ActualArguments && arguments,bool isSubroutine,bool mightBeStructureConstructor)2088 auto ExpressionAnalyzer::GetCalleeAndArguments(
2089 const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
2090 bool isSubroutine, bool mightBeStructureConstructor)
2091 -> std::optional<CalleeAndArguments> {
2092 return std::visit(
2093 common::visitors{
2094 [&](const parser::Name &name) {
2095 return GetCalleeAndArguments(name, std::move(arguments),
2096 isSubroutine, mightBeStructureConstructor);
2097 },
2098 [&](const parser::ProcComponentRef &pcr) {
2099 return AnalyzeProcedureComponentRef(pcr, std::move(arguments));
2100 },
2101 },
2102 pd.u);
2103 }
2104
GetCalleeAndArguments(const parser::Name & name,ActualArguments && arguments,bool isSubroutine,bool mightBeStructureConstructor)2105 auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
2106 ActualArguments &&arguments, bool isSubroutine,
2107 bool mightBeStructureConstructor) -> std::optional<CalleeAndArguments> {
2108 const Symbol *symbol{name.symbol};
2109 if (context_.HasError(symbol)) {
2110 return std::nullopt; // also handles null symbol
2111 }
2112 const Symbol &ultimate{DEREF(symbol).GetUltimate()};
2113 if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
2114 if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
2115 CallCharacteristics{ultimate.name().ToString(), isSubroutine},
2116 arguments, GetFoldingContext())}) {
2117 CheckBadExplicitType(*specificCall, *symbol);
2118 return CalleeAndArguments{
2119 ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
2120 std::move(specificCall->arguments)};
2121 }
2122 } else {
2123 CheckForBadRecursion(name.source, ultimate);
2124 if (ultimate.has<semantics::GenericDetails>()) {
2125 ExpressionAnalyzer::AdjustActuals noAdjustment;
2126 symbol = ResolveGeneric(
2127 *symbol, arguments, noAdjustment, mightBeStructureConstructor);
2128 }
2129 if (symbol) {
2130 if (symbol->GetUltimate().has<semantics::DerivedTypeDetails>()) {
2131 if (mightBeStructureConstructor) {
2132 return CalleeAndArguments{
2133 semantics::SymbolRef{*symbol}, std::move(arguments)};
2134 }
2135 } else if (IsProcedure(*symbol)) {
2136 return CalleeAndArguments{
2137 ProcedureDesignator{*symbol}, std::move(arguments)};
2138 }
2139 if (!context_.HasError(*symbol)) {
2140 AttachDeclaration(
2141 Say(name.source, "'%s' is not a callable procedure"_err_en_US,
2142 name.source),
2143 *symbol);
2144 }
2145 } else if (std::optional<SpecificCall> specificCall{
2146 context_.intrinsics().Probe(
2147 CallCharacteristics{
2148 ultimate.name().ToString(), isSubroutine},
2149 arguments, GetFoldingContext())}) {
2150 // Generics can extend intrinsics
2151 return CalleeAndArguments{
2152 ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
2153 std::move(specificCall->arguments)};
2154 } else {
2155 EmitGenericResolutionError(*name.symbol);
2156 }
2157 }
2158 return std::nullopt;
2159 }
2160
2161 // Fortran 2018 expressly states (8.2 p3) that any declared type for a
2162 // generic intrinsic function "has no effect" on the result type of a
2163 // call to that intrinsic. So one can declare "character*8 cos" and
2164 // still get a real result from "cos(1.)". This is a dangerous feature,
2165 // especially since implementations are free to extend their sets of
2166 // intrinsics, and in doing so might clash with a name in a program.
2167 // So we emit a warning in this situation, and perhaps it should be an
2168 // error -- any correctly working program can silence the message by
2169 // simply deleting the pointless type declaration.
CheckBadExplicitType(const SpecificCall & call,const Symbol & intrinsic)2170 void ExpressionAnalyzer::CheckBadExplicitType(
2171 const SpecificCall &call, const Symbol &intrinsic) {
2172 if (intrinsic.GetUltimate().GetType()) {
2173 const auto &procedure{call.specificIntrinsic.characteristics.value()};
2174 if (const auto &result{procedure.functionResult}) {
2175 if (const auto *typeAndShape{result->GetTypeAndShape()}) {
2176 if (auto declared{
2177 typeAndShape->Characterize(intrinsic, GetFoldingContext())}) {
2178 if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) {
2179 if (auto *msg{Say(
2180 "The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_en_US,
2181 typeAndShape->AsFortran(), intrinsic.name(),
2182 declared->AsFortran())}) {
2183 msg->Attach(intrinsic.name(),
2184 "Ignored declaration of intrinsic function '%s'"_en_US,
2185 intrinsic.name());
2186 }
2187 }
2188 }
2189 }
2190 }
2191 }
2192 }
2193
CheckForBadRecursion(parser::CharBlock callSite,const semantics::Symbol & proc)2194 void ExpressionAnalyzer::CheckForBadRecursion(
2195 parser::CharBlock callSite, const semantics::Symbol &proc) {
2196 if (const auto *scope{proc.scope()}) {
2197 if (scope->sourceRange().Contains(callSite)) {
2198 parser::Message *msg{nullptr};
2199 if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)
2200 msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
2201 callSite);
2202 } else if (IsAssumedLengthCharacter(proc) && IsExternal(proc)) {
2203 msg = Say( // 15.6.2.1(3)
2204 "Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
2205 callSite);
2206 }
2207 AttachDeclaration(msg, proc);
2208 }
2209 }
2210 }
2211
AssumedTypeDummy(const A & x)2212 template <typename A> static const Symbol *AssumedTypeDummy(const A &x) {
2213 if (const auto *designator{
2214 std::get_if<common::Indirection<parser::Designator>>(&x.u)}) {
2215 if (const auto *dataRef{
2216 std::get_if<parser::DataRef>(&designator->value().u)}) {
2217 if (const auto *name{std::get_if<parser::Name>(&dataRef->u)}) {
2218 return AssumedTypeDummy(*name);
2219 }
2220 }
2221 }
2222 return nullptr;
2223 }
2224 template <>
AssumedTypeDummy(const parser::Name & name)2225 const Symbol *AssumedTypeDummy<parser::Name>(const parser::Name &name) {
2226 if (const Symbol * symbol{name.symbol}) {
2227 if (const auto *type{symbol->GetType()}) {
2228 if (type->category() == semantics::DeclTypeSpec::TypeStar) {
2229 return symbol;
2230 }
2231 }
2232 }
2233 return nullptr;
2234 }
2235 template <typename A>
AssumedTypePointerOrAllocatableDummy(const A & object)2236 static const Symbol *AssumedTypePointerOrAllocatableDummy(const A &object) {
2237 // It is illegal for allocatable of pointer objects to be TYPE(*), but at that
2238 // point it is is not guaranteed that it has been checked the object has
2239 // POINTER or ALLOCATABLE attribute, so do not assume nullptr can be directly
2240 // returned.
2241 return std::visit(
2242 common::visitors{
2243 [&](const parser::StructureComponent &x) {
2244 return AssumedTypeDummy(x.component);
2245 },
2246 [&](const parser::Name &x) { return AssumedTypeDummy(x); },
2247 },
2248 object.u);
2249 }
2250 template <>
AssumedTypeDummy(const parser::AllocateObject & x)2251 const Symbol *AssumedTypeDummy<parser::AllocateObject>(
2252 const parser::AllocateObject &x) {
2253 return AssumedTypePointerOrAllocatableDummy(x);
2254 }
2255 template <>
AssumedTypeDummy(const parser::PointerObject & x)2256 const Symbol *AssumedTypeDummy<parser::PointerObject>(
2257 const parser::PointerObject &x) {
2258 return AssumedTypePointerOrAllocatableDummy(x);
2259 }
2260
CheckIsValidForwardReference(const semantics::DerivedTypeSpec & dtSpec)2261 bool ExpressionAnalyzer::CheckIsValidForwardReference(
2262 const semantics::DerivedTypeSpec &dtSpec) {
2263 if (dtSpec.IsForwardReferenced()) {
2264 Say("Cannot construct value for derived type '%s' "
2265 "before it is defined"_err_en_US,
2266 dtSpec.name());
2267 return false;
2268 }
2269 return true;
2270 }
2271
Analyze(const parser::FunctionReference & funcRef,std::optional<parser::StructureConstructor> * structureConstructor)2272 MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,
2273 std::optional<parser::StructureConstructor> *structureConstructor) {
2274 const parser::Call &call{funcRef.v};
2275 auto restorer{GetContextualMessages().SetLocation(call.source)};
2276 ArgumentAnalyzer analyzer{*this, call.source, true /* isProcedureCall */};
2277 for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
2278 analyzer.Analyze(arg, false /* not subroutine call */);
2279 }
2280 if (analyzer.fatalErrors()) {
2281 return std::nullopt;
2282 }
2283 if (std::optional<CalleeAndArguments> callee{
2284 GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
2285 analyzer.GetActuals(), false /* not subroutine */,
2286 true /* might be structure constructor */)}) {
2287 if (auto *proc{std::get_if<ProcedureDesignator>(&callee->u)}) {
2288 return MakeFunctionRef(
2289 call.source, std::move(*proc), std::move(callee->arguments));
2290 }
2291 CHECK(std::holds_alternative<semantics::SymbolRef>(callee->u));
2292 const Symbol &symbol{*std::get<semantics::SymbolRef>(callee->u)};
2293 if (structureConstructor) {
2294 // Structure constructor misparsed as function reference?
2295 const auto &designator{std::get<parser::ProcedureDesignator>(call.t)};
2296 if (const auto *name{std::get_if<parser::Name>(&designator.u)}) {
2297 semantics::Scope &scope{context_.FindScope(name->source)};
2298 semantics::DerivedTypeSpec dtSpec{name->source, symbol.GetUltimate()};
2299 if (!CheckIsValidForwardReference(dtSpec)) {
2300 return std::nullopt;
2301 }
2302 const semantics::DeclTypeSpec &type{
2303 semantics::FindOrInstantiateDerivedType(scope, std::move(dtSpec))};
2304 auto &mutableRef{const_cast<parser::FunctionReference &>(funcRef)};
2305 *structureConstructor =
2306 mutableRef.ConvertToStructureConstructor(type.derivedTypeSpec());
2307 return Analyze(structureConstructor->value());
2308 }
2309 }
2310 if (!context_.HasError(symbol)) {
2311 AttachDeclaration(
2312 Say("'%s' is called like a function but is not a procedure"_err_en_US,
2313 symbol.name()),
2314 symbol);
2315 context_.SetError(symbol);
2316 }
2317 }
2318 return std::nullopt;
2319 }
2320
HasAlternateReturns(const evaluate::ActualArguments & args)2321 static bool HasAlternateReturns(const evaluate::ActualArguments &args) {
2322 for (const auto &arg : args) {
2323 if (arg && arg->isAlternateReturn()) {
2324 return true;
2325 }
2326 }
2327 return false;
2328 }
2329
Analyze(const parser::CallStmt & callStmt)2330 void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
2331 const parser::Call &call{callStmt.v};
2332 auto restorer{GetContextualMessages().SetLocation(call.source)};
2333 ArgumentAnalyzer analyzer{*this, call.source, true /* isProcedureCall */};
2334 const auto &actualArgList{std::get<std::list<parser::ActualArgSpec>>(call.t)};
2335 for (const auto &arg : actualArgList) {
2336 analyzer.Analyze(arg, true /* is subroutine call */);
2337 }
2338 if (!analyzer.fatalErrors()) {
2339 if (std::optional<CalleeAndArguments> callee{
2340 GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
2341 analyzer.GetActuals(), true /* subroutine */)}) {
2342 ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};
2343 CHECK(proc);
2344 if (CheckCall(call.source, *proc, callee->arguments)) {
2345 bool hasAlternateReturns{HasAlternateReturns(callee->arguments)};
2346 callStmt.typedCall.Reset(
2347 new ProcedureRef{std::move(*proc), std::move(callee->arguments),
2348 hasAlternateReturns},
2349 ProcedureRef::Deleter);
2350 }
2351 }
2352 }
2353 }
2354
Analyze(const parser::AssignmentStmt & x)2355 const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
2356 if (!x.typedAssignment) {
2357 ArgumentAnalyzer analyzer{*this};
2358 analyzer.Analyze(std::get<parser::Variable>(x.t));
2359 analyzer.Analyze(std::get<parser::Expr>(x.t));
2360 std::optional<Assignment> assignment;
2361 if (!analyzer.fatalErrors()) {
2362 std::optional<ProcedureRef> procRef{analyzer.TryDefinedAssignment()};
2363 if (!procRef) {
2364 analyzer.CheckForNullPointer(
2365 "in a non-pointer intrinsic assignment statement");
2366 }
2367 assignment.emplace(analyzer.MoveExpr(0), analyzer.MoveExpr(1));
2368 if (procRef) {
2369 assignment->u = std::move(*procRef);
2370 }
2371 }
2372 x.typedAssignment.Reset(new GenericAssignmentWrapper{std::move(assignment)},
2373 GenericAssignmentWrapper::Deleter);
2374 }
2375 return common::GetPtrFromOptional(x.typedAssignment->v);
2376 }
2377
Analyze(const parser::PointerAssignmentStmt & x)2378 const Assignment *ExpressionAnalyzer::Analyze(
2379 const parser::PointerAssignmentStmt &x) {
2380 if (!x.typedAssignment) {
2381 MaybeExpr lhs{Analyze(std::get<parser::DataRef>(x.t))};
2382 MaybeExpr rhs{Analyze(std::get<parser::Expr>(x.t))};
2383 if (!lhs || !rhs) {
2384 x.typedAssignment.Reset(
2385 new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);
2386 } else {
2387 Assignment assignment{std::move(*lhs), std::move(*rhs)};
2388 std::visit(common::visitors{
2389 [&](const std::list<parser::BoundsRemapping> &list) {
2390 Assignment::BoundsRemapping bounds;
2391 for (const auto &elem : list) {
2392 auto lower{AsSubscript(Analyze(std::get<0>(elem.t)))};
2393 auto upper{AsSubscript(Analyze(std::get<1>(elem.t)))};
2394 if (lower && upper) {
2395 bounds.emplace_back(Fold(std::move(*lower)),
2396 Fold(std::move(*upper)));
2397 }
2398 }
2399 assignment.u = std::move(bounds);
2400 },
2401 [&](const std::list<parser::BoundsSpec> &list) {
2402 Assignment::BoundsSpec bounds;
2403 for (const auto &bound : list) {
2404 if (auto lower{AsSubscript(Analyze(bound.v))}) {
2405 bounds.emplace_back(Fold(std::move(*lower)));
2406 }
2407 }
2408 assignment.u = std::move(bounds);
2409 },
2410 },
2411 std::get<parser::PointerAssignmentStmt::Bounds>(x.t).u);
2412 x.typedAssignment.Reset(
2413 new GenericAssignmentWrapper{std::move(assignment)},
2414 GenericAssignmentWrapper::Deleter);
2415 }
2416 }
2417 return common::GetPtrFromOptional(x.typedAssignment->v);
2418 }
2419
IsExternalCalledImplicitly(parser::CharBlock callSite,const ProcedureDesignator & proc)2420 static bool IsExternalCalledImplicitly(
2421 parser::CharBlock callSite, const ProcedureDesignator &proc) {
2422 if (const auto *symbol{proc.GetSymbol()}) {
2423 return symbol->has<semantics::SubprogramDetails>() &&
2424 symbol->owner().IsGlobal() &&
2425 (!symbol->scope() /*ENTRY*/ ||
2426 !symbol->scope()->sourceRange().Contains(callSite));
2427 } else {
2428 return false;
2429 }
2430 }
2431
CheckCall(parser::CharBlock callSite,const ProcedureDesignator & proc,ActualArguments & arguments)2432 std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
2433 parser::CharBlock callSite, const ProcedureDesignator &proc,
2434 ActualArguments &arguments) {
2435 auto chars{characteristics::Procedure::Characterize(
2436 proc, context_.foldingContext())};
2437 if (chars) {
2438 bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
2439 if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) {
2440 Say(callSite,
2441 "References to the procedure '%s' require an explicit interface"_en_US,
2442 DEREF(proc.GetSymbol()).name());
2443 }
2444 // Checks for ASSOCIATED() are done in intrinsic table processing
2445 bool procIsAssociated{false};
2446 if (const SpecificIntrinsic *
2447 specificIntrinsic{proc.GetSpecificIntrinsic()}) {
2448 if (specificIntrinsic->name == "associated") {
2449 procIsAssociated = true;
2450 }
2451 }
2452 if (!procIsAssociated) {
2453 semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
2454 context_.FindScope(callSite), treatExternalAsImplicit,
2455 proc.GetSpecificIntrinsic());
2456 const Symbol *procSymbol{proc.GetSymbol()};
2457 if (procSymbol && !IsPureProcedure(*procSymbol)) {
2458 if (const semantics::Scope *
2459 pure{semantics::FindPureProcedureContaining(
2460 context_.FindScope(callSite))}) {
2461 Say(callSite,
2462 "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US,
2463 procSymbol->name(), DEREF(pure->symbol()).name());
2464 }
2465 }
2466 }
2467 }
2468 return chars;
2469 }
2470
2471 // Unary operations
2472
Analyze(const parser::Expr::Parentheses & x)2473 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
2474 if (MaybeExpr operand{Analyze(x.v.value())}) {
2475 if (const semantics::Symbol * symbol{GetLastSymbol(*operand)}) {
2476 if (const semantics::Symbol * result{FindFunctionResult(*symbol)}) {
2477 if (semantics::IsProcedurePointer(*result)) {
2478 Say("A function reference that returns a procedure "
2479 "pointer may not be parenthesized"_err_en_US); // C1003
2480 }
2481 }
2482 }
2483 return Parenthesize(std::move(*operand));
2484 }
2485 return std::nullopt;
2486 }
2487
NumericUnaryHelper(ExpressionAnalyzer & context,NumericOperator opr,const parser::Expr::IntrinsicUnary & x)2488 static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
2489 NumericOperator opr, const parser::Expr::IntrinsicUnary &x) {
2490 ArgumentAnalyzer analyzer{context};
2491 analyzer.Analyze(x.v);
2492 if (!analyzer.fatalErrors()) {
2493 if (analyzer.IsIntrinsicNumeric(opr)) {
2494 analyzer.CheckForNullPointer();
2495 if (opr == NumericOperator::Add) {
2496 return analyzer.MoveExpr(0);
2497 } else {
2498 return Negation(context.GetContextualMessages(), analyzer.MoveExpr(0));
2499 }
2500 } else {
2501 return analyzer.TryDefinedOp(AsFortran(opr),
2502 "Operand of unary %s must be numeric; have %s"_err_en_US);
2503 }
2504 }
2505 return std::nullopt;
2506 }
2507
Analyze(const parser::Expr::UnaryPlus & x)2508 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
2509 return NumericUnaryHelper(*this, NumericOperator::Add, x);
2510 }
2511
Analyze(const parser::Expr::Negate & x)2512 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Negate &x) {
2513 return NumericUnaryHelper(*this, NumericOperator::Subtract, x);
2514 }
2515
Analyze(const parser::Expr::NOT & x)2516 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
2517 ArgumentAnalyzer analyzer{*this};
2518 analyzer.Analyze(x.v);
2519 if (!analyzer.fatalErrors()) {
2520 if (analyzer.IsIntrinsicLogical()) {
2521 analyzer.CheckForNullPointer();
2522 return AsGenericExpr(
2523 LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));
2524 } else {
2525 return analyzer.TryDefinedOp(LogicalOperator::Not,
2526 "Operand of %s must be LOGICAL; have %s"_err_en_US);
2527 }
2528 }
2529 return std::nullopt;
2530 }
2531
Analyze(const parser::Expr::PercentLoc & x)2532 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
2533 // Represent %LOC() exactly as if it had been a call to the LOC() extension
2534 // intrinsic function.
2535 // Use the actual source for the name of the call for error reporting.
2536 std::optional<ActualArgument> arg;
2537 if (const Symbol * assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
2538 arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
2539 } else if (MaybeExpr argExpr{Analyze(x.v.value())}) {
2540 arg = ActualArgument{std::move(*argExpr)};
2541 } else {
2542 return std::nullopt;
2543 }
2544 parser::CharBlock at{GetContextualMessages().at()};
2545 CHECK(at.size() >= 4);
2546 parser::CharBlock loc{at.begin() + 1, 3};
2547 CHECK(loc == "loc");
2548 return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
2549 }
2550
Analyze(const parser::Expr::DefinedUnary & x)2551 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
2552 const auto &name{std::get<parser::DefinedOpName>(x.t).v};
2553 ArgumentAnalyzer analyzer{*this, name.source};
2554 analyzer.Analyze(std::get<1>(x.t));
2555 return analyzer.TryDefinedOp(name.source.ToString().c_str(),
2556 "No operator %s defined for %s"_err_en_US, nullptr, true);
2557 }
2558
2559 // Binary (dyadic) operations
2560
2561 template <template <typename> class OPR>
NumericBinaryHelper(ExpressionAnalyzer & context,NumericOperator opr,const parser::Expr::IntrinsicBinary & x)2562 MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
2563 const parser::Expr::IntrinsicBinary &x) {
2564 ArgumentAnalyzer analyzer{context};
2565 analyzer.Analyze(std::get<0>(x.t));
2566 analyzer.Analyze(std::get<1>(x.t));
2567 if (!analyzer.fatalErrors()) {
2568 if (analyzer.IsIntrinsicNumeric(opr)) {
2569 analyzer.CheckForNullPointer();
2570 analyzer.CheckConformance();
2571 return NumericOperation<OPR>(context.GetContextualMessages(),
2572 analyzer.MoveExpr(0), analyzer.MoveExpr(1),
2573 context.GetDefaultKind(TypeCategory::Real));
2574 } else {
2575 return analyzer.TryDefinedOp(AsFortran(opr),
2576 "Operands of %s must be numeric; have %s and %s"_err_en_US);
2577 }
2578 }
2579 return std::nullopt;
2580 }
2581
Analyze(const parser::Expr::Power & x)2582 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Power &x) {
2583 return NumericBinaryHelper<Power>(*this, NumericOperator::Power, x);
2584 }
2585
Analyze(const parser::Expr::Multiply & x)2586 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Multiply &x) {
2587 return NumericBinaryHelper<Multiply>(*this, NumericOperator::Multiply, x);
2588 }
2589
Analyze(const parser::Expr::Divide & x)2590 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Divide &x) {
2591 return NumericBinaryHelper<Divide>(*this, NumericOperator::Divide, x);
2592 }
2593
Analyze(const parser::Expr::Add & x)2594 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Add &x) {
2595 return NumericBinaryHelper<Add>(*this, NumericOperator::Add, x);
2596 }
2597
Analyze(const parser::Expr::Subtract & x)2598 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {
2599 return NumericBinaryHelper<Subtract>(*this, NumericOperator::Subtract, x);
2600 }
2601
Analyze(const parser::Expr::ComplexConstructor & x)2602 MaybeExpr ExpressionAnalyzer::Analyze(
2603 const parser::Expr::ComplexConstructor &x) {
2604 auto re{Analyze(std::get<0>(x.t).value())};
2605 auto im{Analyze(std::get<1>(x.t).value())};
2606 if (re && im) {
2607 ConformabilityCheck(GetContextualMessages(), *re, *im);
2608 }
2609 return AsMaybeExpr(ConstructComplex(GetContextualMessages(), std::move(re),
2610 std::move(im), GetDefaultKind(TypeCategory::Real)));
2611 }
2612
Analyze(const parser::Expr::Concat & x)2613 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
2614 ArgumentAnalyzer analyzer{*this};
2615 analyzer.Analyze(std::get<0>(x.t));
2616 analyzer.Analyze(std::get<1>(x.t));
2617 if (!analyzer.fatalErrors()) {
2618 if (analyzer.IsIntrinsicConcat()) {
2619 analyzer.CheckForNullPointer();
2620 return std::visit(
2621 [&](auto &&x, auto &&y) -> MaybeExpr {
2622 using T = ResultType<decltype(x)>;
2623 if constexpr (std::is_same_v<T, ResultType<decltype(y)>>) {
2624 return AsGenericExpr(Concat<T::kind>{std::move(x), std::move(y)});
2625 } else {
2626 DIE("different types for intrinsic concat");
2627 }
2628 },
2629 std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(0).u).u),
2630 std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(1).u).u));
2631 } else {
2632 return analyzer.TryDefinedOp("//",
2633 "Operands of %s must be CHARACTER with the same kind; have %s and %s"_err_en_US);
2634 }
2635 }
2636 return std::nullopt;
2637 }
2638
2639 // The Name represents a user-defined intrinsic operator.
2640 // If the actuals match one of the specific procedures, return a function ref.
2641 // Otherwise report the error in messages.
AnalyzeDefinedOp(const parser::Name & name,ActualArguments && actuals)2642 MaybeExpr ExpressionAnalyzer::AnalyzeDefinedOp(
2643 const parser::Name &name, ActualArguments &&actuals) {
2644 if (auto callee{GetCalleeAndArguments(name, std::move(actuals))}) {
2645 CHECK(std::holds_alternative<ProcedureDesignator>(callee->u));
2646 return MakeFunctionRef(name.source,
2647 std::move(std::get<ProcedureDesignator>(callee->u)),
2648 std::move(callee->arguments));
2649 } else {
2650 return std::nullopt;
2651 }
2652 }
2653
RelationHelper(ExpressionAnalyzer & context,RelationalOperator opr,const parser::Expr::IntrinsicBinary & x)2654 MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
2655 const parser::Expr::IntrinsicBinary &x) {
2656 ArgumentAnalyzer analyzer{context};
2657 analyzer.Analyze(std::get<0>(x.t));
2658 analyzer.Analyze(std::get<1>(x.t));
2659 if (!analyzer.fatalErrors()) {
2660 std::optional<DynamicType> leftType{analyzer.GetType(0)};
2661 std::optional<DynamicType> rightType{analyzer.GetType(1)};
2662 analyzer.ConvertBOZ(leftType, 0, rightType);
2663 analyzer.ConvertBOZ(rightType, 1, leftType);
2664 if (leftType && rightType &&
2665 analyzer.IsIntrinsicRelational(opr, *leftType, *rightType)) {
2666 analyzer.CheckForNullPointer("as a relational operand");
2667 return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
2668 analyzer.MoveExpr(0), analyzer.MoveExpr(1)));
2669 } else {
2670 return analyzer.TryDefinedOp(opr,
2671 leftType && leftType->category() == TypeCategory::Logical &&
2672 rightType && rightType->category() == TypeCategory::Logical
2673 ? "LOGICAL operands must be compared using .EQV. or .NEQV."_err_en_US
2674 : "Operands of %s must have comparable types; have %s and %s"_err_en_US);
2675 }
2676 }
2677 return std::nullopt;
2678 }
2679
Analyze(const parser::Expr::LT & x)2680 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LT &x) {
2681 return RelationHelper(*this, RelationalOperator::LT, x);
2682 }
2683
Analyze(const parser::Expr::LE & x)2684 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LE &x) {
2685 return RelationHelper(*this, RelationalOperator::LE, x);
2686 }
2687
Analyze(const parser::Expr::EQ & x)2688 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQ &x) {
2689 return RelationHelper(*this, RelationalOperator::EQ, x);
2690 }
2691
Analyze(const parser::Expr::NE & x)2692 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NE &x) {
2693 return RelationHelper(*this, RelationalOperator::NE, x);
2694 }
2695
Analyze(const parser::Expr::GE & x)2696 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GE &x) {
2697 return RelationHelper(*this, RelationalOperator::GE, x);
2698 }
2699
Analyze(const parser::Expr::GT & x)2700 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GT &x) {
2701 return RelationHelper(*this, RelationalOperator::GT, x);
2702 }
2703
LogicalBinaryHelper(ExpressionAnalyzer & context,LogicalOperator opr,const parser::Expr::IntrinsicBinary & x)2704 MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,
2705 const parser::Expr::IntrinsicBinary &x) {
2706 ArgumentAnalyzer analyzer{context};
2707 analyzer.Analyze(std::get<0>(x.t));
2708 analyzer.Analyze(std::get<1>(x.t));
2709 if (!analyzer.fatalErrors()) {
2710 if (analyzer.IsIntrinsicLogical()) {
2711 analyzer.CheckForNullPointer("as a logical operand");
2712 return AsGenericExpr(BinaryLogicalOperation(opr,
2713 std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),
2714 std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));
2715 } else {
2716 return analyzer.TryDefinedOp(
2717 opr, "Operands of %s must be LOGICAL; have %s and %s"_err_en_US);
2718 }
2719 }
2720 return std::nullopt;
2721 }
2722
Analyze(const parser::Expr::AND & x)2723 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::AND &x) {
2724 return LogicalBinaryHelper(*this, LogicalOperator::And, x);
2725 }
2726
Analyze(const parser::Expr::OR & x)2727 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::OR &x) {
2728 return LogicalBinaryHelper(*this, LogicalOperator::Or, x);
2729 }
2730
Analyze(const parser::Expr::EQV & x)2731 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQV &x) {
2732 return LogicalBinaryHelper(*this, LogicalOperator::Eqv, x);
2733 }
2734
Analyze(const parser::Expr::NEQV & x)2735 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NEQV &x) {
2736 return LogicalBinaryHelper(*this, LogicalOperator::Neqv, x);
2737 }
2738
Analyze(const parser::Expr::DefinedBinary & x)2739 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
2740 const auto &name{std::get<parser::DefinedOpName>(x.t).v};
2741 ArgumentAnalyzer analyzer{*this, name.source};
2742 analyzer.Analyze(std::get<1>(x.t));
2743 analyzer.Analyze(std::get<2>(x.t));
2744 return analyzer.TryDefinedOp(name.source.ToString().c_str(),
2745 "No operator %s defined for %s and %s"_err_en_US, nullptr, true);
2746 }
2747
CheckFuncRefToArrayElementRefHasSubscripts(semantics::SemanticsContext & context,const parser::FunctionReference & funcRef)2748 static void CheckFuncRefToArrayElementRefHasSubscripts(
2749 semantics::SemanticsContext &context,
2750 const parser::FunctionReference &funcRef) {
2751 // Emit message if the function reference fix will end up an array element
2752 // reference with no subscripts because it will not be possible to later tell
2753 // the difference in expressions between empty subscript list due to bad
2754 // subscripts error recovery or because the user did not put any.
2755 if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {
2756 auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
2757 const auto *name{std::get_if<parser::Name>(&proc.u)};
2758 if (!name) {
2759 name = &std::get<parser::ProcComponentRef>(proc.u).v.thing.component;
2760 }
2761 auto &msg{context.Say(funcRef.v.source,
2762 name->symbol && name->symbol->Rank() == 0
2763 ? "'%s' is not a function"_err_en_US
2764 : "Reference to array '%s' with empty subscript list"_err_en_US,
2765 name->source)};
2766 if (name->symbol) {
2767 if (semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)) {
2768 msg.Attach(name->source,
2769 "A result variable must be declared with RESULT to allow recursive "
2770 "function calls"_en_US);
2771 } else {
2772 AttachDeclaration(&msg, *name->symbol);
2773 }
2774 }
2775 }
2776 }
2777
2778 // Converts, if appropriate, an original misparse of ambiguous syntax like
2779 // A(1) as a function reference into an array reference.
2780 // Misparsed structure constructors are detected elsewhere after generic
2781 // function call resolution fails.
2782 template <typename... A>
FixMisparsedFunctionReference(semantics::SemanticsContext & context,const std::variant<A...> & constU)2783 static void FixMisparsedFunctionReference(
2784 semantics::SemanticsContext &context, const std::variant<A...> &constU) {
2785 // The parse tree is updated in situ when resolving an ambiguous parse.
2786 using uType = std::decay_t<decltype(constU)>;
2787 auto &u{const_cast<uType &>(constU)};
2788 if (auto *func{
2789 std::get_if<common::Indirection<parser::FunctionReference>>(&u)}) {
2790 parser::FunctionReference &funcRef{func->value()};
2791 auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
2792 if (Symbol *
2793 origSymbol{
2794 std::visit(common::visitors{
2795 [&](parser::Name &name) { return name.symbol; },
2796 [&](parser::ProcComponentRef &pcr) {
2797 return pcr.v.thing.component.symbol;
2798 },
2799 },
2800 proc.u)}) {
2801 Symbol &symbol{origSymbol->GetUltimate()};
2802 if (symbol.has<semantics::ObjectEntityDetails>() ||
2803 symbol.has<semantics::AssocEntityDetails>()) {
2804 // Note that expression in AssocEntityDetails cannot be a procedure
2805 // pointer as per C1105 so this cannot be a function reference.
2806 if constexpr (common::HasMember<common::Indirection<parser::Designator>,
2807 uType>) {
2808 CheckFuncRefToArrayElementRefHasSubscripts(context, funcRef);
2809 u = common::Indirection{funcRef.ConvertToArrayElementRef()};
2810 } else {
2811 DIE("can't fix misparsed function as array reference");
2812 }
2813 }
2814 }
2815 }
2816 }
2817
2818 // Common handling of parse tree node types that retain the
2819 // representation of the analyzed expression.
2820 template <typename PARSED>
ExprOrVariable(const PARSED & x,parser::CharBlock source)2821 MaybeExpr ExpressionAnalyzer::ExprOrVariable(
2822 const PARSED &x, parser::CharBlock source) {
2823 if (useSavedTypedExprs_ && x.typedExpr) {
2824 return x.typedExpr->v;
2825 }
2826 auto restorer{GetContextualMessages().SetLocation(source)};
2827 if constexpr (std::is_same_v<PARSED, parser::Expr> ||
2828 std::is_same_v<PARSED, parser::Variable>) {
2829 FixMisparsedFunctionReference(context_, x.u);
2830 }
2831 if (AssumedTypeDummy(x)) { // C710
2832 Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
2833 ResetExpr(x);
2834 return std::nullopt;
2835 }
2836 MaybeExpr result;
2837 if constexpr (common::HasMember<parser::StructureConstructor,
2838 std::decay_t<decltype(x.u)>> &&
2839 common::HasMember<common::Indirection<parser::FunctionReference>,
2840 std::decay_t<decltype(x.u)>>) {
2841 if (const auto *funcRef{
2842 std::get_if<common::Indirection<parser::FunctionReference>>(
2843 &x.u)}) {
2844 // Function references in Exprs might turn out to be misparsed structure
2845 // constructors; we have to try generic procedure resolution
2846 // first to be sure.
2847 std::optional<parser::StructureConstructor> ctor;
2848 result = Analyze(funcRef->value(), &ctor);
2849 if (result && ctor) {
2850 // A misparsed function reference is really a structure
2851 // constructor. Repair the parse tree in situ.
2852 const_cast<PARSED &>(x).u = std::move(*ctor);
2853 }
2854 } else {
2855 result = Analyze(x.u);
2856 }
2857 } else {
2858 result = Analyze(x.u);
2859 }
2860 if (result) {
2861 SetExpr(x, Fold(std::move(*result)));
2862 return x.typedExpr->v;
2863 } else {
2864 ResetExpr(x);
2865 if (!context_.AnyFatalError()) {
2866 std::string buf;
2867 llvm::raw_string_ostream dump{buf};
2868 parser::DumpTree(dump, x);
2869 Say("Internal error: Expression analysis failed on: %s"_err_en_US,
2870 dump.str());
2871 }
2872 return std::nullopt;
2873 }
2874 }
2875
Analyze(const parser::Expr & expr)2876 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {
2877 return ExprOrVariable(expr, expr.source);
2878 }
2879
Analyze(const parser::Variable & variable)2880 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Variable &variable) {
2881 return ExprOrVariable(variable, variable.GetSource());
2882 }
2883
Analyze(const parser::Selector & selector)2884 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Selector &selector) {
2885 if (const auto *var{std::get_if<parser::Variable>(&selector.u)}) {
2886 if (!useSavedTypedExprs_ || !var->typedExpr) {
2887 parser::CharBlock source{var->GetSource()};
2888 auto restorer{GetContextualMessages().SetLocation(source)};
2889 FixMisparsedFunctionReference(context_, var->u);
2890 if (const auto *funcRef{
2891 std::get_if<common::Indirection<parser::FunctionReference>>(
2892 &var->u)}) {
2893 // A Selector that parsed as a Variable might turn out during analysis
2894 // to actually be a structure constructor. In that case, repair the
2895 // Variable parse tree node into an Expr
2896 std::optional<parser::StructureConstructor> ctor;
2897 if (MaybeExpr result{Analyze(funcRef->value(), &ctor)}) {
2898 if (ctor) {
2899 auto &writable{const_cast<parser::Selector &>(selector)};
2900 writable.u = parser::Expr{std::move(*ctor)};
2901 auto &expr{std::get<parser::Expr>(writable.u)};
2902 expr.source = source;
2903 SetExpr(expr, Fold(std::move(*result)));
2904 return expr.typedExpr->v;
2905 } else {
2906 SetExpr(*var, Fold(std::move(*result)));
2907 return var->typedExpr->v;
2908 }
2909 } else {
2910 ResetExpr(*var);
2911 if (context_.AnyFatalError()) {
2912 return std::nullopt;
2913 }
2914 }
2915 }
2916 }
2917 }
2918 // Not a Variable -> FunctionReference; handle normally as Variable or Expr
2919 return Analyze(selector.u);
2920 }
2921
Analyze(const parser::DataStmtConstant & x)2922 MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtConstant &x) {
2923 return ExprOrVariable(x, x.source);
2924 }
2925
Analyze(const parser::AllocateObject & x)2926 MaybeExpr ExpressionAnalyzer::Analyze(const parser::AllocateObject &x) {
2927 return ExprOrVariable(x, parser::FindSourceLocation(x));
2928 }
2929
Analyze(const parser::PointerObject & x)2930 MaybeExpr ExpressionAnalyzer::Analyze(const parser::PointerObject &x) {
2931 return ExprOrVariable(x, parser::FindSourceLocation(x));
2932 }
2933
AnalyzeKindSelector(TypeCategory category,const std::optional<parser::KindSelector> & selector)2934 Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
2935 TypeCategory category,
2936 const std::optional<parser::KindSelector> &selector) {
2937 int defaultKind{GetDefaultKind(category)};
2938 if (!selector) {
2939 return Expr<SubscriptInteger>{defaultKind};
2940 }
2941 return std::visit(
2942 common::visitors{
2943 [&](const parser::ScalarIntConstantExpr &x) {
2944 if (MaybeExpr kind{Analyze(x)}) {
2945 if (std::optional<std::int64_t> code{ToInt64(*kind)}) {
2946 if (CheckIntrinsicKind(category, *code)) {
2947 return Expr<SubscriptInteger>{*code};
2948 }
2949 } else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(*kind)}) {
2950 return ConvertToType<SubscriptInteger>(std::move(*intExpr));
2951 }
2952 }
2953 return Expr<SubscriptInteger>{defaultKind};
2954 },
2955 [&](const parser::KindSelector::StarSize &x) {
2956 std::intmax_t size = x.v;
2957 if (!CheckIntrinsicSize(category, size)) {
2958 size = defaultKind;
2959 } else if (category == TypeCategory::Complex) {
2960 size /= 2;
2961 }
2962 return Expr<SubscriptInteger>{size};
2963 },
2964 },
2965 selector->u);
2966 }
2967
GetDefaultKind(common::TypeCategory category)2968 int ExpressionAnalyzer::GetDefaultKind(common::TypeCategory category) {
2969 return context_.GetDefaultKind(category);
2970 }
2971
GetDefaultKindOfType(common::TypeCategory category)2972 DynamicType ExpressionAnalyzer::GetDefaultKindOfType(
2973 common::TypeCategory category) {
2974 return {category, GetDefaultKind(category)};
2975 }
2976
CheckIntrinsicKind(TypeCategory category,std::int64_t kind)2977 bool ExpressionAnalyzer::CheckIntrinsicKind(
2978 TypeCategory category, std::int64_t kind) {
2979 if (IsValidKindOfIntrinsicType(category, kind)) { // C712, C714, C715, C727
2980 return true;
2981 } else {
2982 Say("%s(KIND=%jd) is not a supported type"_err_en_US,
2983 ToUpperCase(EnumToString(category)), kind);
2984 return false;
2985 }
2986 }
2987
CheckIntrinsicSize(TypeCategory category,std::int64_t size)2988 bool ExpressionAnalyzer::CheckIntrinsicSize(
2989 TypeCategory category, std::int64_t size) {
2990 if (category == TypeCategory::Complex) {
2991 // COMPLEX*16 == COMPLEX(KIND=8)
2992 if (size % 2 == 0 && IsValidKindOfIntrinsicType(category, size / 2)) {
2993 return true;
2994 }
2995 } else if (IsValidKindOfIntrinsicType(category, size)) {
2996 return true;
2997 }
2998 Say("%s*%jd is not a supported type"_err_en_US,
2999 ToUpperCase(EnumToString(category)), size);
3000 return false;
3001 }
3002
AddImpliedDo(parser::CharBlock name,int kind)3003 bool ExpressionAnalyzer::AddImpliedDo(parser::CharBlock name, int kind) {
3004 return impliedDos_.insert(std::make_pair(name, kind)).second;
3005 }
3006
RemoveImpliedDo(parser::CharBlock name)3007 void ExpressionAnalyzer::RemoveImpliedDo(parser::CharBlock name) {
3008 auto iter{impliedDos_.find(name)};
3009 if (iter != impliedDos_.end()) {
3010 impliedDos_.erase(iter);
3011 }
3012 }
3013
IsImpliedDo(parser::CharBlock name) const3014 std::optional<int> ExpressionAnalyzer::IsImpliedDo(
3015 parser::CharBlock name) const {
3016 auto iter{impliedDos_.find(name)};
3017 if (iter != impliedDos_.cend()) {
3018 return {iter->second};
3019 } else {
3020 return std::nullopt;
3021 }
3022 }
3023
EnforceTypeConstraint(parser::CharBlock at,const MaybeExpr & result,TypeCategory category,bool defaultKind)3024 bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
3025 const MaybeExpr &result, TypeCategory category, bool defaultKind) {
3026 if (result) {
3027 if (auto type{result->GetType()}) {
3028 if (type->category() != category) { // C885
3029 Say(at, "Must have %s type, but is %s"_err_en_US,
3030 ToUpperCase(EnumToString(category)),
3031 ToUpperCase(type->AsFortran()));
3032 return false;
3033 } else if (defaultKind) {
3034 int kind{context_.GetDefaultKind(category)};
3035 if (type->kind() != kind) {
3036 Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,
3037 kind, ToUpperCase(EnumToString(category)),
3038 ToUpperCase(type->AsFortran()));
3039 return false;
3040 }
3041 }
3042 } else {
3043 Say(at, "Must have %s type, but is typeless"_err_en_US,
3044 ToUpperCase(EnumToString(category)));
3045 return false;
3046 }
3047 }
3048 return true;
3049 }
3050
MakeFunctionRef(parser::CharBlock callSite,ProcedureDesignator && proc,ActualArguments && arguments)3051 MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,
3052 ProcedureDesignator &&proc, ActualArguments &&arguments) {
3053 if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc.u)}) {
3054 if (intrinsic->name == "null" && arguments.empty()) {
3055 return Expr<SomeType>{NullPointer{}};
3056 }
3057 }
3058 if (const Symbol * symbol{proc.GetSymbol()}) {
3059 if (!ResolveForward(*symbol)) {
3060 return std::nullopt;
3061 }
3062 }
3063 if (auto chars{CheckCall(callSite, proc, arguments)}) {
3064 if (chars->functionResult) {
3065 const auto &result{*chars->functionResult};
3066 if (result.IsProcedurePointer()) {
3067 return Expr<SomeType>{
3068 ProcedureRef{std::move(proc), std::move(arguments)}};
3069 } else {
3070 // Not a procedure pointer, so type and shape are known.
3071 return TypedWrapper<FunctionRef, ProcedureRef>(
3072 DEREF(result.GetTypeAndShape()).type(),
3073 ProcedureRef{std::move(proc), std::move(arguments)});
3074 }
3075 } else {
3076 Say("Function result characteristics are not known"_err_en_US);
3077 }
3078 }
3079 return std::nullopt;
3080 }
3081
MakeFunctionRef(parser::CharBlock intrinsic,ActualArguments && arguments)3082 MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
3083 parser::CharBlock intrinsic, ActualArguments &&arguments) {
3084 if (std::optional<SpecificCall> specificCall{
3085 context_.intrinsics().Probe(CallCharacteristics{intrinsic.ToString()},
3086 arguments, GetFoldingContext())}) {
3087 return MakeFunctionRef(intrinsic,
3088 ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
3089 std::move(specificCall->arguments));
3090 } else {
3091 return std::nullopt;
3092 }
3093 }
3094
Analyze(const parser::Variable & x)3095 void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
3096 source_.ExtendToCover(x.GetSource());
3097 if (MaybeExpr expr{context_.Analyze(x)}) {
3098 if (!IsConstantExpr(*expr)) {
3099 actuals_.emplace_back(std::move(*expr));
3100 return;
3101 }
3102 const Symbol *symbol{GetLastSymbol(*expr)};
3103 if (!symbol) {
3104 context_.SayAt(x, "Assignment to constant '%s' is not allowed"_err_en_US,
3105 x.GetSource());
3106 } else if (auto *subp{symbol->detailsIf<semantics::SubprogramDetails>()}) {
3107 auto *msg{context_.SayAt(x,
3108 "Assignment to subprogram '%s' is not allowed"_err_en_US,
3109 symbol->name())};
3110 if (subp->isFunction()) {
3111 const auto &result{subp->result().name()};
3112 msg->Attach(result, "Function result is '%s'"_err_en_US, result);
3113 }
3114 } else {
3115 context_.SayAt(x, "Assignment to constant '%s' is not allowed"_err_en_US,
3116 symbol->name());
3117 }
3118 }
3119 fatalErrors_ = true;
3120 }
3121
Analyze(const parser::ActualArgSpec & arg,bool isSubroutine)3122 void ArgumentAnalyzer::Analyze(
3123 const parser::ActualArgSpec &arg, bool isSubroutine) {
3124 // TODO: Actual arguments that are procedures and procedure pointers need to
3125 // be detected and represented (they're not expressions).
3126 // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
3127 std::optional<ActualArgument> actual;
3128 std::visit(common::visitors{
3129 [&](const common::Indirection<parser::Expr> &x) {
3130 actual = AnalyzeExpr(x.value());
3131 },
3132 [&](const parser::AltReturnSpec &label) {
3133 if (!isSubroutine) {
3134 context_.Say(
3135 "alternate return specification may not appear on"
3136 " function reference"_err_en_US);
3137 }
3138 actual = ActualArgument(label.v);
3139 },
3140 [&](const parser::ActualArg::PercentRef &) {
3141 context_.Say("TODO: %REF() argument"_err_en_US);
3142 },
3143 [&](const parser::ActualArg::PercentVal &) {
3144 context_.Say("TODO: %VAL() argument"_err_en_US);
3145 },
3146 },
3147 std::get<parser::ActualArg>(arg.t).u);
3148 if (actual) {
3149 if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {
3150 actual->set_keyword(argKW->v.source);
3151 }
3152 actuals_.emplace_back(std::move(*actual));
3153 } else {
3154 fatalErrors_ = true;
3155 }
3156 }
3157
IsIntrinsicRelational(RelationalOperator opr,const DynamicType & leftType,const DynamicType & rightType) const3158 bool ArgumentAnalyzer::IsIntrinsicRelational(RelationalOperator opr,
3159 const DynamicType &leftType, const DynamicType &rightType) const {
3160 CHECK(actuals_.size() == 2);
3161 return semantics::IsIntrinsicRelational(
3162 opr, leftType, GetRank(0), rightType, GetRank(1));
3163 }
3164
IsIntrinsicNumeric(NumericOperator opr) const3165 bool ArgumentAnalyzer::IsIntrinsicNumeric(NumericOperator opr) const {
3166 std::optional<DynamicType> leftType{GetType(0)};
3167 if (actuals_.size() == 1) {
3168 if (IsBOZLiteral(0)) {
3169 return opr == NumericOperator::Add; // unary '+'
3170 } else {
3171 return leftType && semantics::IsIntrinsicNumeric(*leftType);
3172 }
3173 } else {
3174 std::optional<DynamicType> rightType{GetType(1)};
3175 if (IsBOZLiteral(0) && rightType) { // BOZ opr Integer/Real
3176 auto cat1{rightType->category()};
3177 return cat1 == TypeCategory::Integer || cat1 == TypeCategory::Real;
3178 } else if (IsBOZLiteral(1) && leftType) { // Integer/Real opr BOZ
3179 auto cat0{leftType->category()};
3180 return cat0 == TypeCategory::Integer || cat0 == TypeCategory::Real;
3181 } else {
3182 return leftType && rightType &&
3183 semantics::IsIntrinsicNumeric(
3184 *leftType, GetRank(0), *rightType, GetRank(1));
3185 }
3186 }
3187 }
3188
IsIntrinsicLogical() const3189 bool ArgumentAnalyzer::IsIntrinsicLogical() const {
3190 if (std::optional<DynamicType> leftType{GetType(0)}) {
3191 if (actuals_.size() == 1) {
3192 return semantics::IsIntrinsicLogical(*leftType);
3193 } else if (std::optional<DynamicType> rightType{GetType(1)}) {
3194 return semantics::IsIntrinsicLogical(
3195 *leftType, GetRank(0), *rightType, GetRank(1));
3196 }
3197 }
3198 return false;
3199 }
3200
IsIntrinsicConcat() const3201 bool ArgumentAnalyzer::IsIntrinsicConcat() const {
3202 if (std::optional<DynamicType> leftType{GetType(0)}) {
3203 if (std::optional<DynamicType> rightType{GetType(1)}) {
3204 return semantics::IsIntrinsicConcat(
3205 *leftType, GetRank(0), *rightType, GetRank(1));
3206 }
3207 }
3208 return false;
3209 }
3210
CheckConformance()3211 bool ArgumentAnalyzer::CheckConformance() {
3212 if (actuals_.size() == 2) {
3213 const auto *lhs{actuals_.at(0).value().UnwrapExpr()};
3214 const auto *rhs{actuals_.at(1).value().UnwrapExpr()};
3215 if (lhs && rhs) {
3216 auto &foldingContext{context_.GetFoldingContext()};
3217 auto lhShape{GetShape(foldingContext, *lhs)};
3218 auto rhShape{GetShape(foldingContext, *rhs)};
3219 if (lhShape && rhShape) {
3220 if (!evaluate::CheckConformance(foldingContext.messages(), *lhShape,
3221 *rhShape, CheckConformanceFlags::EitherScalarExpandable,
3222 "left operand", "right operand")
3223 .value_or(false /*fail when conformance is not known now*/)) {
3224 fatalErrors_ = true;
3225 return false;
3226 }
3227 }
3228 }
3229 }
3230 return true; // no proven problem
3231 }
3232
CheckForNullPointer(const char * where)3233 bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
3234 for (const std::optional<ActualArgument> &arg : actuals_) {
3235 if (arg) {
3236 if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
3237 if (IsNullPointer(*expr)) {
3238 context_.Say(
3239 source_, "A NULL() pointer is not allowed %s"_err_en_US, where);
3240 fatalErrors_ = true;
3241 return false;
3242 }
3243 }
3244 }
3245 }
3246 return true;
3247 }
3248
TryDefinedOp(const char * opr,parser::MessageFixedText error,const Symbol ** definedOpSymbolPtr,bool isUserOp)3249 MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr,
3250 parser::MessageFixedText error, const Symbol **definedOpSymbolPtr,
3251 bool isUserOp) {
3252 if (!CheckForUntypedNullPointer()) {
3253 return std::nullopt;
3254 }
3255 if (AnyUntypedOrMissingOperand()) {
3256 context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
3257 return std::nullopt;
3258 }
3259 const Symbol *localDefinedOpSymbolPtr{nullptr};
3260 if (!definedOpSymbolPtr) {
3261 definedOpSymbolPtr = &localDefinedOpSymbolPtr;
3262 }
3263 {
3264 auto restorer{context_.GetContextualMessages().DiscardMessages()};
3265 std::string oprNameString{
3266 isUserOp ? std::string{opr} : "operator("s + opr + ')'};
3267 parser::CharBlock oprName{oprNameString};
3268 const auto &scope{context_.context().FindScope(source_)};
3269 if (Symbol * symbol{scope.FindSymbol(oprName)}) {
3270 *definedOpSymbolPtr = symbol;
3271 parser::Name name{symbol->name(), symbol};
3272 if (auto result{context_.AnalyzeDefinedOp(name, GetActuals())}) {
3273 return result;
3274 }
3275 }
3276 for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
3277 if (const Symbol *
3278 symbol{FindBoundOp(oprName, passIndex, *definedOpSymbolPtr)}) {
3279 if (MaybeExpr result{TryBoundOp(*symbol, passIndex)}) {
3280 return result;
3281 }
3282 }
3283 }
3284 }
3285 if (*definedOpSymbolPtr) {
3286 SayNoMatch(ToUpperCase((*definedOpSymbolPtr)->name().ToString()));
3287 } else if (actuals_.size() == 1 || AreConformable()) {
3288 if (CheckForNullPointer()) {
3289 context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
3290 }
3291 } else {
3292 context_.Say(
3293 "Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,
3294 ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());
3295 }
3296 return std::nullopt;
3297 }
3298
TryDefinedOp(std::vector<const char * > oprs,parser::MessageFixedText error)3299 MaybeExpr ArgumentAnalyzer::TryDefinedOp(
3300 std::vector<const char *> oprs, parser::MessageFixedText error) {
3301 const Symbol *definedOpSymbolPtr{nullptr};
3302 for (std::size_t i{1}; i < oprs.size(); ++i) {
3303 auto restorer{context_.GetContextualMessages().DiscardMessages()};
3304 if (auto result{TryDefinedOp(oprs[i], error, &definedOpSymbolPtr)}) {
3305 return result;
3306 }
3307 }
3308 return TryDefinedOp(oprs[0], error, &definedOpSymbolPtr);
3309 }
3310
TryBoundOp(const Symbol & symbol,int passIndex)3311 MaybeExpr ArgumentAnalyzer::TryBoundOp(const Symbol &symbol, int passIndex) {
3312 ActualArguments localActuals{actuals_};
3313 const Symbol *proc{GetBindingResolution(GetType(passIndex), symbol)};
3314 if (!proc) {
3315 proc = &symbol;
3316 localActuals.at(passIndex).value().set_isPassedObject();
3317 }
3318 CheckConformance();
3319 return context_.MakeFunctionRef(
3320 source_, ProcedureDesignator{*proc}, std::move(localActuals));
3321 }
3322
TryDefinedAssignment()3323 std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
3324 using semantics::Tristate;
3325 const Expr<SomeType> &lhs{GetExpr(0)};
3326 const Expr<SomeType> &rhs{GetExpr(1)};
3327 std::optional<DynamicType> lhsType{lhs.GetType()};
3328 std::optional<DynamicType> rhsType{rhs.GetType()};
3329 int lhsRank{lhs.Rank()};
3330 int rhsRank{rhs.Rank()};
3331 Tristate isDefined{
3332 semantics::IsDefinedAssignment(lhsType, lhsRank, rhsType, rhsRank)};
3333 if (isDefined == Tristate::No) {
3334 if (lhsType && rhsType) {
3335 AddAssignmentConversion(*lhsType, *rhsType);
3336 }
3337 return std::nullopt; // user-defined assignment not allowed for these args
3338 }
3339 auto restorer{context_.GetContextualMessages().SetLocation(source_)};
3340 if (std::optional<ProcedureRef> procRef{GetDefinedAssignmentProc()}) {
3341 if (context_.inWhereBody() && !procRef->proc().IsElemental()) { // C1032
3342 context_.Say(
3343 "Defined assignment in WHERE must be elemental, but '%s' is not"_err_en_US,
3344 DEREF(procRef->proc().GetSymbol()).name());
3345 }
3346 context_.CheckCall(source_, procRef->proc(), procRef->arguments());
3347 return std::move(*procRef);
3348 }
3349 if (isDefined == Tristate::Yes) {
3350 if (!lhsType || !rhsType || (lhsRank != rhsRank && rhsRank != 0) ||
3351 !OkLogicalIntegerAssignment(lhsType->category(), rhsType->category())) {
3352 SayNoMatch("ASSIGNMENT(=)", true);
3353 }
3354 }
3355 return std::nullopt;
3356 }
3357
OkLogicalIntegerAssignment(TypeCategory lhs,TypeCategory rhs)3358 bool ArgumentAnalyzer::OkLogicalIntegerAssignment(
3359 TypeCategory lhs, TypeCategory rhs) {
3360 if (!context_.context().languageFeatures().IsEnabled(
3361 common::LanguageFeature::LogicalIntegerAssignment)) {
3362 return false;
3363 }
3364 std::optional<parser::MessageFixedText> msg;
3365 if (lhs == TypeCategory::Integer && rhs == TypeCategory::Logical) {
3366 // allow assignment to LOGICAL from INTEGER as a legacy extension
3367 msg = "nonstandard usage: assignment of LOGICAL to INTEGER"_en_US;
3368 } else if (lhs == TypeCategory::Logical && rhs == TypeCategory::Integer) {
3369 // ... and assignment to LOGICAL from INTEGER
3370 msg = "nonstandard usage: assignment of INTEGER to LOGICAL"_en_US;
3371 } else {
3372 return false;
3373 }
3374 if (context_.context().languageFeatures().ShouldWarn(
3375 common::LanguageFeature::LogicalIntegerAssignment)) {
3376 context_.Say(std::move(*msg));
3377 }
3378 return true;
3379 }
3380
GetDefinedAssignmentProc()3381 std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
3382 auto restorer{context_.GetContextualMessages().DiscardMessages()};
3383 std::string oprNameString{"assignment(=)"};
3384 parser::CharBlock oprName{oprNameString};
3385 const Symbol *proc{nullptr};
3386 const auto &scope{context_.context().FindScope(source_)};
3387 if (const Symbol * symbol{scope.FindSymbol(oprName)}) {
3388 ExpressionAnalyzer::AdjustActuals noAdjustment;
3389 if (const Symbol *
3390 specific{context_.ResolveGeneric(*symbol, actuals_, noAdjustment)}) {
3391 proc = specific;
3392 } else {
3393 context_.EmitGenericResolutionError(*symbol);
3394 }
3395 }
3396 int passedObjectIndex{-1};
3397 const Symbol *definedOpSymbol{nullptr};
3398 for (std::size_t i{0}; i < actuals_.size(); ++i) {
3399 if (const Symbol * specific{FindBoundOp(oprName, i, definedOpSymbol)}) {
3400 if (const Symbol *
3401 resolution{GetBindingResolution(GetType(i), *specific)}) {
3402 proc = resolution;
3403 } else {
3404 proc = specific;
3405 passedObjectIndex = i;
3406 }
3407 }
3408 }
3409 if (!proc) {
3410 return std::nullopt;
3411 }
3412 ActualArguments actualsCopy{actuals_};
3413 if (passedObjectIndex >= 0) {
3414 actualsCopy[passedObjectIndex]->set_isPassedObject();
3415 }
3416 return ProcedureRef{ProcedureDesignator{*proc}, std::move(actualsCopy)};
3417 }
3418
Dump(llvm::raw_ostream & os)3419 void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {
3420 os << "source_: " << source_.ToString() << " fatalErrors_ = " << fatalErrors_
3421 << '\n';
3422 for (const auto &actual : actuals_) {
3423 if (!actual.has_value()) {
3424 os << "- error\n";
3425 } else if (const Symbol * symbol{actual->GetAssumedTypeDummy()}) {
3426 os << "- assumed type: " << symbol->name().ToString() << '\n';
3427 } else if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {
3428 expr->AsFortran(os << "- expr: ") << '\n';
3429 } else {
3430 DIE("bad ActualArgument");
3431 }
3432 }
3433 }
3434
AnalyzeExpr(const parser::Expr & expr)3435 std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
3436 const parser::Expr &expr) {
3437 source_.ExtendToCover(expr.source);
3438 if (const Symbol * assumedTypeDummy{AssumedTypeDummy(expr)}) {
3439 expr.typedExpr.Reset(new GenericExprWrapper{}, GenericExprWrapper::Deleter);
3440 if (isProcedureCall_) {
3441 return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
3442 }
3443 context_.SayAt(expr.source,
3444 "TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
3445 } else if (MaybeExpr argExpr{AnalyzeExprOrWholeAssumedSizeArray(expr)}) {
3446 if (isProcedureCall_ || !IsProcedure(*argExpr)) {
3447 return ActualArgument{std::move(*argExpr)};
3448 }
3449 context_.SayAt(expr.source,
3450 IsFunction(*argExpr) ? "Function call must have argument list"_err_en_US
3451 : "Subroutine name is not allowed here"_err_en_US);
3452 }
3453 return std::nullopt;
3454 }
3455
AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr & expr)3456 MaybeExpr ArgumentAnalyzer::AnalyzeExprOrWholeAssumedSizeArray(
3457 const parser::Expr &expr) {
3458 // If an expression's parse tree is a whole assumed-size array:
3459 // Expr -> Designator -> DataRef -> Name
3460 // treat it as a special case for argument passing and bypass
3461 // the C1002/C1014 constraint checking in expression semantics.
3462 if (const auto *name{parser::Unwrap<parser::Name>(expr)}) {
3463 if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) {
3464 auto restorer{context_.AllowWholeAssumedSizeArray()};
3465 return context_.Analyze(expr);
3466 }
3467 }
3468 return context_.Analyze(expr);
3469 }
3470
AreConformable() const3471 bool ArgumentAnalyzer::AreConformable() const {
3472 CHECK(actuals_.size() == 2);
3473 return actuals_[0] && actuals_[1] &&
3474 evaluate::AreConformable(*actuals_[0], *actuals_[1]);
3475 }
3476
3477 // Look for a type-bound operator in the type of arg number passIndex.
FindBoundOp(parser::CharBlock oprName,int passIndex,const Symbol * & definedOp)3478 const Symbol *ArgumentAnalyzer::FindBoundOp(
3479 parser::CharBlock oprName, int passIndex, const Symbol *&definedOp) {
3480 const auto *type{GetDerivedTypeSpec(GetType(passIndex))};
3481 if (!type || !type->scope()) {
3482 return nullptr;
3483 }
3484 const Symbol *symbol{type->scope()->FindComponent(oprName)};
3485 if (!symbol) {
3486 return nullptr;
3487 }
3488 definedOp = symbol;
3489 ExpressionAnalyzer::AdjustActuals adjustment{
3490 [&](const Symbol &proc, ActualArguments &) {
3491 return passIndex == GetPassIndex(proc);
3492 }};
3493 const Symbol *result{context_.ResolveGeneric(*symbol, actuals_, adjustment)};
3494 if (!result) {
3495 context_.EmitGenericResolutionError(*symbol);
3496 }
3497 return result;
3498 }
3499
3500 // If there is an implicit conversion between intrinsic types, make it explicit
AddAssignmentConversion(const DynamicType & lhsType,const DynamicType & rhsType)3501 void ArgumentAnalyzer::AddAssignmentConversion(
3502 const DynamicType &lhsType, const DynamicType &rhsType) {
3503 if (lhsType.category() == rhsType.category() &&
3504 lhsType.kind() == rhsType.kind()) {
3505 // no conversion necessary
3506 } else if (auto rhsExpr{evaluate::ConvertToType(lhsType, MoveExpr(1))}) {
3507 actuals_[1] = ActualArgument{*rhsExpr};
3508 } else {
3509 actuals_[1] = std::nullopt;
3510 }
3511 }
3512
GetType(std::size_t i) const3513 std::optional<DynamicType> ArgumentAnalyzer::GetType(std::size_t i) const {
3514 return i < actuals_.size() ? actuals_[i].value().GetType() : std::nullopt;
3515 }
GetRank(std::size_t i) const3516 int ArgumentAnalyzer::GetRank(std::size_t i) const {
3517 return i < actuals_.size() ? actuals_[i].value().Rank() : 0;
3518 }
3519
3520 // If the argument at index i is a BOZ literal, convert its type to match the
3521 // otherType. If it's REAL convert to REAL, otherwise convert to INTEGER.
3522 // Note that IBM supports comparing BOZ literals to CHARACTER operands. That
3523 // is not currently supported.
ConvertBOZ(std::optional<DynamicType> & thisType,std::size_t i,std::optional<DynamicType> otherType)3524 void ArgumentAnalyzer::ConvertBOZ(std::optional<DynamicType> &thisType,
3525 std::size_t i, std::optional<DynamicType> otherType) {
3526 if (IsBOZLiteral(i)) {
3527 Expr<SomeType> &&argExpr{MoveExpr(i)};
3528 auto *boz{std::get_if<BOZLiteralConstant>(&argExpr.u)};
3529 if (otherType && otherType->category() == TypeCategory::Real) {
3530 int kind{context_.context().GetDefaultKind(TypeCategory::Real)};
3531 MaybeExpr realExpr{
3532 ConvertToKind<TypeCategory::Real>(kind, std::move(*boz))};
3533 actuals_[i] = std::move(*realExpr);
3534 thisType.emplace(TypeCategory::Real, kind);
3535 } else {
3536 int kind{context_.context().GetDefaultKind(TypeCategory::Integer)};
3537 MaybeExpr intExpr{
3538 ConvertToKind<TypeCategory::Integer>(kind, std::move(*boz))};
3539 actuals_[i] = std::move(*intExpr);
3540 thisType.emplace(TypeCategory::Integer, kind);
3541 }
3542 }
3543 }
3544
3545 // Report error resolving opr when there is a user-defined one available
SayNoMatch(const std::string & opr,bool isAssignment)3546 void ArgumentAnalyzer::SayNoMatch(const std::string &opr, bool isAssignment) {
3547 std::string type0{TypeAsFortran(0)};
3548 auto rank0{actuals_[0]->Rank()};
3549 if (actuals_.size() == 1) {
3550 if (rank0 > 0) {
3551 context_.Say("No intrinsic or user-defined %s matches "
3552 "rank %d array of %s"_err_en_US,
3553 opr, rank0, type0);
3554 } else {
3555 context_.Say("No intrinsic or user-defined %s matches "
3556 "operand type %s"_err_en_US,
3557 opr, type0);
3558 }
3559 } else {
3560 std::string type1{TypeAsFortran(1)};
3561 auto rank1{actuals_[1]->Rank()};
3562 if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {
3563 context_.Say("No intrinsic or user-defined %s matches "
3564 "rank %d array of %s and rank %d array of %s"_err_en_US,
3565 opr, rank0, type0, rank1, type1);
3566 } else if (isAssignment && rank0 != rank1) {
3567 if (rank0 == 0) {
3568 context_.Say("No intrinsic or user-defined %s matches "
3569 "scalar %s and rank %d array of %s"_err_en_US,
3570 opr, type0, rank1, type1);
3571 } else {
3572 context_.Say("No intrinsic or user-defined %s matches "
3573 "rank %d array of %s and scalar %s"_err_en_US,
3574 opr, rank0, type0, type1);
3575 }
3576 } else {
3577 context_.Say("No intrinsic or user-defined %s matches "
3578 "operand types %s and %s"_err_en_US,
3579 opr, type0, type1);
3580 }
3581 }
3582 }
3583
TypeAsFortran(std::size_t i)3584 std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
3585 if (i >= actuals_.size() || !actuals_[i]) {
3586 return "missing argument";
3587 } else if (std::optional<DynamicType> type{GetType(i)}) {
3588 return type->category() == TypeCategory::Derived
3589 ? "TYPE("s + type->AsFortran() + ')'
3590 : type->category() == TypeCategory::Character
3591 ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
3592 : ToUpperCase(type->AsFortran());
3593 } else {
3594 return "untyped";
3595 }
3596 }
3597
AnyUntypedOrMissingOperand()3598 bool ArgumentAnalyzer::AnyUntypedOrMissingOperand() {
3599 for (const auto &actual : actuals_) {
3600 if (!actual || !actual->GetType()) {
3601 return true;
3602 }
3603 }
3604 return false;
3605 }
3606
CheckForUntypedNullPointer()3607 bool ArgumentAnalyzer::CheckForUntypedNullPointer() {
3608 for (const std::optional<ActualArgument> &arg : actuals_) {
3609 if (arg) {
3610 if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
3611 if (std::holds_alternative<NullPointer>(expr->u)) {
3612 context_.Say(source_,
3613 "A typeless NULL() pointer is not allowed as an operand"_err_en_US);
3614 fatalErrors_ = true;
3615 return false;
3616 }
3617 }
3618 }
3619 }
3620 return true;
3621 }
3622
3623 } // namespace Fortran::evaluate
3624
3625 namespace Fortran::semantics {
AnalyzeKindSelector(SemanticsContext & context,common::TypeCategory category,const std::optional<parser::KindSelector> & selector)3626 evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
3627 SemanticsContext &context, common::TypeCategory category,
3628 const std::optional<parser::KindSelector> &selector) {
3629 evaluate::ExpressionAnalyzer analyzer{context};
3630 auto restorer{
3631 analyzer.GetContextualMessages().SetLocation(context.location().value())};
3632 return analyzer.AnalyzeKindSelector(category, selector);
3633 }
3634
ExprChecker(SemanticsContext & context)3635 ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}
3636
Pre(const parser::DataImpliedDo & ido)3637 bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {
3638 parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);
3639 const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};
3640 auto name{bounds.name.thing.thing};
3641 int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
3642 if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
3643 if (dynamicType->category() == TypeCategory::Integer) {
3644 kind = dynamicType->kind();
3645 }
3646 }
3647 exprAnalyzer_.AddImpliedDo(name.source, kind);
3648 parser::Walk(std::get<std::list<parser::DataIDoObject>>(ido.t), *this);
3649 exprAnalyzer_.RemoveImpliedDo(name.source);
3650 return false;
3651 }
3652
Walk(const parser::Program & program)3653 bool ExprChecker::Walk(const parser::Program &program) {
3654 parser::Walk(program, *this);
3655 return !context_.AnyFatalError();
3656 }
3657 } // namespace Fortran::semantics
3658