diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -1711,8 +1711,17 @@ 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); diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -612,6 +612,10 @@ 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 diff --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90 --- a/flang/test/Semantics/call02.f90 +++ b/flang/test/Semantics/call02.f90 @@ -110,7 +110,7 @@ end end -program p04 +subroutine p04 implicit none !ERROR: No explicit type declared for 'index' call s1(index) diff --git a/flang/test/Semantics/case01.f90 b/flang/test/Semantics/case01.f90 --- a/flang/test/Semantics/case01.f90 +++ b/flang/test/Semantics/case01.f90 @@ -164,7 +164,7 @@ end program -program test_overlap +subroutine test_overlap integer :: i !OK: these cases do not overlap select case(i) @@ -178,7 +178,7 @@ end select end -program test_overflow +subroutine test_overflow integer :: j select case(1_1) case (127) diff --git a/flang/test/Semantics/modfile41.f90 b/flang/test/Semantics/modfile41.f90 --- a/flang/test/Semantics/modfile41.f90 +++ b/flang/test/Semantics/modfile41.f90 @@ -34,61 +34,61 @@ !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 diff --git a/flang/test/Semantics/multi-programs01.f90 b/flang/test/Semantics/multi-programs01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/multi-programs01.f90 @@ -0,0 +1,6 @@ +! 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 diff --git a/flang/test/Semantics/multi-programs02.f90 b/flang/test/Semantics/multi-programs02.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/multi-programs02.f90 @@ -0,0 +1,7 @@ +! 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 diff --git a/flang/test/Semantics/multi-programs03.f90 b/flang/test/Semantics/multi-programs03.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/multi-programs03.f90 @@ -0,0 +1,7 @@ +! 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 diff --git a/flang/test/Semantics/multi-programs04.f90 b/flang/test/Semantics/multi-programs04.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/multi-programs04.f90 @@ -0,0 +1,9 @@ +! 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 diff --git a/flang/test/Semantics/multi-programs05.f90 b/flang/test/Semantics/multi-programs05.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/multi-programs05.f90 @@ -0,0 +1,8 @@ +! 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 diff --git a/flang/test/Semantics/multi-programs06.f90 b/flang/test/Semantics/multi-programs06.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/multi-programs06.f90 @@ -0,0 +1,8 @@ +! 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 diff --git a/flang/test/Semantics/omp-do04.f90 b/flang/test/Semantics/omp-do04.f90 --- a/flang/test/Semantics/omp-do04.f90 +++ b/flang/test/Semantics/omp-do04.f90 @@ -4,7 +4,7 @@ ! 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) @@ -16,9 +16,10 @@ 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. @@ -29,9 +30,10 @@ 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() @@ -47,9 +49,10 @@ !$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" @@ -63,7 +66,7 @@ end do !$omp end do -end program omp_do3 +end subroutine omp_do3 module tp !integer i,j @@ -76,7 +79,7 @@ use tp end module usetp -program main +subroutine main use usetp !$omp do !ERROR: Loop iteration variable i is not allowed in THREADPRIVATE. @@ -86,9 +89,9 @@ 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. @@ -98,4 +101,4 @@ end do end do !$omp end do -end program +end subroutine diff --git a/flang/test/Semantics/omp-do11.f90 b/flang/test/Semantics/omp-do11.f90 --- a/flang/test/Semantics/omp-do11.f90 +++ b/flang/test/Semantics/omp-do11.f90 @@ -21,8 +21,8 @@ !$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 @@ -33,4 +33,4 @@ print *, "it", i end do !$omp end do -end program omp_do2 +end subroutine omp_do2 diff --git a/flang/test/Semantics/resolve102.f90 b/flang/test/Semantics/resolve102.f90 --- a/flang/test/Semantics/resolve102.f90 +++ b/flang/test/Semantics/resolve102.f90 @@ -26,7 +26,7 @@ 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 @@ -36,9 +36,9 @@ end subroutine end interface call p(sub) -end program +end subroutine -Program mutual +subroutine mutual Procedure(sub1) :: p Call p(sub) @@ -52,9 +52,9 @@ Subroutine sub(p2) Procedure(sub1) :: p2 End Subroutine -End Program +End subroutine -Program mutual1 +subroutine mutual1 Procedure(sub1) :: p Call p(sub) @@ -68,18 +68,18 @@ 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 @@ -89,7 +89,7 @@ call p1 call p2 call p3 -end program +end subroutine module mutualSpecExprs contains diff --git a/flang/test/Semantics/resolve14.f90 b/flang/test/Semantics/resolve14.f90 --- a/flang/test/Semantics/resolve14.f90 +++ b/flang/test/Semantics/resolve14.f90 @@ -12,7 +12,7 @@ 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 diff --git a/flang/test/Semantics/resolve49.f90 b/flang/test/Semantics/resolve49.f90 --- a/flang/test/Semantics/resolve49.f90 +++ b/flang/test/Semantics/resolve49.f90 @@ -1,6 +1,6 @@ ! 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 @@ -10,7 +10,7 @@ end ! Test substring -program p2 +subroutine p2 type t1(n1,n2) integer,kind :: n1,n2 integer :: c2(iachar('ABCDEFGHIJ'(n1:n1))) @@ -31,7 +31,7 @@ end ! Test pointer assignment with bounds -program p3 +subroutine p3 integer, pointer :: a(:,:) integer, target :: b(2,2) integer :: n @@ -41,7 +41,7 @@ end ! Test pointer assignment to array element -program p4 +subroutine p4 type :: t real, pointer :: a end type @@ -49,4 +49,4 @@ integer :: i real, target :: y x(i)%a => y -end program +end subroutine diff --git a/flang/test/Semantics/resolve61.f90 b/flang/test/Semantics/resolve61.f90 --- a/flang/test/Semantics/resolve61.f90 +++ b/flang/test/Semantics/resolve61.f90 @@ -1,5 +1,5 @@ ! 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 @@ -8,38 +8,38 @@ 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 @@ -51,7 +51,7 @@ end end -program p8 +subroutine p8 integer(8), parameter :: k = 2 type t end type @@ -66,7 +66,7 @@ end end -program p9 +subroutine p9 integer(8), parameter :: k = 2 type t end type @@ -85,13 +85,13 @@ 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) @@ -99,7 +99,7 @@ parameter(b=3) end -program p12 +subroutine p12 type t1 sequence real c1 diff --git a/flang/test/Semantics/symbol16.f90 b/flang/test/Semantics/symbol16.f90 --- a/flang/test/Semantics/symbol16.f90 +++ b/flang/test/Semantics/symbol16.f90 @@ -16,12 +16,12 @@ 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