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))) call abort
  20   if (trim (buffer1) .ne. trim (buffer2)) call abort
  21   select type (ptr)
  22     type is (real)
  23       if (any (ptr .ne. cst2)) call abort
  24   end select
  25   deallocate (ptr)
  26
  27   write (buffer1, *) cst2
  28   if (.not.associated(return_pointer(cst2))) call abort
  29   if (trim (buffer1) .ne. trim (buffer2)) call abort
  30   select type (ptr)
  31     type is (real)
  32       if (any (ptr .ne. cst3)) call abort
  33   end select
  34   deallocate (ptr)
  35
  36   write (buffer1, *) cst1
  37   if (.not.associated(return_pointer2(cst1))) call abort
  38   if (trim (buffer1) .ne. trim (buffer2)) call abort
  39   select type (ptr)
  40     type is (real)
  41       if (any (ptr .ne. cst2)) call abort
  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