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