diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -169,6 +169,9 @@ Result operator()(const semantics::Symbol &symbol) const { if (semantics::IsNamedConstant(symbol)) { return std::nullopt; + } else if (scope_.IsDerivedType() && IsVariableName(symbol)) { // C750 + return "reference to variable '"s + symbol.name().ToString() + + "' not allowed for derived type components"; } else if (symbol.IsDummy()) { if (symbol.attrs().test(semantics::Attr::OPTIONAL)) { return "reference to OPTIONAL dummy argument '"s + @@ -219,10 +222,35 @@ return "reference to impure function '"s + symbol->name().ToString() + "'"; } + if (semantics::IsStmtFunction(*symbol)) { + return "reference to statement function '"s + + symbol->name().ToString() + "'"; + } + if (scope_.IsDerivedType()) { // C750 + return "reference to function '"s + symbol->name().ToString() + + "' not allowed for derived type components"; + } // TODO: other checks for standard module procedures } else { const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; - if (intrin.name == "present") { + if (scope_.IsDerivedType()) { // C750 + const std::string badIntrinsicsForComponents{ + "allocated associated extends_type_of present same_type_as"}; + if (badIntrinsicsForComponents.find(intrin.name) != std::string::npos) { + return "reference to intrinsic '"s + intrin.name + + "' not allowed for derived type components"; + } + const std::string inquiryIntrinsics{ + "allocated associated bit_size coshape digits epsilon " + "extends_type_of huge is_contiguous kind lbound lcobound len " + "maxexponent minexponent new_line precision present radix range " + "rank same_type_as shape size storage_size tiny ubound ucobound"}; + if (inquiryIntrinsics.find(intrin.name) != std::string::npos && + !IsConstantExpr(x)) { + return "non-constant reference to inquiry intrinsic '"s + + intrin.name + "' not allowed for derived type components"; + } + } else if (intrin.name == "present") { return std::nullopt; // no need to check argument(s) } if (IsConstantExpr(x)) { 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 @@ -384,15 +384,25 @@ CheckAssumedTypeEntity(symbol, details); symbolBeingChecked_ = nullptr; if (!details.coshape().empty()) { + bool isDeferredShape{details.coshape().IsDeferredShape()}; if (IsAllocatable(symbol)) { - if (!details.coshape().IsDeferredShape()) { // C827 - messages_.Say( - "ALLOCATABLE coarray must have a deferred coshape"_err_en_US); + if (!isDeferredShape) { // C827 + messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred" + " coshape"_err_en_US, + symbol.name()); } + } else if (symbol.owner().IsDerivedType()) { // C746 + std::string deferredMsg{ + isDeferredShape ? "" : " and have a deferred coshape"}; + messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE" + " attribute%s"_err_en_US, + symbol.name(), deferredMsg); } else { if (!details.coshape().IsAssumedSize()) { // C828 messages_.Say( - "Non-ALLOCATABLE coarray must have an explicit coshape"_err_en_US); + "Component '%s' is a non-ALLOCATABLE coarray and must have" + " an explicit coshape"_err_en_US, + symbol.name()); } } } @@ -409,7 +419,8 @@ "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US); } } - if (InPure() && !IsPointer(symbol) && !IsIntentIn(symbol) && + if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) && + !IsPointer(symbol) && !IsIntentIn(symbol) && !symbol.attrs().test(Attr::VALUE)) { if (InFunction()) { // C1583 messages_.Say( diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2084,13 +2084,14 @@ } semantics::CheckArguments(*chars, arguments, GetFoldingContext(), context_.FindScope(callSite), treatExternalAsImplicit); - if (!chars->attrs.test(characteristics::Procedure::Attr::Pure)) { + const Symbol *procSymbol{proc.GetSymbol()}; + if (procSymbol && !IsPureProcedure(*procSymbol)) { if (const semantics::Scope * pure{semantics::FindPureProcedureContaining( context_.FindScope(callSite))}) { Say(callSite, "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US, - DEREF(proc.GetSymbol()).name(), DEREF(pure->symbol()).name()); + procSymbol->name(), DEREF(pure->symbol()).name()); } } } 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 @@ -3679,7 +3679,7 @@ if (symbol->has() && !paramNames.count(name)) { SayDerivedType(name, "'%s' is not a type parameter of this derived type"_err_en_US, - currScope()); // C742 + currScope()); // C741 } } Walk(std::get>>(x.t)); @@ -3820,14 +3820,46 @@ !attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) { attrs.set(Attr::PRIVATE); } - if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { - if (const auto *declType{GetDeclTypeSpec()}) { - if (const auto *derived{declType->AsDerived()}) { + if (const auto *declType{GetDeclTypeSpec()}) { + if (const auto *derived{declType->AsDerived()}) { + if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C744 Say("Recursive use of the derived type requires " "POINTER or ALLOCATABLE"_err_en_US); } } + if (!coarraySpec().empty()) { // C747 + if (IsTeamType(derived)) { + Say("A coarray component may not be of type TEAM_TYPE from " + "ISO_FORTRAN_ENV"_err_en_US); + } else { + if (IsIsoCType(derived)) { + Say("A coarray component may not be of type C_PTR or C_FUNPTR from " + "ISO_C_BINDING when an allocatable object is a " + "coarray"_err_en_US); + } + } + } + if (auto it{FindCoarrayUltimateComponent(*derived)}) { // C748 + std::string ultimateName{it.BuildResultDesignatorName()}; + if (attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { + evaluate::AttachDeclaration( + Say(name.source, + "A component with a POINTER or ALLOCATABLE attribute may not " + "be of a type with a coarray ultimate component (named " + "'%s')"_err_en_US, + ultimateName), + derived->typeSymbol()); + } + if (!arraySpec().empty() || !coarraySpec().empty()) { + evaluate::AttachDeclaration( + Say(name.source, + "An array or coarray component may not be of a type with a " + "coarray ultimate component (named '%s')"_err_en_US, + ultimateName), + derived->typeSymbol()); + } + } } } if (OkToAddComponent(name)) { @@ -4741,7 +4773,7 @@ const SourceName &name, Details &&details) { Scope &derivedType{currScope()}; CHECK(derivedType.IsDerivedType()); - if (auto *symbol{FindInScope(derivedType, name)}) { + if (auto *symbol{FindInScope(derivedType, name)}) { // C742 Say2(name, "Type parameter, component, or procedure binding '%s'" " already defined in this type"_err_en_US, diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -270,6 +270,27 @@ } else if (!IsProcedure(symbol)) { return false; } + if (IsStmtFunction(symbol)) { + // Section 15.7(1) states that a statement function is PURE if it does not + // reference an IMPURE procedure or a VOLATILE variable + const SubprogramDetails *funcDetails{symbol.detailsIf()}; + if (funcDetails) { + const MaybeExpr &expr{funcDetails->stmtFunction()}; + if (expr) { + for (const Symbol &refSymbol : evaluate::CollectSymbols(*expr)) { + if (IsFunction(refSymbol) && !IsPureProcedure(refSymbol)) { + return false; + } + if (const Symbol * root{GetAssociationRoot(refSymbol)}) { + if (root->attrs().test(Attr::VOLATILE)) { + return false; + } + } + } + } + } + return true; // statement function was not found to be impure + } return symbol.attrs().test(Attr::PURE) || (symbol.attrs().test(Attr::ELEMENTAL) && !symbol.attrs().test(Attr::IMPURE)); diff --git a/flang/test/Semantics/allocate11.f90 b/flang/test/Semantics/allocate11.f90 --- a/flang/test/Semantics/allocate11.f90 +++ b/flang/test/Semantics/allocate11.f90 @@ -5,19 +5,6 @@ ! Rules I should know when working with coarrays and derived type: -! C736: If EXTENDS appears and the type being defined has a coarray ultimate -! component, its parent type shall have a coarray ultimate component. - -! C746: (R737) If a coarray-spec appears, it shall be a deferred-coshape-spec-list -! and the component shall have the ALLOCATABLE attribute. - -! C747: If a coarray-spec appears, the component shall not be of type C_PTR or -! C_FUNPTR from the intrinsic module ISO_C_BINDING (18.2), or of type TEAM_TYPE from the -! intrinsic module ISO_FORTRAN_ENV (16.10.2). - -! C748: A data component whose type has a coarray ultimate component shall be a -! nonpointer nonallocatable scalar and shall not be a coarray. - ! 7.5.4.3 Coarray components ! 7.5.6 Final subroutines: C786 @@ -38,7 +25,6 @@ type B type(A) y - type(B), pointer :: forward real :: u end type @@ -47,7 +33,7 @@ end type type D - type(A), pointer :: potential + type(A) :: potential end type @@ -66,9 +52,6 @@ ! Also, as per C826 or C852, var can only be an allocatable, not a pointer - ! OK, x is not an ultimate component - allocate(D:: var) - !ERROR: Type-spec in ALLOCATE must not specify a type with a coarray ultimate component allocate(A:: var) !ERROR: Type-spec in ALLOCATE must not specify a type with a coarray ultimate component diff --git a/flang/test/Semantics/call10.f90 b/flang/test/Semantics/call10.f90 --- a/flang/test/Semantics/call10.f90 +++ b/flang/test/Semantics/call10.f90 @@ -136,6 +136,12 @@ !ERROR: Procedure 'notpure' referenced in pure subprogram 's10' must be pure too n = notpure(1) end subroutine + pure subroutine s10a + integer :: iVar + iStmtFunc(iArg) = iArg + 3 + !OK, since a statement function is pure by default + iVar = iStmtFunc(4) + end subroutine pure subroutine s11(to) ! C1596 ! Implicit deallocation at the end of the subroutine !ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a pure subprogram diff --git a/flang/test/Semantics/call12.f90 b/flang/test/Semantics/call12.f90 --- a/flang/test/Semantics/call12.f90 +++ b/flang/test/Semantics/call12.f90 @@ -15,7 +15,7 @@ real, pointer :: p end type type :: hasCoarray - real :: co[*] + real, allocatable :: co[:] end type contains pure function test(ptr, in, hpd) diff --git a/flang/test/Semantics/call14.f90 b/flang/test/Semantics/call14.f90 --- a/flang/test/Semantics/call14.f90 +++ b/flang/test/Semantics/call14.f90 @@ -3,7 +3,7 @@ module m type :: hasCoarray - real :: coarray[*] + real, allocatable :: coarray[:] end type contains !ERROR: VALUE attribute may apply only to a dummy data object diff --git a/flang/test/Semantics/misc-declarations.f90 b/flang/test/Semantics/misc-declarations.f90 --- a/flang/test/Semantics/misc-declarations.f90 +++ b/flang/test/Semantics/misc-declarations.f90 @@ -4,12 +4,12 @@ ! - 8.5.19 constraints on the VOLATILE attribute module m - !ERROR: ALLOCATABLE coarray must have a deferred coshape + !ERROR: 'mustbedeferred' is an ALLOCATABLE coarray and must have a deferred coshape real, allocatable :: mustBeDeferred[*] ! C827 - !ERROR: Non-ALLOCATABLE coarray must have an explicit coshape + !ERROR: Component 'mustbeexplicit' is a non-ALLOCATABLE coarray and must have an explicit coshape real :: mustBeExplicit[:] ! C828 type :: hasCoarray - real :: coarray[*] + real, allocatable :: coarray[:] end type real :: coarray[*] type(hasCoarray) :: coarrayComponent diff --git a/flang/test/Semantics/modfile24.f90 b/flang/test/Semantics/modfile24.f90 --- a/flang/test/Semantics/modfile24.f90 +++ b/flang/test/Semantics/modfile24.f90 @@ -36,8 +36,8 @@ ! coarray-spec in components and with non-constants bounds module m3 type t - real :: c[1:10,1:*] - complex, codimension[5,*] :: d + real, allocatable :: c[:,:] + complex, allocatable, codimension[:,:] :: d end type real, allocatable :: e[:,:,:] contains @@ -50,8 +50,8 @@ !Expect: m3.mod !module m3 ! type::t -! real(4)::c[1_8:10_8,1_8:*] -! complex(4)::d[1_8:5_8,1_8:*] +! real(4),allocatable::c[:,:] +! complex(4),allocatable::d[:,:] ! end type ! real(4),allocatable::e[:,:,:] !contains diff --git a/flang/test/Semantics/resolve33.f90 b/flang/test/Semantics/resolve33.f90 --- a/flang/test/Semantics/resolve33.f90 +++ b/flang/test/Semantics/resolve33.f90 @@ -2,6 +2,12 @@ ! Derived type parameters ! C731 The same type-param-name shall not appear more than once in a given ! derived-type-stmt. +! C741 A type-param-name in a type-param-def-stmt in a derived-type-def shall +! be one of the type-paramnames in the derived-type-stmt of that +! derived-type-def. +! C742 Each type-param-name in the derived-type-stmt in a derived-type-def +! shall appear exactly once as a type-param-name in a type-param-def-stmt +! in that derived-type-def. module m !ERROR: Duplicate type parameter name: 'a' diff --git a/flang/test/Semantics/resolve44.f90 b/flang/test/Semantics/resolve44.f90 --- a/flang/test/Semantics/resolve44.f90 +++ b/flang/test/Semantics/resolve44.f90 @@ -1,5 +1,8 @@ ! RUN: %B/test/Semantics/test_errors.sh %s %flang %t ! Error tests for recursive use of derived types. +! C744 If neither the POINTER nor the ALLOCATABLE attribute is specified, the +! declaration-type-spec in the component-def-stmt shall specify an intrinsic +! type or a previously defined derived type. program main type :: recursive1 diff --git a/flang/test/Semantics/resolve88.f90 b/flang/test/Semantics/resolve88.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve88.f90 @@ -0,0 +1,75 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +! C746, C747, and C748 +module m + use ISO_FORTRAN_ENV + use ISO_C_BINDING + + ! C746 If a coarray-spec appears, it shall be a deferred-coshape-spec-list and + ! the component shall have the ALLOCATABLE attribute. + + type testCoArrayType + real, allocatable, codimension[:] :: allocatableField + !ERROR: Component 'deferredfield' is a coarray and must have the ALLOCATABLE attribute + real, codimension[:] :: deferredField + !ERROR: 'pointerfield' may not have the POINTER attribute because it is a coarray + !ERROR: Component 'pointerfield' is a coarray and must have the ALLOCATABLE attribute + real, pointer, codimension[:] :: pointerField + !ERROR: Component 'realfield' is a coarray and must have the ALLOCATABLE attribute and have a deferred coshape + real, codimension[*] :: realField + !ERROR: 'realfield2' is an ALLOCATABLE coarray and must have a deferred coshape + real, allocatable, codimension[*] :: realField2 + end type testCoArrayType + + ! C747 If a coarray-spec appears, the component shall not be of type C_PTR or + ! C_FUNPTR from the intrinsic module ISO_C_BINDING (18.2), or of type + ! TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV (16.10.2). + + type goodCoarrayType + real, allocatable, codimension[:] :: field + end type goodCoarrayType + + type goodTeam_typeCoarrayType + type(team_type), allocatable :: field + end type goodTeam_typeCoarrayType + + type goodC_ptrCoarrayType + type(c_ptr), allocatable :: field + end type goodC_ptrCoarrayType + + type goodC_funptrCoarrayType + type(c_funptr), allocatable :: field + end type goodC_funptrCoarrayType + + type team_typeCoarrayType + !ERROR: A coarray component may not be of type TEAM_TYPE from ISO_FORTRAN_ENV + type(team_type), allocatable, codimension[:] :: field + end type team_typeCoarrayType + + type c_ptrCoarrayType + !ERROR: A coarray component may not be of type C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray + type(c_ptr), allocatable, codimension[:] :: field + end type c_ptrCoarrayType + + type c_funptrCoarrayType + !ERROR: A coarray component may not be of type C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray + type(c_funptr), allocatable, codimension[:] :: field + end type c_funptrCoarrayType + +! C748 A data component whose type has a coarray ultimate component shall be a +! nonpointer nonallocatable scalar and shall not be a coarray. + + type coarrayType + real, allocatable, codimension[:] :: goodCoarrayField + end type coarrayType + + type testType + type(coarrayType) :: goodField + !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named '%goodcoarrayfield') + type(coarrayType), pointer :: pointerField + !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named '%goodcoarrayfield') + type(coarrayType), allocatable :: allocatableField + !ERROR: An array or coarray component may not be of a type with a coarray ultimate component (named '%goodcoarrayfield') + type(coarrayType), dimension(3) :: arrayField + end type testType + +end module m diff --git a/flang/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve89.f90 @@ -0,0 +1,83 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +! C750 Each bound in the explicit-shape-spec shall be a specification +! expression in which there are no references to specification functions or +! the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_- TYPE_OF, PRESENT, +! or SAME_TYPE_AS, every specification inquiry reference is a constant +! expression, and the value does not depend on the value of a variable. +impure function impureFunc() + integer :: impureFunc + + impureFunc = 3 +end function impureFunc + +pure function pureFunc() + integer :: pureFunc + + pureFunc = 3 +end function pureFunc + +module m + real, allocatable :: mVar +end module m + +subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg) + use m + implicit logical(l) + integer, intent(in) :: iArg + real, allocatable, intent(in) :: allocArg + real, pointer, intent(in) :: pointerArg + integer, dimension(:), intent(in) :: arrayArg + integer, intent(inout) :: ioArg + real, optional, intent(in) :: optionalArg + + ! These declarations are OK since they're not in a derived type + real :: realVar + real, volatile :: volatileVar + real, dimension(merge(1, 2, allocated(allocArg))) :: realVar1 + real, dimension(merge(1, 2, associated(pointerArg))) :: realVar2 + real, dimension(merge(1, 2, is_contiguous(arrayArg))) :: realVar3 + real, dimension(ioArg) :: realVar4 + real, dimension(merge(1, 2, present(optionalArg))) :: realVar5 + + ! statement functions referenced below + iVolatileStmtFunc() = 3 * volatileVar + iImpureStmtFunc() = 3 * impureFunc() + iPureStmtFunc() = 3 * pureFunc() + + ! This is OK + real, dimension(merge(1, 2, allocated(mVar))) :: rVar + + + integer :: var = 3 + !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc' + real, dimension(iVolatileStmtFunc()) :: arrayVarWithVolatile + !ERROR: Invalid specification expression: reference to impure function 'iimpurestmtfunc' + real, dimension(iImpureStmtFunc()) :: arrayVarWithImpureFunction + !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc' + real, dimension(iPureStmtFunc()) :: arrayVarWithPureFunction + real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic + + type arrayType + !ERROR: Invalid specification expression: reference to variable 'var' not allowed for derived type components + real, dimension(var) :: varField + !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc' + real, dimension(iVolatileStmtFunc()) :: arrayFieldWithVolatile + !ERROR: Invalid specification expression: reference to impure function 'iimpurestmtfunc' + real, dimension(iImpureStmtFunc()) :: arrayFieldWithImpureFunction + !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc' + real, dimension(iPureStmtFunc()) :: arrayFieldWithPureFunction + !ERROR: Invalid specification expression: reference to variable 'iarg' not allowed for derived type components + real, dimension(iabs(iArg)) :: arrayFieldWithIntrinsic + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + real, dimension(merge(1, 2, allocated(allocArg))) :: realField1 + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + real, dimension(merge(1, 2, associated(pointerArg))) :: realField2 + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components + real, dimension(merge(1, 2, is_contiguous(arrayArg))) :: realField3 + !ERROR: Invalid specification expression: reference to variable 'ioarg' not allowed for derived type components + real, dimension(ioArg) :: realField4 + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + real, dimension(merge(1, 2, present(optionalArg))) :: realField5 + end type arrayType + +end subroutine s