diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -218,7 +218,13 @@ const ProcInterface &interface() const { return interface_; } ProcInterface &interface() { return interface_; } - void set_interface(const ProcInterface &interface) { interface_ = interface; } + void set_interface(const ProcInterface &interface) { + CHECK(!IsInterfaceSet()); + interface_ = interface; + } + bool IsInterfaceSet() { + return interface_.symbol() != nullptr || interface_.type() != nullptr; + } inline bool HasExplicitInterface() const; // Be advised: !init().has_value() => uninitialized pointer, diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3435,18 +3435,25 @@ const parser::Name &name, Attrs attrs, const ProcInterface &interface) { Symbol &symbol{DeclareEntity(name, attrs)}; if (auto *details{symbol.detailsIf()}) { - if (interface.type()) { - symbol.set(Symbol::Flag::Function); - } else if (interface.symbol()) { - if (interface.symbol()->test(Symbol::Flag::Function)) { + if (details->IsInterfaceSet()) { + SayWithDecl(name, symbol, + "The interface for procedure '%s' has already been " + "declared"_err_en_US); + context().SetError(symbol); + } else { + if (interface.type()) { symbol.set(Symbol::Flag::Function); - } else if (interface.symbol()->test(Symbol::Flag::Subroutine)) { - symbol.set(Symbol::Flag::Subroutine); + } else if (interface.symbol()) { + if (interface.symbol()->test(Symbol::Flag::Function)) { + symbol.set(Symbol::Flag::Function); + } else if (interface.symbol()->test(Symbol::Flag::Subroutine)) { + symbol.set(Symbol::Flag::Subroutine); + } } + details->set_interface(interface); + SetBindNameOn(symbol); + SetPassNameOn(symbol); } - details->set_interface(interface); - SetBindNameOn(symbol); - SetPassNameOn(symbol); } return symbol; } @@ -3460,18 +3467,22 @@ } if (!arraySpec().empty()) { if (details->IsArray()) { - Say(name, - "The dimensions of '%s' have already been declared"_err_en_US); - context().SetError(symbol); + if (!context().HasError(symbol)) { + Say(name, + "The dimensions of '%s' have already been declared"_err_en_US); + context().SetError(symbol); + } } else { details->set_shape(arraySpec()); } } if (!coarraySpec().empty()) { if (details->IsCoarray()) { - Say(name, - "The codimensions of '%s' have already been declared"_err_en_US); - context().SetError(symbol); + if (!context().HasError(symbol)) { + Say(name, + "The codimensions of '%s' have already been declared"_err_en_US); + context().SetError(symbol); + } } else { details->set_coshape(coarraySpec()); } @@ -3913,7 +3924,7 @@ CHECK(!interfaceName_); return true; } -void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &stmt) { +void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) { interfaceName_ = nullptr; } bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { @@ -4702,9 +4713,11 @@ } else if (!symbol.test(Symbol::Flag::Implicit)) { SayWithDecl( name, symbol, "The type of '%s' has already been declared"_err_en_US); + context().SetError(symbol); } else if (type != *prevType) { SayWithDecl(name, symbol, "The type of '%s' has already been implicitly declared"_err_en_US); + context().SetError(symbol); } else { symbol.set(Symbol::Flag::Implicit, false); } @@ -5697,17 +5710,21 @@ const parser::Name &name, const parser::InitialDataTarget &target) { if (name.symbol) { Symbol &ultimate{name.symbol->GetUltimate()}; - if (IsPointer(ultimate)) { - if (auto *details{ultimate.detailsIf()}) { - CHECK(!details->init()); - Walk(target); - if (MaybeExpr expr{EvaluateExpr(target)}) { - CheckInitialDataTarget(ultimate, *expr, target.value().source); - details->set_init(std::move(*expr)); + if (!context().HasError(ultimate)) { + if (IsPointer(ultimate)) { + if (auto *details{ultimate.detailsIf()}) { + CHECK(!details->init()); + Walk(target); + if (MaybeExpr expr{EvaluateExpr(target)}) { + CheckInitialDataTarget(ultimate, *expr, target.value().source); + details->set_init(std::move(*expr)); + } } + } else { + Say(name, + "'%s' is not a pointer but is initialized like one"_err_en_US); + context().SetError(ultimate); } - } else { - Say(name, "'%s' is not a pointer but is initialized like one"_err_en_US); } } } @@ -5715,22 +5732,25 @@ const parser::Name &name, const parser::ProcPointerInit &target) { if (name.symbol) { Symbol &ultimate{name.symbol->GetUltimate()}; - if (IsProcedurePointer(ultimate)) { - auto &details{ultimate.get()}; - CHECK(!details.init()); - Walk(target); - if (const auto *targetName{std::get_if(&target.u)}) { - CheckInitialProcTarget(ultimate, *targetName, name.source); - if (targetName->symbol) { - details.set_init(*targetName->symbol); + if (!context().HasError(ultimate)) { + if (IsProcedurePointer(ultimate)) { + auto &details{ultimate.get()}; + CHECK(!details.init()); + Walk(target); + if (const auto *targetName{std::get_if(&target.u)}) { + CheckInitialProcTarget(ultimate, *targetName, name.source); + if (targetName->symbol) { + details.set_init(*targetName->symbol); + } + } else { + details.set_init(nullptr); // explicit NULL() } } else { - details.set_init(nullptr); // explicit NULL() + Say(name, + "'%s' is not a procedure pointer but is initialized " + "like one"_err_en_US); + context().SetError(ultimate); } - } else { - Say(name, - "'%s' is not a procedure pointer but is initialized " - "like one"_err_en_US); } } } diff --git a/flang/test/Semantics/resolve91.f90 b/flang/test/Semantics/resolve91.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve91.f90 @@ -0,0 +1,46 @@ +! RUN: %S/test_errors.sh %s %t %f18 +! Tests for duplicate definitions and initializations, mostly of procedures +module m + procedure(real), pointer :: p + !ERROR: The interface for procedure 'p' has already been declared + procedure(integer), pointer :: p +end + +module m1 + real, dimension(:), pointer :: realArray => null() + !ERROR: The type of 'realarray' has already been declared + real, dimension(:), pointer :: realArray => localArray +end module m1 + +module m2 + interface + subroutine sub() + end subroutine sub + end interface + + procedure(sub), pointer :: p1 => null() + !ERROR: The interface for procedure 'p1' has already been declared + procedure(sub), pointer :: p1 => null() + +end module m2 + +module m3 + interface + real function fun() + end function fun + end interface + + procedure(fun), pointer :: f1 => null() + !ERROR: The interface for procedure 'f1' has already been declared + procedure(fun), pointer :: f1 => null() + +end module m3 + +module m4 + real, dimension(:), pointer :: localArray => null() + type :: t2 + real, dimension(:), pointer :: realArray => null() + !ERROR: Component 'realarray' is already declared in this derived type + real, dimension(:), pointer :: realArray => localArray + end type +end module m4