From cb378080580b5039a0b9072d99fc06eb71d08635 Mon Sep 17 00:00:00 2001 From: Tim Keith Date: Mon, 13 Jan 2020 16:39:00 -0800 Subject: [PATCH] [flang] Pointer assignment semantic checks Call `CheckPointerAssignment()` when analyzing a pointer assignment statement. NOTE: the cases with bounds-spec and bounds-remapping are still to be done. Perform checks on pointer symbols in `check-declarations.cc`. Check for pointer to generic intrinsic in `semantics/expression.cc`. Add the other required pointer assignment checks to `pointer-assignment.cc`. Original-commit: flang-compiler/f18@3dc5fd6d9e58d1ef0efd1deefcbaa52499ad93f9 Reviewed-on: https://github.com/flang-compiler/f18/pull/928 --- flang/lib/evaluate/characteristics.cc | 4 +- flang/lib/semantics/assignment.cc | 12 ++- flang/lib/semantics/check-declarations.cc | 36 +++++++ flang/lib/semantics/expression.cc | 25 ++--- flang/lib/semantics/pointer-assignment.cc | 108 +++++++++++++++++---- flang/test/semantics/CMakeLists.txt | 1 + flang/test/semantics/assign02.f90 | 153 ++++++++++++++++++++++++++++++ flang/test/semantics/assign03.f90 | 92 ++++++++++++++++++ flang/test/semantics/call09.f90 | 2 +- flang/test/semantics/procinterface01.f90 | 8 +- flang/test/semantics/resolve46.f90 | 6 +- flang/test/semantics/symbol17.f90 | 4 +- 12 files changed, 410 insertions(+), 41 deletions(-) create mode 100644 flang/test/semantics/assign02.f90 diff --git a/flang/lib/evaluate/characteristics.cc b/flang/lib/evaluate/characteristics.cc index cd464f4..18ab90d 100644 --- a/flang/lib/evaluate/characteristics.cc +++ b/flang/lib/evaluate/characteristics.cc @@ -71,8 +71,10 @@ std::optional TypeAndShape::Characterize( 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{}; } }, [&](const semantics::UseDetails &use) { diff --git a/flang/lib/semantics/assignment.cc b/flang/lib/semantics/assignment.cc index 880f439..064d6f8 100644 --- a/flang/lib/semantics/assignment.cc +++ b/flang/lib/semantics/assignment.cc @@ -160,6 +160,7 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) { 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) { @@ -174,12 +175,14 @@ void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) { 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}); @@ -206,8 +209,15 @@ void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) { 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() } } diff --git a/flang/lib/semantics/check-declarations.cc b/flang/lib/semantics/check-declarations.cc index 385811d..650a142 100644 --- a/flang/lib/semantics/check-declarations.cc +++ b/flang/lib/semantics/check-declarations.cc @@ -51,6 +51,7 @@ private: 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 &); @@ -72,6 +73,7 @@ private: const Symbol &, const GenericDetails &, const std::vector &); void SayNotDistinguishable( const SourceName &, GenericKind, const Symbol &, const Symbol &); + bool CheckConflicting(const Symbol &, Attr, Attr); bool InPure() const { return innermostSymbol_ && IsPureProcedure(*innermostSymbol_); } @@ -139,6 +141,9 @@ void CheckHelper::Check(const Symbol &symbol) { 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); }, @@ -444,6 +449,15 @@ void CheckHelper::CheckProcEntity( } 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( @@ -739,6 +753,17 @@ bool CheckHelper::CheckDefinedAssignmentArg( 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> CheckHelper::Characterize( const SymbolVector &specifics) { std::vector result; @@ -776,6 +801,17 @@ void CheckHelper::CheckVolatile(const Symbol &symbol, bool isAssociated, } } +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) { diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc index 4b89518..a5eb00b 100644 --- a/flang/lib/semantics/expression.cc +++ b/flang/lib/semantics/expression.cc @@ -207,19 +207,20 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) { if (semantics::IsProcedure(symbol)) { if (auto *component{std::get_if(&ref.u)}) { return Expr{ProcedureDesignator{std::move(*component)}}; + } else if (!std::holds_alternative(ref.u)) { + DIE("unexpected alternative in DataRef"); + } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) { + return Expr{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{ProcedureDesignator{std::move(intrinsic)}}; } else { - CHECK(std::holds_alternative(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{ProcedureDesignator{std::move(intrinsic)}}; - } - } else { - return Expr{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(*dyType, std::move(ref)); diff --git a/flang/lib/semantics/pointer-assignment.cc b/flang/lib/semantics/pointer-assignment.cc index 06ebc50..fc2b07a 100644 --- a/flang/lib/semantics/pointer-assignment.cc +++ b/flang/lib/semantics/pointer-assignment.cc @@ -43,6 +43,7 @@ public: PointerAssignmentChecker &set_lhsType(std::optional &&); PointerAssignmentChecker &set_procedure(std::optional &&); PointerAssignmentChecker &set_isContiguous(bool); + PointerAssignmentChecker &set_isVolatile(bool); void Check(const SomeExpr &); private: @@ -56,7 +57,7 @@ private: // Target is a procedure void Check( parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr); - + bool LhsOkForUnlimitedPoly() const; template parser::Message *Say(A &&...); const parser::CharBlock source_; @@ -66,6 +67,7 @@ private: std::optional lhsType_; std::optional procedure_; bool isContiguous_{false}; + bool isVolatile_{false}; }; PointerAssignmentChecker &PointerAssignmentChecker::set_lhs(const Symbol &lhs) { @@ -91,6 +93,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous( return *this; } +PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile( + bool isVolatile) { + isVolatile_ = isVolatile; + return *this; +} + template 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" @@ -180,12 +188,26 @@ void PointerAssignmentChecker::Check(const evaluate::Designator &d) { } 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) { @@ -194,25 +216,60 @@ void PointerAssignmentChecker::Check(const evaluate::Designator &d) { } } +// 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 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); } } @@ -238,6 +295,19 @@ void PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) { 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 parser::Message *PointerAssignmentChecker::Say(A &&... x) { auto *msg{context_.messages().Say(std::forward(x)...)}; @@ -263,6 +333,7 @@ void CheckPointerAssignment( .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); } } @@ -273,6 +344,7 @@ void CheckPointerAssignment(evaluate::FoldingContext &context, 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); } diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index f7dd741..81101b5 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -105,6 +105,7 @@ set(ERROR_TESTS structconst03.f90 structconst04.f90 assign01.f90 + assign02.f90 assign03.f90 if_arith02.f90 if_arith03.f90 diff --git a/flang/test/semantics/assign02.f90 b/flang/test/semantics/assign02.f90 new file mode 100644 index 0000000..89317aa --- /dev/null +++ b/flang/test/semantics/assign02.f90 @@ -0,0 +1,153 @@ +! 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 diff --git a/flang/test/semantics/assign03.f90 b/flang/test/semantics/assign03.f90 index b3d94a6..da8ffcb 100644 --- a/flang/test/semantics/assign03.f90 +++ b/flang/test/semantics/assign03.f90 @@ -1,3 +1,5 @@ +! Pointer assignment constraints 10.2.2.2 (see also assign02.f90) + module m interface subroutine s(i) @@ -6,6 +8,7 @@ module m end interface type :: t procedure(s), pointer, nopass :: p + real, pointer :: q end type contains ! C1027 @@ -16,4 +19,93 @@ contains !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 diff --git a/flang/test/semantics/call09.f90 b/flang/test/semantics/call09.f90 index 596ccc9..06c304a 100644 --- a/flang/test/semantics/call09.f90 +++ b/flang/test/semantics/call09.f90 @@ -38,7 +38,7 @@ module m end function function intprocptr() procedure(intfunc), pointer :: intprocptr - procptr => intfunc + intprocptr => intfunc end function subroutine test1 ! 15.5.2.9(5) diff --git a/flang/test/semantics/procinterface01.f90 b/flang/test/semantics/procinterface01.f90 index 9dfc80b..5ab53d5 100644 --- a/flang/test/semantics/procinterface01.f90 +++ b/flang/test/semantics/procinterface01.f90 @@ -4,18 +4,18 @@ !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 diff --git a/flang/test/semantics/resolve46.f90 b/flang/test/semantics/resolve46.f90 index 0b36f81..8a0385a 100644 --- a/flang/test/semantics/resolve46.f90 +++ b/flang/test/semantics/resolve46.f90 @@ -1,3 +1,4 @@ +! C1030 - pointers to intrinsic procedures program main intrinsic :: cos ! a specific & generic intrinsic name intrinsic :: alog10 ! a specific intrinsic name, not generic @@ -11,9 +12,10 @@ program main 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 diff --git a/flang/test/semantics/symbol17.f90 b/flang/test/semantics/symbol17.f90 index cd8d516..a861e2f 100644 --- a/flang/test/semantics/symbol17.f90 +++ b/flang/test/semantics/symbol17.f90 @@ -21,8 +21,8 @@ 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) -- 2.7.4