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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [allocate_deferred_char_scalar_1.f03] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn 
! { dg-do run }
2 
!
3 
! Automatic reallocate on assignment, deferred length parameter for char
4 
!
5 
! PR fortran/45170
6 
! PR fortran/35810
7 
! PR fortran/47350
8 
!
9 
! Contributed by Tobias Burnus
10 
!
11 
program test
12 
  implicit none
13 
  call mold_check()
14 
  call mold_check4()
15 
  call source_check()
16 
  call source_check4()
17 
  call ftn_test()
18 
  call ftn_test4()
19 
  call source3()
20 
contains
21 
  subroutine source_check()
22 
    character(len=:), allocatable :: str, str2
23 
    target :: str
24 
    character(len=8) :: str3
25 
    character(len=:), pointer :: str4, str5
26 
    nullify(str4)
27 
    str3 = 'AbCdEfGhIj'
28 
    if(allocated(str)) call abort()
29 
    allocate(str, source=str3)
30 
    if(.not.allocated(str)) call abort()
31 
    if(len(str) /= 8) call abort()
32 
    if(str /= 'AbCdEfGh') call abort()
33 
    if(associated(str4)) call abort()
34 
    str4 => str
35 
    if(str4 /= str .or. len(str4)/=8) call abort()
36 
    if(.not.associated(str4, str)) call abort()
37 
    str4 => null()
38 
    str = '12a56b78'
39 
    if(str4 == '12a56b78') call abort()
40 
    str4 = 'ABCDEFGH'
41 
    if(str == 'ABCDEFGH') call abort()
42 
    allocate(str5, source=str)
43 
    if(associated(str5, str)) call abort()
44 
    if(str5 /= '12a56b78' .or. len(str5)/=8) call abort()
45 
    str = 'abcdef'
46 
    if(str5 == 'abcdef') call abort()
47 
    str5 = 'ABCDEF'
48 
    if(str == 'ABCDEF') call abort()
49 
  end subroutine source_check
50 
  subroutine source_check4()
51 
    character(kind=4,len=:), allocatable :: str, str2
52 
    target :: str
53 
    character(kind=4,len=8) :: str3
54 
    character(kind=4,len=:), pointer :: str4, str5
55 
    nullify(str4)
56 
    str3 = 4_'AbCdEfGhIj'
57 
    if(allocated(str)) call abort()
58 
    allocate(str, source=str3)
59 
    if(.not.allocated(str)) call abort()
60 
    if(len(str) /= 8) call abort()
61 
    if(str /= 4_'AbCdEfGh') call abort()
62 
    if(associated(str4)) call abort()
63 
    str4 => str
64 
    if(str4 /= str .or. len(str4)/=8) call abort()
65 
    if(.not.associated(str4, str)) call abort()
66 
    str4 => null()
67 
    str = 4_'12a56b78'
68 
    if(str4 == 4_'12a56b78') call abort()
69 
    str4 = 4_'ABCDEFGH'
70 
    if(str == 4_'ABCDEFGH') call abort()
71 
    allocate(str5, source=str)
72 
    if(associated(str5, str)) call abort()
73 
    if(str5 /= 4_'12a56b78' .or. len(str5)/=8) call abort()
74 
    str = 4_'abcdef'
75 
    if(str5 == 4_'abcdef') call abort()
76 
    str5 = 4_'ABCDEF'
77 
    if(str == 4_'ABCDEF') call abort()
78 
  end subroutine source_check4
79 
  subroutine mold_check()
80 
    character(len=:), allocatable :: str, str2
81 
    character(len=8) :: str3
82 
    character(len=:), pointer :: str4, str5
83 
    nullify(str4)
84 
    str2 = "ABCE"
85 
    ALLOCATE( str, MOLD=str3)
86 
    if (len(str) /= 8) call abort()
87 
    DEALLOCATE(str)
88 
    ALLOCATE( str, MOLD=str2)
89 
    if (len(str) /= 4) call abort()
90 
 
91 
    IF (associated(str4)) call abort()
92 
    ALLOCATE( str4, MOLD=str3)
93 
    IF (.not.associated(str4)) call abort()
94 
    str4 = '12345678'
95 
    if (len(str4) /= 8) call abort()
