|
131
|
1 ! { dg-do compile }
|
|
|
2 module strings
|
|
|
3
|
|
|
4 type string
|
|
|
5 integer :: len = 0, size = 0
|
|
|
6 character, pointer :: chars(:) => null()
|
|
|
7 end type string
|
|
|
8
|
|
|
9 interface length
|
|
|
10 module procedure len_s
|
|
|
11 end interface
|
|
|
12
|
|
|
13 interface char
|
|
|
14 module procedure s_to_c, s_to_slc
|
|
|
15 end interface
|
|
|
16
|
|
|
17 interface uppercase
|
|
|
18 module procedure uppercase_c
|
|
|
19 end interface
|
|
|
20
|
|
|
21 interface replace
|
|
|
22 module procedure replace_ccs
|
|
|
23 end interface
|
|
|
24
|
|
|
25 contains
|
|
|
26
|
|
|
27 elemental function len_s(s)
|
|
|
28 type(string), intent(in) :: s
|
|
|
29 integer :: len_s
|
|
|
30 end function len_s
|
|
|
31
|
|
|
32 pure function s_to_c(s)
|
|
|
33 type(string),intent(in) :: s
|
|
|
34 character(length(s)) :: s_to_c
|
|
|
35 end function s_to_c
|
|
|
36
|
|
|
37 pure function s_to_slc(s,long)
|
|
|
38 type(string),intent(in) :: s
|
|
|
39 integer, intent(in) :: long
|
|
|
40 character(long) :: s_to_slc
|
|
|
41 end function s_to_slc
|
|
|
42
|
|
|
43 pure function lr_sc_s(s,start,ss) result(l)
|
|
|
44 type(string), intent(in) :: s
|
|
|
45 character(*), intent(in) :: ss
|
|
|
46 integer, intent(in) :: start
|
|
|
47 integer :: l
|
|
|
48 end function lr_sc_s
|
|
|
49
|
|
|
50 pure function lr_ccc(s,tgt,ss,action) result(l)
|
|
|
51 character(*), intent(in) :: s,tgt,ss,action
|
|
|
52 integer :: l
|
|
|
53 select case(uppercase(action))
|
|
|
54 case default
|
|
|
55 end select
|
|
|
56 end function lr_ccc
|
|
|
57
|
|
|
58 function replace_ccs(s,tgt,ss) result(r)
|
|
|
59 character(*), intent(in) :: s,tgt
|
|
|
60 type(string), intent(in) :: ss
|
|
|
61 character(lr_ccc(s,tgt,char(ss),'first')) :: r
|
|
|
62 end function replace_ccs
|
|
|
63
|
|
|
64 pure function uppercase_c(c)
|
|
|
65 character(*), intent(in) :: c
|
|
|
66 character(len(c)) :: uppercase_c
|
|
|
67 end function uppercase_c
|
|
|
68
|
|
|
69 end module strings
|
