gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fcoarray=lib -fdump-tree-original" }
   3 !
   4 ! Check whether TOKEN and OFFSET are correctly propagated
   5 !
   6
   7 ! THIS PART FAILED (ICE) DUE TO TYPE SHARING
   8
   9 module matrix_data
  10    implicit none
  11    type sparse_CSR_matrix
  12       integer, allocatable :: a(:)
  13    end type sparse_CSR_matrix
  14 CONTAINS
  15
  16 subroutine build_CSR_matrix(CSR)
  17    type(sparse_CSR_matrix), intent(out) :: CSR
  18    integer, allocatable :: CAF_begin[:]
  19    call global_to_local_index(CAF_begin)
  20 end subroutine build_CSR_matrix
  21
  22 subroutine global_to_local_index(CAF_begin)
  23    integer, intent(out) :: CAF_begin[*]
  24 end subroutine  global_to_local_index
  25
  26 end module matrix_data
  27
  28
  29 ! DUMP TESTING
  30
  31 program main
  32   implicit none
  33   type t
  34     integer(4) :: a, b
  35   end type t
  36   integer, allocatable :: caf[:]
  37   type(t), allocatable :: caf_dt[:]
  38
  39   allocate (caf[*])
  40   allocate (caf_dt[*])
  41
  42   caf = 42
  43   caf_dt = t (1,2)
  44   call sub (caf, caf_dt%b)
  45   print *,caf, caf_dt%b
  46   if (caf /= -99 .or. caf_dt%b /= -101) call abort ()
  47   call sub_opt ()
  48   call sub_opt (caf)
  49   if (caf /= 124) call abort ()
  50 contains
  51
  52   subroutine sub (x1, x2)
  53     integer :: x1[*], x2[*]
  54     call sub2 (x1, x2)
  55   end subroutine sub
  56
  57   subroutine sub2 (y1, y2)
  58     integer :: y1[*], y2[*]
  59
  60     print *, y1, y2
  61     if (y1 /= 42 .or. y2 /= 2) call abort ()
  62     y1 = -99
  63     y2 = -101
  64   end subroutine sub2
  65
  66   subroutine sub_opt (z)
  67     integer, optional :: z[*]
  68     if (present (z)) then
  69       if (z /= -99) call abort ()
  70       z = 124
  71     end if
  72   end subroutine sub_opt
  73
  74 end program main
  75
  76 ! SCAN TREE DUMP AND CLEANUP
  77 !
  78 ! PROTOTYPE 1:
  79 !
  80 ! sub (integer(kind=4) * restrict x1, integer(kind=4) * restrict x2,
  81 !      void * restrict caf_token.4, integer(kind=8) caf_offset.5,
  82 !      void * restrict caf_token.6, integer(kind=8) caf_offset.7)
  83 !
  84 ! { dg-final { scan-tree-dump-times "sub \\(integer.kind=4. . restrict x1, integer.kind=4. . restrict x2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original" } }
  85 !
  86 ! PROTOTYPE 2:
  87 !
  88 ! sub2 (integer(kind=4) * restrict y1, integer(kind=4) * restrict y2,
  89 !       void * restrict caf_token.0, integer(kind=8) caf_offset.1,
  90 !       void * restrict caf_token.2, integer(kind=8) caf_offset.3)
  91 !
  92 ! { dg-final { scan-tree-dump-times "sub2 \\(integer.kind=4. . restrict y1, integer.kind=4. . restrict y2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original" } }
  93 !
  94 ! CALL 1
  95 !
  96 !  sub ((integer(kind=4) *) caf.data, &((struct t * restrict) caf_dt.data)->b,
  97 !       caf.token, 0, caf_dt.token, 4);
  98 !
  99 ! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf.data, &\[^,\]*caf_dt.data.->b, caf.token, 0, caf_dt.token, 4\\)" 1 "original" } }
 100 !
 101 !  sub2 ((integer(kind=4) *) x1, (integer(kind=4) *) x2,
 102 !        caf_token.4, NON_LVALUE_EXPR <caf_offset.5>,
 103 !        caf_token.6, NON_LVALUE_EXPR <caf_offset.7>);
 104 !
 105 ! { dg-final { scan-tree-dump-times "sub2 \\(\[^,\]*x1, \[^,\]*x2, caf_token.\[0-9]+, \[^,\]*caf_offset\[^,\]*, caf_token.\[0-9\]+, \[^,\]*caf_offset\[^,\]*\\)" 1 "original" } }
 106 !
 107 ! CALL 3
 108 !
 109 ! { dg-final { scan-tree-dump-times "sub_opt \\(0B, 0B, 0\\)" 1 "original" } }
 110 !
 111 ! CALL 4
 112 !
 113 ! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf.data, caf.token, 0\\)" 1 "original" } }
 114 !
 115 ! { dg-final { cleanup-tree-dump "original" } }