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 @@ -422,14 +422,14 @@ }; // Track array specifications. They can occur in AttrSpec, EntityDecl, -// ObjectDecl, DimensionStmt, CommonBlockObject, BasedPointerStmt, and +// ObjectDecl, DimensionStmt, CommonBlockObject, BasedPointer, and // ComponentDecl. // 1. INTEGER, DIMENSION(10) :: x // 2. INTEGER :: x(10) // 3. ALLOCATABLE :: x(:) // 4. DIMENSION :: x(10) // 5. COMMON x(10) -// 6. BasedPointerStmt +// 6. POINTER(p,x(10)) class ArraySpecVisitor : public virtual BaseVisitor { public: void Post(const parser::ArraySpec &); @@ -1003,7 +1003,8 @@ void Post(const parser::CommonBlockObject &); bool Pre(const parser::EquivalenceStmt &); bool Pre(const parser::SaveStmt &); - bool Pre(const parser::BasedPointerStmt &); + bool Pre(const parser::BasedPointer &); + void Post(const parser::BasedPointer &); void PointerInitialization( const parser::Name &, const parser::InitialDataTarget &); @@ -5687,78 +5688,67 @@ return false; } -bool DeclarationVisitor::Pre(const parser::BasedPointerStmt &x) { - for (const parser::BasedPointer &bp : x.v) { - const parser::ObjectName &pointerName{std::get<0>(bp.t)}; - const parser::ObjectName &pointeeName{std::get<1>(bp.t)}; - auto *pointer{FindSymbol(pointerName)}; - if (!pointer) { - pointer = &MakeSymbol(pointerName, ObjectEntityDetails{}); - } else if (!ConvertToObjectEntity(*pointer) || IsNamedConstant(*pointer)) { - SayWithDecl(pointerName, *pointer, "'%s' is not a variable"_err_en_US); - } else if (pointer->Rank() > 0) { - SayWithDecl(pointerName, *pointer, - "Cray pointer '%s' must be a scalar"_err_en_US); - } else if (pointer->test(Symbol::Flag::CrayPointee)) { - Say(pointerName, - "'%s' cannot be a Cray pointer as it is already a Cray pointee"_err_en_US); - } - pointer->set(Symbol::Flag::CrayPointer); - const DeclTypeSpec &pointerType{MakeNumericType(TypeCategory::Integer, - context().defaultKinds().subscriptIntegerKind())}; - const auto *type{pointer->GetType()}; - if (!type) { - pointer->SetType(pointerType); - } else if (*type != pointerType) { - Say(pointerName.source, "Cray pointer '%s' must have type %s"_err_en_US, - pointerName.source, pointerType.AsFortran()); - } - // pmk: change parse tree to use DimensionStmt::Declaration in BasedPointerStmt, then change this - // routine to a Post() - if (ResolveName(pointeeName)) { - Symbol &pointee{*pointeeName.symbol}; - if (pointee.has()) { - Say(pointeeName, - "'%s' cannot be a Cray pointee as it is use-associated"_err_en_US); - continue; - } else if (!ConvertToObjectEntity(pointee) || IsNamedConstant(pointee)) { - Say(pointeeName, "'%s' is not a variable"_err_en_US); - continue; - } else if (pointee.test(Symbol::Flag::CrayPointer)) { - Say(pointeeName, - "'%s' cannot be a Cray pointee as it is already a Cray pointer"_err_en_US); - } else if (pointee.test(Symbol::Flag::CrayPointee)) { - Say(pointeeName, - "'%s' was already declared as a Cray pointee"_err_en_US); - } else { - pointee.set(Symbol::Flag::CrayPointee); - } - if (const auto *pointeeType{pointee.GetType()}) { - if (const auto *derived{pointeeType->AsDerived()}) { - if (!derived->typeSymbol().get().sequence()) { - Say(pointeeName, - "Type of Cray pointee '%s' is a non-sequence derived type"_err_en_US); - } - } - } - // process the pointee array-spec, if present - BeginArraySpec(); - Walk(std::get>(bp.t)); - const auto &spec{arraySpec()}; - if (!spec.empty()) { - auto &details{pointee.get()}; - if (details.shape().empty()) { - details.set_shape(spec); - } else { - SayWithDecl(pointeeName, pointee, - "Array spec was already declared for '%s'"_err_en_US); +bool DeclarationVisitor::Pre(const parser::BasedPointer &) { + BeginArraySpec(); + return true; +} + +void DeclarationVisitor::Post(const parser::BasedPointer &bp) { + const parser::ObjectName &pointerName{std::get<0>(bp.t)}; + auto *pointer{FindSymbol(pointerName)}; + if (!pointer) { + pointer = &MakeSymbol(pointerName, ObjectEntityDetails{}); + } else if (!ConvertToObjectEntity(*pointer)) { + SayWithDecl(pointerName, *pointer, "'%s' is not a variable"_err_en_US); + } else if (IsNamedConstant(*pointer)) { + SayWithDecl(pointerName, *pointer, + "'%s' is a named constant and may not be a Cray pointer"_err_en_US); + } else if (pointer->Rank() > 0) { + SayWithDecl( + pointerName, *pointer, "Cray pointer '%s' must be a scalar"_err_en_US); + } else if (pointer->test(Symbol::Flag::CrayPointee)) { + Say(pointerName, + "'%s' cannot be a Cray pointer as it is already a Cray pointee"_err_en_US); + } + pointer->set(Symbol::Flag::CrayPointer); + const DeclTypeSpec &pointerType{MakeNumericType( + TypeCategory::Integer, context().defaultKinds().subscriptIntegerKind())}; + const auto *type{pointer->GetType()}; + if (!type) { + pointer->SetType(pointerType); + } else if (*type != pointerType) { + Say(pointerName.source, "Cray pointer '%s' must have type %s"_err_en_US, + pointerName.source, pointerType.AsFortran()); + } + const parser::ObjectName &pointeeName{std::get<1>(bp.t)}; + DeclareObjectEntity(pointeeName); + if (Symbol * pointee{pointeeName.symbol}) { + if (!ConvertToObjectEntity(*pointee)) { + return; + } + if (IsNamedConstant(*pointee)) { + Say(pointeeName, + "'%s' is a named constant and may not be a Cray pointee"_err_en_US); + return; + } + if (pointee->test(Symbol::Flag::CrayPointer)) { + Say(pointeeName, + "'%s' cannot be a Cray pointee as it is already a Cray pointer"_err_en_US); + } else if (pointee->test(Symbol::Flag::CrayPointee)) { + Say(pointeeName, "'%s' was already declared as a Cray pointee"_err_en_US); + } else { + pointee->set(Symbol::Flag::CrayPointee); + } + if (const auto *pointeeType{pointee->GetType()}) { + if (const auto *derived{pointeeType->AsDerived()}) { + if (!derived->typeSymbol().get().sequence()) { + Say(pointeeName, + "Type of Cray pointee '%s' is a non-sequence derived type"_err_en_US); } } - ClearArraySpec(); - currScope().add_crayPointer(pointeeName.source, *pointer); } + currScope().add_crayPointer(pointeeName.source, *pointer); } - return false; } bool DeclarationVisitor::Pre(const parser::NamelistStmt::Group &x) { diff --git a/flang/test/Semantics/resolve61.f90 b/flang/test/Semantics/resolve61.f90 --- a/flang/test/Semantics/resolve61.f90 +++ b/flang/test/Semantics/resolve61.f90 @@ -35,7 +35,7 @@ subroutine p6 real b(8) - !ERROR: Array spec was already declared for 'b' + !ERROR: The dimensions of 'b' have already been declared pointer(a, b(4)) end @@ -59,7 +59,7 @@ pointer(t, a) !ERROR: 's' is not a variable pointer(s, b) - !ERROR: 'k' is not a variable + !ERROR: 'k' is a named constant and may not be a Cray pointer pointer(k, c) contains subroutine s @@ -70,11 +70,11 @@ integer(8), parameter :: k = 2 type t end type - !ERROR: 't' is not a variable + !ERROR: 't' is already declared in this scoping unit pointer(a, t) - !ERROR: 's' is not a variable + !ERROR: Declaration of 's' conflicts with its use as internal procedure pointer(b, s) - !ERROR: 'k' is not a variable + !ERROR: 'k' is a named constant and may not be a Cray pointee pointer(c, k) contains subroutine s @@ -87,7 +87,7 @@ end subroutine p10 use m10 - !ERROR: 'b' cannot be a Cray pointee as it is use-associated + !ERROR: 'b' is use-associated from module 'm10' and cannot be re-declared pointer(a, c),(d, b) end @@ -113,3 +113,11 @@ !ERROR: Type of Cray pointee 'x2' is a non-sequence derived type pointer(b, x2) end + +subroutine p13 + pointer(ip, x) + contains + subroutine s + pointer(ip, x) ! ok, local declaration + end +end