[flang] Fixes for problems with declaring procedure entities

[PeteSteinfeld]

Summary

We were not detecting declaring multiple interfaces to the same procedure.
Also, we were not handling the initialization of entitiies where the associated
Symbol had previously had errors.

I added a boolean to ProcEntityDetails to indicate if set_interface() had been
called. I then checked that boolean when calling set_interface() and emitting
an error message if the interface was already set.

Also, in situations where we were emitting error messages for symbols, I set
the Error flag on the Symbol. Then when performing initialization on the
Symbol, I first check to see if the Symbol had an error.

[tskeith]

flang/include/flang/Semantics/symbol.h

238

ProcInterface already has an "unset" state. When it is default-initialized it has neither a symbol nor type. So isInterfaceSet could be determined by checking that rather than maintaining a separate boolean.

[PeteSteinfeld]

I plan to change the implementation of isInterfaceSet() to IsInterfaceSet() and make it be based on the contents of the ProcInterface.

flang/include/flang/Semantics/symbol.h

238

Thanks, Tim. I'll change the implementation of isInterfaceSet(). Since it's no longer an accessor, I'll capitalize it.

[PeteSteinfeld]

Changed the implementation of the test to see if the ProcInterface of the
ProcEntityDetails had already been set.

[tskeith]

flang/include/flang/Semantics/symbol.h

222

This could be CHECK(!interface_.IsInterfaceSet()).

[PeteSteinfeld]

flang/include/flang/Semantics/symbol.h

222

Good suggestion. Actually, though, I think it's `CHECK(!IsInterfaceSet()). Stay tuned for another updates.

flang/include/flang/Semantics/symbol.h

 // A procedure pointer, dummy procedure, or external procedure
 class ProcEntityDetails : public EntityDetails, public WithPassArg {
 public:
   ProcEntityDetails() = default;
   explicit ProcEntityDetails(EntityDetails &&d);
 
   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,
   // while *init() == nullptr => explicit NULL() initialization.
   std::optional<const Symbol *> init() const { return init_; }
   void set_init(const Symbol &symbol) { init_ = &symbol; }
   void set_init(std::nullptr_t) { init_ = nullptr; }
 
 private:
   ProcInterface interface_;
   std::optional<const Symbol *> init_;
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const ProcEntityDetails &);
 };
 
 // These derived type details represent the characteristics of a derived
 // type definition that are shared by all instantiations of that type.
 // The DerivedTypeSpec instances whose type symbols share these details
 // each own a scope into which the components' symbols have been cloned

flang/lib/Semantics/resolve-names.cpp

if (!arraySpec().empty() || !coarraySpec().empty()) {
     return symbol;
   }
 }
 
 Symbol &DeclarationVisitor::DeclareProcEntity(
     const parser::Name &name, Attrs attrs, const ProcInterface &interface) {
   Symbol &symbol{DeclareEntity<ProcEntityDetails>(name, attrs)};
   if (auto *details{symbol.detailsIf<ProcEntityDetails>()}) {
+    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()) {
         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);
     }
+  }
   return symbol;
 }
 
 Symbol &DeclarationVisitor::DeclareObjectEntity(
     const parser::Name &name, Attrs attrs) {
   Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, attrs)};
   if (auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
     if (auto *type{GetDeclTypeSpec()}) {
       SetType(name, *type);
     }
     if (!arraySpec().empty()) {
       if (details->IsArray()) {
+        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()) {
+        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());
       }
     }
     SetBindNameOn(symbol);
   }
   ClearArraySpec();
   ClearCoarraySpec();
bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) {
   set_allowForwardReferenceToDerivedType(false);
   Walk(std::get<std::list<parser::ComponentDecl>>(x.t));
   return false;
 }
 bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) {
   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) {
   if (auto *name{std::get_if<parser::Name>(&x.u)}) {
     return !NameIsKnownOrIntrinsic(*name);
   }
   return true;
 }
void DeclarationVisitor::SetType(
   auto *prevType{symbol.GetType()};
   if (!prevType) {
     symbol.SetType(type);
   } else if (symbol.has<UseDetails>()) {
     // error recovery case, redeclaration of use-associated name
   } 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);
   }
 }
 
 std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveDerivedType(
     const parser::Name &name) {
   Symbol *symbol{FindSymbol(name)};
if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
     }
   }
 }
 
 void DeclarationVisitor::PointerInitialization(
     const parser::Name &name, const parser::InitialDataTarget &target) {
   if (name.symbol) {
     Symbol &ultimate{name.symbol->GetUltimate()};
+    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);
+        Say(name,
+            "'%s' is not a pointer but is initialized like one"_err_en_US);
+        context().SetError(ultimate);
+      }
     }
   }
 }
 void DeclarationVisitor::PointerInitialization(
     const parser::Name &name, const parser::ProcPointerInit &target) {
   if (name.symbol) {
     Symbol &ultimate{name.symbol->GetUltimate()};
+    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 {
         Say(name,
             "'%s' is not a procedure pointer but is initialized "
             "like one"_err_en_US);
+        context().SetError(ultimate);
+      }
     }
   }
 }
 
 void ResolveNamesVisitor::HandleCall(
     Symbol::Flag procFlag, const parser::Call &call) {
   std::visit(
       common::visitors{

flang/test/Semantics/resolve91.f90

+! 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