gcc/testsuite/gfortran.dg/impure_assignment_2.f90

   1 ! { dg-do compile }
   2 ! Tests the fix for PR20863 and PR20882, which were concerned with incorrect
   3 ! application of constraints associated with "impure" variables in PURE
   4 ! procedures.
   5 !
   6 ! resolve.c (gfc_impure_variable) detects the following:
   7 ! 12.6 Constraint: In a pure subprogram any variable which is in common or
   8 ! accessed by host or use association, is a dummy argument to a pure function,
   9 ! is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
  10 ! is storage associated with any such variable, shall not be used in the
  11 ! following contexts: (clients of this function).  */
  12 !
  13 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
  14 !
  15 MODULE pr20863
  16  TYPE node_type
  17   TYPE(node_type), POINTER :: next=>null()
  18  END TYPE
  19 CONTAINS
  20 ! Original bug - pointer assignments to "impure" derived type with
  21 ! pointer component.
  22   PURE FUNCTION give_next1(node)
  23      TYPE(node_type), POINTER :: node
  24      TYPE(node_type), POINTER :: give_next
  25      give_next => node%next ! { dg-error "Bad target" }
  26      node%next => give_next ! { dg-error "Bad pointer object" }
  27   END FUNCTION
  28 ! Comment #2
  29   PURE integer FUNCTION give_next2(i)
  30      TYPE node_type
  31        sequence
  32        TYPE(node_type), POINTER :: next
  33      END TYPE
  34      TYPE(node_type), POINTER :: node
  35      TYPE(node_type), target  :: t
  36      integer, intent(in)      :: i
  37      node%next = t          ! This is OK
  38      give_next2 = i
  39   END FUNCTION
  40   PURE FUNCTION give_next3(node)
  41      TYPE(node_type), intent(in) :: node
  42      TYPE(node_type) :: give_next
  43      give_next = node ! { dg-error "impure variable" }
  44   END FUNCTION
  45 END MODULE pr20863
  46
  47 MODULE pr20882
  48   TYPE T1
  49     INTEGER :: I
  50   END TYPE T1
  51   TYPE(T1), POINTER :: B
  52 CONTAINS
  53   PURE FUNCTION TST(A) RESULT(RES)
  54     TYPE(T1), INTENT(IN), TARGET :: A
  55     TYPE(T1), POINTER :: RES
  56     RES => A  ! { dg-error "Bad target" }
  57     RES => B  ! { dg-error "Bad target" }
  58     B => RES  ! { dg-error "Bad pointer object" }
  59   END FUNCTION
  60   PURE FUNCTION TST2(A) RESULT(RES)
  61     TYPE(T1), INTENT(IN), TARGET :: A
  62     TYPE(T1), POINTER :: RES
  63     allocate (RES)
  64     RES = A
  65     B = RES  ! { dg-error "Cannot assign" }
  66     RES = B
  67   END FUNCTION
  68 END MODULE pr20882
  69 ! { dg-final { cleanup-modules "pr20863 pr20882" } }
  70