[flang] Changes to enforce constraints C727 to C730 and most constrai…

…nts related to attributes

The full list of constraints is C727, C728, C729, C730, C743, C755, C759, C778,
and C1543.

I added a function to tools.cpp to check to see if a symbol name is the name
of an intrinsic type.

The biggest change was to resolve-names.cpp to check to see if attributes were
either duplicated or in conflict with each other.  I changed all locations
where attributes were set to check for duplicates or conflicts.

I also added tests for all checks and annotated the tests and code with the
numbers of the constraints being tested/checked.

Original-commit: flang-compiler/f18@3f30e8a
Reviewed-on: flang-compiler/f18#1084

flang/include/flang/Semantics/attr.h

@@ -22,10 +22,10 @@ namespace Fortran::semantics {
 
 // All available attributes.
 ENUM_CLASS(Attr, ABSTRACT, ALLOCATABLE, ASYNCHRONOUS, BIND_C, CONTIGUOUS,
-    DEFERRED, ELEMENTAL, EXTERNAL, IMPURE, INTENT_IN, INTENT_INOUT, INTENT_OUT,
-    INTRINSIC, MODULE, NON_OVERRIDABLE, NON_RECURSIVE, NOPASS, OPTIONAL,
-    PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PUBLIC, PURE, RECURSIVE, SAVE,
-    TARGET, VALUE, VOLATILE)
+    DEFERRED, ELEMENTAL, EXTENDS, EXTERNAL, IMPURE, INTENT_IN, INTENT_INOUT,
+    INTENT_OUT, INTRINSIC, MODULE, NON_OVERRIDABLE, NON_RECURSIVE, NOPASS,
+    OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PUBLIC, PURE,
+    RECURSIVE, SAVE, TARGET, VALUE, VOLATILE)
 
 // Set of attributes
 class Attrs : public common::EnumSet<Attr, Attr_enumSize> {

flang/include/flang/Semantics/tools.h

@@ -107,6 +107,7 @@ bool IsOrContainsEventOrLockComponent(const Symbol &);
 bool IsSaved(const Symbol &);
 bool CanBeTypeBoundProc(const Symbol *);
 bool IsInitialized(const Symbol &);
+bool HasIntrinsicTypeName(const Symbol &);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
 const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,

flang/lib/Semantics/check-declarations.cpp

@@ -641,6 +641,10 @@ void CheckHelper::CheckDerivedType(
       }
     }
   }
+  if (HasIntrinsicTypeName(symbol)) {  // C729
+    messages_.Say("A derived type name cannot be the name of an intrinsic"
+                  " type"_err_en_US);
+  }
 }
 
 void CheckHelper::CheckGeneric(

flang/lib/Semantics/expression.cpp

@@ -626,7 +626,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::LogicalLiteralConstant &x) {
       TypeKindVisitor<TypeCategory::Logical, Constant, bool>{
           kind, std::move(value)})};
   if (!result) {
-    Say("unsupported LOGICAL(KIND=%d)"_err_en_US, kind);
+    Say("unsupported LOGICAL(KIND=%d)"_err_en_US, kind);  // C728
   }
   return result;
 }