96 
    if(str4 /= '12345678') call abort()
97 
    DEALLOCATE(str4)
98 
    ALLOCATE( str4, MOLD=str2)
99 
    str4 = 'ABCD'
100 
    if (len(str4) /= 4) call abort()
101 
    if (str4 /= 'ABCD') call abort()
102 
    str5 => str4
103 
    if(.not.associated(str4,str5)) call abort()
104 
    if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort()
105 
    if(str5 /= str4) call abort()
106 
    deallocate(str4)
107 
  end subroutine mold_check
108 
  subroutine mold_check4()
109 
    character(len=:,kind=4), allocatable :: str, str2
110 
    character(len=8,kind=4) :: str3
111 
    character(len=:,kind=4), pointer :: str4, str5
112 
    nullify(str4)
113 
    str2 = 4_"ABCE"
114 
    ALLOCATE( str, MOLD=str3)
115 
    if (len(str) /= 8) call abort()
116 
    DEALLOCATE(str)
117 
    ALLOCATE( str, MOLD=str2)
118 
    if (len(str) /= 4) call abort()
119 
 
120 
    IF (associated(str4)) call abort()
121 
    ALLOCATE( str4, MOLD=str3)
122 
    IF (.not.associated(str4)) call abort()
123 
    str4 = 4_'12345678'
124 
    if (len(str4) /= 8) call abort()
125 
    if(str4 /= 4_'12345678') call abort()
126 
    DEALLOCATE(str4)
127 
    ALLOCATE( str4, MOLD=str2)
128 
    str4 = 4_'ABCD'
129 
    if (len(str4) /= 4) call abort()
130 
    if (str4 /= 4_'ABCD') call abort()
131 
    str5 => str4
132 
    if(.not.associated(str4,str5)) call abort()
133 
    if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort()
134 
    if(str5 /= str4) call abort()
135 
    deallocate(str4)
136 
  end subroutine mold_check4
137 
  subroutine ftn_test()
138 
    character(len=:), allocatable :: str_a
139 
    character(len=:), pointer     :: str_p
140 
    nullify(str_p)
141 
    call proc_test(str_a, str_p, .false.)
142 
    if (str_p /= '123457890abcdef') call abort()
143 
    if (len(str_p) /= 50) call abort()
144 
    if (str_a(1:5) /= 'ABCDE ') call abort()
145 
    if (len(str_a) /= 50) call abort()
146 
    deallocate(str_p)
147 
    str_a = '1245'
148 
    if(len(str_a) /= 4) call abort()
149 
    if(str_a /= '1245') call abort()
150 
    allocate(character(len=6) :: str_p)
151 
    if(len(str_p) /= 6) call abort()
152 
    str_p = 'AbCdEf'
153 
    call proc_test(str_a, str_p, .true.)
154 
    if (str_p /= '123457890abcdef') call abort()
155 
    if (len(str_p) /= 50) call abort()
156 
    if (str_a(1:5) /= 'ABCDE ') call abort()
157 
    if (len(str_a) /= 50) call abort()
158 
    deallocate(str_p)
159 
  end subroutine ftn_test
160 
  subroutine proc_test(a, p, alloc)
161 
    character(len=:), allocatable :: a
162 
    character(len=:), pointer     :: p
163 
    character(len=5), target :: loc
164 
    logical :: alloc
165 
    if (.not.  alloc) then
166 
      if(associated(p)) call abort()
167 
      if(allocated(a)) call abort()
168 
    else
169 
      if(len(a) /= 4) call abort()
170 
      if(a /= '1245') call abort()
171 
      if(len(p) /= 6) call abort()
172 
      if(p /= 'AbCdEf') call abort()
173 
      deallocate(a)
174 
      nullify(p)
175 
    end if
176 
    allocate(character(len=50) :: a)
177 
    a(1:5) = 'ABCDE'
178 
    if(len(a) /= 50) call abort()
179 
    if(a(1:5) /= "ABCDE") call abort()
180 
    loc = '12345'
181 
    p => loc
182 
    if (len(p) /= 5) call abort()
183 
    if (p /= '12345') call abort()
184 
    p = '12345679'
185 
    if (len(p) /= 5) call abort()
