gcc/testsuite/gfortran.dg/PR94110.f90

   1 ! { dg-do compile }
   2 !
   3 ! Test the fix for PR94110
   4 !
   5
   6 program asa_p
   7
   8   implicit none
   9
  10   integer, parameter :: n = 7
  11
  12   type t
  13   end type t
  14
  15   interface
  16     subroutine fc2 (x)
  17       import :: t
  18       class(t), pointer, intent(in) :: x(..)
  19     end subroutine
  20   end interface
  21
  22   integer :: p(n)
  23   integer :: s
  24
  25   p = 1
  26   s = sumf_as(p)
  27   if (s/=n) stop 1
  28   s = sumf_ar(p)
  29   if (s/=n) stop 2
  30   stop
  31
  32 contains
  33
  34   function sumf_as(a) result(s)
  35     integer, target, intent(in) :: a(*)
  36
  37     integer :: s
  38
  39     s = sum_as(a)   ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
  40     s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
  41     s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
  42     return
  43   end function sumf_as
  44
  45   function sumf_ar(a) result(s)
  46     integer, target, intent(in) :: a(..)
  47
  48     integer :: s
  49
  50     select rank(a)
  51     rank(*)
  52       s = sum_as(a)   ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
  53       s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
  54       s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
  55     rank default
  56       stop 3
  57     end select
  58     return
  59   end function sumf_ar
  60
  61   function sum_as(a) result(s)
  62     integer, intent(in) :: a(:)
  63
  64     integer :: s
  65
  66     s = sum(a)
  67     return
  68   end function sum_as
  69
  70   function sum_p_ds(a) result(s)
  71     integer, pointer, intent(in) :: a(:)
  72
  73     integer :: s
  74
  75     s = -1
  76     if(associated(a))&
  77       s = sum(a)
  78     return
  79   end function sum_p_ds
  80
  81   function sum_p_ar(a) result(s)
  82     integer, pointer, intent(in) :: a(..)
  83
  84     integer :: s
  85
  86     s = -1
  87     select rank(a)
  88     rank(1)
  89       if(associated(a))&
  90         s = sum(a)
  91     rank default
  92       stop 4
  93     end select
  94     return
  95   end function sum_p_ar
  96
  97   subroutine sub1(y)
  98     type(t), target :: y(*)
  99     call fc2 (y) ! { dg-error "Actual argument for .x. cannot be an assumed-size array" }
 100   end subroutine sub1
 101
 102 end program asa_p
 103