diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -142,12 +142,6 @@ // its INTEGER kind type parameter. std::optional IsImpliedDo(parser::CharBlock) const; - // Allows a whole assumed-size array to appear for the lifetime of - // the returned value. - common::Restorer AllowWholeAssumedSizeArray() { - return common::ScopedSet(isWholeAssumedSizeArrayOk_, true); - } - common::Restorer DoNotUseSavedTypedExprs() { return common::ScopedSet(useSavedTypedExprs_, false); } @@ -255,6 +249,17 @@ int IntegerTypeSpecKind(const parser::IntegerTypeSpec &); private: + // Allows a whole assumed-size array to appear for the lifetime of + // the returned value. + common::Restorer AllowWholeAssumedSizeArray() { + return common::ScopedSet(isWholeAssumedSizeArrayOk_, true); + } + + // Allows an Expr to be a null pointer. + common::Restorer AllowNullPointer() { + return common::ScopedSet(isNullPointerOk_, true); + } + MaybeExpr Analyze(const parser::IntLiteralConstant &, bool negated = false); MaybeExpr Analyze(const parser::RealLiteralConstant &); MaybeExpr Analyze(const parser::ComplexPart &); @@ -375,6 +380,7 @@ FoldingContext &foldingContext_{context_.foldingContext()}; std::map impliedDos_; // values are INTEGER kinds bool isWholeAssumedSizeArrayOk_{false}; + bool isNullPointerOk_{false}; bool useSavedTypedExprs_{true}; bool inWhereBody_{false}; bool inDataStmtConstant_{false}; 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 @@ -838,7 +838,8 @@ } MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &n) { - if (MaybeExpr value{Analyze(n.v)}) { + auto restorer{AllowNullPointer()}; + if (MaybeExpr value{Analyze(n.v.value())}) { // Subtle: when the NullInit is a DataStmtConstant, it might // be a misparse of a structure constructor without parameters // or components (e.g., T()). Checking the result to ensure @@ -1710,6 +1711,9 @@ bool checkConflicts{true}; // until we hit one auto &messages{GetContextualMessages()}; + // NULL() can be a valid component + auto restorer{AllowNullPointer()}; + for (const auto &component : std::get>(structure.t)) { const parser::Expr &expr{ @@ -1842,8 +1846,41 @@ semantics::CheckStructConstructorPointerComponent( GetFoldingContext(), *symbol, *value, innermost); // C7104, C7105 result.Add(*symbol, Fold(std::move(*value))); - } else if (MaybeExpr converted{ - ConvertToType(*symbol, std::move(*value))}) { + continue; + } + if (IsNullPointer(*value)) { + if (IsAllocatable(*symbol)) { + if (IsBareNullPointer(&*value)) { + // NULL() with no arguments allowed by 7.5.10 para 6 for + // ALLOCATABLE. + result.Add(*symbol, Expr{NullPointer{}}); + continue; + } + if (IsNullObjectPointer(*value)) { + AttachDeclaration( + Say(expr.source, + "NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US, + symbol->name()), + *symbol); + // proceed to check type & shape + } else { + AttachDeclaration( + Say(expr.source, + "A NULL procedure pointer may not be used as the value for component '%s'"_err_en_US, + symbol->name()), + *symbol); + continue; + } + } else { + AttachDeclaration( + Say(expr.source, + "A NULL pointer may not be used as the value for component '%s'"_err_en_US, + symbol->name()), + *symbol); + continue; + } + } + if (MaybeExpr converted{ConvertToType(*symbol, std::move(*value))}) { if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) { if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) { if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) { @@ -1881,9 +1918,6 @@ symbol->name()), *symbol); } - } else if (IsAllocatable(*symbol) && IsBareNullPointer(&*value)) { - // NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE. - result.Add(*symbol, Expr{NullPointer{}}); } else if (auto symType{DynamicType::From(symbol)}) { if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() && valueType) { @@ -2615,7 +2649,11 @@ const parser::PointerAssignmentStmt &x) { if (!x.typedAssignment) { MaybeExpr lhs{Analyze(std::get(x.t))}; - MaybeExpr rhs{Analyze(std::get(x.t))}; + MaybeExpr rhs; + { + auto restorer{AllowNullPointer()}; + rhs = Analyze(std::get(x.t)); + } if (!lhs || !rhs) { x.typedAssignment.Reset( new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter); @@ -3084,9 +3122,6 @@ template MaybeExpr ExpressionAnalyzer::ExprOrVariable( const PARSED &x, parser::CharBlock source) { - if (useSavedTypedExprs_ && x.typedExpr) { - return x.typedExpr->v; - } auto restorer{GetContextualMessages().SetLocation(source)}; if constexpr (std::is_same_v || std::is_same_v) { @@ -3138,10 +3173,21 @@ } MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) { - return ExprOrVariable(expr, expr.source); + if (useSavedTypedExprs_ && expr.typedExpr) { + return expr.typedExpr->v; + } + MaybeExpr result{ExprOrVariable(expr, expr.source)}; + if (!isNullPointerOk_ && result && IsNullPointer(*result)) { + Say(expr.source, + "NULL() may not be used as an expression in this context"_err_en_US); + } + return result; } MaybeExpr ExpressionAnalyzer::Analyze(const parser::Variable &variable) { + if (useSavedTypedExprs_ && variable.typedExpr) { + return variable.typedExpr->v; + } return ExprOrVariable(variable, variable.GetSource()); } @@ -3425,8 +3471,6 @@ void ArgumentAnalyzer::Analyze( const parser::ActualArgSpec &arg, bool isSubroutine) { - // TODO: Actual arguments that are procedures and procedure pointers need to - // be detected and represented (they're not expressions). // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed. std::optional actual; common::visit(common::visitors{ @@ -3796,6 +3840,7 @@ return context_.Analyze(expr); } } + auto restorer{context_.AllowNullPointer()}; return context_.Analyze(expr); } 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 @@ -4932,8 +4932,17 @@ bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { if (auto *name{std::get_if(&x.u)}) { return !NameIsKnownOrIntrinsic(*name) && !CheckUseError(*name); + } else { + const auto &null{DEREF(std::get_if(&x.u))}; + Walk(null); + if (auto nullInit{EvaluateExpr(null)}) { + if (!evaluate::IsNullPointer(*nullInit)) { + Say(null.v.value().source, + "Procedure pointer initializer must be a name or intrinsic NULL()"_err_en_US); + } + } + return false; } - return true; } void DeclarationVisitor::Post(const parser::ProcInterface &x) { if (auto *name{std::get_if(&x.u)}) { @@ -6886,9 +6895,9 @@ [&](const parser::NullInit &null) { // => NULL() Walk(null); if (auto nullInit{EvaluateExpr(null)}) { - if (!evaluate::IsNullPointer(*nullInit)) { - Say(name, - "Pointer initializer must be intrinsic NULL()"_err_en_US); // C813 + if (!evaluate::IsNullPointer(*nullInit)) { // C813 + Say(null.v.value().source, + "Pointer initializer must be intrinsic NULL()"_err_en_US); } else if (IsPointer(ultimate)) { if (auto *object{ultimate.detailsIf()}) { object->set_init(std::move(*nullInit)); @@ -6947,14 +6956,14 @@ if (IsProcedurePointer(ultimate)) { auto &details{ultimate.get()}; CHECK(!details.init()); - Walk(target); if (const auto *targetName{std::get_if(&target.u)}) { + Walk(target); if (!CheckUseError(*targetName) && targetName->symbol) { // Validation is done in declaration checking. details.set_init(*targetName->symbol); } - } else { - details.set_init(nullptr); // explicit NULL() + } else { // explicit NULL + details.set_init(nullptr); } } else { Say(name, diff --git a/flang/test/Semantics/null01.f90 b/flang/test/Semantics/null01.f90 --- a/flang/test/Semantics/null01.f90 +++ b/flang/test/Semantics/null01.f90 @@ -32,6 +32,7 @@ external implicit type :: dt0 integer, pointer :: ip0 + integer :: n = 666 end type dt0 type :: dt1 integer, pointer :: ip1(:) @@ -42,11 +43,15 @@ type :: dt3 procedure(s1), pointer, nopass :: pps1 end type dt3 + type :: dt4 + real, allocatable :: ra0 + end type dt4 integer :: j type(dt0) :: dt0x type(dt1) :: dt1x type(dt2) :: dt2x type(dt3) :: dt3x + type(dt4) :: dt4x integer, pointer :: ip0, ip1(:), ip2(:,:) integer, allocatable :: ia0, ia1(:), ia2(:,:) real, pointer :: rp0, rp1(:) @@ -55,6 +60,7 @@ integer, parameter :: ip2r = rank(null(mold=ip2)) integer, parameter :: eight = ip0r + ip1r + ip2r + 5 real(kind=eight) :: r8check + logical, pointer :: lp ip0 => null() ! ok ip1 => null() ! ok ip2 => null() ! ok @@ -68,6 +74,8 @@ dt0x = dt0(ip0=null(mold=ip0)) !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)' dt0x = dt0(ip0=null(mold=rp0)) + !ERROR: A NULL pointer may not be used as the value for component 'n' + dt0x = dt0(null(), null()) !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)' dt1x = dt1(ip1=null(mold=rp1)) dt2x = dt2(pps0=null()) @@ -77,6 +85,14 @@ !ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer: distinct numbers of dummy arguments dt3x = dt3(pps1=null(mold=dt2x%pps0)) dt3x = dt3(pps1=null(mold=dt3x%pps1)) + dt4x = dt4(null()) ! ok + !PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'ra0' + dt4x = dt4(null(rp0)) + !PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'ra0' + !ERROR: Rank-1 array value is not compatible with scalar component 'ra0' + dt4x = dt4(null(rp1)) + !ERROR: A NULL procedure pointer may not be used as the value for component 'ra0' + dt4x = dt4(null(dt2x%pps0)) call canbenull(null(), null()) ! fine call canbenull(null(mold=ip0), null(mold=rp0)) ! fine !ERROR: Null pointer argument requires an explicit interface @@ -87,4 +103,10 @@ print *, sin(null(rp0)) !ERROR: A NULL() pointer is not allowed for 'source=' intrinsic argument print *, transfer(null(rp0),ip0) + !ERROR: NULL() may not be used as an expression in this context + select case(null(ip0)) + end select + !ERROR: NULL() may not be used as an expression in this context + if (null(lp)) then + end if end subroutine test