186 
    if (p /= '12345') call abort()
187 
    p = 'ABC'
188 
    if (loc /= 'ABC  ') call abort()
189 
    allocate(p, mold=a)
190 
    if (.not.associated(p)) call abort()
191 
    p = '123457890abcdef'
192 
    if (p /= '123457890abcdef') call abort()
193 
    if (len(p) /= 50) call abort()
194 
  end subroutine proc_test
195 
  subroutine ftn_test4()
196 
    character(len=:,kind=4), allocatable :: str_a
197 
    character(len=:,kind=4), pointer     :: str_p
198 
    nullify(str_p)
199 
    call proc_test4(str_a, str_p, .false.)
200 
    if (str_p /= 4_'123457890abcdef') call abort()
201 
    if (len(str_p) /= 50) call abort()
202 
    if (str_a(1:5) /= 4_'ABCDE ') call abort()
203 
    if (len(str_a) /= 50) call abort()
204 
    deallocate(str_p)
205 
    str_a = 4_'1245'
206 
    if(len(str_a) /= 4) call abort()
207 
    if(str_a /= 4_'1245') call abort()
208 
    allocate(character(len=6, kind = 4) :: str_p)
209 
    if(len(str_p) /= 6) call abort()
210 
    str_p = 4_'AbCdEf'
211 
    call proc_test4(str_a, str_p, .true.)
212 
    if (str_p /= 4_'123457890abcdef') call abort()
213 
    if (len(str_p) /= 50) call abort()
214 
    if (str_a(1:5) /= 4_'ABCDE ') call abort()
215 
    if (len(str_a) /= 50) call abort()
216 
    deallocate(str_p)
217 
  end subroutine ftn_test4
218 
  subroutine proc_test4(a, p, alloc)
219 
    character(len=:,kind=4), allocatable :: a
220 
    character(len=:,kind=4), pointer     :: p
221 
    character(len=5,kind=4), target :: loc
222 
    logical :: alloc
223 
    if (.not.  alloc) then
224 
      if(associated(p)) call abort()
225 
      if(allocated(a)) call abort()
226 
    else
227 
      if(len(a) /= 4) call abort()
228 
      if(a /= 4_'1245') call abort()
229 
      if(len(p) /= 6) call abort()
230 
      if(p /= 4_'AbCdEf') call abort()
231 
      deallocate(a)
232 
      nullify(p)
233 
    end if
234 
    allocate(character(len=50,kind=4) :: a)
235 
    a(1:5) = 4_'ABCDE'
236 
    if(len(a) /= 50) call abort()
237 
    if(a(1:5) /= 4_"ABCDE") call abort()
238 
    loc = '12345'
239 
    p => loc
240 
    if (len(p) /= 5) call abort()
241 
    if (p /= 4_'12345') call abort()
242 
    p = 4_'12345679'
243 
    if (len(p) /= 5) call abort()
244 
    if (p /= 4_'12345') call abort()
245 
    p = 4_'ABC'
246 
    if (loc /= 4_'ABC  ') call abort()
247 
    allocate(p, mold=a)
248 
    if (.not.associated(p)) call abort()
249 
    p = 4_'123457890abcdef'
250 
    if (p /= 4_'123457890abcdef') call abort()
251 
    if (len(p) /= 50) call abort()
252 
  end subroutine proc_test4
253 
  subroutine source3()
254 
     character(len=:, kind=1), allocatable :: a1
255 
     character(len=:, kind=4), allocatable :: a4
256 
     character(len=:, kind=1), pointer     :: p1
257 
     character(len=:, kind=4), pointer     :: p4
258 
     allocate(a1, source='ABC') ! << ICE
259 
     if(len(a1) /= 3 .or. a1 /= 'ABC') call abort()
260 
     allocate(a4, source=4_'12345') ! << ICE
261 
     if(len(a4) /= 5 .or. a4 /= 4_'12345') call abort()
262 
     allocate(p1, mold='AB') ! << ICE
263 
     if(len(p1) /= 2) call abort()
264 
     allocate(p4, mold=4_'145') ! << ICE
265 
     if(len(p4) /= 3) call abort()
266 
  end subroutine source3
267 
end program test

powered by: WebSVN 2.1.0

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