CHECK(!fatalErrors_);
return std::move(actuals_);
}
- Expr<SomeType> GetAsExpr(std::size_t i) const {
+ const Expr<SomeType> &GetExpr(std::size_t i) const {
return DEREF(actuals_.at(i).value().UnwrapExpr());
}
+ Expr<SomeType> &&MoveExpr(std::size_t i) {
+ return std::move(DEREF(actuals_.at(i).value().UnwrapExpr()));
+ }
void Analyze(const common::Indirection<parser::Expr> &x) {
Analyze(x.value());
}
actuals_.emplace_back(AnalyzeExpr(x));
fatalErrors_ |= !actuals_.back();
}
+ void Analyze(const parser::Variable &);
void Analyze(const parser::ActualArgSpec &, bool isSubroutine);
bool IsIntrinsicRelational(RelationalOperator) const;
return TryDefinedOp(
context_.context().languageFeatures().GetNames(opr), std::move(msg));
}
+ // Find and return a user-defined assignment
+ std::optional<ProcedureRef> TryDefinedAssignment();
+ std::optional<ProcedureRef> GetDefinedAssignmentProc();
private:
MaybeExpr TryDefinedOp(
std::vector<const char *>, parser::MessageFixedText &&);
std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
bool AreConformable() const;
- const Symbol *FindDefinedOp(const char *) const;
+ Symbol *FindDefinedOp(const char *) const;
std::optional<DynamicType> GetType(std::size_t) const;
bool IsBOZLiteral(std::size_t i) const {
- return std::holds_alternative<BOZLiteralConstant>(GetAsExpr(i).u);
+ return std::holds_alternative<BOZLiteralConstant>(GetExpr(i).u);
}
- void SayNoMatch(const char *);
+ void SayNoMatch(const std::string &, bool isAssignment = false);
std::string TypeAsFortran(std::size_t);
bool AnyUntypedOperand();
return std::nullopt;
}
+void ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
+ ArgumentAnalyzer analyzer{*this};
+ analyzer.Analyze(std::get<parser::Variable>(x.t));
+ analyzer.Analyze(std::get<parser::Expr>(x.t));
+ if (!analyzer.fatalErrors()) {
+ std::optional<ProcedureRef> procRef{analyzer.TryDefinedAssignment()};
+ x.typedAssignment.reset(new GenericAssignmentWrapper{procRef
+ ? Assignment{std::move(*procRef)}
+ : Assignment{analyzer.MoveExpr(0), analyzer.MoveExpr(1)}});
+ }
+}
+
static bool IsExternalCalledImplicitly(
parser::CharBlock callSite, const ProcedureDesignator &proc) {
if (const auto *symbol{proc.GetSymbol()}) {
pure{semantics::FindPureProcedureContaining(
context_.FindScope(callSite))}) {
Say(callSite,
- "Procedure referenced in PURE subprogram '%s' must be PURE too"_err_en_US,
- DEREF(pure->symbol()).name());
+ "Procedure '%s' referenced in PURE subprogram '%s' must be PURE too"_err_en_US,
+ DEREF(proc.GetSymbol()).name(), DEREF(pure->symbol()).name());
}
}
}
return std::nullopt;
} else if (analyzer.IsIntrinsicNumeric(opr)) {
if (opr == NumericOperator::Add) {
- return analyzer.GetAsExpr(0);
+ return analyzer.MoveExpr(0);
} else {
- return Negation(context.GetContextualMessages(), analyzer.GetAsExpr(0));
+ return Negation(context.GetContextualMessages(), analyzer.MoveExpr(0));
}
} else {
return analyzer.TryDefinedOp(AsFortran(opr),
return std::nullopt;
} else if (analyzer.IsIntrinsicLogical()) {
return AsGenericExpr(
- LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.GetAsExpr(0).u)));
+ LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));
} else {
return analyzer.TryDefinedOp(LogicalOperator::Not,
"Operand of %s must be LOGICAL; have %s"_err_en_US);
return std::nullopt;
} else if (analyzer.IsIntrinsicNumeric(opr)) {
return NumericOperation<OPR>(context.GetContextualMessages(),
- analyzer.GetAsExpr(0), analyzer.GetAsExpr(1),
+ analyzer.MoveExpr(0), analyzer.MoveExpr(1),
context.GetDefaultKind(TypeCategory::Real));
} else {
return analyzer.TryDefinedOp(AsFortran(opr),
DIE("different types for intrinsic concat");
}
},
- std::move(std::get<Expr<SomeCharacter>>(analyzer.GetAsExpr(0).u).u),
- std::move(std::get<Expr<SomeCharacter>>(analyzer.GetAsExpr(1).u).u));
+ std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(0).u).u),
+ std::move(std::get<Expr<SomeCharacter>>(analyzer.MoveExpr(1).u).u));
} else {
return analyzer.TryDefinedOp("//",
"Operands of %s must be CHARACTER with the same kind; have %s and %s"_err_en_US);
return std::nullopt;
} else if (analyzer.IsIntrinsicRelational(opr)) {
return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
- analyzer.GetAsExpr(0), analyzer.GetAsExpr(1)));
+ analyzer.MoveExpr(0), analyzer.MoveExpr(1)));
} else {
return analyzer.TryDefinedOp(opr,
"Operands of %s must have comparable types; have %s and %s"_err_en_US);
return std::nullopt;
} else if (analyzer.IsIntrinsicLogical()) {
return AsGenericExpr(BinaryLogicalOperation(opr,
- std::get<Expr<SomeLogical>>(analyzer.GetAsExpr(0).u),
- std::get<Expr<SomeLogical>>(analyzer.GetAsExpr(1).u)));
+ std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),
+ std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));
} else {
return analyzer.TryDefinedOp(
opr, "Operands of %s must be LOGICAL; have %s and %s"_err_en_US);
}
}
+void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
+ source_.ExtendToCover(x.GetSource());
+ if (MaybeExpr expr{context_.Analyze(x)}) {
+ actuals_.emplace_back(std::move(*expr));
+ } else {
+ fatalErrors_ = true;
+ }
+}
+
void ArgumentAnalyzer::Analyze(
const parser::ActualArgSpec &arg, bool isSubroutine) {
// TODO: C1002: Allow a whole assumed-size array to appear if the dummy
MaybeExpr ArgumentAnalyzer::TryDefinedOp(
const char *opr, parser::MessageFixedText &&error) {
- const Symbol *symbol{AnyUntypedOperand() ? nullptr : FindDefinedOp(opr)};
+ Symbol *symbol{AnyUntypedOperand() ? nullptr : FindDefinedOp(opr)};
if (!symbol) {
if (actuals_.size() == 1 || AreConformable()) {
context_.Say(std::move(error), ToUpperCase(opr), TypeAsFortran(0),
return std::nullopt;
}
parser::Messages messages;
- parser::Name name{source_, const_cast<Symbol *>(symbol)};
+ parser::Name name{source_, symbol};
if (auto result{context_.AnalyzeDefinedOp(messages, name, GetActuals())}) {
return result;
} else {
- SayNoMatch(opr);
+ SayNoMatch("OPERATOR(" + ToUpperCase(opr) + ')');
return std::nullopt;
}
}
return TryDefinedOp(oprs[0], std::move(error));
}
+std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
+ using semantics::Tristate;
+ const Expr<SomeType> &lhs{GetExpr(0)};
+ const Expr<SomeType> &rhs{GetExpr(1)};
+ Tristate isDefined{semantics::IsDefinedAssignment(
+ lhs.GetType(), lhs.Rank(), rhs.GetType(), rhs.Rank())};
+ if (isDefined == Tristate::No) {
+ return std::nullopt; // user-defined assignment not allowed for these args
+ }
+ auto restorer{context_.GetContextualMessages().SetLocation(source_)};
+ auto procRef{GetDefinedAssignmentProc()};
+ if (!procRef) {
+ if (isDefined == Tristate::Yes) {
+ SayNoMatch("ASSIGNMENT(=)", true);
+ }
+ return std::nullopt;
+ }
+ context_.CheckCall(source_, procRef->proc(), procRef->arguments());
+ return std::move(*procRef);
+}
+
+std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
+ parser::Messages tmpMessages;
+ auto restorer{context_.GetContextualMessages().SetMessages(tmpMessages)};
+ const auto &scope{context_.context().FindScope(source_)};
+ if (const Symbol *
+ symbol{scope.FindSymbol(parser::CharBlock{"assignment(=)"s})}) {
+ const Symbol *specific{context_.ResolveGeneric(*symbol, actuals_)};
+ if (specific) {
+ ProcedureDesignator designator{*specific};
+ actuals_[1]->Parenthesize();
+ return ProcedureRef{std::move(designator), std::move(actuals_)};
+ }
+ }
+ return std::nullopt;
+}
+
std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
const parser::Expr &expr) {
source_.ExtendToCover(expr.source);
return evaluate::AreConformable(*actuals_[0], *actuals_[1]);
}
-const Symbol *ArgumentAnalyzer::FindDefinedOp(const char *opr) const {
+Symbol *ArgumentAnalyzer::FindDefinedOp(const char *opr) const {
const auto &scope{context_.context().FindScope(source_)};
return scope.FindSymbol(parser::CharBlock{"operator("s + opr + ')'});
}
}
// Report error resolving opr when there is a user-defined one available
-void ArgumentAnalyzer::SayNoMatch(const char *opr) {
+void ArgumentAnalyzer::SayNoMatch(const std::string &opr, bool isAssignment) {
+ std::string type0{TypeAsFortran(0)};
auto rank0{actuals_[0]->Rank()};
if (actuals_.size() == 1) {
if (rank0 > 0) {
- context_.Say("No user-defined or intrinsic %s operator matches "
+ context_.Say("No intrinsic or user-defined %s matches "
"rank %d array of %s"_err_en_US,
- ToUpperCase(opr), rank0, TypeAsFortran(0));
+ opr, rank0, type0);
} else {
- context_.Say("No user-defined or intrinsic %s operator matches "
+ context_.Say("No intrinsic or user-defined %s matches "
"operand type %s"_err_en_US,
- ToUpperCase(opr), TypeAsFortran(0));
+ opr, type0);
}
} else {
+ std::string type1{TypeAsFortran(1)};
auto rank1{actuals_[1]->Rank()};
if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {
- context_.Say("No user-defined or intrinsic %s operator matches "
+ context_.Say("No intrinsic or user-defined %s matches "
"rank %d array of %s and rank %d array of %s"_err_en_US,
- ToUpperCase(opr), rank0, TypeAsFortran(0), rank1, TypeAsFortran(1));
+ opr, rank0, type0, rank1, type1);
+ } else if (isAssignment && rank0 != rank1) {
+ if (rank0 == 0) {
+ context_.Say("No intrinsic or user-defined %s matches "
+ "scalar %s and rank %d array of %s"_err_en_US,
+ opr, type0, rank1, type1);
+ } else {
+ context_.Say("No intrinsic or user-defined %s matches "
+ "rank %d array of %s and scalar %s"_err_en_US,
+ opr, rank0, type0, type1);
+ }
} else {
- context_.Say("No user-defined or intrinsic %s operator matches "
+ context_.Say("No intrinsic or user-defined %s matches "
"operand types %s and %s"_err_en_US,
- ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
+ opr, type0, type1);
}
}
}
evaluate::ExpressionAnalyzer{context}.Analyze(call);
}
+void AnalyzeAssignmentStmt(
+ SemanticsContext &context, const parser::AssignmentStmt &stmt) {
+ evaluate::ExpressionAnalyzer{context}.Analyze(stmt);
+}
+
ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}
bool ExprChecker::Walk(const parser::Program &program) {
--- /dev/null
+! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Test that user-defined assignment is used in the right places
+
+module m1
+ type t1
+ end type
+ type t2
+ end type
+ interface assignment(=)
+ subroutine assign_il(x, y)
+ integer, intent(out) :: x
+ logical, intent(in) :: y
+ end
+ subroutine assign_li(x, y)
+ logical, intent(out) :: x
+ integer, intent(in) :: y
+ end
+ subroutine assign_tt(x, y)
+ import t1
+ type(t1), intent(out) :: x
+ type(t1), intent(in) :: y
+ end
+ subroutine assign_tz(x, y)
+ import t1
+ type(t1), intent(out) :: x
+ complex, intent(in) :: y
+ end
+ subroutine assign_01(x, y)
+ real, intent(out) :: x
+ real, intent(in) :: y(:)
+ end
+ end interface
+contains
+ ! These are all intrinsic assignments
+ pure subroutine test1()
+ type(t2) :: a, b, b5(5)
+ logical :: l
+ integer :: i, i5(5)
+ a = b
+ b5 = a
+ l = .true.
+ i = z'1234'
+ i5 = 1.0
+ end
+
+ ! These have invalid type combinations
+ subroutine test2()
+ type(t1) :: a
+ type(t2) :: b
+ logical :: l, l5(5)
+ complex :: z, z5(5), z55(5,5)
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t1) and TYPE(t2)
+ a = b
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types REAL(4) and LOGICAL(4)
+ r = l
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types LOGICAL(4) and REAL(4)
+ l = r
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t1) and REAL(4)
+ a = r
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t2) and COMPLEX(4)
+ b = z
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar COMPLEX(4) and rank 1 array of COMPLEX(4)
+ z = z5
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches rank 1 array of LOGICAL(4) and scalar COMPLEX(4)
+ l5 = z
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches rank 1 array of COMPLEX(4) and rank 2 array of COMPLEX(4)
+ z5 = z55
+ end
+
+ ! These should all be defined assignments. Because the subroutines
+ ! implementing them are not pure, they should all produce errors
+ pure subroutine test3()
+ type(t1) :: a, b
+ integer :: i
+ logical :: l
+ complex :: z
+ real :: r, r5(5)
+ !ERROR: Procedure 'assign_tt' referenced in PURE subprogram 'test3' must be PURE too
+ a = b
+ !ERROR: Procedure 'assign_il' referenced in PURE subprogram 'test3' must be PURE too
+ i = l
+ !ERROR: Procedure 'assign_li' referenced in PURE subprogram 'test3' must be PURE too
+ l = i
+ !ERROR: Procedure 'assign_il' referenced in PURE subprogram 'test3' must be PURE too
+ i = .true.
+ !ERROR: Procedure 'assign_tz' referenced in PURE subprogram 'test3' must be PURE too
+ a = z
+ !ERROR: Procedure 'assign_01' referenced in PURE subprogram 'test3' must be PURE too
+ r = r5
+ end
+
+ ! Like test3 but not in a pure subroutine so no errors.
+ subroutine test4()
+ type(t1) :: a, b
+ integer :: i
+ logical :: l
+ complex :: z
+ real :: r, r5(5)
+ a = b
+ i = l
+ l = i
+ i = .true.
+ a = z
+ r = r5
+ end
+end
projects / platform / upstream / llvm.git / commitdiff