1 //===-- lib/Semantics/check-data.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 "check-data.h"
10 #include "flang/Evaluate/traverse.h"
11 #include "flang/Semantics/expression.h"
12 
13 namespace Fortran::semantics {
14 
15 void DataChecker::Leave(const parser::DataStmtConstant &dataConst) {
16   if (auto *structure{
17           std::get_if<parser::StructureConstructor>(&dataConst.u)}) {
18     for (const auto &component :
19         std::get<std::list<parser::ComponentSpec>>(structure->t)) {
20       const parser::Expr &parsedExpr{
21           std::get<parser::ComponentDataSource>(component.t).v.value()};
22       if (const auto *expr{GetExpr(parsedExpr)}) {
23         if (!evaluate::IsConstantExpr(*expr)) { // C884
24           exprAnalyzer_.Say(parsedExpr.source,
25               "Structure constructor in data value must be a constant expression"_err_en_US);
26         }
27       }
28     }
29   }
30 }
31 
32 // Ensures that references to an implied DO loop control variable are
33 // represented as such in the "body" of the implied DO loop.
34 void DataChecker::Enter(const parser::DataImpliedDo &x) {
35   auto name{std::get<parser::DataImpliedDo::Bounds>(x.t).name.thing.thing};
36   int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
37   if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
38     kind = dynamicType->kind();
39   }
40   exprAnalyzer_.AddImpliedDo(name.source, kind);
41 }
42 
43 void DataChecker::Leave(const parser::DataImpliedDo &x) {
44   auto name{std::get<parser::DataImpliedDo::Bounds>(x.t).name.thing.thing};
45   exprAnalyzer_.RemoveImpliedDo(name.source);
46 }
47 
48 class DataVarChecker : public evaluate::AllTraverse<DataVarChecker, true> {
49 public:
50   using Base = evaluate::AllTraverse<DataVarChecker, true>;
51   DataVarChecker(SemanticsContext &c, parser::CharBlock src)
52       : Base{*this}, context_{c}, source_{src} {}
53   using Base::operator();
54   bool HasComponentWithoutSubscripts() const {
55     return hasComponent_ && !hasSubscript_;
56   }
57   bool operator()(const evaluate::Component &component) {
58     hasComponent_ = true;
59     return (*this)(component.base());
60   }
61   bool operator()(const evaluate::Subscript &subs) {
62     hasSubscript_ = true;
63     return std::visit(
64         common::visitors{
65             [&](const evaluate::IndirectSubscriptIntegerExpr &expr) {
66               return CheckSubscriptExpr(expr);
67             },
68             [&](const evaluate::Triplet &triplet) {
69               return CheckSubscriptExpr(triplet.lower()) &&
70                   CheckSubscriptExpr(triplet.upper()) &&
71                   CheckSubscriptExpr(triplet.stride());
72             },
73         },
74         subs.u);
75   }
76   template <typename T>
77   bool operator()(const evaluate::FunctionRef<T> &) const { // C875
78     context_.Say(source_,
79         "Data object variable must not be a function reference"_err_en_US);
80     return false;
81   }
82   bool operator()(const evaluate::CoarrayRef &) const { // C874
83     context_.Say(
84         source_, "Data object must not be a coindexed variable"_err_en_US);
85     return false;
86   }
87 
88 private:
89   bool CheckSubscriptExpr(
90       const std::optional<evaluate::IndirectSubscriptIntegerExpr> &x) const {
91     return !x || CheckSubscriptExpr(*x);
92   }
93   bool CheckSubscriptExpr(
94       const evaluate::IndirectSubscriptIntegerExpr &expr) const {
95     return CheckSubscriptExpr(expr.value());
96   }
97   bool CheckSubscriptExpr(
98       const evaluate::Expr<evaluate::SubscriptInteger> &expr) const {
99     if (!evaluate::IsConstantExpr(expr)) { // C875,C881
100       context_.Say(
101           source_, "Data object must have constant subscripts"_err_en_US);
102       return false;
103     } else {
104       return true;
105     }
106   }
107 
108   SemanticsContext &context_;
109   parser::CharBlock source_;
110   bool hasComponent_{false};
111   bool hasSubscript_{false};
112 };
113 
114 // TODO: C876, C877, C879
115 void DataChecker::Leave(const parser::DataIDoObject &object) {
116   if (const auto *designator{
117           std::get_if<parser::Scalar<common::Indirection<parser::Designator>>>(
118               &object.u)}) {
119     if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) {
120       auto source{designator->thing.value().source};
121       if (evaluate::IsConstantExpr(*expr)) { // C878
122         exprAnalyzer_.Say(
123             source, "Data implied do object must be a variable"_err_en_US);
124       } else {
125         DataVarChecker checker{exprAnalyzer_.context(), source};
126         if (checker(*expr) && checker.HasComponentWithoutSubscripts()) { // C880
127           exprAnalyzer_.Say(source,
128               "Data implied do structure component must be subscripted"_err_en_US);
129         }
130       }
131     }
132   }
133 }
134 
135 void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
136   if (const auto *var{
137           std::get_if<common::Indirection<parser::Variable>>(&dataObject.u)}) {
138     if (auto expr{exprAnalyzer_.Analyze(*var)}) {
139       DataVarChecker{exprAnalyzer_.context(),
140           parser::FindSourceLocation(dataObject)}(expr);
141     }
142   }
143 }
144 
145 void DataChecker::Leave(const parser::DataStmtRepeat &dataRepeat) {
146   if (const auto *designator{parser::Unwrap<parser::Designator>(dataRepeat)}) {
147     if (auto *dataRef{std::get_if<parser::DataRef>(&designator->u)}) {
148       if (MaybeExpr checked{exprAnalyzer_.Analyze(*dataRef)}) {
149         auto expr{evaluate::Fold(
150             exprAnalyzer_.GetFoldingContext(), std::move(checked))};
151         if (auto i64{ToInt64(expr)}) {
152           if (*i64 < 0) { // C882
153             exprAnalyzer_.Say(designator->source,
154                 "Repeat count for data value must not be negative"_err_en_US);
155           }
156         }
157       }
158     }
159   }
160 }
161 } // namespace Fortran::semantics
162