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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { dg-do run }
2
!
3
! PR 36322/36463
4
!
5
! Original code by James Van Buskirk.
6
! Modified by Janus Weil 
7
 
8
module m
9
 
10
   use ISO_C_BINDING
11
 
12
   character, allocatable, save :: my_message(:)
13
 
14
   abstract interface
15
      function abs_fun(x)
16
         use ISO_C_BINDING
17
         import my_message
18
         integer(C_INT) x(:)
19
         character(size(my_message),C_CHAR) abs_fun(size(x))
20
      end function abs_fun
21
   end interface
22
 
23
contains
24
 
25
  function foo(y)
26
    implicit none
27
    integer(C_INT) :: y(:)
28
    character(size(my_message),C_CHAR) :: foo(size(y))
29
    integer i,j
30
    do i=1,size(y)
31
      do j=1,size(my_message)
32
        foo(i)(j:j) = achar(iachar(my_message(j))+y(i))
33
      end do
34
    end do
35
  end function
36
 
37
  subroutine check(p,a)
38
    integer a(:)
39
    procedure(abs_fun) :: p
40
    character(size(my_message),C_CHAR) :: c(size(a))
41
    integer k,l,m
42
    c = p(a)
43
    m=iachar('a')
44
    do k=1,size(a)
45
      do l=1,size(my_message)
46
        if (c(k)(l:l) /= achar(m)) call abort()
47
        m = m + 1
48
      end do
49
    end do
50
  end subroutine
51
 
52
end module
53
 
54
program prog
55
 
56
use m
57
 
58
integer :: i(4) = (/0,6,12,18/)
59
 
60
allocate(my_message(1:6))
61
 
62
my_message = (/'a','b','c','d','e','f'/)
63
 
64
call check(foo,i)
65
 
66
end program
67
 
68
! { dg-final { cleanup-modules "m" } }

powered by: WebSVN 2.1.0

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