// its INTEGER kind type parameter.
std::optional<int> IsImpliedDo(parser::CharBlock) const;
- // Allows a whole assumed-size array to appear for the lifetime of
- // the returned value.
- common::Restorer<bool> AllowWholeAssumedSizeArray() {
- return common::ScopedSet(isWholeAssumedSizeArrayOk_, true);
- }
-
common::Restorer<bool> DoNotUseSavedTypedExprs() {
return common::ScopedSet(useSavedTypedExprs_, false);
}
int IntegerTypeSpecKind(const parser::IntegerTypeSpec &);
private:
+ // Allows a whole assumed-size array to appear for the lifetime of
+ // the returned value.
+ common::Restorer<bool> AllowWholeAssumedSizeArray() {
+ return common::ScopedSet(isWholeAssumedSizeArrayOk_, true);
+ }
+
+ // Allows an Expr to be a null pointer.
+ common::Restorer<bool> AllowNullPointer() {
+ return common::ScopedSet(isNullPointerOk_, true);
+ }
+
MaybeExpr Analyze(const parser::IntLiteralConstant &, bool negated = false);
MaybeExpr Analyze(const parser::RealLiteralConstant &);
MaybeExpr Analyze(const parser::ComplexPart &);
FoldingContext &foldingContext_{context_.foldingContext()};
std::map<parser::CharBlock, int> impliedDos_; // values are INTEGER kinds
bool isWholeAssumedSizeArrayOk_{false};
+ bool isNullPointerOk_{false};
bool useSavedTypedExprs_{true};
bool inWhereBody_{false};
bool inDataStmtConstant_{false};
}
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
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<std::list<parser::ComponentSpec>>(structure.t)) {
const parser::Expr &expr{
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<SomeType>{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) {
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<SomeType>{NullPointer{}});
} else if (auto symType{DynamicType::From(symbol)}) {
if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() &&
valueType) {
const parser::PointerAssignmentStmt &x) {
if (!x.typedAssignment) {
MaybeExpr lhs{Analyze(std::get<parser::DataRef>(x.t))};
- MaybeExpr rhs{Analyze(std::get<parser::Expr>(x.t))};
+ MaybeExpr rhs;
+ {
+ auto restorer{AllowNullPointer()};
+ rhs = Analyze(std::get<parser::Expr>(x.t));
+ }
if (!lhs || !rhs) {
x.typedAssignment.Reset(
new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);
template <typename PARSED>
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<PARSED, parser::Expr> ||
std::is_same_v<PARSED, parser::Variable>) {
}
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());
}
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<ActualArgument> actual;
common::visit(common::visitors{
return context_.Analyze(expr);
}
}
+ auto restorer{context_.AllowNullPointer()};
return context_.Analyze(expr);
}
bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) {
if (auto *name{std::get_if<parser::Name>(&x.u)}) {
return !NameIsKnownOrIntrinsic(*name) && !CheckUseError(*name);
+ } else {
+ const auto &null{DEREF(std::get_if<parser::NullInit>(&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<parser::Name>(&x.u)}) {
[&](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<ObjectEntityDetails>()}) {
object->set_init(std::move(*nullInit));
if (IsProcedurePointer(ultimate)) {
auto &details{ultimate.get<ProcEntityDetails>()};
CHECK(!details.init());
- Walk(target);
if (const auto *targetName{std::get_if<parser::Name>(&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,
external implicit
type :: dt0
integer, pointer :: ip0
+ integer :: n = 666
end type dt0
type :: dt1
integer, pointer :: ip1(:)
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(:)
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
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())
!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
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