const semantics::ProcInterface &interface{proc.interface()};
if (interface.type()) {
return Characterize(*interface.type());
- } else {
+ } else if (interface.symbol()) {
return Characterize(*interface.symbol(), context);
+ } else {
+ return std::optional<TypeAndShape>{};
}
},
[&](const semantics::UseDetails &use) {
void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
CHECK(!where_);
if (const evaluate::Assignment * asst{GetAssignment(stmt)}) {
+ bool hasBounds{false};
auto [lhs, rhs]{std::visit(
common::visitors{
[&](const evaluate::Assignment::IntrinsicAssignment &x) {
common::visitors{
[&](const evaluate::Assignment::PointerAssignment::
BoundsSpec &bounds) {
+ hasBounds = !bounds.empty();
for (const auto &bound : bounds) {
CheckForImpureCall(SomeExpr{bound});
}
},
[&](const evaluate::Assignment::PointerAssignment::
BoundsRemapping &bounds) {
+ hasBounds = !bounds.empty();
for (const auto &bound : bounds) {
CheckForImpureCall(SomeExpr{bound.first});
CheckForImpureCall(SomeExpr{bound.second});
context_.Say( // C1027
"Procedure pointer may not be a coindexed object"_err_en_US);
}
+ if (hasBounds) {
+ // TODO cases with bounds-spec and bounds-remapping
+ } else {
+ auto &foldingContext{context_.foldingContext()};
+ auto restorer{
+ foldingContext.messages().SetLocation(context_.location().value())};
+ CheckPointerAssignment(foldingContext, *pointer, *rhs);
+ }
}
- // TODO continue here, using CheckPointerAssignment()
}
}
void CheckValue(const Symbol &, const DerivedTypeSpec *);
void CheckVolatile(
const Symbol &, bool isAssociated, const DerivedTypeSpec *);
+ void CheckPointer(const Symbol &);
void CheckPassArg(
const Symbol &proc, const Symbol *interface, const WithPassArg &);
void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
const Symbol &, const GenericDetails &, const std::vector<Procedure> &);
void SayNotDistinguishable(
const SourceName &, GenericKind, const Symbol &, const Symbol &);
+ bool CheckConflicting(const Symbol &, Attr, Attr);
bool InPure() const {
return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);
}
if (isAssociated) {
return; // only care about checking VOLATILE on associated symbols
}
+ if (IsPointer(symbol)) {
+ CheckPointer(symbol);
+ }
std::visit(
common::visitors{
[&](const ProcBindingDetails &x) { CheckProcBinding(symbol, x); },
} else if (symbol.owner().IsDerivedType()) {
CheckPassArg(symbol, details.interface().symbol(), details);
}
+ if (symbol.attrs().test(Attr::POINTER)) {
+ if (const Symbol * interface{details.interface().symbol()}) {
+ if (interface->attrs().test(Attr::ELEMENTAL) &&
+ !interface->attrs().test(Attr::INTRINSIC)) {
+ messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
+ symbol.name()); // C1517
+ }
+ }
+ }
}
void CheckHelper::CheckDerivedType(
return true;
}
+// Report a conflicting attribute error if symbol has both of these attributes
+bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
+ if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
+ messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
+ symbol.name(), EnumToString(a1), EnumToString(a2));
+ return true;
+ } else {
+ return false;
+ }
+}
+
std::optional<std::vector<Procedure>> CheckHelper::Characterize(
const SymbolVector &specifics) {
std::vector<Procedure> result;
}
}
+void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
+ CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);
+ CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE);
+ CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
+ if (symbol.Corank() > 0) {
+ messages_.Say(
+ "'%s' may not have the POINTER attribute because it is a coarray"_err_en_US,
+ symbol.name());
+ }
+}
+
// C760 constraints on the passed-object dummy argument
void CheckHelper::CheckPassArg(
const Symbol &proc, const Symbol *interface, const WithPassArg &details) {
if (semantics::IsProcedure(symbol)) {
if (auto *component{std::get_if<Component>(&ref.u)}) {
return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
+ } else if (!std::holds_alternative<SymbolRef>(ref.u)) {
+ DIE("unexpected alternative in DataRef");
+ } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
+ return Expr<SomeType>{ProcedureDesignator{symbol}};
+ } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
+ symbol.name().ToString())}) {
+ SpecificIntrinsic intrinsic{
+ symbol.name().ToString(), std::move(*interface)};
+ intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
+ return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
} else {
- CHECK(std::holds_alternative<SymbolRef>(ref.u));
- if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
- if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
- symbol.name().ToString())}) {
- SpecificIntrinsic intrinsic{
- symbol.name().ToString(), std::move(*interface)};
- intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
- return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
- }
- } else {
- return Expr<SomeType>{ProcedureDesignator{symbol}};
- }
+ Say("'%s' is not a specific intrinsic procedure"_err_en_US,
+ symbol.name());
+ return std::nullopt;
}
} else if (auto dyType{DynamicType::From(symbol)}) {
return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_procedure(std::optional<Procedure> &&);
PointerAssignmentChecker &set_isContiguous(bool);
+ PointerAssignmentChecker &set_isVolatile(bool);
void Check(const SomeExpr &);
private:
// Target is a procedure
void Check(
parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr);
-
+ bool LhsOkForUnlimitedPoly() const;
template<typename... A> parser::Message *Say(A &&...);
const parser::CharBlock source_;
std::optional<TypeAndShape> lhsType_;
std::optional<Procedure> procedure_;
bool isContiguous_{false};
+ bool isVolatile_{false};
};
PointerAssignmentChecker &PointerAssignmentChecker::set_lhs(const Symbol &lhs) {
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
+ bool isVolatile) {
+ isVolatile_ = isVolatile;
+ return *this;
+}
+
template<typename A> void PointerAssignmentChecker::Check(const A &) {
// Catch-all case for really bad target expression
Say("Target associated with %s must be a designator or a call to a"
} else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025
msg = "In assignment to object %s, the target '%s' is not an object with"
" POINTER or TARGET attributes"_err_en_US;
- } else if (auto rhsTypeAndShape{
- TypeAndShape::Characterize(*last, context_)}) {
- if (!lhsType_ ||
- !lhsType_->IsCompatibleWith(context_.messages(), *rhsTypeAndShape)) {
+ } else if (auto rhsType{TypeAndShape::Characterize(*last, context_)}) {
+ if (!lhsType_) {
msg = "%s associated with object '%s' with incompatible type or"
" shape"_err_en_US;
+ } else if (rhsType->corank() > 0 &&
+ (isVolatile_ != last->attrs().test(Attr::VOLATILE))) { // C1020
+ if (isVolatile_) {
+ msg = "Pointer may not be VOLATILE when target is a"
+ " non-VOLATILE coarray"_err_en_US;
+ } else {
+ msg = "Pointer must be VOLATILE when target is a"
+ " VOLATILE coarray"_err_en_US;
+ }
+ } else if (rhsType->type().IsUnlimitedPolymorphic()) {
+ if (!LhsOkForUnlimitedPoly()) {
+ msg = "Pointer type must be unlimited polymorphic or non-extensible"
+ " derived type when target is unlimited polymorphic"_err_en_US;
+ }
+ } else {
+ lhsType_->IsCompatibleWith(context_.messages(), *rhsType);
}
}
if (msg) {
}
}
+// Compare procedure characteristics for equality except that lhs may be
+// Pure or Elemental when rhs is not.
+static bool CharacteristicsMatch(const Procedure &lhs, const Procedure &rhs) {
+ using Attr = Procedure::Attr;
+ auto lhsAttrs{rhs.attrs};
+ lhsAttrs.set(
+ Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
+ lhsAttrs.set(Attr::Elemental,
+ lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
+ return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
+ lhs.dummyArguments == rhs.dummyArguments;
+}
+
// Common handling for procedure pointer right-hand sides
void PointerAssignmentChecker::Check(
- parser::CharBlock rhsName, bool isCall, const Procedure *targetChars) {
+ parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
+ std::optional<parser::MessageFixedText> msg;
if (!procedure_) {
- Say("In assignment to object %s, the target '%s' is a procedure designator"_err_en_US,
- description_, rhsName);
- } else if (!targetChars) {
- Say("In assignment to procedure %s, the characteristics of the target"
- " procedure '%s' could not be determined"_err_en_US,
- description_, rhsName);
- } else if (*procedure_ == *targetChars) {
+ msg = "In assignment to object %s, the target '%s' is a procedure"
+ " designator"_err_en_US;
+ } else if (!rhsProcedure) {
+ msg = "In assignment to procedure %s, the characteristics of the target"
+ " procedure '%s' could not be determined"_err_en_US;
+ } else if (CharacteristicsMatch(*procedure_, *rhsProcedure)) {
// OK
} else if (isCall) {
- Say("Procedure %s associated with result of reference to function '%s' that"
- " is an incompatible procedure pointer"_err_en_US,
- description_, rhsName);
+ msg = "Procedure %s associated with result of reference to function '%s'"
+ " that is an incompatible procedure pointer"_err_en_US;
+ } else if (procedure_->IsPure() && !rhsProcedure->IsPure()) {
+ msg = "PURE procedure %s may not be associated with non-PURE"
+ " procedure designator '%s'"_err_en_US;
+ } else if (procedure_->IsElemental() && !rhsProcedure->IsElemental()) {
+ msg = "ELEMENTAL procedure %s may not be associated with non-ELEMENTAL"
+ " procedure designator '%s'"_err_en_US;
+ } else if (procedure_->IsFunction() && !rhsProcedure->IsFunction()) {
+ msg = "Function %s may not be associated with subroutine"
+ " designator '%s'"_err_en_US;
+ } else if (!procedure_->IsFunction() && rhsProcedure->IsFunction()) {
+ msg = "Subroutine %s may not be associated with function"
+ " designator '%s'"_err_en_US;
+ } else if (procedure_->HasExplicitInterface() &&
+ !rhsProcedure->HasExplicitInterface()) {
+ msg = "Procedure %s with explicit interface may not be associated with"
+ " procedure designator '%s' with implicit interface"_err_en_US;
+ } else if (!procedure_->HasExplicitInterface() &&
+ rhsProcedure->HasExplicitInterface()) {
+ msg = "Procedure %s with implicit interface may not be associated with"
+ " procedure designator '%s' with explicit interface"_err_en_US;
} else {
- Say("Procedure %s associated with incompatible procedure designator '%s'"_err_en_US,
- description_, rhsName);
+ msg = "Procedure %s associated with incompatible procedure"
+ " designator '%s'"_err_en_US;
+ }
+ if (msg) {
+ Say(std::move(*msg), description_, rhsName);
}
}
Check(ref.proc().GetName(), true, procedure);
}
+// The target can be unlimited polymorphic if the pointer is, or if it is
+// a non-extensible derived type.
+bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
+ const auto &type{lhsType_->type()};
+ if (type.category() != TypeCategory::Derived || type.IsAssumedType()) {
+ return false;
+ } else if (type.IsUnlimitedPolymorphic()) {
+ return true;
+ } else {
+ return !IsExtensibleType(&type.GetDerivedTypeSpec());
+ }
+}
+
template<typename... A>
parser::Message *PointerAssignmentChecker::Say(A &&... x) {
auto *msg{context_.messages().Say(std::forward<A>(x)...)};
.set_procedure(Procedure::Characterize(lhs, context.intrinsics()))
.set_lhs(lhs)
.set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS))
+ .set_isVolatile(lhs.attrs().test(Attr::VOLATILE))
.Check(rhs);
}
}
PointerAssignmentChecker{source, description, context}
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
+ .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
.Check(rhs);
}
structconst03.f90
structconst04.f90
assign01.f90
+ assign02.f90
assign03.f90
if_arith02.f90
if_arith03.f90
--- /dev/null
+! Pointer assignment constraints 10.2.2.2
+
+module m1
+ type :: t(k)
+ integer, kind :: k
+ end type
+ type t2
+ sequence
+ end type
+contains
+
+ ! C853
+ subroutine s0
+ !ERROR: 'p1' may not have both the POINTER and TARGET attributes
+ real, pointer :: p1, p3
+ allocatable :: p2
+ !ERROR: 'sin' may not have both the POINTER and INTRINSIC attributes
+ real, intrinsic, pointer :: sin
+ target :: p1
+ !ERROR: 'p2' may not have both the POINTER and ALLOCATABLE attributes
+ pointer :: p2
+ !ERROR: 'a' may not have the POINTER attribute because it is a coarray
+ real, pointer :: a(:)[*]
+ end
+
+ ! C1015
+ subroutine s1
+ real, target :: r
+ real(8), target :: r8
+ logical, target :: l
+ real, pointer :: p
+ p => r
+ !ERROR: TARGET type 'REAL(8)' is not compatible with POINTER type 'REAL(4)'
+ p => r8
+ !ERROR: TARGET type 'LOGICAL(4)' is not compatible with POINTER type 'REAL(4)'
+ p => l
+ end
+
+ ! C1015
+ subroutine s2
+ real, target :: r1(4), r2(4,4)
+ real, pointer :: p(:)
+ p => r1
+ !ERROR: Rank of POINTER is 1, but TARGET has rank 2
+ p => r2
+ end
+
+ ! C1015
+ subroutine s3
+ type(t(1)), target :: x1
+ type(t(2)), target :: x2
+ type(t(1)), pointer :: p
+ p => x1
+ !ERROR: TARGET type 't(k=2_4)' is not compatible with POINTER type 't(k=1_4)'
+ p => x2
+ end
+
+ ! C1016
+ subroutine s4(x)
+ class(*), target :: x
+ type(t(1)), pointer :: p1
+ type(t2), pointer :: p2
+ class(*), pointer :: p3
+ real, pointer :: p4
+ p2 => x ! OK - not extensible
+ p3 => x ! OK - unlimited polymorphic
+ !ERROR: Pointer type must be unlimited polymorphic or non-extensible derived type when target is unlimited polymorphic
+ p1 => x
+ !ERROR: Pointer type must be unlimited polymorphic or non-extensible derived type when target is unlimited polymorphic
+ p4 => x
+ end
+
+ ! C1020
+ subroutine s5
+ real, target :: x[*]
+ real, target, volatile :: y[*]
+ real, pointer :: p
+ real, pointer, volatile :: q
+ p => x
+ !ERROR: Pointer must be VOLATILE when target is a VOLATILE coarray
+ p => y
+ !ERROR: Pointer may not be VOLATILE when target is a non-VOLATILE coarray
+ q => x
+ q => y
+ end
+
+ ! C1021, C1023
+ subroutine s6
+ real, target :: x
+ real :: p
+ type :: tp
+ real, pointer :: a
+ real :: b
+ end type
+ type(tp) :: y
+ !ERROR: 'p' is not a pointer
+ p => x
+ y%a => x
+ !ERROR: 'b' is not a pointer
+ y%b => x
+ end
+
+ !C1025 (R1037) The expr shall be a designator that designates a
+ !variable with either the TARGET or POINTER attribute and is not
+ !an array section with a vector subscript, or it shall be a reference
+ !to a function that returns a data pointer.
+ subroutine s7
+ real, target :: a
+ real, pointer :: b
+ real, pointer :: c
+ real :: d
+ b => a
+ c => b
+ !ERROR: In assignment to object pointer 'b', the target 'd' is not an object with POINTER or TARGET attributes
+ b => d
+ end
+
+ ! C1025
+ subroutine s8
+ real :: a(10)
+ integer :: b(10)
+ real, pointer :: p(:)
+ !ERROR: An array section with a vector subscript may not be a pointer target
+ p => a(b)
+ end
+
+ ! C1025
+ subroutine s9
+ real, target :: x
+ real, pointer :: p
+ p => f1()
+ !ERROR: pointer 'p' is associated with the result of a reference to function 'f2' that is a not a pointer
+ p => f2()
+ contains
+ function f1()
+ real, pointer :: f1
+ f1 => x
+ end
+ function f2()
+ real :: f2
+ f2 = x
+ end
+ end
+
+ ! C1026 (R1037) A data-target shall not be a coindexed object.
+ subroutine s10
+ real, target :: a[*]
+ real, pointer :: b
+ !ERROR: A coindexed object may not be a pointer target
+ b => a[1]
+ end
+
+end
+! Pointer assignment constraints 10.2.2.2 (see also assign02.f90)
+
module m
interface
subroutine s(i)
end interface
type :: t
procedure(s), pointer, nopass :: p
+ real, pointer :: q
end type
contains
! C1027
!ERROR: Procedure pointer may not be a coindexed object
b[1]%p => s
end
+ ! C1028
+ subroutine s2
+ type(t) :: a
+ a%p => s
+ !ERROR: In assignment to object pointer 'q', the target 's' is a procedure designator
+ a%q => s
+ end
+ ! C1029
+ subroutine s3
+ type(t) :: a
+ a%p => f() ! OK: pointer-valued function
+ !ERROR: Subroutine pointer 'p' may not be associated with function designator 'f'
+ a%p => f
+ contains
+ function f()
+ procedure(s), pointer :: f
+ f => s
+ end
+ end
+
+ ! C1030 and 10.2.2.4 - procedure names as target of procedure pointer
+ subroutine s4(s_dummy)
+ procedure(s), intent(in) :: s_dummy
+ procedure(s), pointer :: p, q
+ procedure(), pointer :: r
+ integer :: i
+ external :: s_external
+ p => s_dummy
+ p => s_internal
+ p => s_module
+ q => p
+ r => s_external
+ contains
+ subroutine s_internal(i)
+ integer i
+ end
+ end
+ subroutine s_module(i)
+ integer i
+ end
+
+ ! 10.2.2.4(3)
+ subroutine s5
+ procedure(f_pure), pointer :: p_pure
+ procedure(f_impure), pointer :: p_impure
+ !ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
+ procedure(f_elemental), pointer :: p_elemental
+ p_pure => f_pure
+ p_impure => f_impure
+ p_impure => f_pure
+ !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure'
+ p_pure => f_impure
+ contains
+ pure integer function f_pure()
+ f_pure = 1
+ end
+ integer function f_impure()
+ f_impure = 1
+ end
+ elemental integer function f_elemental()
+ f_elemental = 1
+ end
+ end
+
+ ! 10.2.2.4(4)
+ subroutine s6
+ procedure(s), pointer :: p, q
+ procedure(), pointer :: r
+ external :: s_external
+ !ERROR: Procedure pointer 'p' with explicit interface may not be associated with procedure designator 's_external' with implicit interface
+ p => s_external
+ !ERROR: Procedure pointer 'r' with implicit interface may not be associated with procedure designator 's_module' with explicit interface
+ r => s_module
+ end
+
+ ! 10.2.2.4(5)
+ subroutine s7
+ procedure(real) :: f_external
+ external :: s_external
+ procedure(), pointer :: p_s
+ procedure(real), pointer :: p_f
+ p_f => f_external
+ p_s => s_external
+ !ERROR: Subroutine pointer 'p_s' may not be associated with function designator 'f_external'
+ p_s => f_external
+ !ERROR: Function pointer 'p_f' may not be associated with subroutine designator 's_external'
+ p_f => s_external
+ end
+
end
end function
function intprocptr()
procedure(intfunc), pointer :: intprocptr
- procptr => intfunc
+ intprocptr => intfunc
end function
subroutine test1 ! 15.5.2.9(5)
!DEF: /module1 Module
module module1
abstract interface
- !DEF: /module1/abstract1 ELEMENTAL, PUBLIC (Function) Subprogram REAL(4)
+ !DEF: /module1/abstract1 PUBLIC (Function) Subprogram REAL(4)
!DEF: /module1/abstract1/x INTENT(IN) ObjectEntity REAL(4)
- real elemental function abstract1(x)
+ real function abstract1(x)
!REF: /module1/abstract1/x
real, intent(in) :: x
end function abstract1
end interface
interface
- !DEF: /module1/explicit1 ELEMENTAL, EXTERNAL, PUBLIC (Function) Subprogram REAL(4)
+ !DEF: /module1/explicit1 EXTERNAL, PUBLIC (Function) Subprogram REAL(4)
!DEF: /module1/explicit1/x INTENT(IN) ObjectEntity REAL(4)
- real elemental function explicit1(x)
+ real function explicit1(x)
!REF: /module1/explicit1/x
real, intent(in) :: x
end function explicit1
+! C1030 - pointers to intrinsic procedures
program main
intrinsic :: cos ! a specific & generic intrinsic name
intrinsic :: alog10 ! a specific intrinsic name, not generic
p => alog10 ! ditto, but already declared intrinsic
p => cos ! ditto, but also generic
p => tan ! a generic & an unrestricted specific, not already declared
- !TODO ERROR: a restricted specific, to be caught in ass't semantics
+ !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'amin0'
p => amin0
+ !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'amin1'
p => amin1
- !TODO ERROR: a generic, to be caught in ass't semantics
+ !ERROR: 'bessel_j0' is not a specific intrinsic procedure
p => bessel_j0
end program main
type(t2), pointer :: t2p
end type
!REF: /main/t1
- !DEF: /main/t1x ObjectEntity TYPE(t1)
- type(t1) :: t1x
+ !DEF: /main/t1x TARGET ObjectEntity TYPE(t1)
+ type(t1), target :: t1x
!REF: /main/t1x
!REF: /main/t1/t1a
allocate(t1x%t1a)
projects / platform / upstream / llvm.git / commitdiff