Index: flang/include/flang/Semantics/type.h =================================================================== --- flang/include/flang/Semantics/type.h +++ flang/include/flang/Semantics/type.h @@ -268,7 +268,6 @@ bool IsForwardReferenced() const; bool HasDefaultInitialization(bool ignoreAllocatable = false) const; bool HasDestruction() const; - bool HasFinalization() const; // The "raw" type parameter list is a simple transcription from the // parameter list in the parse tree, built by calling AddRawParamValue(). Index: flang/lib/Semantics/check-declarations.cpp =================================================================== --- flang/lib/Semantics/check-declarations.cpp +++ flang/lib/Semantics/check-declarations.cpp @@ -518,6 +518,8 @@ } CheckAssumedTypeEntity(symbol, details); WarnMissingFinal(symbol); + const DeclTypeSpec *type{details.type()}; + const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr}; if (!details.coshape().empty()) { bool isDeferredCoshape{details.coshape().CanBeDeferredShape()}; if (IsAllocatable(symbol)) { @@ -539,16 +541,14 @@ symbol.name()); } } - if (const DeclTypeSpec * type{details.type()}) { - if (IsBadCoarrayType(type->AsDerived())) { // C747 & C824 - messages_.Say( - "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US, - symbol.name()); - } + if (IsBadCoarrayType(derived)) { // C747 & C824 + messages_.Say( + "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US, + symbol.name()); } } if (details.isDummy()) { - if (symbol.attrs().test(Attr::INTENT_OUT)) { + if (IsIntentOut(symbol)) { if (FindUltimateComponent(symbol, [](const Symbol &x) { return evaluate::IsCoarray(x) && IsAllocatable(x); })) { // C846 @@ -559,6 +559,22 @@ messages_.Say( "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US); } + if (details.IsAssumedSize()) { // C834 + if (type && type->IsPolymorphic()) { + messages_.Say( + "An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US); + } + if (derived) { + if (derived->HasDefaultInitialization()) { + messages_.Say( + "An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization"_err_en_US); + } + if (IsFinalizable(*derived)) { + messages_.Say( + "An INTENT(OUT) assumed-size dummy argument array may not be finalizable"_err_en_US); + } + } + } } if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) && !IsPointer(symbol) && !IsIntentIn(symbol) && @@ -567,22 +583,20 @@ messages_.Say( "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US); } else if (IsIntentOut(symbol)) { - if (const DeclTypeSpec * type{details.type()}) { - if (type && type->IsPolymorphic()) { // C1588 + if (type && type->IsPolymorphic()) { // C1588 + messages_.Say( + "An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic"_err_en_US); + } else if (derived) { + if (FindUltimateComponent(*derived, [](const Symbol &x) { + const DeclTypeSpec *type{x.GetType()}; + return type && type->IsPolymorphic(); + })) { // C1588 messages_.Say( - "An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic"_err_en_US); - } else if (const DerivedTypeSpec * derived{type->AsDerived()}) { - if (FindUltimateComponent(*derived, [](const Symbol &x) { - const DeclTypeSpec *type{x.GetType()}; - return type && type->IsPolymorphic(); - })) { // C1588 - messages_.Say( - "An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US); - } - if (HasImpureFinal(*derived)) { // C1587 - messages_.Say( - "An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US); - } + "An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US); + } + if (HasImpureFinal(*derived)) { // C1587 + messages_.Say( + "An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US); } } } else if (!IsIntentInOut(symbol)) { // C1586 @@ -661,14 +675,12 @@ "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US); } } - if (const DeclTypeSpec * type{details.type()}) { // C708 - if (type->IsPolymorphic() && - !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) || - IsDummy(symbol))) { - messages_.Say("CLASS entity '%s' must be a dummy argument or have " - "ALLOCATABLE or POINTER attribute"_err_en_US, - symbol.name()); - } + if (type && type->IsPolymorphic() && + !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) || + IsDummy(symbol))) { // C708 + messages_.Say("CLASS entity '%s' must be a dummy argument or have " + "ALLOCATABLE or POINTER attribute"_err_en_US, + symbol.name()); } } Index: flang/test/Semantics/call29.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/call29.f90 @@ -0,0 +1,38 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 + +module m + type t1 + integer, allocatable :: a(:) + end type + type t2 + integer :: n = 123 + end type + type t3 + contains + final :: t3final + end type + type t4 + type(t1) :: c1 + type(t2) :: c2 + type(t3) :: c3 + end type + type t5 + end type + contains + elemental subroutine t3final(x) + type(t3), intent(in) :: x + end subroutine + subroutine test1(x1,x2,x3,x4,x5) + !ERROR: An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization + type(t1), intent(out) :: x1(*) + !ERROR: An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization + type(t2), intent(out) :: x2(*) + !ERROR: An INTENT(OUT) assumed-size dummy argument array may not be finalizable + type(t3), intent(out) :: x3(*) + !ERROR: An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization + !ERROR: An INTENT(OUT) assumed-size dummy argument array may not be finalizable + type(t4), intent(out) :: x4(*) + !ERROR: An INTENT(OUT) assumed-size dummy argument array may not be polymorphic + class(t5), intent(out) :: x5(*) + end subroutine +end module