OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [pointer_check_5.f90] - Blame information for rev 694

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { dg-do run }
2
! { dg-options "-fcheck=pointer" }
3
! { dg-shouldfail "Unassociated/unallocated actual argument" }
4
!
5
! { dg-output ".*At line 46 .*Pointer actual argument 'getptr' is not associated" }
6
!
7
! PR fortran/40580
8
!
9
! Run-time check of passing deallocated/nonassociated actuals
10
! to nonallocatable/nonpointer dummies.
11
!
12
! Check for function actuals
13
!
14
 
15
subroutine test1(a)
16
  integer :: a
17
  print *, a
18
end subroutine test1
19
 
20
subroutine test2(a)
21
  integer :: a(2)
22
  print *, a
23
end subroutine test2
24
 
25
subroutine ppTest(f)
26
  implicit none
27
  external f
28
  call f()
29
end subroutine ppTest
30
 
31
Program RunTimeCheck
32
  implicit none
33
  external :: test1, test2, ppTest
34
  procedure(), pointer :: pptr
35
 
36
  ! OK
37
  call test1(getPtr(.true.))
38
  call test2(getPtrArray(.true.))
39
  call test2(getAlloc(.true.))
40
 
41
  ! OK but fails due to PR 40593
42
!  call ppTest(getProcPtr(.true.))
43
!  call ppTest2(getProcPtr(.true.))
44
 
45
  ! Invalid:
46
  call test1(getPtr(.false.))
47
!  call test2(getAlloc(.false.)) - fails because the check is inserted after
48
!                                  _gfortran_internal_pack, which fails with out of memory
49
!  call ppTest(getProcPtr(.false.)) - fails due to PR 40593
50
!  call ppTest2(getProcPtr(.false.)) - fails due to PR 40593
51
 
52
contains
53
  function getPtr(alloc)
54
    integer, pointer :: getPtr
55
    logical, intent(in) :: alloc
56
    if (alloc) then
57
      allocate (getPtr)
58
      getPtr = 1
59
    else
60
      nullify (getPtr)
61
    end if
62
  end function getPtr
63
  function getPtrArray(alloc)
64
    integer, pointer :: getPtrArray(:)
65
    logical, intent(in) :: alloc
66
    if (alloc) then
67
      allocate (getPtrArray(2))
68
      getPtrArray = 1
69
    else
70
      nullify (getPtrArray)
71
    end if
72
  end function getPtrArray
73
  function getAlloc(alloc)
74
    integer, allocatable :: getAlloc(:)
75
    logical, intent(in) :: alloc
76
    if (alloc) then
77
      allocate (getAlloc(2))
78
      getAlloc = 2
79
    else if (allocated(getAlloc)) then
80
      deallocate(getAlloc)
81
    end if
82
  end function getAlloc
83
  subroutine sub()
84
    print *, 'Hello World'
85
  end subroutine sub
86
  function getProcPtr(alloc)
87
    procedure(sub), pointer :: getProcPtr
88
    logical, intent(in) :: alloc
89
    if (alloc) then
90
      getProcPtr => sub
91
    else
92
      nullify (getProcPtr)
93
    end if
94
  end function getProcPtr
95
  subroutine ppTest2(f)
96
    implicit none
97
    procedure(sub) :: f
98
    call f()
99
  end subroutine ppTest2
100
end Program RunTimeCheck

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.