const parser::Name &name, Attrs attrs, const ProcInterface &interface) {
Symbol &symbol{DeclareEntity<ProcEntityDetails>(name, attrs)};
if (auto *details{symbol.detailsIf<ProcEntityDetails>()}) {
- 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;
}
}
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());
}
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) {
} 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);
}
const parser::Name &name, const parser::InitialDataTarget &target) {
if (name.symbol) {
Symbol &ultimate{name.symbol->GetUltimate()};
- if (IsPointer(ultimate)) {
- if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
- 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<ObjectEntityDetails>()}) {
+ 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);
}
}
}
const parser::Name &name, const parser::ProcPointerInit &target) {
if (name.symbol) {
Symbol &ultimate{name.symbol->GetUltimate()};
- if (IsProcedurePointer(ultimate)) {
- auto &details{ultimate.get<ProcEntityDetails>()};
- CHECK(!details.init());
- Walk(target);
- if (const auto *targetName{std::get_if<parser::Name>(&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<ProcEntityDetails>()};
+ CHECK(!details.init());
+ Walk(target);
+ if (const auto *targetName{std::get_if<parser::Name>(&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);
}
}
}
--- /dev/null
+! 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