127 lines · plain
1! Test analysis of character procedure pointer assignments inside FORALL.2! Character procedure gets their own tests because they are tracked differently3! in FIR because of the length of the function result.4 5! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \6! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only -I nw %s 2>&1 | FileCheck %s7! REQUIRES: asserts8 9module char_proc_ptr_forall10 type :: t11 procedure(f1), nopass, pointer :: p12 end type13contains14 pure character(2) function f1()15 f1 = "01"16 end function17 pure character(2) function f2()18 f2 = "02"19 end function20 pure character(2) function f3()21 f3 = "03"22 end function23 pure character(2) function f4()24 f4 = "04"25 end function26 pure character(2) function f5()27 f5 = "05"28 end function29 pure character(2) function f6()30 f6 = "06"31 end function32 pure character(2) function f7()33 f7 = "07"34 end function35 pure character(2) function f8()36 f8 = "08"37 end function38 pure character(2) function f9()39 f9 = "09"40 end function41 pure character(2) function f10()42 f10 = "10"43 end function44 45 integer pure function decode(c)46 character(2), intent(in) :: c47 decode = modulo(iachar(c(2:2))-49,10)+148 end function49 50 subroutine test_no_conflict(x)51 type(t) :: x(10)52 forall(i=1:10) x(i)%p => f153 end subroutine54! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_no_conflict ------------55! CHECK-NEXT: run 1 evaluate: forall/region_assign156 57 subroutine test_need_to_save_rhs(x)58 type(t) :: x(10)59 forall(i=1:10) x(i)%p => x(11-i)%p60 end subroutine61! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_rhs ------------62! CHECK-NEXT: conflict: R/W63! CHECK-NEXT: run 1 save : forall/region_assign1/rhs64! CHECK-NEXT: run 2 evaluate: forall/region_assign165 66 subroutine test_need_to_save_lhs(x)67 type(t) :: x(10)68 forall(i=1:10) x(decode(x(11-i)%p()))%p => f169 end subroutine70! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_lhs ------------71! CHECK: conflict: R/W72! CHECK-NEXT: run 1 save : forall/region_assign1/lhs73! CHECK-NEXT: run 2 evaluate: forall/region_assign174 75 subroutine test_need_to_save_lhs_and_rhs(x)76 type(t) :: x(10)77 forall(i=1:10) x(decode(x(11-i)%p()))%p => x(modulo(-2*i, 11))%p78 end subroutine79! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_lhs_and_rhs ------------80! CHECK: conflict: R/W81! CHECK-NEXT: run 1 save : forall/region_assign1/rhs82! CHECK: conflict: R/W83! CHECK-NEXT: run 1 save : forall/region_assign1/lhs84! CHECK-NEXT: run 2 evaluate: forall/region_assign185 86 87! End-to-end test utilities for debugging purposes.88 89 subroutine reset(a)90 type(t) :: a(:)91 a = [t(f10), t(f9), t(f8), t(f7), t(f6), t(f5), t(f4), t(f3), t(f2), t(f1)]92 end subroutine93 94 subroutine print(a)95 type(t) :: a(:)96 print *, [(decode(a(i)%p()), i=1,10)]97 end subroutine98 99 logical function check_equal(a, expected)100 type(t) :: a(:)101 integer :: expected(:)102 check_equal = all([(decode(a(i)%p()), i=1,10)].eq.expected)103 if (.not.check_equal) then104 print *, "expected:", expected105 print *, "got:", [(decode(a(i)%p()), i=1,10)]106 end if107 end function108end module109 110! End-to-end test for debugging purposes (not verified by lit).111 use char_proc_ptr_forall112 type(t) :: a(10)113 114 call reset(a)115 call test_need_to_save_rhs(a)116 if (.not.check_equal(a, [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])) stop 1117 118 call reset(a)119 call test_need_to_save_lhs(a)120 if (.not.check_equal(a, [1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) stop 2121 122 call reset(a)123 call test_need_to_save_lhs_and_rhs(a)124 if (.not.check_equal(a, [2, 4, 6, 8, 10, 1, 3, 5, 7, 9])) stop 3125 print *, "PASS"126end127