gcc/testsuite/gfortran.dg/assumed_rank_21.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR98342.
   4 !
   5 ! Contributed by Martin Stein  <mscfd@gmx.net>
   6 !
   7 module mod
   8   implicit none
   9   private
  10   public get_tuple, sel_rank1, sel_rank2, sel_rank3
  11
  12   type, public :: tuple
  13   integer, dimension(:), allocatable :: t
  14 end type tuple
  15
  16 contains
  17
  18 function sel_rank1(x) result(s)
  19   character(len=:), allocatable :: s
  20   type(tuple), dimension(..), intent(in) :: x
  21   select rank (x)
  22     rank (0)
  23       s = '10'
  24     rank (1)
  25       s = '11'
  26     rank default
  27       s = '?'
  28   end select
  29 end function sel_rank1
  30
  31 function sel_rank2(x) result(s)
  32   character(len=:), allocatable :: s
  33   class(tuple), dimension(..), intent(in) :: x
  34   select rank (x)
  35     rank (0)
  36       s = '20'
  37     rank (1)
  38       s = '21'
  39     rank default
  40       s = '?'
  41   end select
  42 end function sel_rank2
  43
  44 function sel_rank3(x) result(s)
  45   character(len=:), allocatable :: s
  46   class(*), dimension(..), intent(in) :: x
  47   select rank (x)
  48     rank (0)
  49       s = '30'
  50     rank (1)
  51       s = '31'
  52     rank default
  53       s = '?'
  54   end select
  55 end function sel_rank3
  56
  57 function get_tuple(t) result(a)
  58   type(tuple) :: a
  59   integer, dimension(:), intent(in) :: t
  60   allocate(a%t, source=t)
  61 end function get_tuple
  62
  63 end module mod
  64
  65
  66 program alloc_rank
  67   use mod
  68   implicit none
  69
  70   integer, dimension(1:3) :: x
  71   character(len=:), allocatable :: output
  72   type(tuple) :: z
  73
  74   x = [1,2,3]
  75   z = get_tuple (x)
  76                                        ! Derived type formal arg
  77   output = sel_rank1(get_tuple (x))    ! runtime: Error in `./alloc_rank.x':
  78   if (output .ne. '10') stop 1
  79   output = sel_rank1([z])              ! This worked OK
  80   if (output .ne. '11') stop 2
  81
  82                                        ! Class formal arg
  83   output = sel_rank2(get_tuple (x))    ! runtime: Error in `./alloc_rank.x':
  84   if (output .ne. '20') stop 3
  85   output = sel_rank2([z])              ! This worked OK
  86   if (output .ne. '21') stop 4
  87
  88                                        ! Unlimited polymorphic formal arg
  89   output = sel_rank3(get_tuple (x))    ! runtime: Error in `./alloc_rank.x':
  90   if (output .ne. '30') stop 5
  91   output = sel_rank3([z])              ! runtime: segmentation fault
  92   if (output .ne. '31') stop 6
  93
  94   deallocate (output)
  95   deallocate (z%t)
  96 end program alloc_rank