diff --git a/flang/docs/f2018-grammar.md b/flang/docs/f2018-grammar.md --- a/flang/docs/f2018-grammar.md +++ b/flang/docs/f2018-grammar.md @@ -216,7 +216,7 @@ function-name [* char-length] R804 object-name -> name R805 initialization -> = constant-expr | => null-init | => initial-data-target -R806 null-init -> function-reference +R806 null-init -> function-reference {constrained to be NULL()} R807 access-spec -> PUBLIC | PRIVATE R808 language-binding-spec -> BIND ( C [, NAME = scalar-default-char-constant-expr] ) diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -974,9 +974,8 @@ u; }; -// R806 null-init -> function-reference -// TODO replace with semantic check on expression -EMPTY_CLASS(NullInit); +// R806 null-init -> function-reference ... which must be NULL() +WRAPPER_CLASS(NullInit, common::Indirection); // R744 initial-data-target -> designator using InitialDataTarget = common::Indirection; @@ -1412,7 +1411,7 @@ // scalar-constant | scalar-constant-subobject | // signed-int-literal-constant | signed-real-literal-constant | // null-init | initial-data-target | -// constant-structure-constructor <- added "constant-" +// structure-constructor struct DataStmtConstant { UNION_CLASS_BOILERPLATE(DataStmtConstant); CharBlock source; 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 @@ -237,6 +237,7 @@ MaybeExpr Analyze(const parser::SignedComplexLiteralConstant &); MaybeExpr Analyze(const parser::StructureConstructor &); MaybeExpr Analyze(const parser::InitialDataTarget &); + MaybeExpr Analyze(const parser::NullInit &); void Analyze(const parser::CallStmt &); const Assignment *Analyze(const parser::AssignmentStmt &); @@ -255,7 +256,6 @@ MaybeExpr Analyze(const parser::HollerithLiteralConstant &); MaybeExpr Analyze(const parser::BOZLiteralConstant &); MaybeExpr Analyze(const parser::NamedConstant &); - MaybeExpr Analyze(const parser::NullInit &); MaybeExpr Analyze(const parser::DataStmtConstant &); MaybeExpr Analyze(const parser::Substring &); MaybeExpr Analyze(const parser::ArrayElement &); 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 @@ -190,6 +190,9 @@ template bool operator()(const Parentheses &x) const { return (*this)(x.left()); } + template bool operator()(const FunctionRef &x) const { + return false; + } bool operator()(const Relational &) const { return false; } private: diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -644,9 +644,8 @@ TYPE_PARSER(construct(objectName, maybe(arraySpec), maybe(coarraySpec), maybe("*" >> charLength), maybe(initialization))) -// R806 null-init -> function-reference -// TODO: confirm in semantics that NULL still intrinsic in this scope -TYPE_PARSER(construct("NULL ( )"_tok) / !"("_tok) +// R806 null-init -> function-reference ... which must resolve to NULL() +TYPE_PARSER(lookAhead(name / "( )") >> construct(expr)) // R807 access-spec -> PUBLIC | PRIVATE TYPE_PARSER(construct("PUBLIC" >> pure(AccessSpec::Kind::Public)) || @@ -827,7 +826,11 @@ // R845 data-stmt-constant -> // scalar-constant | scalar-constant-subobject | // signed-int-literal-constant | signed-real-literal-constant | -// null-init | initial-data-target | structure-constructor +// null-init | initial-data-target | +// constant-structure-constructor +// null-init and a structure-constructor without parameters or components +// are syntactically ambiguous in DATA, so "x()" is misparsed into a +// null-init then fixed up later in expression semantics. // TODO: Some structure constructors can be misrecognized as array // references into constant subobjects. TYPE_PARSER(sourced(first( diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -252,6 +252,7 @@ bool isPointer{lastSymbol && IsPointer(*lastSymbol)}; bool isProcPointer{lastSymbol && IsProcedurePointer(*lastSymbol)}; evaluate::FoldingContext &context{exprAnalyzer_.GetFoldingContext()}; + auto restorer{context.messages().SetLocation(values_.LocateSource())}; const auto DescribeElement{[&]() { if (auto badDesignator{ @@ -302,39 +303,37 @@ } else if (evaluate::IsNullPointer(*expr)) { // nothing to do; rely on zero initialization return true; - } else if (evaluate::IsProcedure(*expr)) { - if (isProcPointer) { + } else if (isProcPointer) { + if (evaluate::IsProcedure(*expr)) { if (CheckPointerAssignment(context, designator, *expr)) { GetImage().AddPointer(offsetSymbol.offset(), *expr); return true; } } else { - exprAnalyzer_.Say(values_.LocateSource(), - "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US, + exprAnalyzer_.Say( + "Data object '%s' may not be used to initialize '%s', which is a procedure pointer"_err_en_US, expr->AsFortran(), DescribeElement()); } - } else if (isProcPointer) { - exprAnalyzer_.Say(values_.LocateSource(), - "Data object '%s' may not be used to initialize '%s', which is a procedure pointer"_err_en_US, + } else if (evaluate::IsProcedure(*expr)) { + exprAnalyzer_.Say( + "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US, expr->AsFortran(), DescribeElement()); } else if (CheckInitialTarget(context, designator, *expr)) { GetImage().AddPointer(offsetSymbol.offset(), *expr); return true; } } else if (evaluate::IsNullPointer(*expr)) { - exprAnalyzer_.Say(values_.LocateSource(), - "Initializer for '%s' must not be a pointer"_err_en_US, + exprAnalyzer_.Say("Initializer for '%s' must not be a pointer"_err_en_US, DescribeElement()); } else if (evaluate::IsProcedure(*expr)) { - exprAnalyzer_.Say(values_.LocateSource(), - "Initializer for '%s' must not be a procedure"_err_en_US, + exprAnalyzer_.Say("Initializer for '%s' must not be a procedure"_err_en_US, DescribeElement()); } else if (auto designatorType{designator.GetType()}) { if (auto converted{ConvertElement(*expr, *designatorType)}) { // value non-pointer initialization if (std::holds_alternative(expr->u) && designatorType->category() != TypeCategory::Integer) { // 8.6.7(11) - exprAnalyzer_.Say(values_.LocateSource(), + exprAnalyzer_.Say( "BOZ literal should appear in a DATA statement only as a value for an integer object, but '%s' is '%s'"_en_US, DescribeElement(), designatorType->AsFortran()); } else if (converted->second) { @@ -348,7 +347,7 @@ case evaluate::InitialImage::Ok: return true; case evaluate::InitialImage::NotAConstant: - exprAnalyzer_.Say(values_.LocateSource(), + exprAnalyzer_.Say( "DATA statement value '%s' for '%s' is not a constant"_err_en_US, folded.AsFortran(), DescribeElement()); break; 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 @@ -709,8 +709,16 @@ return std::nullopt; } -MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &x) { - return Expr{NullPointer{}}; +MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &n) { + if (MaybeExpr value{Analyze(n.v)}) { + // 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 + // that a "=>" data entity initializer actually resolved to + // a null pointer has to be done by the caller. + return Fold(std::move(*value)); + } + return std::nullopt; } MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) { 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 @@ -188,14 +188,12 @@ if (context().HasError(symbol)) { return std::nullopt; } - auto maybeExpr{AnalyzeExpr(*context_, expr)}; - if (!maybeExpr) { - return std::nullopt; - } - auto exprType{maybeExpr->GetType()}; - auto converted{evaluate::ConvertToType(symbol, std::move(*maybeExpr))}; - if (!converted) { - if (exprType) { + if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) { + if (auto converted{ + evaluate::ConvertToType(symbol, std::move(*maybeExpr))}) { + return FoldExpr(std::move(*converted)); + } + if (auto exprType{maybeExpr->GetType()}) { Say(source, "Initialization expression could not be converted to declared type of '%s' from %s"_err_en_US, symbol.name(), exprType->AsFortran()); @@ -204,9 +202,8 @@ "Initialization expression could not be converted to declared type of '%s'"_err_en_US, symbol.name()); } - return std::nullopt; } - return FoldExpr(std::move(*converted)); + return std::nullopt; } template MaybeIntExpr EvaluateIntExpr(const T &expr) { @@ -3345,6 +3342,10 @@ if (!ConvertToProcEntity(*symbol)) { SayWithDecl( name, *symbol, "EXTERNAL attribute not allowed on '%s'"_err_en_US); + } else if (symbol->attrs().test(Attr::INTRINSIC)) { // C840 + Say(symbol->name(), + "Symbol '%s' cannot have both INTRINSIC and EXTERNAL attributes"_err_en_US, + symbol->name()); } } return false; @@ -5730,18 +5731,27 @@ // derived types may still need more attention. return; } - if (auto *details{ultimate.detailsIf()}) { + if (auto *object{ultimate.detailsIf()}) { // TODO: check C762 - all bounds and type parameters of component // are colons or constant expressions if component is initialized - bool isNullPointer{false}; std::visit( common::visitors{ [&](const parser::ConstantExpr &expr) { NonPointerInitialization(name, expr, inComponentDecl); }, - [&](const parser::NullInit &) { - isNullPointer = true; - details->set_init(SomeExpr{evaluate::NullPointer{}}); + [&](const parser::NullInit &null) { + Walk(null); + if (auto nullInit{EvaluateExpr(null)}) { + if (!evaluate::IsNullPointer(*nullInit)) { + Say(name, + "Pointer initializer must be intrinsic NULL()"_err_en_US); // C813 + } else if (IsPointer(ultimate)) { + object->set_init(std::move(*nullInit)); + } else { + Say(name, + "Non-pointer component '%s' initialized with null pointer"_err_en_US); + } + } }, [&](const parser::InitialDataTarget &) { DIE("InitialDataTarget can't appear here"); @@ -5757,15 +5767,6 @@ }, }, init.u); - if (isNullPointer) { - if (!IsPointer(ultimate)) { - Say(name, - "Non-pointer component '%s' initialized with null pointer"_err_en_US); - } - } else if (IsPointer(ultimate)) { - Say(name, - "Object pointer component '%s' initialized with non-pointer expression"_err_en_US); - } } } @@ -5885,8 +5886,6 @@ } ConvertToProcEntity(*symbol); SetProcFlag(name, *symbol, flag); - } else if (symbol->has()) { - DIE("unexpected UnknownDetails"); } else if (CheckUseError(name)) { // error was reported } else { diff --git a/flang/test/Semantics/modfile20.f90 b/flang/test/Semantics/modfile20.f90 --- a/flang/test/Semantics/modfile20.f90 +++ b/flang/test/Semantics/modfile20.f90 @@ -33,7 +33,7 @@ ! integer(4)::a=123_4 ! type(t),pointer::b=>NULL() ! end type +! intrinsic::null ! type(t),parameter::x=t(a=456_4,b=NULL()) ! type(t),parameter::y=t(a=789_4,b=NULL()) -! intrinsic::null !end diff --git a/flang/test/Semantics/null-init.f90 b/flang/test/Semantics/null-init.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/null-init.f90 @@ -0,0 +1,75 @@ +! RUN: %S/test_errors.sh %s %t %f18 +! Tests valid and invalid NULL initializers + +module m1 + implicit none + !ERROR: No explicit type declared for 'null' + private :: null +end module + +module m2 + implicit none + private :: null + integer, pointer :: p => null() +end module + +module m3 + private :: null + integer, pointer :: p => null() +end module + +module m4 + intrinsic :: null + integer, pointer :: p => null() +end module + +module m5 + external :: null + !ERROR: Pointer initializer must be intrinsic NULL() + integer, pointer :: p => null() +end module + +module m6 + !ERROR: Symbol 'null' cannot have both INTRINSIC and EXTERNAL attributes + integer, pointer :: p => null() + external :: null +end module + +module m7 + interface + function null() result(p) + integer, pointer :: p + end function + end interface + !ERROR: Pointer initializer must be intrinsic NULL() + integer, pointer :: p => null() +end module + +module m8 + integer, pointer :: p => null() + interface + !ERROR: 'null' is already declared in this scoping unit + function null() result(p) + integer, pointer :: p + end function + end interface +end module + +module m9a + intrinsic :: null + contains + function foo() + integer, pointer :: foo + foo => null() + end function +end module +module m9b + use m9a, renamed => null, null => foo + integer, pointer :: p => renamed() + !ERROR: Pointer initializer must be intrinsic NULL() + integer, pointer :: q => null() + integer, pointer :: d1, d2 + data d1/renamed()/ + !ERROR: An initial data target must be a designator with constant subscripts + data d2/null()/ +end module diff --git a/flang/test/Semantics/symbol15.f90 b/flang/test/Semantics/symbol15.f90 --- a/flang/test/Semantics/symbol15.f90 +++ b/flang/test/Semantics/symbol15.f90 @@ -12,6 +12,7 @@ !DEF: /m/op1 POINTER, PUBLIC ObjectEntity REAL(4) real, pointer :: op1 !DEF: /m/op2 POINTER, PUBLIC ObjectEntity REAL(4) + !DEF: /m/null INTRINSIC, PUBLIC (Function) ProcEntity real, pointer :: op2 => null() !DEF: /m/op3 POINTER, PUBLIC ObjectEntity REAL(4) !DEF: /m/x PUBLIC, TARGET ObjectEntity REAL(4) @@ -24,6 +25,7 @@ procedure(iface), pointer :: pp1 !REF: /m/iface !DEF: /m/pp2 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity + !REF: /m/null procedure(iface), pointer :: pp2 => null() !REF: /m/iface !DEF: /m/pp3 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity @@ -46,6 +48,7 @@ !DEF: /m/t1/opc1 POINTER ObjectEntity REAL(4) real, pointer :: opc1 !DEF: /m/t1/opc2 POINTER ObjectEntity REAL(4) + !REF: /m/null real, pointer :: opc2 => null() !DEF: /m/t1/opc3 POINTER ObjectEntity REAL(4) !REF: /m/x @@ -58,6 +61,7 @@ procedure(iface), nopass, pointer :: ppc1 !REF: /m/iface !DEF: /m/t1/ppc2 NOPASS, POINTER (Subroutine) ProcEntity + !REF: /m/null procedure(iface), nopass, pointer :: ppc2 => null() !REF: /m/iface !DEF: /m/t1/ppc3 NOPASS, POINTER (Subroutine) ProcEntity @@ -94,6 +98,7 @@ !DEF: /m/pdt1/opc1 POINTER ObjectEntity REAL(4) real, pointer :: opc1 !DEF: /m/pdt1/opc2 POINTER ObjectEntity REAL(4) + !REF: /m/null real, pointer :: opc2 => null() !DEF: /m/pdt1/opc3 POINTER ObjectEntity REAL(4) !REF: /m/x @@ -107,6 +112,7 @@ procedure(iface), nopass, pointer :: ppc1 !REF: /m/iface !DEF: /m/pdt1/ppc2 NOPASS, POINTER (Subroutine) ProcEntity + !REF: /m/null procedure(iface), nopass, pointer :: ppc2 => null() !REF: /m/iface !DEF: /m/pdt1/ppc3 NOPASS, POINTER (Subroutine) ProcEntity