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 @@ -90,6 +90,9 @@ bool InPure() const { return innermostSymbol_ && IsPureProcedure(*innermostSymbol_); } + bool InElemental() const { + return innermostSymbol_ && innermostSymbol_->attrs().test(Attr::ELEMENTAL); + } bool InFunction() const { return innermostSymbol_ && IsFunction(*innermostSymbol_); } @@ -526,6 +529,44 @@ messages_.Say("OPTIONAL attribute may apply only to a dummy " "argument"_err_en_US); // C849 } + if (InElemental()) { + if (details.isDummy()) { // C15100 + if (details.shape().Rank() > 0) { + messages_.Say( + "A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US); + } + if (IsAllocatable(symbol)) { + messages_.Say( + "A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US); + } + if (IsCoarray(symbol)) { + messages_.Say( + "A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US); + } + if (IsPointer(symbol)) { + messages_.Say( + "A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US); + } + if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN, + Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // C15102 + messages_.Say( + "A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US); + } + } else if (IsFunctionResult(symbol)) { // C15101 + if (details.shape().Rank() > 0) { + messages_.Say( + "The result of an ELEMENTAL function must be scalar"_err_en_US); + } + if (IsAllocatable(symbol)) { + messages_.Say( + "The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US); + } + if (IsPointer(symbol)) { + messages_.Say( + "The result of an ELEMENTAL function may not be a POINTER"_err_en_US); + } + } + } if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization CheckPointerInitialization(symbol); if (IsAutomatic(symbol)) { @@ -689,7 +730,10 @@ messages_.Say("A dummy procedure without the POINTER attribute" " may not have an INTENT attribute"_err_en_US); } - + if (InElemental()) { // C15100 + messages_.Say( + "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US); + } const Symbol *interface { details.interface().symbol() }; if (!symbol.attrs().test(Attr::INTRINSIC) && (symbol.attrs().test(Attr::ELEMENTAL) || @@ -845,9 +889,21 @@ } } } - // See comment on the similar check in CheckProcEntity() - if (details.isDummy() && symbol.attrs().test(Attr::ELEMENTAL)) { - messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); + if (symbol.attrs().test(Attr::ELEMENTAL)) { + // See comment on the similar check in CheckProcEntity() + if (details.isDummy()) { + messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); + } else if (details.dummyArgs().empty()) { + messages_.Say( + "An ELEMENTAL subprogram must have at least one dummy argument"_err_en_US); + } else { + for (const Symbol *dummy : details.dummyArgs()) { + if (!dummy) { // C15100 + messages_.Say( + "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US); + } + } + } } } diff --git a/flang/test/Evaluate/folding28.f90 b/flang/test/Evaluate/folding28.f90 --- a/flang/test/Evaluate/folding28.f90 +++ b/flang/test/Evaluate/folding28.f90 @@ -1,5 +1,4 @@ -! RUN: %S/test_folding.sh %s %t %flang_fc1 -! REQUIRES: shell +! RUN: %python %S/test_folding.py %s %flang_fc1 ! Tests folding of SQRT() module m implicit none diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90 --- a/flang/test/Semantics/assign03.f90 +++ b/flang/test/Semantics/assign03.f90 @@ -79,8 +79,9 @@ integer function f_impure() f_impure = 1 end - elemental integer function f_elemental() - f_elemental = 1 + elemental integer function f_elemental(n) + real, value :: n + f_elemental = n end end diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90 --- a/flang/test/Semantics/associated.f90 +++ b/flang/test/Semantics/associated.f90 @@ -27,8 +27,9 @@ pureFunc = 343 end function pureFunc - elemental integer function elementalFunc() - elementalFunc = 343 + elemental integer function elementalFunc(n) + integer, value :: n + elementalFunc = n end function elementalFunc subroutine subr(i) diff --git a/flang/test/Semantics/elemental01.f90 b/flang/test/Semantics/elemental01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/elemental01.f90 @@ -0,0 +1,54 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Tests ELEMENTAL subprogram constraints C15100-15102 + +!ERROR: An ELEMENTAL subprogram must have at least one dummy argument +elemental integer function noargs + noargs = 1 +end function + +!ERROR: An ELEMENTAL subroutine may not have an alternate return dummy argument +elemental subroutine altret(*) +end subroutine + +elemental subroutine arrarg(a) + !ERROR: A dummy argument of an ELEMENTAL procedure must be scalar + real, intent(in) :: a(1) +end subroutine + +elemental subroutine alloarg(a) + !ERROR: A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE + real, intent(in), allocatable :: a +end subroutine + +elemental subroutine coarg(a) + !ERROR: A dummy argument of an ELEMENTAL procedure may not be a coarray + real, intent(in) :: a[*] +end subroutine + +elemental subroutine ptrarg(a) + !ERROR: A dummy argument of an ELEMENTAL procedure may not be a POINTER + real, intent(in), pointer :: a +end subroutine + +impure elemental subroutine barearg(a) + !ERROR: A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute + real :: a +end subroutine + +elemental function arrf(n) + integer, value :: n + !ERROR: The result of an ELEMENTAL function must be scalar + real :: arrf(n) +end function + +elemental function allof(n) + integer, value :: n + !ERROR: The result of an ELEMENTAL function may not be ALLOCATABLE + real, allocatable :: allof +end function + +elemental function ptrf(n) + integer, value :: n + !ERROR: The result of an ELEMENTAL function may not be a POINTER + real, pointer :: ptrf +end function diff --git a/flang/test/Semantics/final02.f90 b/flang/test/Semantics/final02.f90 --- a/flang/test/Semantics/final02.f90 +++ b/flang/test/Semantics/final02.f90 @@ -33,9 +33,9 @@ type(t1) :: x(:) end subroutine impure elemental subroutine t2fe(x) - type(t2) :: x + type(t2), intent(in out) :: x end subroutine - impure elemental subroutine t3far(x) + subroutine t3far(x) type(t3) :: x(..) end subroutine end module diff --git a/flang/test/Semantics/resolve83.f90 b/flang/test/Semantics/resolve83.f90 --- a/flang/test/Semantics/resolve83.f90 +++ b/flang/test/Semantics/resolve83.f90 @@ -28,7 +28,9 @@ end function realFunc !WARNING: Attribute 'ELEMENTAL' cannot be used more than once - elemental real elemental function elementalFunc() + elemental real elemental function elementalFunc(x) + real, value :: x + elementalFunc = x end function elementalFunc !WARNING: Attribute 'IMPURE' cannot be used more than once diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90 --- a/flang/test/Semantics/typeinfo01.f90 +++ b/flang/test/Semantics/typeinfo01.f90 @@ -121,7 +121,7 @@ type(t) :: x(3,3) end subroutine impure elemental subroutine s3(x) - type(t) :: x + type(t), intent(in) :: x end subroutine !CHECK: .dt.t, SAVE, TARGET (CompilerCreated): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=3200_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1) !CHECK: .s.t, SAVE, TARGET (CompilerCreated): ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,proc=s2)]