[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

7216

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

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

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

Thanks for the explanation. Fixed.

1721

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

flang/lib/Semantics/check-declarations.cpp

if (scope.IsParameterizedDerivedTypeInstantiation()) {
     auto restorer{common::ScopedSet(
         scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
     for (const auto &set : scope.equivalenceSets()) {
       CheckEquivalenceSet(set);
     }
     for (const auto &pair : scope) {
       Check(*pair.second);
     }
+    int mainProgCnt{0};
     for (const Scope &child : scope.children()) {
       Check(child);
+      // A program shall consist of exactly one main program (5.2.2).
+      if (child.kind() == Scope::Kind::MainProgram) {
+        ++mainProgCnt;
+        if (mainProgCnt > 1) {
+          messages_.Say(child.sourceRange(),
+              "A source file cannot contain more than one main program"_err_en_US);
+        }
+      }
     }
     if (scope.kind() == Scope::Kind::BlockData) {
       CheckBlockData(scope);
     }
     CheckGenericOps(scope);
   }
 }
 

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;
     }
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::ProgramUnit &x) {
   if (std::holds_alternative<common::Indirection<parser::CompilerDirective>>(
           x.u)) {
     // TODO: global directives
     return true;
   }
   auto root{ProgramTree::Build(x)};
   SetScope(topScope_);
   ResolveSpecificationParts(root);

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 source file 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 source file 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
+!ERROR: A source file cannot contain more than one main program
+program m
+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: A source file cannot contain more than one main program
+!ERROR: 'm' is already declared in this scoping unit
+program m
+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
+!ERROR: A source file cannot contain more than one main program
+program m2
+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 source file cannot contain more than one main program
+end
+!ERROR: A source file 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