impure_assignment_2.f90

来自「用于进行gcc测试」· F90 代码 · 共 71 行

! { dg-do compile }
! Tests the fix for PR20863 and PR20882, which were concerned with incorrect
! application of constraints associated with "impure" variables in PURE
! procedures.
!
! resolve.c (gfc_impure_variable) detects the following: 
! 12.6 Constraint: In a pure subprogram any variable which is in common or
! accessed by host or use association, is a dummy argument to a pure function,
! is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
! is storage associated with any such variable, shall not be used in the
! following contexts: (clients of this function).  */
!
! Contributed by Joost VandeVondele <[e-mail]>
!
MODULE pr20863
 TYPE node_type
  TYPE(node_type), POINTER :: next=>null()
 END TYPE
CONTAINS
! Original bug - pointer assignments to "impure" derived type with
! pointer component.
  PURE FUNCTION give_next1(node)
     TYPE(node_type), POINTER :: node
     TYPE(node_type), POINTER :: give_next
     give_next => node%next ! { dg-error "Bad target" }
     node%next => give_next ! { dg-error "Bad pointer object" }
  END FUNCTION
! Comment #2
  PURE integer FUNCTION give_next2(i)
     TYPE node_type
       sequence
       TYPE(node_type), POINTER :: next
     END TYPE
     TYPE(node_type), POINTER :: node
     TYPE(node_type), target  :: t
     integer, intent(in)      :: i
     node%next = t          ! This is OK
     give_next2 = i
  END FUNCTION
  PURE FUNCTION give_next3(node)
     TYPE(node_type), intent(in) :: node
     TYPE(node_type) :: give_next
     give_next = node ! { dg-error "impure variable" }
  END FUNCTION
END MODULE pr20863

MODULE pr20882
  TYPE T1
    INTEGER :: I
  END TYPE T1
  TYPE(T1), POINTER :: B
CONTAINS
  PURE FUNCTION TST(A) RESULT(RES)
    TYPE(T1), INTENT(IN), TARGET :: A
    TYPE(T1), POINTER :: RES
    RES => A  ! { dg-error "Bad target" }
    RES => B  ! { dg-error "Bad target" }
    B => RES  ! { dg-error "Bad pointer object" }
  END FUNCTION
  PURE FUNCTION TST2(A) RESULT(RES)
    TYPE(T1), INTENT(IN), TARGET :: A
    TYPE(T1), POINTER :: RES
    allocate (RES)
    RES = A
    B = RES  ! { dg-error "Cannot assign" }
    RES = B
  END FUNCTION
END MODULE pr20882
! { dg-final { cleanup-modules "pr20863 pr20882" } }