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 @@ -205,7 +205,8 @@ if (semantics::IsNamedConstant(symbol)) { return std::nullopt; } else if (scope_.IsDerivedType() && IsVariableName(symbol)) { // C750, C754 - return "derived type component not allowed to reference variable '"s + + return "derived type component or type parameter value not allowed to " + "reference variable '"s + symbol.name().ToString() + "'"; } else if (symbol.IsDummy()) { if (symbol.attrs().test(semantics::Attr::OPTIONAL)) { @@ -255,8 +256,8 @@ Result operator()(const TypeParamInquiry &inq) const { if (scope_.IsDerivedType() && !IsConstantExpr(inq) && inq.parameter().owner() != scope_) { // C750, C754 - return "non-constant reference to a type parameter inquiry " - "not allowed for derived type components"; + return "non-constant reference to a type parameter inquiry not " + "allowed for derived type components or type parameter values"; } return std::nullopt; } @@ -273,7 +274,8 @@ } if (scope_.IsDerivedType()) { // C750, C754 return "reference to function '"s + symbol->name().ToString() + - "' not allowed for derived type components"; + "' not allowed for derived type components or type parameter" + " values"; } // TODO: other checks for standard module procedures } else { @@ -284,13 +286,16 @@ badIntrinsicsForComponents_.end()) || IsProhibitedFunction(intrin.name)) { return "reference to intrinsic '"s + intrin.name + - "' not allowed for derived type components"; + "' not allowed for derived type components or type parameter" + " values"; } if (table_.GetIntrinsicClass(intrin.name) == IntrinsicClass::inquiryFunction && !IsConstantExpr(x)) { return "non-constant reference to inquiry intrinsic '"s + - intrin.name + "' not allowed for derived type components"; + intrin.name + + "' not allowed for derived type components or type" + " parameter values"; } } else if (intrin.name == "present") { return std::nullopt; // no need to check argument(s) 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 @@ -154,7 +154,6 @@ } void CheckHelper::Check(const Symbol &symbol) { - // xmark if (context_.HasError(symbol)) { return; } @@ -285,12 +284,11 @@ "A dummy argument may not have the SAVE attribute"_err_en_US); } } - if (symbol.owner().IsDerivedType()) { - if (symbol.attrs().test(Attr::CONTIGUOUS) && - !(IsPointer(symbol) && symbol.Rank() > 0)) { // C752 - messages_.Say( - "A CONTIGUOUS component must be an array with the POINTER attribute"_err_en_US); - } + if (symbol.owner().IsDerivedType() && + (symbol.attrs().test(Attr::CONTIGUOUS) && + !(IsPointer(symbol) && symbol.Rank() > 0))) { // C752 + messages_.Say( + "A CONTIGUOUS component must be an array with the POINTER attribute"_err_en_US); } } @@ -582,6 +580,12 @@ messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); } } else if (symbol.owner().IsDerivedType()) { + if (!symbol.attrs().test(Attr::POINTER)) { // C756 + const auto &name{symbol.name()}; + messages_.Say(name, + "Procedure component '%s' must have POINTER attribute"_err_en_US, + name); + } CheckPassArg(symbol, details.interface().symbol(), details); } if (symbol.attrs().test(Attr::POINTER)) { 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 @@ -3671,6 +3671,14 @@ if (!symbol) { Say(paramName, "No definition found for type parameter '%s'"_err_en_US); // C742 + // No symbol for a type param. Create one and mark it as containing an + // error to improve subsequent semantic processing + CHECK(!attrs_); + attrs_ = std::make_optional(); + Symbol *typeParam{MakeTypeSymbol( + paramName, TypeParamDetails{common::TypeParamAttr::Len})}; + attrs_.reset(); + typeParam->set(Symbol::Flag::Error); } else if (!symbol->has()) { Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US, *symbol, "Definition of '%s'"_en_US); // C741 @@ -3907,17 +3915,6 @@ return true; } void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &stmt) { - const auto &attrList{ - std::get>(stmt.t)}; - bool foundPointer{false}; - for (const auto &attr : attrList) { - if (std::get_if(&attr.u)) { - foundPointer = true; - } - } - if (!foundPointer) { // C756 - Say("A procedure component must have the POINTER attribute"_err_en_US); - } interfaceName_ = nullptr; } bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { @@ -4821,21 +4818,23 @@ for (const Scope *scope{&currScope()}; scope;) { CHECK(scope->IsDerivedType()); if (auto *prev{FindInScope(*scope, name)}) { - auto msg{""_en_US}; - if (extends) { - msg = "Type cannot be extended as it has a component named" - " '%s'"_err_en_US; - } else if (prev->test(Symbol::Flag::ParentComp)) { - msg = "'%s' is a parent type of this type and so cannot be" - " a component"_err_en_US; - } else if (scope != &currScope()) { - msg = "Component '%s' is already declared in a parent of this" - " derived type"_err_en_US; - } else { - msg = "Component '%s' is already declared in this" - " derived type"_err_en_US; + if (!prev->test(Symbol::Flag::Error)) { + auto msg{""_en_US}; + if (extends) { + msg = "Type cannot be extended as it has a component named" + " '%s'"_err_en_US; + } else if (prev->test(Symbol::Flag::ParentComp)) { + msg = "'%s' is a parent type of this type and so cannot be" + " a component"_err_en_US; + } else if (scope != &currScope()) { + msg = "Component '%s' is already declared in a parent of this" + " derived type"_err_en_US; + } else { + msg = "Component '%s' is already declared in this" + " derived type"_err_en_US; + } + Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US); } - Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US); return false; } if (scope == &currScope() && extends) { diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -123,9 +123,12 @@ continue; } } - evaluate::SayWithDeclaration(messages, symbol, - "Value of type parameter '%s' (%s) is not convertible to its type"_err_en_US, - name, expr->AsFortran()); + if (!symbol.test(Symbol::Flag::Error)) { + evaluate::SayWithDeclaration(messages, symbol, + "Value of type parameter '%s' (%s) is not convertible to its" + " type"_err_en_US, + name, expr->AsFortran()); + } } } } @@ -148,9 +151,11 @@ evaluate::Fold(foldingContext, common::Clone(details.init()))}; AddParamValue(name, ParamValue{std::move(*expr), details.attr()}); } else { - messages.Say(name_, - "Type parameter '%s' lacks a value and has no default"_err_en_US, - name); + if (!symbol.test(Symbol::Flag::Error)) { + messages.Say(name_, + "Type parameter '%s' lacks a value and has no default"_err_en_US, + name); + } } } } 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 @@ -39,8 +39,6 @@ !ERROR: No definition found for type parameter 'k' !ERROR: No definition found for type parameter 'l' type :: t6(k, l) - !ERROR: Must be a constant value - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'l' character(kind=k, len=l) :: d3 end type type(t6(2, 10)) :: x3 diff --git a/flang/test/Semantics/resolve34.f90 b/flang/test/Semantics/resolve34.f90 --- a/flang/test/Semantics/resolve34.f90 +++ b/flang/test/Semantics/resolve34.f90 @@ -27,9 +27,13 @@ !ERROR: 't1' is a parent type of this type and so cannot be a component real :: t1 end type - type, extends(t2) :: t3 - !ERROR: 't1' is a parent type of this type and so cannot be a component - real :: t1 + type :: t3 + end type + type, extends(t3) :: t4 + end type + type, extends(t4) :: t5 + !ERROR: 't3' is a parent type of this type and so cannot be a component + real :: t3 end type end diff --git a/flang/test/Semantics/resolve79.f90 b/flang/test/Semantics/resolve79.f90 --- a/flang/test/Semantics/resolve79.f90 +++ b/flang/test/Semantics/resolve79.f90 @@ -24,7 +24,7 @@ procedure(passNopassProc), pass, pointer, nopass :: passNopassField !WARNING: Attribute 'POINTER' cannot be used more than once procedure(pointerProc), pointer, public, pointer :: pointerField - !ERROR: A procedure component must have the POINTER attribute + !ERROR: Procedure component 'nonpointerfield' must have POINTER attribute procedure(publicProc), public :: nonpointerField contains procedure :: noPassProc diff --git a/flang/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90 --- a/flang/test/Semantics/resolve89.f90 +++ b/flang/test/Semantics/resolve89.f90 @@ -65,7 +65,7 @@ real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic type arrayType - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'var' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'var' real, dimension(var) :: varField !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc' real, dimension(iVolatileStmtFunc()) :: arrayFieldWithVolatile @@ -73,17 +73,17 @@ real, dimension(iImpureStmtFunc()) :: arrayFieldWithImpureFunction !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc' real, dimension(iPureStmtFunc()) :: arrayFieldWithPureFunction - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'iarg' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'iarg' real, dimension(iabs(iArg)) :: arrayFieldWithIntrinsic - !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values real, dimension(merge(1, 2, allocated(allocArg))) :: realField1 - !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values 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 + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components or type parameter values real, dimension(merge(1, 2, is_contiguous(arrayArg))) :: realField3 - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'ioarg' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'ioarg' real, dimension(ioArg) :: realField4 - !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values real, dimension(merge(1, 2, present(optionalArg))) :: realField5 end type arrayType @@ -107,7 +107,7 @@ type localDerivedType ! OK because the specification inquiry is a constant integer, dimension(localDerived%kindParam) :: goodField - !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components + !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components or type parameter values integer, dimension(derivedArg%lenParam) :: badField end type localDerivedType @@ -129,28 +129,28 @@ end type paramType type charType - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'iarg' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'iarg' character(iabs(iArg)) :: fieldWithIntrinsic - !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values character(merge(1, 2, allocated(allocArg))) :: allocField - !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values character(merge(1, 2, associated(pointerArg))) :: assocField - !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components or type parameter values character(merge(1, 2, is_contiguous(arrayArg))) :: contigField - !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values character(merge(1, 2, present(optionalArg))) :: presentField end type charType type derivedType - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'iarg' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'iarg' type(paramType(iabs(iArg))) :: fieldWithIntrinsic - !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values type(paramType(merge(1, 2, allocated(allocArg)))) :: allocField - !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values type(paramType(merge(1, 2, associated(pointerArg)))) :: assocField - !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components or type parameter values type(paramType(merge(1, 2, is_contiguous(arrayArg)))) :: contigField - !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values type(paramType(merge(1, 2, present(optionalArg)))) :: presentField end type derivedType end subroutine s2