From 657aaf8b8d6c0df6156025bb1db73280cf3d7870 Mon Sep 17 00:00:00 2001 From: Pete Steinfeld Date: Wed, 26 Feb 2020 20:19:48 -0800 Subject: [PATCH] [flang] Semantic checks for C712 through C727 I've updated the compiler and test source with references to the contraints at the points where they were enforced and tested. Many of these were already implemented and required no code change. A few constraint checks were both implemented and tested, and I only added references to the constraint numbers in the compiler source and tests. Here are the things I had to implement: Constraint C716 states that, in a REAL constant, if both a kind-param and an exponent letter appear, the exponent letter must be 'E'. Constraints C715 and C719 require that a KIND value be actually implemented. Constraint C722 requires that functions that return assumed-length character types are external. Constraint C726 disallows assumed lenght charater types for dummy arguments and return types. Original-commit: flang-compiler/f18@45998741e5f04bba7db6eed6a4d27c1d25209b41 Reviewed-on: https://github.com/flang-compiler/f18/pull/1031 Tree-same-pre-rewrite: false --- flang/include/flang/Semantics/expression.h | 2 +- flang/include/flang/Semantics/tools.h | 8 +++-- flang/lib/Evaluate/tools.cpp | 2 +- flang/lib/Semantics/check-declarations.cpp | 27 +++++++++------ flang/lib/Semantics/expression.cpp | 27 +++++++-------- flang/lib/Semantics/resolve-names.cpp | 8 +++++ flang/lib/Semantics/tools.cpp | 35 ++++++++++++++++--- flang/test/Semantics/CMakeLists.txt | 5 +++ flang/test/Semantics/call05.f90 | 4 +-- flang/test/Semantics/complex01.f90 | 32 +++++++++++++++++ flang/test/Semantics/kinds02.f90 | 27 +++++++++++++++ flang/test/Semantics/kinds04.f90 | 31 +++++++++++++++++ flang/test/Semantics/resolve35.f90 | 1 + flang/test/Semantics/resolve37.f90 | 1 + flang/test/Semantics/resolve41.f90 | 1 + flang/test/Semantics/resolve73.f90 | 40 ++++++++++++++++++++++ flang/test/Semantics/resolve74.f90 | 37 ++++++++++++++++++++ flang/test/Semantics/resolve75.f90 | 13 +++++++ 18 files changed, 265 insertions(+), 36 deletions(-) create mode 100644 flang/test/Semantics/complex01.f90 create mode 100644 flang/test/Semantics/kinds04.f90 create mode 100644 flang/test/Semantics/resolve73.f90 create mode 100644 flang/test/Semantics/resolve74.f90 create mode 100644 flang/test/Semantics/resolve75.f90 diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h index 2e135b0885d0..7282a96f1095 100644 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -186,7 +186,7 @@ public: auto result{Analyze(x.thing)}; if (result) { *result = Fold(std::move(*result)); - if (!IsConstantExpr(*result)) { //C886,C887 + if (!IsConstantExpr(*result)) { // C886, C887, C713 SayAt(x, "Must be a constant value"_err_en_US); ResetExpr(x); return std::nullopt; diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index 69ca0e35dfe9..f73958472fdf 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -48,7 +48,7 @@ const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &); const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &); const DeclTypeSpec *FindParentTypeSpec(const Scope &); const DeclTypeSpec *FindParentTypeSpec(const Symbol &); - + // Return the Symbol of the variable of a construct association, if it exists const Symbol *GetAssociationRoot(const Symbol &); @@ -78,6 +78,10 @@ bool DoesScopeContain(const Scope *, const Symbol &); bool IsUseAssociated(const Symbol &, const Scope &); bool IsHostAssociated(const Symbol &, const Scope &); bool IsDummy(const Symbol &); +bool IsStmtFunction(const Symbol &); +bool IsInStmtFunction(const Symbol &); +bool IsStmtFunctionDummy(const Symbol &); +bool IsStmtFunctionResult(const Symbol &); bool IsPointerDummy(const Symbol &); bool IsFunction(const Symbol &); bool IsPureProcedure(const Symbol &); @@ -154,7 +158,7 @@ inline bool IsAssumedSizeArray(const Symbol &symbol) { return details && details->IsAssumedSize(); } bool IsAssumedLengthCharacter(const Symbol &); -bool IsAssumedLengthCharacterFunction(const Symbol &); +bool IsAssumedLengthExternalCharacterFunction(const Symbol &); // Is the symbol modifiable in this scope std::optional WhyNotModifiable( const Symbol &, const Scope &); diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index cfa675c1bf81..624fb352a59e 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -101,7 +101,7 @@ ConvertRealOperandsResult ConvertRealOperands( return {AsSameKindExprs( ConvertTo(ry, std::move(bx)), std::move(ry))}; }, - [&](auto &&, auto &&) -> ConvertRealOperandsResult { + [&](auto &&, auto &&) -> ConvertRealOperandsResult { // C718 messages.Say("operands must be INTEGER or REAL"_err_en_US); return std::nullopt; }, diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 4e463319accc..1b7dd988e5b1 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -105,9 +105,11 @@ private: void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) { if (value.isAssumed()) { - if (!canBeAssumed) { // C795 + if (!canBeAssumed) { // C795, C721, C726 messages_.Say( - "An assumed (*) type parameter may be used only for a dummy argument, associate name, or named constant"_err_en_US); + "An assumed (*) type parameter may be used only for a (non-statement" + " function) dummy argument, associate name, named constant, or" + " external function result"_err_en_US); } } else { CheckSpecExpr(value.GetExplicit()); @@ -186,16 +188,19 @@ void CheckHelper::Check(const Symbol &symbol) { } } } - if (type) { + if (type) { // Section 7.2, paragraph 7 bool canHaveAssumedParameter{IsNamedConstant(symbol) || - IsAssumedLengthCharacterFunction(symbol) || + IsAssumedLengthExternalCharacterFunction(symbol) || // C722 symbol.test(Symbol::Flag::ParentComp)}; - if (const auto *object{symbol.detailsIf()}) { - canHaveAssumedParameter |= object->isDummy() || - (object->isFuncResult() && - type->category() == DeclTypeSpec::Character); - } else { - canHaveAssumedParameter |= symbol.has(); + if (!IsStmtFunctionDummy(symbol)) { // C726 + if (const auto *object{symbol.detailsIf()}) { + canHaveAssumedParameter |= object->isDummy() || + (object->isFuncResult() && + type->category() == DeclTypeSpec::Character) || + IsStmtFunctionResult(symbol); // Avoids multiple messages + } else { + canHaveAssumedParameter |= symbol.has(); + } } Check(*type, canHaveAssumedParameter); if (InPure() && InFunction() && IsFunctionResult(symbol)) { @@ -216,7 +221,7 @@ void CheckHelper::Check(const Symbol &symbol) { } } } - if (IsAssumedLengthCharacterFunction(symbol)) { // C723 + if (IsAssumedLengthExternalCharacterFunction(symbol)) { // C723 if (symbol.attrs().test(Attr::RECURSIVE)) { messages_.Say( "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US); diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index a41e754d5ade..5c1a040d1074 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -500,10 +500,10 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) { // Use a local message context around the real literal for better // provenance on any messages. auto restorer{GetContextualMessages().SetLocation(x.real.source)}; - // If a kind parameter appears, it defines the kind of the literal and any - // letter used in an exponent part (e.g., the 'E' in "6.02214E+23") - // should agree. In the absence of an explicit kind parameter, any exponent - // letter determines the kind. Otherwise, defaults apply. + // If a kind parameter appears, it defines the kind of the literal and the + // letter used in an exponent part must be 'E' (e.g., the 'E' in + // "6.02214E+23"). In the absence of an explicit kind parameter, any + // exponent letter determines the kind. Otherwise, defaults apply. auto &defaults{context_.defaultKinds()}; int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)}; const char *end{x.real.source.end()}; @@ -525,14 +525,13 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) { defaultKind = *letterKind; } auto kind{AnalyzeKindParam(x.kind, defaultKind)}; - if (letterKind && kind != *letterKind && expoLetter != 'e') { - Say("Explicit kind parameter on real constant disagrees with " - "exponent letter '%c'"_en_US, - expoLetter); + if (x.kind && letterKind && expoLetter != 'e') { // C716 + Say("Explicit kind parameter on REAL constant can only be used with" + " exponent letter 'E'"_err_en_US); } auto result{common::SearchTypes( RealTypeVisitor{kind, x.real.source, GetFoldingContext()})}; - if (!result) { + if (!result) { // C717 Say("Unsupported REAL(KIND=%d)"_err_en_US, kind); } return AsMaybeExpr(std::move(result)); @@ -704,7 +703,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::NamedConstant &n) { if (IsConstantExpr(folded)) { return {folded}; } - Say(n.v.source, "must be a constant"_err_en_US); + Say(n.v.source, "must be a constant"_err_en_US); // C718 } return std::nullopt; } @@ -1820,8 +1819,8 @@ void ExpressionAnalyzer::CheckForBadRecursion( if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3) msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US, callSite); - } else if (IsAssumedLengthCharacterFunction(proc)) { // 15.6.2.1(3) - msg = Say( + } else if (IsAssumedLengthExternalCharacterFunction(proc)) { + msg = Say( // 15.6.2.1(3) "Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US, callSite); } @@ -2422,7 +2421,7 @@ DynamicType ExpressionAnalyzer::GetDefaultKindOfType( bool ExpressionAnalyzer::CheckIntrinsicKind( TypeCategory category, std::int64_t kind) { - if (IsValidKindOfIntrinsicType(category, kind)) { + if (IsValidKindOfIntrinsicType(category, kind)) { // C712, C714, C715 return true; } else { Say("%s(KIND=%jd) is not a supported type"_err_en_US, @@ -2471,7 +2470,7 @@ bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at, const MaybeExpr &result, TypeCategory category, bool defaultKind) { if (result) { if (auto type{result->GetType()}) { - if (type->category() != category) { // C885 + if (type->category() != category) { // C885 Say(at, "Must have %s type, but is %s"_err_en_US, ToUpperCase(EnumToString(category)), ToUpperCase(type->AsFortran())); diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 7d6fa5d644da..670cec7ed970 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -2602,6 +2602,7 @@ bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) { if (resultType) { resultDetails.set_type(*resultType); } + resultDetails.set_funcResult(true); Symbol &result{MakeSymbol(name, std::move(resultDetails))}; ApplyImplicitRules(result); details.set_result(result); @@ -3271,6 +3272,13 @@ void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &) { } void DeclarationVisitor::Post(const parser::CharSelector::LengthAndKind &x) { charInfo_.kind = EvaluateSubscriptIntExpr(x.kind); + std::optional intKind{ToInt64(charInfo_.kind)}; + if (intKind && + !evaluate::IsValidKindOfIntrinsicType( + TypeCategory::Character, *intKind)) { // C715, C719 + Say(currStmtSource().value(), + "KIND value (%jd) not valid for CHARACTER"_err_en_US, *intKind); + } if (x.length) { charInfo_.length = GetParamValue(*x.length, common::TypeParamAttr::Len); } diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index b4a2a281ee7d..d5fc39c987b6 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -196,6 +196,29 @@ bool IsDummy(const Symbol &symbol) { } } +bool IsStmtFunction(const Symbol &symbol) { + const auto *subprogram{symbol.detailsIf()}; + if (subprogram && subprogram->stmtFunction()) { + return true; + } + return false; +} + +bool IsInStmtFunction(const Symbol &symbol) { + if (const Symbol * function{symbol.owner().symbol()}) { + return IsStmtFunction(*function); + } + return false; +} + +bool IsStmtFunctionDummy(const Symbol &symbol) { + return IsDummy(symbol) && IsInStmtFunction(symbol); +} + +bool IsStmtFunctionResult(const Symbol &symbol) { + return IsFunctionResult(symbol) && IsInStmtFunction(symbol); +} + bool IsPointerDummy(const Symbol &symbol) { return IsPointer(symbol) && IsDummy(symbol); } @@ -686,11 +709,13 @@ bool IsAssumedLengthCharacter(const Symbol &symbol) { } } -bool IsAssumedLengthCharacterFunction(const Symbol &symbol) { - // Assumed-length character functions only appear as such in their - // definitions; their interfaces, pointers to them, and dummy procedures - // cannot be assumed-length. - return symbol.has() && IsAssumedLengthCharacter(symbol); +// C722 and C723: For a function to be assumed length, it must be external and +// of CHARACTER type +bool IsAssumedLengthExternalCharacterFunction(const Symbol &symbol) { + return IsAssumedLengthCharacter(symbol) && + ((symbol.has() && symbol.owner().IsGlobal()) || + (symbol.test(Symbol::Flag::Function) && + symbol.attrs().test(Attr::EXTERNAL))); } const Symbol *IsExternalInPureContext( diff --git a/flang/test/Semantics/CMakeLists.txt b/flang/test/Semantics/CMakeLists.txt index ac3e9f641c0c..51cc8e4850ff 100644 --- a/flang/test/Semantics/CMakeLists.txt +++ b/flang/test/Semantics/CMakeLists.txt @@ -31,6 +31,7 @@ set(ERROR_TESTS io09.f90 io10.f90 kinds02.f90 + kinds04.f90 resolve01.f90 resolve02.f90 resolve03.f90 @@ -103,6 +104,9 @@ set(ERROR_TESTS resolve70.f90 resolve71.f90 resolve72.f90 + resolve73.f90 + resolve74.f90 + resolve75.f90 stop01.f90 structconst01.f90 structconst02.f90 @@ -207,6 +211,7 @@ set(ERROR_TESTS critical02.f90 critical03.f90 block-data01.f90 + complex01.f90 data01.f90 ) diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90 index 09a2c1327b19..368ec59b33b8 100644 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -19,9 +19,9 @@ module m class(t2), allocatable :: pa2(:) class(*), pointer :: up(:) class(*), allocatable :: ua(:) - !ERROR: An assumed (*) type parameter may be used only for a dummy argument, associate name, or named constant + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result type(pdt(*)), pointer :: amp(:) - !ERROR: An assumed (*) type parameter may be used only for a dummy argument, associate name, or named constant + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result type(pdt(*)), allocatable :: ama(:) type(pdt(:)), pointer :: dmp(:) type(pdt(:)), allocatable :: dma(:) diff --git a/flang/test/Semantics/complex01.f90 b/flang/test/Semantics/complex01.f90 new file mode 100644 index 000000000000..4fb46ba56b71 --- /dev/null +++ b/flang/test/Semantics/complex01.f90 @@ -0,0 +1,32 @@ +! C718 Each named constant in a complex literal constant shall be of type +! integer or real. +subroutine s() + integer :: ivar = 35 + integer, parameter :: iconst = 35 + real :: rvar = 68.9 + real, parameter :: rconst = 68.9 + character :: cvar = 'hello' + character, parameter :: cconst = 'hello' + logical :: lvar = .true. + logical, parameter :: lconst = .true. + complex :: cvar1 = (1, 1) + complex :: cvar2 = (1.0, 1.0) + complex :: cvar3 = (1.0, 1) + complex :: cvar4 = (1, 1.0) + complex :: cvar5 = (iconst, 1.0) + complex :: cvar6 = (iconst, rconst) + complex :: cvar7 = (rconst, iconst) + + !ERROR: must be a constant + complex :: cvar8 = (ivar, 1.0) + !ERROR: must be a constant + !ERROR: must be a constant + complex :: cvar9 = (ivar, rvar) + !ERROR: must be a constant + !ERROR: must be a constant + complex :: cvar10 = (rvar, ivar) + !ERROR: operands must be INTEGER or REAL + complex :: cvar11 = (cconst, 1.0) + !ERROR: operands must be INTEGER or REAL + complex :: cvar12 = (lconst, 1.0) +end subroutine s diff --git a/flang/test/Semantics/kinds02.f90 b/flang/test/Semantics/kinds02.f90 index 4ad99ad5f01b..9fb921345d85 100644 --- a/flang/test/Semantics/kinds02.f90 +++ b/flang/test/Semantics/kinds02.f90 @@ -1,3 +1,15 @@ +! C712 The value of scalar-int-constant-expr shall be nonnegative and +! shall specify a representation method that exists on the processor. +! C714 The value of kind-param shall be nonnegative. +! C715 The value of kind-param shall specify a representation method that +! exists on the processor. +! C719 The value of scalar-int-constant-expr shall be nonnegative and shall +! specify a representation method that exists on the processor. +! C725 The optional comma in a length-selector is permitted only if no +! double-colon separator appears in the typedeclaration- stmt. +! C727 The value of kind-param shall specify a representation method that +! exists on the processor. +! !ERROR: INTEGER(KIND=0) is not a supported type integer(kind=0) :: j0 !ERROR: INTEGER(KIND=-1) is not a supported type @@ -40,4 +52,19 @@ logical(kind=-1) :: lm1 logical(kind=3) :: l3 !ERROR: LOGICAL(KIND=16) is not a supported type logical(kind=16) :: l16 +character (len=99, kind=1) :: cvar1 +character (len=99, kind=2) :: cvar2 +character *4, cvar3 +character *(5), cvar4 +!ERROR: KIND value (3) not valid for CHARACTER +character (len=99, kind=3) :: cvar5 +!ERROR: KIND value (-1) not valid for CHARACTER +character (len=99, kind=-1) :: cvar6 +character(len=*), parameter :: cvar7 = 1_"abcd" +character(len=*), parameter :: cvar8 = 2_"abcd" +!ERROR: CHARACTER(KIND=3) is not a supported type +character(len=*), parameter :: cvar9 = 3_"abcd" +character(len=*), parameter :: cvar10 = 4_"abcd" +!ERROR: CHARACTER(KIND=8) is not a supported type +character(len=*), parameter :: cvar11 = 8_"abcd" end program diff --git a/flang/test/Semantics/kinds04.f90 b/flang/test/Semantics/kinds04.f90 new file mode 100644 index 000000000000..a44c62bae47e --- /dev/null +++ b/flang/test/Semantics/kinds04.f90 @@ -0,0 +1,31 @@ +! C716 If both kind-param and exponent-letter appear, exponent-letter +! shall be E. +! C717 The value of kind-param shall specify an approximation method that +! exists on the processor. +subroutine s(var) + real :: realvar1 = 4.0E6_4 + real :: realvar2 = 4.0D6 + real :: realvar3 = 4.0Q6 + !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E' + real :: realvar4 = 4.0D6_8 + !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E' + real :: realvar5 = 4.0Q6_16 + real :: realvar6 = 4.0E6_8 + real :: realvar7 = 4.0E6_10 + real :: realvar8 = 4.0E6_16 + !ERROR: Unsupported REAL(KIND=32) + real :: realvar9 = 4.0E6_32 + + double precision :: doublevar1 = 4.0E6_4 + double precision :: doublevar2 = 4.0D6 + double precision :: doublevar3 = 4.0Q6 + !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E' + double precision :: doublevar4 = 4.0D6_8 + !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E' + double precision :: doublevar5 = 4.0Q6_16 + double precision :: doublevar6 = 4.0E6_8 + double precision :: doublevar7 = 4.0E6_10 + double precision :: doublevar8 = 4.0E6_16 + !ERROR: Unsupported REAL(KIND=32) + double precision :: doublevar9 = 4.0E6_32 +end subroutine s diff --git a/flang/test/Semantics/resolve35.f90 b/flang/test/Semantics/resolve35.f90 index 2598d9ca82e8..6acd24f49b5e 100644 --- a/flang/test/Semantics/resolve35.f90 +++ b/flang/test/Semantics/resolve35.f90 @@ -66,6 +66,7 @@ subroutine s6b integer :: l = 4 forall(integer(k) :: i = 1:10) end forall + ! C713 A scalar-int-constant-name shall be a named constant of type integer. !ERROR: Must be a constant value forall(integer(l) :: i = 1:10) end forall diff --git a/flang/test/Semantics/resolve37.f90 b/flang/test/Semantics/resolve37.f90 index a33e3700a932..ccc05f3d1715 100644 --- a/flang/test/Semantics/resolve37.f90 +++ b/flang/test/Semantics/resolve37.f90 @@ -6,6 +6,7 @@ integer :: n = 2 !ERROR: Must be a constant value parameter(m=n) integer(k) :: x +! C713 A scalar-int-constant-name shall be a named constant of type integer. !ERROR: Must have INTEGER type, but is REAL(4) integer(l) :: y !ERROR: Must be a constant value diff --git a/flang/test/Semantics/resolve41.f90 b/flang/test/Semantics/resolve41.f90 index 3e5c48e9aaa6..2f618675de60 100644 --- a/flang/test/Semantics/resolve41.f90 +++ b/flang/test/Semantics/resolve41.f90 @@ -4,6 +4,7 @@ module m !ERROR: Must have INTEGER type, but is REAL(4) integer :: aa = 2_a integer :: b = 8 + ! C713 A scalar-int-constant-name shall be a named constant of type integer. !ERROR: Must be a constant value integer :: bb = 2_b !TODO: should get error -- not scalar diff --git a/flang/test/Semantics/resolve73.f90 b/flang/test/Semantics/resolve73.f90 new file mode 100644 index 000000000000..191be316b620 --- /dev/null +++ b/flang/test/Semantics/resolve73.f90 @@ -0,0 +1,40 @@ +! C721 A type-param-value of * shall be used only +! * to declare a dummy argument, +! * to declare a named constant, +! * in the type-spec of an ALLOCATE statement wherein each allocate-object is +! a dummy argument of type CHARACTER with an assumed character length, +! * in the type-spec or derived-type-spec of a type guard statement (11.1.11), +! or +! * in an external function, to declare the character length parameter of the function result. +subroutine s(arg) + character(len=*), pointer :: arg + character*(*), parameter :: cvar1 = "abc" + character*4, cvar2 + character(len=4_4) :: cvar3 + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result + character(len=*) :: cvar4 + + type derived(param) + integer, len :: param + class(*), allocatable :: x + end type + type(derived(34)) :: a + interface + function fun() + character(len=4) :: fun + end function fun + end interface + + select type (ax => a%x) + type is (integer) + print *, "hello" + type is (character(len=*)) + print *, "hello" + class is (derived(param=*)) + print *, "hello" + class default + print *, "hello" + end select + + allocate (character(len=*) :: arg) +end subroutine s diff --git a/flang/test/Semantics/resolve74.f90 b/flang/test/Semantics/resolve74.f90 new file mode 100644 index 000000000000..a674b1f37ac2 --- /dev/null +++ b/flang/test/Semantics/resolve74.f90 @@ -0,0 +1,37 @@ +! C722 A function name shall not be declared with an asterisk type-param-value +! unless it is of type CHARACTER and is the name of a dummy function or the +! name of the result of an external function. +subroutine s() + + type derived(param) + integer, len :: param + end type + type(derived(34)) :: a + + procedure(character(len=*)) :: externCharFunc + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result + procedure(type(derived(param =*))) :: externDerivedFunc + + interface + subroutine subr(dummyFunc) + character(len=*) :: dummyFunc + end subroutine subr + end interface + + contains + function works() + type(derived(param=4)) :: works + end function works + + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result + function fails1() + character(len=*) :: fails1 + end function fails1 + + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result + function fails2() + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result + type(derived(param=*)) :: fails2 + end function fails2 + +end subroutine s diff --git a/flang/test/Semantics/resolve75.f90 b/flang/test/Semantics/resolve75.f90 new file mode 100644 index 000000000000..2c63a36fe523 --- /dev/null +++ b/flang/test/Semantics/resolve75.f90 @@ -0,0 +1,13 @@ +! C726 The length specified for a character statement function or for a +! statement function dummy argument of type character shall be a constant +! expression. +subroutine s() + implicit character(len=3) (c) + implicit character(len=*) (d) + stmtFunc1 (x) = x * 32 + cStmtFunc2 (x) = "abc" + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result + cStmtFunc3 (dummy) = "abc" + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result + dStmtFunc3 (x) = "abc" +end subroutine s