@@ -2494,7 +2494,7 @@ DynamicType ExpressionAnalyzer::GetDefaultKindOfType(
 
 bool ExpressionAnalyzer::CheckIntrinsicKind(
     TypeCategory category, std::int64_t kind) {
-  if (IsValidKindOfIntrinsicType(category, kind)) {  // C712, C714, C715
+  if (IsValidKindOfIntrinsicType(category, kind)) {  // C712, C714, C715, C727
     return true;
   } else {
     Say("%s(KIND=%jd) is not a supported type"_err_en_US,
@@ -2543,7 +2543,7 @@ bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
     const MaybeExpr &result, TypeCategory category, bool defaultKind) {
   if (result) {
     if (auto type{result->GetType()}) {
-      if (type->category() != category) { // C885
+      if (type->category() != category) {  // C885
         Say(at, "Must have %s type, but is %s"_err_en_US,
             ToUpperCase(EnumToString(category)),
             ToUpperCase(type->AsFortran()));

flang/lib/Semantics/resolve-names.cpp

@@ -242,10 +242,12 @@ class AttrsVisitor : public virtual BaseVisitor {
   bool Pre(const parser::IntentSpec &);
   bool Pre(const parser::Pass &);
 
+  bool CheckAndSet(Attr);
+
 // Simple case: encountering CLASSNAME causes ATTRNAME to be set.
 #define HANDLE_ATTR_CLASS(CLASSNAME, ATTRNAME) \
   bool Pre(const parser::CLASSNAME &) { \
-    attrs_->set(Attr::ATTRNAME); \
+    CheckAndSet(Attr::ATTRNAME); \
     return false; \
   }
   HANDLE_ATTR_CLASS(PrefixSpec::Elemental, ELEMENTAL)
@@ -294,6 +296,10 @@ class AttrsVisitor : public virtual BaseVisitor {
   }
 
 private:
+  bool IsDuplicateAttr(Attr);
+  bool HaveAttrConflict(Attr, Attr, Attr);
+  bool IsConflictingAttr(Attr);
+
   MaybeExpr bindName_;  // from BIND(C, NAME="...")
   std::optional<SourceName> passName_;  // from PASS(...)
 };
@@ -607,6 +613,7 @@ class ModuleVisitor : public virtual ScopeHandler {
 class InterfaceVisitor : public virtual ScopeHandler {
 public:
   bool Pre(const parser::InterfaceStmt &);
+  void Post(const parser::InterfaceStmt &);
   void Post(const parser::EndInterfaceStmt &);
   bool Pre(const parser::GenericSpec &);
   bool Pre(const parser::ProcedureStmt &);
@@ -1548,26 +1555,69 @@ bool AttrsVisitor::SetBindNameOn(Symbol &symbol) {
 
 void AttrsVisitor::Post(const parser::LanguageBindingSpec &x) {
   CHECK(attrs_);
-  attrs_->set(Attr::BIND_C);
-  if (x.v) {
-    bindName_ = EvaluateExpr(*x.v);
+  if (CheckAndSet(Attr::BIND_C)) {
+    if (x.v) {
+      bindName_ = EvaluateExpr(*x.v);
+    }
   }
 }
 bool AttrsVisitor::Pre(const parser::IntentSpec &x) {
   CHECK(attrs_);
-  attrs_->set(IntentSpecToAttr(x));
+  CheckAndSet(IntentSpecToAttr(x));
   return false;
 }
 bool AttrsVisitor::Pre(const parser::Pass &x) {
-  if (x.v) {
-    passName_ = x.v->source;
-    MakePlaceholder(*x.v, MiscDetails::Kind::PassName);
-  } else {
-    attrs_->set(Attr::PASS);
+  if (CheckAndSet(Attr::PASS)) {
+    if (x.v) {
+      passName_ = x.v->source;
+      MakePlaceholder(*x.v, MiscDetails::Kind::PassName);
+    }
   }
   return false;
 }
 
+// C730, C743, C755, C778, C1543 say no attribute or prefix repetitions
+bool AttrsVisitor::IsDuplicateAttr(Attr attrName) {
+  if (attrs_->test(attrName)) {
+    Say(currStmtSource().value(),
+        "Attribute '%s' cannot be used more than once"_en_US,
+        AttrToString(attrName));
+    return true;
+  }
+  return false;
+}
+
+// See if attrName violates a constraint cause by a conflict.  attr1 and attr2
+// name attributes that cannot be used on the same declaration
+bool AttrsVisitor::HaveAttrConflict(Attr attrName, Attr attr1, Attr attr2) {
+  if ((attrName == attr1 && attrs_->test(attr2)) ||
+      (attrName == attr2 && attrs_->test(attr1))) {
+    Say(currStmtSource().value(),
+        "Attributes '%s' and '%s' conflict with each other"_err_en_US,
+        AttrToString(attr1), AttrToString(attr2));
+    return true;
+  }
+  return false;
+}
+// C759, C1543
+bool AttrsVisitor::IsConflictingAttr(Attr attrName) {
+  return HaveAttrConflict(attrName, Attr::INTENT_IN, Attr::INTENT_INOUT) ||
+      HaveAttrConflict(attrName, Attr::INTENT_IN, Attr::INTENT_OUT) ||
+      HaveAttrConflict(attrName, Attr::INTENT_INOUT, Attr::INTENT_OUT) ||
+      HaveAttrConflict(attrName, Attr::PASS, Attr::NOPASS) ||
+      HaveAttrConflict(attrName, Attr::PURE, Attr::IMPURE) ||
+      HaveAttrConflict(attrName, Attr::PUBLIC, Attr::PRIVATE) ||
+      HaveAttrConflict(attrName, Attr::RECURSIVE, Attr::NON_RECURSIVE);
+}
+bool AttrsVisitor::CheckAndSet(Attr attrName) {
+  CHECK(attrs_);
+  if (IsConflictingAttr(attrName) || IsDuplicateAttr(attrName)) {
+    return false;
+  }
+  attrs_->set(attrName);
+  return true;
+}
+
 // DeclTypeSpecVisitor implementation
 
 const DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() {
@@ -1824,14 +1874,22 @@ void ArraySpecVisitor::PostAttrSpec() {
   // Save dimension/codimension from attrs so we can process array/coarray-spec
   // on the entity-decl
   if (!arraySpec_.empty()) {
-    CHECK(attrArraySpec_.empty());
-    attrArraySpec_ = arraySpec_;
-    arraySpec_.clear();
+    if (attrArraySpec_.empty()) {
+      attrArraySpec_ = arraySpec_;
+      arraySpec_.clear();
+    } else {
+      Say(currStmtSource().value(),
+          "Attribute 'DIMENSION' cannot be used more than once"_err_en_US);
+    }
   }
   if (!coarraySpec_.empty()) {
-    CHECK(attrCoarraySpec_.empty());
-    attrCoarraySpec_ = coarraySpec_;
-    coarraySpec_.clear();
+    if (attrCoarraySpec_.empty()) {
+      attrCoarraySpec_ = coarraySpec_;
+      coarraySpec_.clear();
+    } else {
+      Say(currStmtSource().value(),
+          "Attribute 'CODIMENSION' cannot be used more than once"_err_en_US);
+    }
   }
 }
 
@@ -2395,9 +2453,11 @@ void ModuleVisitor::ApplyDefaultAccess() {
 bool InterfaceVisitor::Pre(const parser::InterfaceStmt &x) {
   bool isAbstract{std::holds_alternative<parser::Abstract>(x.u)};
   genericInfo_.emplace(/*isInterface*/ true, isAbstract);
-  return true;
+  return BeginAttrs();
 }
 
+void InterfaceVisitor::Post(const parser::InterfaceStmt &) { EndAttrs(); }
+
 void InterfaceVisitor::Post(const parser::EndInterfaceStmt &) {
   genericInfo_.pop();
 }
@@ -2624,9 +2684,15 @@ bool SubprogramVisitor::Pre(const parser::Suffix &suffix) {
 bool SubprogramVisitor::Pre(const parser::PrefixSpec &x) {
   // Save this to process after UseStmt and ImplicitPart
   if (const auto *parsedType{std::get_if<parser::DeclarationTypeSpec>(&x.u)}) {
-    funcInfo_.parsedType = parsedType;
-    funcInfo_.source = currStmtSource();
-    return false;
+    if (funcInfo_.parsedType) {  // C1543
+      Say(currStmtSource().value(),
+          "FUNCTION prefix cannot specify the type more than once"_err_en_US);
+      return false;
+    } else {
+      funcInfo_.parsedType = parsedType;
+      funcInfo_.source = currStmtSource();
+      return false;
+    }
   } else {
     return true;
   }
@@ -3057,7 +3123,7 @@ bool DeclarationVisitor::Pre(const parser::AccessSpec &x) {
         "%s attribute may only appear in the specification part of a module"_err_en_US,
         EnumToString(attr));
   }
-  attrs_->set(attr);
+  CheckAndSet(attr);
   return false;
 }
 
@@ -3522,7 +3588,12 @@ void DeclarationVisitor::Post(const parser::TypeParamDefStmt &x) {
   EndDecl();
 }
 bool DeclarationVisitor::Pre(const parser::TypeAttrSpec::Extends &x) {
-  derivedTypeInfo_.extends = &x.v;
+  if (derivedTypeInfo_.extends) {
+    Say(currStmtSource().value(),
+        "Attribute 'EXTENDS' cannot be used more than once"_err_en_US);
+  } else {
+    derivedTypeInfo_.extends = &x.v;
+  }
   return false;
 }
 

flang/lib/Semantics/tools.cpp

@@ -674,6 +674,22 @@ bool IsInitialized(const Symbol &symbol) {
   return false;
 }
 
+bool HasIntrinsicTypeName(const Symbol &symbol) {
+  std::string name{symbol.name().ToString()};
+  if (name == "doubleprecision") {
+    return true;
+  } else if (name == "derived") {
+    return false;
+  } else {
+    for (int i{0}; i != common::TypeCategory_enumSize; ++i) {
+      if (name == parser::ToLowerCaseLetters(EnumToString(TypeCategory{i}))) {
+        return true;
+      }
+    }
+    return false;
+  }
+}
+
 bool IsFinalizable(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     if (const DerivedTypeSpec * derived{type->AsDerived()}) {

flang/test/Semantics/kinds02.f90

@@ -10,6 +10,8 @@
 ! double-colon separator appears in the typedeclaration- stmt.
 ! C727 The value of kind-param shall specify a representation method that 
 ! exists on the processor.
+! C728 The value of kind-param shall specify a representation method that 
+! exists on the processor.
 !
 !ERROR: INTEGER(KIND=0) is not a supported type
 integer(kind=0) :: j0
@@ -53,6 +55,18 @@
 logical(kind=3) :: l3
 !ERROR: LOGICAL(KIND=16) is not a supported type
 logical(kind=16) :: l16
+integer, parameter :: negOne = -1
+!ERROR: unsupported LOGICAL(KIND=0)
+logical :: lvar0 = .true._0
+logical :: lvar1 = .true._1
+logical :: lvar2 = .true._2
+!ERROR: unsupported LOGICAL(KIND=3)
+logical :: lvar3 = .true._3
+logical :: lvar4 = .true._4
+!ERROR: unsupported LOGICAL(KIND=5)
+logical :: lvar5 = .true._5
+!ERROR: unsupported LOGICAL(KIND=-1)
+logical :: lvar6 = .true._negOne
 character (len=99, kind=1) :: cvar1
 character (len=99, kind=2) :: cvar2
 character *4, cvar3

flang/test/Semantics/resolve78.f90

@@ -0,0 +1,32 @@
+! RUN: %S/test_errors.sh %s %flang %t
+module m
+! C743 No component-attr-spec shall appear more than once in a 
+! given component-def-stmt.
+!
+! R737 data-component-def-stmt ->
+!        declaration-type-spec [[, component-attr-spec-list] ::]
+!        component-decl-list
+!  component-attr-spec values are:
+!    PUBLIC, PRIVATE, ALLOCATABLE, CODIMENSION [*], CONTIGUOUS, DIMENSION(5), 
+!      POINTER
+
+  type :: derived
+    !WARNING: Attribute 'PUBLIC' cannot be used more than once
+    real, public, allocatable, public :: field1
+    !WARNING: Attribute 'PRIVATE' cannot be used more than once
+    real, private, allocatable, private :: field2
+    !ERROR: Attributes 'PUBLIC' and 'PRIVATE' conflict with each other
+    real, public, allocatable, private :: field3
+    !WARNING: Attribute 'ALLOCATABLE' cannot be used more than once
+    real, allocatable, public, allocatable :: field4
+    !ERROR: Attribute 'CODIMENSION' cannot be used more than once
+    real, public, codimension[:], allocatable, codimension[:] :: field5
+    !WARNING: Attribute 'CONTIGUOUS' cannot be used more than once
+    real, public, contiguous, pointer, contiguous, dimension(:) :: field6
+    !ERROR: Attribute 'DIMENSION' cannot be used more than once
+    real, dimension(5), public, dimension(5) :: field7
+    !WARNING: Attribute 'POINTER' cannot be used more than once
+    real, pointer, public, pointer :: field8
+  end type derived
+
+end module m

flang/test/Semantics/resolve79.f90

@@ -0,0 +1,54 @@
+! RUN: %S/test_errors.sh %s %flang %t
+module m
+! C755 The same proc-component-attr-spec shall not appear more than once in a 
+! given proc-component-def-stmt.
+! C759 PASS and NOPASS shall not both appear in the same 
+! proc-component-attr-spec-list.
+!
+! R741 proc-component-def-stmt ->
+!        PROCEDURE ( [proc-interface] ) , proc-component-attr-spec-list
+!          :: proc-decl-list
+!  proc-component-attr-spec values are:
+!    PUBLIC, PRIVATE, NOPASS, PASS, POINTER
+
+  type :: procComponentType
+    !WARNING: Attribute 'PUBLIC' cannot be used more than once
+    procedure(publicProc), public, pointer, public :: publicField
+    !WARNING: Attribute 'PRIVATE' cannot be used more than once
+    procedure(privateProc), private, pointer, private :: privateField
+    !WARNING: Attribute 'NOPASS' cannot be used more than once
+    procedure(nopassProc), nopass, pointer, nopass :: noPassField
+    !WARNING: Attribute 'PASS' cannot be used more than once
+    procedure(passProc), pass, pointer, pass :: passField
+    !ERROR: Attributes 'PASS' and 'NOPASS' conflict with each other
+    procedure(passNopassProc), pass, pointer, nopass :: passNopassField
+    !WARNING: Attribute 'POINTER' cannot be used more than once
+    procedure(pointerProc), pointer, public, pointer :: pointerField
+  contains
+    procedure :: noPassProc
+    procedure :: passProc
+    procedure :: passNopassProc
+    procedure :: publicProc
+    procedure :: privateProc
+  end type procComponentType
+
+contains
+    subroutine publicProc(arg)
+      class(procComponentType) :: arg
+    end
+    subroutine privateProc(arg)
+      class(procComponentType) :: arg
+    end
+    subroutine noPassProc(arg)
+      class(procComponentType) :: arg
+    end
+    subroutine passProc(arg)
+      class(procComponentType) :: arg
+    end
+    subroutine passNopassProc(arg)
+      class(procComponentType) :: arg
+    end
+    subroutine pointerProc(arg)
+      class(procComponentType) :: arg
+    end
+end module m