[flang] Enforce a program not including more than one main program

[peixin]

Summary

As Fortran 2018 5.2.2 states, a program shall consist of exactly one
main program. Add this semantic check.

[klausler]

flang/lib/Semantics/resolve-names.cpp

7217

Don't use "unsigned" when "int" suffices.

Please use braced initialization, not "="; it's safer.

Please reference the applicable point in the Fortran standard that establishes this restriction (subclause 5.2.2)

There are probably better places for this check than resolve-names.cpp -- the file is already too large and this kind of error checking is not its purpose. You could put it in the program tree constructor, or (best) in check-declarations.cpp, which is where one would expect to find it.

The phrase "source file" would perhaps be more clear to the user than "program" in the error message.

[peixin]

Thanks for @klausler 's comments. Doing this in check-declarations.cpp is better. Addressed the comments.

[klausler]

flang/lib/Semantics/check-declarations.cpp

1719 ↗

(On Diff #427942)

In C++ it is best to use the prefix forms of ++ and --. It matters for many iterator types, so it's a good habit to get into. The postfix forms of ++ and -- should be used only in the context of an expression that really depends on using the "old" value of the variable.

1721 ↗

(On Diff #427942)

Please check that this message is associated with the right source code location.

[peixin]

Add the source code location for error message to make it more readable.

[peixin]

flang/lib/Semantics/check-declarations.cpp

1719 ↗

(On Diff #427942)

Thanks for the explanation. Fixed.

1721 ↗

(On Diff #427942)

Now, it is associated with the right source code location.

flang/lib/Semantics/resolve-names.cpp

if (symbol->CanReplaceDetails(details)) {
       }
       symbol->set_details(std::move(details));
       return *symbol;
     } else if constexpr (std::is_same_v<UnknownDetails, D>) {
       symbol->attrs() |= attrs;
       return *symbol;
     } else {
       if (!CheckPossibleBadForwardRef(*symbol)) {
+        if (name.empty() && symbol->name().empty()) {
+          // report the error elsewhere
+          return *symbol;
+        }
         SayAlreadyDeclared(name, *symbol);
       }
       // replace the old symbol with a new one with correct details
       EraseSymbol(*symbol);
       auto &result{MakeSymbol(name, attrs, std::move(details))};
       context().SetError(result);
       return result;
     }
public:
   }
   void Post(const parser::ProcComponentRef &);
   bool Pre(const parser::FunctionReference &);
   bool Pre(const parser::CallStmt &);
   bool Pre(const parser::ImportStmt &);
   void Post(const parser::TypeGuardStmt &);
   bool Pre(const parser::StmtFunctionStmt &);
   bool Pre(const parser::DefinedOpName &);
+  bool Pre(const parser::Program &);
   bool Pre(const parser::ProgramUnit &);
   void Post(const parser::AssignStmt &);
   void Post(const parser::AssignedGotoStmt &);
 
   // These nodes should never be reached: they are handled in ProgramUnit
   bool Pre(const parser::MainProgram &) {
     llvm_unreachable("This node is handled in ProgramUnit");
   }
void ResolveNamesVisitor::Post(const parser::AssignStmt &x) {
   }
 }
 void ResolveNamesVisitor::Post(const parser::AssignedGotoStmt &x) {
   if (auto *name{ResolveName(std::get<parser::Name>(x.t))}) {
     ConvertToObjectEntity(DEREF(name->symbol));
   }
 }
 
+bool ResolveNamesVisitor::Pre(const parser::Program &program) {
+  unsigned mainProgCnt = 0;
+  for (auto &unit : program.v) {
+    if (const auto *mainProg{
+            std::get_if<common::Indirection<parser::MainProgram>>(&unit.u)}) {
+      auto &endProgStmt{std::get<parser::Statement<parser::EndProgramStmt>>(
+          mainProg->value().t)};
+      if (mainProgCnt > 0) {
+        Say(endProgStmt.source,
+            "A program cannot contain more than one main program"_err_en_US);
+      }
+      mainProgCnt++;
+    }
+  }
+  return true;
+}
+
 bool ResolveNamesVisitor::Pre(const parser::ProgramUnit &x) {
   if (std::holds_alternative<common::Indirection<parser::CompilerDirective>>(
           x.u)) {
     // TODO: global directives
     return true;
   }
   auto root{ProgramTree::Build(x)};
   SetScope(topScope_);

flang/test/Semantics/call02.f90

contains
   subroutine s2(x)
     real :: x
   end
   subroutine s3(p)
     procedure(real) :: p
   end
 end
 
-program p04
+subroutine p04
   implicit none
   !ERROR: No explicit type declared for 'index'
   call s1(index)
 end

flang/test/Semantics/case01.f90

select case (name)
      case ('ha')
      !ERROR: CASE ("hz") conflicts with previous cases
      case ('hz')
      case default
    end select
 
 end program
 
-program test_overlap
+subroutine test_overlap
   integer :: i
   !OK: these cases do not overlap
   select case(i)
     case(0:)
     case(:-1)
   end select
   select case(i)
     case(-1:)
     !ERROR: CASE (:0_4) conflicts with previous cases
     case(:0)
   end select
 end
 
-program test_overflow
+subroutine test_overflow
   integer :: j
   select case(1_1)
   case (127)
   !WARN: CASE value (128_4) overflows type (INTEGER(1)) of SELECT CASE expression
   case (128)
   !WARN: CASE value (129_4) overflows type (INTEGER(1)) of SELECT CASE expression
   !WARN: CASE value (130_4) overflows type (INTEGER(1)) of SELECT CASE expression
   case (129:130)

flang/test/Semantics/modfile41.f90

 end module m6
 program testUse1
   use m1
   use m1,z=>a ! This prevents the use association of m1's "a" as local "a"
   use m2 ! m2's version of "a" gets use associated
   !ERROR: 'a' is use-associated from module 'm2' and cannot be re-declared
   integer :: a = 2
 end
-program testUse2
+subroutine testUse2
   use m1,only : a ! This forces the use association of m1's "a" as local "a"
   use m1,z=>a ! This rename doesn't affect the previous forced USE association
   !ERROR: 'a' is use-associated from module 'm1' and cannot be re-declared
   integer :: a = 2
 end
-program testUse3
+subroutine testUse3
   use m1 ! By itself, this would use associate m1's "a" with a local "a"
   use m1,z=>a ! This rename of m1'a "a" removes the previous use association
   integer :: a = 2
 end
-program testUse4
+subroutine testUse4
   use m1,only : a ! Use associate m1's "a" with local "a"
   use m1,z=>a ! Also use associate m1's "a" with local "z", also pulls in "b"
   !ERROR: 'b' is use-associated from module 'm1' and cannot be re-declared
   integer :: b = 2
 end
-program testUse5
+subroutine testUse5
   use m1,z=>a ! The rename prevents creation of a local "a"
   use m1 ! Does not create a local "a" because of the previous rename
   integer :: a = 2
 end
-program testUse6
+subroutine testUse6
   use m1, z => a ! Hides m1's "a"
   use m1, y => b ! Hides m1's "b"
   integer :: a = 4 ! OK
   integer :: b = 5 ! OK
 end
-program testUse7
+subroutine testUse7
   use m3,t1=>t2,t2=>t1 ! Looks weird but all is good
   type(t1) x
   type(t2) y
   x%t2_value = a
   y%t1_value = z
 end
-program testUse8
+subroutine testUse8
   use m4 ! This USE associates all of m1
   !ERROR: 'a' is use-associated from module 'm4' and cannot be re-declared
   integer :: a = 2
 end
-program testUse9
+subroutine testUse9
   use m5
   integer :: a = 2
 end
-program testUse10
+subroutine testUse10
   use m4
   use m4, z=>a ! This rename erases the USE assocated "a" from m1
   integer :: a = 2
 end
-program testUse11
+subroutine testUse11
   use m6
   use m6, z=>a ! This rename erases the USE assocated "a" from m1
   integer :: a = 2
 end
-program testUse12
+subroutine testUse12
   use m4 ! This USE associates "a" from m1
   use m1, z=>a ! This renames the "a" from m1, but not the one through m4
   !ERROR: 'a' is use-associated from module 'm4' and cannot be re-declared
   integer :: a = 2
 end

flang/test/Semantics/multi-programs01.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test the restriction in 5.2.2
+
+end
+!ERROR: A program cannot contain more than one main program
+end

flang/test/Semantics/multi-programs02.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test the restriction in 5.2.2
+
+program m
+end
+!ERROR: A program cannot contain more than one main program
+end

flang/test/Semantics/multi-programs03.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test the restriction in 5.2.2
+
+end
+program m
+!ERROR: A program cannot contain more than one main program
+end

flang/test/Semantics/multi-programs04.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test the restriction in 5.2.2
+
+program m
+end
+!ERROR: 'm' is already declared in this scoping unit
+program m
+!ERROR: A program cannot contain more than one main program
+end

flang/test/Semantics/multi-programs05.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test the restriction in 5.2.2
+
+program m
+end
+program m2
+!ERROR: A program cannot contain more than one main program
+end

flang/test/Semantics/multi-programs06.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test the restriction in 5.2.2
+
+end
+!ERROR: A program cannot contain more than one main program
+end
+!ERROR: A program cannot contain more than one main program
+end

flang/test/Semantics/omp-do04.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1 -fopenmp
 ! OpenMP Version 4.5
 ! 2.7.1 Loop Construct
 ! The loop iteration variable may not appear in a threadprivate directive.
 
 
-program omp_do
+subroutine omp_do
   integer, save:: i, j, k,n
   !$omp  threadprivate(k,j,i)
   !$omp  do collapse(2)
   !ERROR: Loop iteration variable i is not allowed in THREADPRIVATE.
   do i = 1, 10
     !ERROR: Loop iteration variable j is not allowed in THREADPRIVATE.
     do j = 1, 10
       print *, "Hello"
     end do
   end do
   !$omp end do
-end program omp_do
+end subroutine omp_do
 
-program omp_do1
+subroutine omp_do1
+  integer, save :: i, j, k
   !$omp  threadprivate(k,j,i)
   !$omp  do
   !ERROR: Loop iteration variable i is not allowed in THREADPRIVATE.
   do i = 1, 10
     do j = 1, 10
       print *, "Hello"
     end do
   end do
   !$omp end do
 
-end program omp_do1
+end subroutine omp_do1
 
-program omp_do2
+subroutine omp_do2
+  integer, save :: k, j
   !$omp threadprivate(k)
   !$omp threadprivate(j)
   call compute()
   contains
   subroutine compute()
   !$omp  do ordered(1) collapse(1)
   !ERROR: Loop iteration variable k is not allowed in THREADPRIVATE.
   foo: do k = 1, 10
     do i = 1, 10
       print *, "Hello"
     end do
   end do foo
   !$omp end do
   end subroutine
 
-end program omp_do2
+end subroutine omp_do2
 
-program omp_do3
+subroutine omp_do3
+  integer, save :: i
   !$omp  threadprivate(i)
   !$omp parallel
   print *, "parallel"
   !$omp end parallel
   !$omp  do
   !ERROR: Loop iteration variable i is not allowed in THREADPRIVATE.
   do i = 1, 10
     do j = 1, 10
       print *, "Hello"
     end do
   end do
   !$omp end do
 
-end program omp_do3
+end subroutine omp_do3
 
 module tp
   !integer i,j
   integer, save:: i, j, k,n
   !$omp threadprivate(i)
   !$omp threadprivate(j)
 end module tp
 
 module usetp
   use tp
 end module usetp
 
-program main
+subroutine main
   use usetp
   !$omp  do
   !ERROR: Loop iteration variable i is not allowed in THREADPRIVATE.
   do i = 1, 10
     do j = 1, 10
       print *, "Hello"
     end do
   end do
   !$omp end do
-end program
+end subroutine
 
-program main1
+subroutine main1
   use tp
   !$omp  do
   !ERROR: Loop iteration variable j is not allowed in THREADPRIVATE.
   do j = 1, 10
     do i = 1, 10
       print *, "Hello"
     end do
   end do
   !$omp end do
-end program
+end subroutine

flang/test/Semantics/omp-do11.f90

do j=1,10
       !REF: /omp_do/Block1/i
       !REF: /omp_do/j
       print *, "it", i, j
     end do
   end do
   !$omp end do
 end program omp_do
 
-!DEF: /omp_do2 MainProgram
-program omp_do2
+!DEF: /omp_do2 (Subroutine)Subprogram
+subroutine omp_do2
   !DEF: /omp_do2/i ObjectEntity INTEGER(4)
   !DEF: /omp_do2/k ObjectEntity INTEGER(4)
   integer :: i = 0, k
   !$omp do
   !DEF: /omp_do2/Block1/i (OmpPrivate, OmpPreDetermined) HostAssoc INTEGER(4)
   do i=1,10
     !REF: /omp_do2/Block1/i
     print *, "it", i
   end do
   !$omp end do
-end program omp_do2
+end subroutine omp_do2

flang/test/Semantics/resolve102.f90

 end subroutine circular
 
 !ERROR: Procedure 'foo' is recursively defined.  Procedures in the cycle: 'foo', 'r'
 function foo() result(r)
   !ERROR: Procedure 'r' is recursively defined.  Procedures in the cycle: 'foo', 'r'
   procedure(foo), pointer :: r 
 end function foo
 
-program iface
+subroutine iface
   !ERROR: Procedure 'p' is recursively defined.  Procedures in the cycle: 'p', 'sub', 'p2'
   procedure(sub) :: p
   interface
     subroutine sub(p2)
       import p
       procedure(p) :: p2
     end subroutine
   end interface
   call p(sub)
-end program
+end subroutine
 
-Program mutual
+subroutine mutual
   Procedure(sub1) :: p
 
   Call p(sub)
 
   contains
     !ERROR: Procedure 'sub1' is recursively defined.  Procedures in the cycle: 'p', 'sub1', 'arg'
     Subroutine sub1(arg)
       procedure(sub1) :: arg
     End Subroutine
 
     Subroutine sub(p2)
       Procedure(sub1) :: p2
     End Subroutine
-End Program
+End subroutine
 
-Program mutual1
+subroutine mutual1
   Procedure(sub1) :: p
 
   Call p(sub)
 
   contains
     !ERROR: Procedure 'sub1' is recursively defined.  Procedures in the cycle: 'p', 'sub1', 'arg', 'sub', 'p2'
     Subroutine sub1(arg)
       procedure(sub) :: arg
     End Subroutine
 
     Subroutine sub(p2)
       Procedure(sub1) :: p2
     End Subroutine
-End Program
+End subroutine
 
-program twoCycle
+subroutine twoCycle
   !ERROR: The interface for procedure 'p1' is recursively defined
   !ERROR: The interface for procedure 'p2' is recursively defined
   procedure(p1) p2
   procedure(p2) p1
   call p1
   call p2
-end program
+end subroutine
 
-program threeCycle
+subroutine threeCycle
   !ERROR: The interface for procedure 'p1' is recursively defined
   !ERROR: The interface for procedure 'p2' is recursively defined
   procedure(p1) p2
   !ERROR: The interface for procedure 'p3' is recursively defined
   procedure(p2) p3
   procedure(p3) p1
   call p1
   call p2
   call p3
-end program
+end subroutine
 
 module mutualSpecExprs
 contains
   pure integer function f(n)
     integer, intent(in) :: n
     real arr(g(n))
     f = size(arr)
   end function
   pure integer function g(n)
     integer, intent(in) :: n
     !ERROR: Procedure 'f' is referenced before being sufficiently defined in a context where it must be so
     real arr(f(n))
     g = size(arr)
   end function
 end

flang/test/Semantics/resolve14.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 module m1
   integer :: x
   integer :: y
   integer :: z
   integer, parameter :: k1 = selected_int_kind(9)
 end
 module m2
   real :: y
   real :: z
   real :: w
   integer, parameter :: k2 = selected_int_kind(9)
 end
 
-program p1
+subroutine p1
   use m1
   use m2
   ! check that selected_int_kind is not use-associated
   integer, parameter :: k = selected_int_kind(9)
 end
 
 program p2
   use m1, xx => x, y => z

flang/test/Semantics/resolve49.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Test section subscript
-program p1
+subroutine p1
   real :: a(10,10)
   real :: b(5,5)
   real :: c
   integer :: n
   n = 2
   b = a(1:10:n,1:n+3)
 end
 
 ! Test substring
-program p2
+subroutine p2
   type t1(n1,n2)
     integer,kind :: n1,n2
     integer :: c2(iachar('ABCDEFGHIJ'(n1:n1)))
   end type
   character :: a(10)
   character :: b(5)
   character :: c(0)
   integer :: n
   n = 3
   b = a(n:7)
   b = a(n+3:)
   b = a(:n+2)
   a(n:7) = b
   a(n+3:) = b
   a(:n+2) = b
   n = iachar(1_'ABCDEFGHIJ'(1:1))
   c = 'ABCDEFGHIJ'(1:0)
 end
 
 ! Test pointer assignment with bounds
-program p3
+subroutine p3
   integer, pointer :: a(:,:)
   integer, target :: b(2,2)
   integer :: n
   n = 2
   a(n:,n:) => b
   a(1:n,1:n) => b
 end
 
 ! Test pointer assignment to array element
-program p4
+subroutine p4
   type :: t
     real, pointer :: a
   end type
   type(t) :: x(10)
   integer :: i
   real, target :: y
   x(i)%a => y
-end program
+end subroutine

flang/test/Semantics/resolve61.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
-program p1
+subroutine p1
   integer(8) :: a, b, c, d
   pointer(a, b)
   !ERROR: 'b' cannot be a Cray pointer as it is already a Cray pointee
   pointer(b, c)
   !ERROR: 'a' cannot be a Cray pointee as it is already a Cray pointer
   pointer(d, a)
 end
 
-program p2
+subroutine p2
   pointer(a, c)
   !ERROR: 'c' was already declared as a Cray pointee
   pointer(b, c)
 end
 
-program p3
+subroutine p3
   real a
   !ERROR: Cray pointer 'a' must have type INTEGER(8)
   pointer(a, b)
 end
 
-program p4
+subroutine p4
   implicit none
   real b
   !ERROR: No explicit type declared for 'd'
   pointer(a, b), (c, d)
 end
 
-program p5
+subroutine p5
   integer(8) a(10)
   !ERROR: Cray pointer 'a' must be a scalar
   pointer(a, b)
 end
 
-program p6
+subroutine p6
   real b(8)
   !ERROR: Array spec was already declared for 'b'
   pointer(a, b(4))
 end
 
-program p7
+subroutine p7
   !ERROR: Cray pointee 'b' must have must have explicit shape or assumed size
   pointer(a, b(:))
 contains
   subroutine s(x, y)
     real :: x(*)  ! assumed size
     !ERROR: Cray pointee 'y' must have must have explicit shape or assumed size
     real :: y(:)  ! assumed shape
     pointer(w, y)
   end
 end
 
-program p8
+subroutine p8
   integer(8), parameter :: k = 2
   type t
   end type
   !ERROR: 't' is not a variable
   pointer(t, a)
   !ERROR: 's' is not a variable
   pointer(s, b)
   !ERROR: 'k' is not a variable
   pointer(k, c)
 contains
   subroutine s
   end
 end
 
-program p9
+subroutine p9
   integer(8), parameter :: k = 2
   type t
   end type
   !ERROR: 't' is not a variable
   pointer(a, t)
   !ERROR: 's' is not a variable
   pointer(b, s)
   !ERROR: 'k' is not a variable
   pointer(c, k)
 contains
   subroutine s
   end
 end
 
 module m10
   integer(8) :: a
   real :: b
 end
-program p10
+subroutine p10
   use m10
   !ERROR: 'b' cannot be a Cray pointee as it is use-associated
   pointer(a, c),(d, b)
 end
 
-program p11
+subroutine p11
   pointer(a, b)
   !ERROR: PARAMETER attribute not allowed on 'a'
   parameter(a=2)
   !ERROR: PARAMETER attribute not allowed on 'b'
   parameter(b=3)
 end
 
-program p12
+subroutine p12
   type t1
     sequence
     real c1
   end type
   type t2
     integer c2
   end type
   type(t1) :: x1
   type(t2) :: x2
   pointer(a, x1)
   !ERROR: Type of Cray pointee 'x2' is a non-sequence derived type
   pointer(b, x2)
 end

flang/test/Semantics/symbol16.f90

  !REF: /p1/i
  !DEF: /p1/f/i ObjectEntity INTEGER(4)
  f(i) = i + 1
  !REF: /p1/j
  !REF: /p1/f
  j = f(2)
 end program
 
-!DEF: /p2 MainProgram
-program p2
+!DEF: /p2 (Subroutine)Subprogram
+subroutine p2
  !DEF: /p2/f (Function, StmtFunction) Subprogram REAL(4)
  !DEF: /p2/f/x (Implicit) ObjectEntity REAL(4)
  !DEF: /p2/y (Implicit) ObjectEntity REAL(4)
  f(x) = y
  !REF: /p2/y
  y = 1.0
-end program
+end subroutine