gcc/testsuite/gfortran.dg/select_type_37.f03

   1 ! { dg-do run }
   2 !
   3 ! Checks the fix for PR69556 in which using implicit function results
   4 ! in SELECT TYPE caused all sorts of problems, especially in the form
   5 ! in 'return_pointer1' with "associate_name => selector". The original
   6 ! PR is encapsulated in 'return_pointer'. Explicit results, such as in
   7 ! 'return_pointer2' always worked.
   8 !
   9 ! Contributed by James Greenhalgh  <jgreenhalgh@gcc.gnu.org>
  10 !
  11 program pr69556
  12   class(*), pointer :: ptr(:)
  13   character(40) :: buffer1, buffer2
  14   real :: cst1(2) = [1.0, 2.0]
  15   real :: cst2(2) = [3.0, 4.0]
  16   real :: cst3(2) = [5.0, 6.0]
  17
  18   write (buffer1, *) cst1
  19   if (.not.associated(return_pointer1(cst1))) STOP 1
  20   if (trim (buffer1) .ne. trim (buffer2)) STOP 2
  21   select type (ptr)
  22     type is (real)
  23       if (any (ptr .ne. cst2)) STOP 3
  24   end select
  25   deallocate (ptr)
  26
  27   write (buffer1, *) cst2
  28   if (.not.associated(return_pointer(cst2))) STOP 4
  29   if (trim (buffer1) .ne. trim (buffer2)) STOP 5
  30   select type (ptr)
  31     type is (real)
  32       if (any (ptr .ne. cst3)) STOP 6
  33   end select
  34   deallocate (ptr)
  35
  36   write (buffer1, *) cst1
  37   if (.not.associated(return_pointer2(cst1))) STOP 7
  38   if (trim (buffer1) .ne. trim (buffer2)) STOP 8
  39   select type (ptr)
  40     type is (real)
  41       if (any (ptr .ne. cst2)) STOP 9
  42   end select
  43   deallocate (ptr)
  44
  45 contains
  46
  47   function return_pointer2(arg) result (res) ! Explicit result always worked.
  48     class(*), pointer :: res(:)
  49     real, intent(inout) :: arg(:)
  50     allocate (res, source = arg)
  51     ptr => res                               ! Check association and cleanup
  52     select type (z => res)
  53       type is (real(4))
  54         write (buffer2, *) z                 ! Check associate expression is OK.
  55         z = cst2                             ! Check associate is OK for lvalue.
  56     end select
  57   end function
  58
  59   function return_pointer1(arg)
  60     class(*), pointer :: return_pointer1(:)
  61     real, intent(inout) :: arg(:)
  62     allocate (return_pointer1, source = arg)
  63     ptr => return_pointer1
  64     select type (z => return_pointer1) ! This caused a segfault in compilation.
  65       type is (real(4))
  66         write (buffer2, *) z
  67         z = cst2
  68     end select
  69   end function
  70
  71   function return_pointer(arg) ! The form in the PR.
  72     class(*), pointer :: return_pointer(:)
  73     real, intent(inout) :: arg(:)
  74     allocate (return_pointer, source = cst2)
  75     ptr => return_pointer
  76     select type (return_pointer)
  77       type is (real(4)) ! Associate-name ‘__tmp_REAL_4’ at (1) is used as array
  78         write (buffer2, *) return_pointer
  79         return_pointer = cst3
  80     end select
  81   end function
  82 end program
  83