[flang] These are additional changes for issue 458, to perform semantic checks on DO

variable and initial, final, and step expressions.

Here's a summary of the changes since my original pull request:

 - I've taken into account the possibility that the DO variable is declared in
   a MODULE.  This required a call to GetUltimate() on the Symbol for the DO
   variable.
 - The previous change exposed problems in the semantic checking for NULLIFY
   and DEALLOCATE statements, so I've included fixes and tests for those.  I
   also added a test for the ALLOCATE statement, even though it was already
   handling this case.
 - I now handle the case where a procedure name is erroneously used as a DO variable.
 - I now handle the case where a pointer to a procedure is erroneously used as
   a DO variable.
 - I now check that the DO expressions are not null.
 - I added tests for all cases listed above.

Original-commit: flang-compiler/f18@219d856fdb
Reviewed-on: https://github.com/flang-compiler/f18/pull/478
Tree-same-pre-rewrite: false

flang/lib/semantics/check-do-stmt.cc

@@ -397,6 +397,10 @@ private:
     return std::get<Bounds>(loopControl.u);
   }
 
+  void SayBadDoControl(parser::CharBlock sourceLocation) {
+    context_.Say(sourceLocation, "DO controls should be INTEGER"_err_en_US);
+  }
+
   void CheckDoControl(parser::CharBlock sourceLocation, bool isReal) {
     bool warn{context_.warnOnNonstandardUsage() ||
         context_.ShouldWarn(parser::LanguageFeature::RealDoControls)};
@@ -406,31 +410,50 @@ private:
       // TODO: Mark the following message as a warning when we have warnings
       context_.Say(sourceLocation, "DO controls should be INTEGER"_en_US);
     } else {
-      context_.Say(sourceLocation, "DO controls should be INTEGER"_err_en_US);
+      SayBadDoControl(sourceLocation);
     }
   }
 
   void CheckDoVariable(const parser::ScalarName &scalarName) {
-    const DeclTypeSpec *symType{scalarName.thing.symbol->GetType()};
-    if (symType->IsNumeric(TypeCategory::Integer)) {
-      return;  // No warnings or errors for INTEGER
-    }
     const parser::CharBlock &sourceLocation{scalarName.thing.source};
-    CheckDoControl(sourceLocation, symType->IsNumeric(TypeCategory::Real));
+    const Symbol *symbol{scalarName.thing.symbol};
+    if (!symbol) {
+      SayBadDoControl(sourceLocation);
+    } else {
+      if (!IsVariableName(*symbol)) {
+        context_.Say(
+            sourceLocation, "DO control must be an INTEGER variable"_err_en_US);
+      } else {
+        const DeclTypeSpec *symType{symbol->GetType()};
+        if (!symType) {
+          SayBadDoControl(sourceLocation);
+        } else {
+          if (!symType->IsNumeric(TypeCategory::Integer)) {
+            CheckDoControl(
+                sourceLocation, symType->IsNumeric(TypeCategory::Real));
+          }
+        }
+      } // No messages for INTEGER
+    }
   }
 
   void CheckDoExpression(const parser::ScalarExpr &scalarExpression) {
     const evaluate::Expr<evaluate::SomeType> *expr{GetExpr(scalarExpression)};
-    if (ExprHasTypeCategory(*expr, TypeCategory::Integer)) {
-      return;  // No warnings or errors for INTEGER
-    }
     const parser::CharBlock &sourceLocation{
         scalarExpression.thing.value().source};
-    CheckDoControl(
-        sourceLocation, ExprHasTypeCategory(*expr, TypeCategory::Real));
+    if (!expr) {
+      SayBadDoControl(sourceLocation);
+    } else {
+      if (ExprHasTypeCategory(*expr, TypeCategory::Integer)) {
+        return;  // No warnings or errors for INTEGER
+      }
+      CheckDoControl(
+          sourceLocation, ExprHasTypeCategory(*expr, TypeCategory::Real));
+    }
   }
 
   void CheckDoNormal(const parser::DoConstruct &doConstruct) {
+    // C1120 extended by allowing REAL and DOUBLE PRECISION
     // Get the bounds, then check the variable, init, final, and step
     const Bounds &bounds{GetBounds(doConstruct)};
     CheckDoVariable(bounds.name);

flang/lib/semantics/tools.cc

@@ -130,12 +130,13 @@ bool IsPointerDummy(const Symbol &symbol) {
 
 // variable-name
 bool IsVariableName(const Symbol &symbol) {
-  return symbol.has<ObjectEntityDetails>() && !IsParameter(symbol);
+  const Symbol &ultimate{symbol.GetUltimate()};
+  return ultimate.has<ObjectEntityDetails>() && !IsParameter(ultimate);
 }
 
 // proc-name
 bool IsProcName(const Symbol &symbol) {
-  return symbol.has<ProcEntityDetails>();
+  return symbol.GetUltimate().has<ProcEntityDetails>();
 }
 
 bool IsFunction(const Symbol &symbol) {

flang/test/semantics/allocate01.f90

@@ -14,6 +14,11 @@
 
 ! Check for semantic errors in ALLOCATE statements
 
+! Creating a symbol that allocate should accept
+module share
+  real, pointer :: rp
+end module share
+
 module m
 ! Creating symbols that allocate should not accept
   type :: a_type
@@ -37,6 +42,7 @@ end module
 
 subroutine C932(ed1, ed5, ed7, edc9, edc10, okad1, okpd1, okacd5)
 ! Each allocate-object shall be a data pointer or an allocatable variable.
+  use :: share
   use :: m, only: a_type
   type TestType1
     integer, allocatable :: ok(:)
@@ -124,4 +130,5 @@ subroutine C932(ed1, ed5, ed7, edc9, edc10, okad1, okpd1, okacd5)
   allocate(e8%ok)
   allocate(edc9%ok(4))
   allocate(edc10%ok)
+  allocate(rp)
 end subroutine

flang/test/semantics/deallocate05.f90

@@ -14,6 +14,13 @@
 
 ! Check for semantic errors in DEALLOCATE statements
 
+Module share
+  Real, Pointer :: rp
+End Module share
+
+Program deallocatetest
+Use share
+
 INTEGER, PARAMETER :: maxvalue=1024
 
 Type dt
@@ -32,6 +39,9 @@ Integer :: pi
 Character(256) :: ee
 Procedure(Real) :: prp
 
+Allocate(rp)
+Deallocate(rp)
+
 Allocate(x(3))
 
 !ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
@@ -66,4 +76,4 @@ Deallocate(x, stat=s, errmsg=ee, stat=s)
 !ERROR: ERRMSG may not be duplicated in a DEALLOCATE statement
 Deallocate(x, stat=s, errmsg=ee, errmsg=ee)
 
-End Program
+End Program deallocatetest

flang/test/semantics/dosemantics03.f90

@@ -22,7 +22,23 @@
 
 !OPTIONS: -Mstandard -Werror
 
+! C1120 -- DO variable (and associated expressions) must be INTEGER.
+! This is extended by allowing REAL and DOUBLE PRECISION
+
+SUBROUTINE sub()
+END SUBROUTINE sub
+
+FUNCTION ifunc()
+END FUNCTION ifunc
+
+MODULE share
+  INTEGER :: intvarshare
+  REAL :: realvarshare
+  DOUBLE PRECISION :: dpvarshare
+END MODULE share
+
 PROGRAM do_issue_458
+  USE share
   IMPLICIT NONE
   INTEGER :: ivar
   REAL :: rvar
@@ -40,6 +56,7 @@ PROGRAM do_issue_458
   REAL, POINTER :: prvar
   DOUBLE PRECISION, POINTER :: pdvar
   LOGICAL, POINTER :: plvar
+  PROCEDURE(ifunc), POINTER :: pifunc => NULL()
 
 ! DO variables
 ! INTEGER DO variable
@@ -106,6 +123,52 @@ PROGRAM do_issue_458
     PRINT *, "plvar is: ", plvar
   END DO
 
+! SUBROUTINE DO variable
+!ERROR: DO control must be an INTEGER variable
+  DO sub = 1, 10, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
+! FUNCTION DO variable
+!ERROR: DO control must be an INTEGER variable
+  DO ifunc = 1, 10, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
+! POINTER to FUNCTION DO variable
+!ERROR: DO control must be an INTEGER variable
+  DO pifunc = 1, 10, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
+! Array DO variable
+!ERROR: Must be a scalar value, but is a rank-1 array
+  DO avar = 1, 10, 3
+    PRINT *, "plvar is: ", plvar
+  END DO
+
+! Undeclared DO variable
+!ERROR: No explicit type declared for 'undeclared'
+!ERROR: DO controls should be INTEGER
+  DO undeclared = 1, 10, 3
+    PRINT *, "plvar is: ", plvar
+  END DO
+
+! Shared association INTEGER DO variable
+  DO intvarshare = 1, 10, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
+! Shared association REAL DO variable
+  DO realvarshare = 1, 10, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
+! Shared association DOUBLE PRECISION DO variable
+  DO dpvarshare = 1, 10, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
 ! Initial expressions
 ! REAL initial expression
   DO ivar = rvar, 10, 3
@@ -156,6 +219,13 @@ PROGRAM do_issue_458
     PRINT *, "ivar is: ", ivar
   END DO
 
+! Invalid initial expression
+!ERROR: DO controls should be INTEGER
+!ERROR: Integer literal is too large for INTEGER(KIND=4)
+  DO ivar = -2147483648_4, 10, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
 ! Final expression
 ! REAL final expression
   DO ivar = 1, rvar, 3
@@ -188,6 +258,13 @@ PROGRAM do_issue_458
     PRINT *, "ivar is: ", ivar
   END DO
 
+! Invalid final expression
+!ERROR: DO controls should be INTEGER
+!ERROR: Integer literal is too large for INTEGER(KIND=4)
+  DO ivar = 1, -2147483648_4, 3
+    PRINT *, "ivar is: ", ivar
+  END DO
+
 ! Step expression
 ! REAL step expression
   DO ivar = 1, 10, rvar
@@ -220,10 +297,11 @@ PROGRAM do_issue_458
     PRINT *, "ivar is: ", ivar
   END DO
 
-! Array DO variable
-!ERROR: Must be a scalar value, but is a rank-1 array
-  DO avar = 1, 10, 3
-    PRINT *, "plvar is: ", plvar
+! Invalid step expression
+!ERROR: DO controls should be INTEGER
+!ERROR: Integer literal is too large for INTEGER(KIND=4)
+  DO ivar = 1, 10, -2147483648_4
+    PRINT *, "ivar is: ", ivar
   END DO
 
 END PROGRAM do_issue_458

flang/test/semantics/nullify01.f90

@@ -14,6 +14,14 @@
 
 ! Test that NULLIFY works
 
+Module share
+  Real, Pointer :: rp
+  Procedure(Real), Pointer :: mprp
+End Module share
+
+Program nullifytest
+Use share
+
 INTEGER, PARAMETER :: maxvalue=1024
 
 Type dt
@@ -30,6 +38,9 @@ Type(t),Pointer :: z
 Integer, Pointer :: pi
 Procedure(Real), Pointer :: prp
 
+Allocate(rp)
+Nullify(rp)
+
 Allocate(x(3))
 Nullify(x(2)%p)
 
@@ -37,6 +48,7 @@ Nullify(y(2)%p)
 
 Nullify(pi)
 Nullify(prp)
+Nullify(mprp)
 
 Nullify(z%p)