gcc/testsuite/gfortran.dg/assumed_rank_9.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources assumed_rank_8_c.c }
   3 !
   4 ! PR fortran/48820
   5 !
   6 ! Scalars to assumed-rank tests
   7 !
   8 program main
   9   implicit none
  10
  11   type t
  12     integer :: i
  13   end type t
  14
  15   interface
  16     subroutine check (x)
  17       integer :: x(..)
  18     end subroutine check
  19     subroutine check2 (x)
  20       import t
  21       class(t) :: x(..)
  22     end subroutine check2
  23   end interface
  24
  25   integer :: j
  26
  27   type(t), target :: y
  28   class(t), allocatable, target :: yac
  29
  30   y%i = 489
  31   allocate (yac)
  32   yac%i = 489
  33   j = 0
  34   call fc()
  35   call fc(null())
  36   call fc(y)
  37   call fc(yac)
  38   if (j /= 2) call abort ()
  39
  40   j = 0
  41   call gc(null())
  42   call gc(y)
  43   call gc(yac)
  44   deallocate (yac)
  45   call gc(yac)
  46   if (j /= 2) call abort ()
  47
  48   j = 0
  49   call hc(yac)
  50   allocate (yac)
  51   yac%i = 489
  52   call hc(yac)
  53   if (j /= 1) call abort ()
  54
  55   j = 0
  56   call ft()
  57   call ft(null())
  58   call ft(y)
  59   call ft(yac)
  60   if (j /= 2) call abort ()
  61
  62   j = 0
  63   call gt(null())
  64   call gt(y)
  65   call gt(yac)
  66   deallocate (yac)
  67   call gt(yac)
  68   if (j /= 2) call abort ()
  69
  70   j = 0
  71   call ht(yac)
  72   allocate (yac)
  73   yac%i = 489
  74   call ht(yac)
  75   if (j /= 1) call abort ()
  76
  77 contains
  78
  79   subroutine fc (x)
  80     class(t), optional :: x(..)
  81
  82     if (.not. present (x)) return
  83     if (.not. SAME_TYPE_AS (x, yac)) call abort ()
  84     if (rank (x) /= 0) call abort
  85     call check2 (x)
  86     j = j + 1
  87   end subroutine
  88
  89   subroutine gc (x)
  90     class(t), pointer, intent(in) :: x(..)
  91
  92     if (.not. associated (x)) return
  93     if (.not. SAME_TYPE_AS (x, yac)) call abort ()
  94     if (rank (x) /= 0) call abort ()
  95     call check2 (x)
  96     j = j + 1
  97   end subroutine
  98
  99   subroutine hc (x)
 100     class(t), allocatable :: x(..)
 101
 102     if (.not. allocated (x)) return
 103     if (.not. SAME_TYPE_AS (x, yac)) call abort ()
 104     if (rank (x) /= 0) call abort
 105     call check2 (x)
 106     j = j + 1
 107   end subroutine
 108
 109   subroutine ft (x)
 110     type(t), optional :: x(..)
 111
 112     if (.not. present (x)) return
 113     if (.not. SAME_TYPE_AS (x, yac)) call abort ()
 114     if (rank (x) /= 0) call abort
 115     call check2 (x)
 116     j = j + 1
 117   end subroutine
 118
 119   subroutine gt (x)
 120     type(t), pointer, intent(in) :: x(..)
 121
 122     if (.not. associated (x)) return
 123     if (.not. SAME_TYPE_AS (x, yac)) call abort ()
 124     if (rank (x) /= 0) call abort ()
 125     call check2 (x)
 126     j = j + 1
 127   end subroutine
 128
 129   subroutine ht (x)
 130     type(t), allocatable :: x(..)
 131
 132     if (.not. allocated (x)) return
 133     if (.not. SAME_TYPE_AS (x, yac)) call abort ()
 134     if (rank (x) /= 0) call abort
 135     call check2 (x)
 136     j = j + 1
 137   end subroutine
 138
 139 end program main