Merge lp:~albertog/xmlf90/wxml-upgrade into lp:xmlf90
- wxml-upgrade
- Merge into trunk
Proposed by
Alberto Garcia
Status: | Merged |
---|---|
Approved by: | Alberto Garcia |
Approved revision: | 10 |
Merged at revision: | 9 |
Proposed branch: | lp:~albertog/xmlf90/wxml-upgrade |
Merge into: | lp:xmlf90 |
Diff against target: |
1492 lines (+745/-201) 11 files modified
Examples/wxml/m_pseudo_utils.f90 (+12/-11) Examples/wxml/simple.f90 (+8/-4) wxml/m_wxml_array_str.f90 (+77/-0) wxml/m_wxml_buffer.f90 (+41/-12) wxml/m_wxml_core.f90 (+220/-61) wxml/m_wxml_dictionary.f90 (+131/-62) wxml/m_wxml_elstack.f90 (+53/-23) wxml/m_wxml_overloads.f90 (+143/-0) wxml/m_wxml_text.F90 (+47/-23) wxml/makefile (+12/-2) wxml/xmlf90_wxml.f90 (+1/-3) |
To merge this branch: | bzr merge lp:~albertog/xmlf90/wxml-upgrade |
Related bugs: |
Reviewer | Review Type | Date Requested | Status |
---|---|---|---|
Alberto Garcia | Approve | ||
Review via email: mp+284429@code.launchpad.net |
Commit message
Description of the change
Updated wxml code, brought from the libpsml distribution.
To post a comment you must log in.
lp:~albertog/xmlf90/wxml-upgrade
updated
- 10. By Alberto Garcia
-
Trim attribute values when using the overloaded interface
Attribute values can be written in the form
pi = 3.1416
call xml_AddAttribute(xf,"key" ,pi [,fmt="(f6.2)"]) which internally calls the str() function to convert
the real (or integer, etc) to a string, which is now
trimmed.
Revision history for this message
Alberto Garcia (albertog) wrote : | # |
OK. I will merge it now.
review:
Approve
Preview Diff
[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1 | === modified file 'Examples/wxml/m_pseudo_utils.f90' | |||
2 | --- Examples/wxml/m_pseudo_utils.f90 2016-01-15 15:49:14 +0000 | |||
3 | +++ Examples/wxml/m_pseudo_utils.f90 2016-01-30 12:34:50 +0000 | |||
4 | @@ -183,7 +183,8 @@ | |||
5 | 183 | call xml_AddAttribute(xf,"version","0.5") | 183 | call xml_AddAttribute(xf,"version","0.5") |
6 | 184 | call xml_NewElement(xf,"header") | 184 | call xml_NewElement(xf,"header") |
7 | 185 | call xml_AddAttribute(xf,"symbol",trim(p%name)) | 185 | call xml_AddAttribute(xf,"symbol",trim(p%name)) |
9 | 186 | call xml_AddAttribute(xf,"zval",trim(str(p%zval))) | 186 | !call xml_AddAttribute(xf,"zval",trim(str(p%zval))) |
10 | 187 | call xml_AddAttribute(xf,"zval",p%zval) ! Overloaded | ||
11 | 187 | call xml_AddAttribute(xf,"creator",trim(p%creator)) | 188 | call xml_AddAttribute(xf,"creator",trim(p%creator)) |
12 | 188 | call xml_AddAttribute(xf,"date",trim(p%date)) | 189 | call xml_AddAttribute(xf,"date",trim(p%date)) |
13 | 189 | call xml_AddAttribute(xf,"flavor",trim(p%flavor)) | 190 | call xml_AddAttribute(xf,"flavor",trim(p%flavor)) |
14 | @@ -206,27 +207,27 @@ | |||
15 | 206 | call xml_NewElement(xf,"grid") | 207 | call xml_NewElement(xf,"grid") |
16 | 207 | call xml_AddAttribute(xf,"type","log") | 208 | call xml_AddAttribute(xf,"type","log") |
17 | 208 | call xml_AddAttribute(xf,"units","bohr") | 209 | call xml_AddAttribute(xf,"units","bohr") |
22 | 209 | call xml_AddAttribute(xf,"scale",trim(str(p%grid_scale))) | 210 | call xml_AddAttribute(xf,"scale",p%grid_scale) |
23 | 210 | call xml_AddAttribute(xf,"step",trim(str(p%grid_step))) | 211 | call xml_AddAttribute(xf,"step",p%grid_step) |
24 | 211 | call xml_AddAttribute(xf,"npts",trim(str(p%nr-1))) | 212 | call xml_AddAttribute(xf,"npts",p%nr-1) |
25 | 212 | call xml_EndElement(xf,"grid") | 213 | call xml_EndElement(xf,"grid") |
26 | 213 | 214 | ||
27 | 214 | call xml_NewElement(xf,"semilocal") | 215 | call xml_NewElement(xf,"semilocal") |
28 | 215 | 216 | ||
29 | 216 | call xml_AddAttribute(xf,"units","rydberg") | 217 | call xml_AddAttribute(xf,"units","rydberg") |
30 | 217 | call xml_AddAttribute(xf,"format","r*V") | 218 | call xml_AddAttribute(xf,"format","r*V") |
33 | 218 | call xml_AddAttribute(xf,"npots-down",trim(str(p%npotd))) | 219 | call xml_AddAttribute(xf,"npots-down",p%npotd) |
34 | 219 | call xml_AddAttribute(xf,"npots-up",trim(str(p%npotu))) | 220 | call xml_AddAttribute(xf,"npots-up",p%npotu) |
35 | 220 | 221 | ||
36 | 221 | do i=1,p%npotd | 222 | do i=1,p%npotd |
37 | 222 | call xml_NewElement(xf,"vps") | 223 | call xml_NewElement(xf,"vps") |
38 | 223 | call xml_AddAttribute(xf,"principal-n", & | 224 | call xml_AddAttribute(xf,"principal-n", & |
41 | 224 | trim(str(p%principal_n(p%ldown(i))))) | 225 | p%principal_n(p%ldown(i))) |
42 | 225 | call xml_AddAttribute(xf,"l",trim(str(p%ldown(i)))) | 226 | call xml_AddAttribute(xf,"l",p%ldown(i)) |
43 | 226 | call xml_AddAttribute(xf,"cutoff", & | 227 | call xml_AddAttribute(xf,"cutoff", & |
45 | 227 | trim(str(p%cutoff(p%ldown(i))))) | 228 | p%cutoff(p%ldown(i))) |
46 | 228 | call xml_AddAttribute(xf,"occupation", & | 229 | call xml_AddAttribute(xf,"occupation", & |
48 | 229 | trim(str(p%occupation(p%ldown(i))))) | 230 | p%occupation(p%ldown(i))) |
49 | 230 | call xml_AddAttribute(xf,"spin","-1") | 231 | call xml_AddAttribute(xf,"spin","-1") |
50 | 231 | 232 | ||
51 | 232 | call xml_NewElement(xf,"radfunc") | 233 | call xml_NewElement(xf,"radfunc") |
52 | 233 | 234 | ||
53 | === modified file 'Examples/wxml/simple.f90' | |||
54 | --- Examples/wxml/simple.f90 2016-01-15 15:49:14 +0000 | |||
55 | +++ Examples/wxml/simple.f90 2016-01-30 12:34:50 +0000 | |||
56 | @@ -2,6 +2,8 @@ | |||
57 | 2 | 2 | ||
58 | 3 | use xmlf90_wxml | 3 | use xmlf90_wxml |
59 | 4 | 4 | ||
60 | 5 | integer, parameter :: dp = selected_real_kind(15,100) | ||
61 | 6 | |||
62 | 5 | type(xmlf_t) :: xf | 7 | type(xmlf_t) :: xf |
63 | 6 | 8 | ||
64 | 7 | integer :: age = 34 | 9 | integer :: age = 34 |
65 | @@ -12,12 +14,14 @@ | |||
66 | 12 | 14 | ||
67 | 13 | call xml_AddXMLDeclaration(xf,"UTF-8") | 15 | call xml_AddXMLDeclaration(xf,"UTF-8") |
68 | 14 | call xml_NewElement(xf,"john") | 16 | call xml_NewElement(xf,"john") |
70 | 15 | call xml_AddAttribute(xf,"age",str(age)) | 17 | call xml_AddAttribute(xf,"age",age) ! Overloaded int, with trimming |
71 | 16 | call xml_NewElement(xf,"peter") | 18 | call xml_NewElement(xf,"peter") |
72 | 19 | call xml_AddAttribute(xf,"with-blanks"," ..Ha.. ") ! String, no trimming | ||
73 | 17 | call xml_NewElement(xf,"tim") | 20 | call xml_NewElement(xf,"tim") |
77 | 18 | call xml_AddAttribute(xf,"age","37") | 21 | call xml_AddAttribute(xf,"age","37") ! String, no trimming |
78 | 19 | call xml_AddAttribute(xf,"weight",str(123.45,"(f7.3)")) | 22 | call xml_AddAttribute(xf,"weight",123.45_dp,fmt="(f7.3)") ! Overloaded, trimming |
79 | 20 | call xml_AddAttribute(xf,"cholesterol",str(167.0,format="(f8.0)")) | 23 | call xml_AddAttribute(xf,"cholesterol",167.0,fmt="(f8.0)") ! Overloaded, trimming |
80 | 24 | call xml_AddAttribute(xf,"realdefault",137.01) ! Overloaded, default fmt, trimming | ||
81 | 21 | call xml_EndElement(xf,"tim") | 25 | call xml_EndElement(xf,"tim") |
82 | 22 | call xml_AddPcdata(xf,"Ping-pong") | 26 | call xml_AddPcdata(xf,"Ping-pong") |
83 | 23 | call xml_AddPcdata(xf,"champion", line_feed=.false.) | 27 | call xml_AddPcdata(xf,"champion", line_feed=.false.) |
84 | 24 | 28 | ||
85 | === added file 'wxml/m_wxml_array_str.f90' | |||
86 | --- wxml/m_wxml_array_str.f90 1970-01-01 00:00:00 +0000 | |||
87 | +++ wxml/m_wxml_array_str.f90 2016-01-30 12:34:50 +0000 | |||
88 | @@ -0,0 +1,77 @@ | |||
89 | 1 | module m_wxml_array_str | ||
90 | 2 | ! | ||
91 | 3 | ! Utilities for character to character array | ||
92 | 4 | ! conversions and tests of equality. | ||
93 | 5 | ! | ||
94 | 6 | interface operator (.equal.) | ||
95 | 7 | module procedure compare_array_str | ||
96 | 8 | end interface | ||
97 | 9 | ! | ||
98 | 10 | ! Not supported by all compilers... | ||
99 | 11 | ! interface assignment (=) | ||
100 | 12 | ! module procedure assign_array_to_str !!!! , assign_str_to_array | ||
101 | 13 | ! end interface | ||
102 | 14 | |||
103 | 15 | public :: operator(.equal.) !!!! , assignment(=) | ||
104 | 16 | public :: assign_array_to_str , assign_str_to_array | ||
105 | 17 | private | ||
106 | 18 | |||
107 | 19 | CONTAINS | ||
108 | 20 | !------------------------------------------------------------- | ||
109 | 21 | subroutine assign_array_to_str(str,s) | ||
110 | 22 | implicit none | ||
111 | 23 | character(len=1), dimension(:), intent(in) :: s | ||
112 | 24 | character(len=*), intent(out) :: str | ||
113 | 25 | |||
114 | 26 | integer :: i, lstr | ||
115 | 27 | |||
116 | 28 | lstr = len(str) | ||
117 | 29 | do i = 1, min(size(s),lstr) | ||
118 | 30 | str(i:i) = s(i) | ||
119 | 31 | enddo | ||
120 | 32 | do i = size(s)+1, lstr | ||
121 | 33 | str(i:i) = " " | ||
122 | 34 | enddo | ||
123 | 35 | end subroutine assign_array_to_str | ||
124 | 36 | |||
125 | 37 | !------------------------------------------------------------- | ||
126 | 38 | ! The NAG and Intel compilers cannot distinguish this from the | ||
127 | 39 | ! intrinsic assignment... so we resort to using an explicit | ||
128 | 40 | ! subroutine call. | ||
129 | 41 | ! | ||
130 | 42 | subroutine assign_str_to_array(s,str) | ||
131 | 43 | implicit none | ||
132 | 44 | character(len=1), dimension(:), intent(out) :: s | ||
133 | 45 | character(len=*), intent(in) :: str | ||
134 | 46 | |||
135 | 47 | integer :: i, lstr | ||
136 | 48 | |||
137 | 49 | lstr = len(str) | ||
138 | 50 | do i = 1, min(size(s),lstr) | ||
139 | 51 | s(i) = str(i:i) | ||
140 | 52 | enddo | ||
141 | 53 | |||
142 | 54 | end subroutine assign_str_to_array | ||
143 | 55 | |||
144 | 56 | !------------------------------------------------------------- | ||
145 | 57 | function compare_array_str(s,str) result(equal) ! .equal. generic | ||
146 | 58 | implicit none | ||
147 | 59 | character(len=1), dimension(:), intent(in) :: s | ||
148 | 60 | character(len=*), intent(in) :: str | ||
149 | 61 | logical :: equal | ||
150 | 62 | integer :: lens, lenstr, i | ||
151 | 63 | |||
152 | 64 | |||
153 | 65 | equal = .false. | ||
154 | 66 | lens = size(s) | ||
155 | 67 | lenstr = len(str) | ||
156 | 68 | if (lens .ne. lenstr) return | ||
157 | 69 | |||
158 | 70 | do i = 1, lens | ||
159 | 71 | if (s(i) .ne. str(i:i)) return | ||
160 | 72 | enddo | ||
161 | 73 | equal = .true. | ||
162 | 74 | |||
163 | 75 | end function compare_array_str | ||
164 | 76 | |||
165 | 77 | end module m_wxml_array_str | ||
166 | 0 | 78 | ||
167 | === modified file 'wxml/m_wxml_buffer.f90' | |||
168 | --- wxml/m_wxml_buffer.f90 2014-09-04 09:28:10 +0000 | |||
169 | +++ wxml/m_wxml_buffer.f90 2016-01-30 12:34:50 +0000 | |||
170 | @@ -1,5 +1,9 @@ | |||
171 | 1 | module m_wxml_buffer | 1 | module m_wxml_buffer |
172 | 2 | 2 | ||
173 | 3 | use m_wxml_error | ||
174 | 4 | |||
175 | 5 | implicit none | ||
176 | 6 | |||
177 | 3 | ! | 7 | ! |
178 | 4 | ! At this point we use a fixed-size buffer. | 8 | ! At this point we use a fixed-size buffer. |
179 | 5 | ! Note however that buffer overflows will only be | 9 | ! Note however that buffer overflows will only be |
180 | @@ -9,13 +13,13 @@ | |||
181 | 9 | ! There is code in the parser module m_fsm to avoid buffer overflows | 13 | ! There is code in the parser module m_fsm to avoid buffer overflows |
182 | 10 | ! caused by pcdata values. | 14 | ! caused by pcdata values. |
183 | 11 | ! | 15 | ! |
185 | 12 | ! This module is re-used from the parser package. | 16 | ! This module is re-used from the parser package, except the size. |
186 | 13 | ! Most of the routines are superfluous at this point. | 17 | ! Most of the routines are superfluous at this point. |
187 | 14 | ! | 18 | ! |
188 | 15 | ! In a forthcoming implementation it could be made dynamical... | 19 | ! In a forthcoming implementation it could be made dynamical... |
189 | 16 | ! | 20 | ! |
192 | 17 | integer, parameter, public :: MAX_BUFF_SIZE = 2000 | 21 | integer, parameter, public :: MAX_BUFF_SIZE = 10000 |
193 | 18 | integer, parameter, private :: BUFF_SIZE_WARNING = 1750 | 22 | integer, parameter, private :: BUFF_SIZE_WARNING = 9500 |
194 | 19 | ! | 23 | ! |
195 | 20 | type, public :: buffer_t | 24 | type, public :: buffer_t |
196 | 21 | private | 25 | private |
197 | @@ -23,12 +27,12 @@ | |||
198 | 23 | character(len=MAX_BUFF_SIZE) :: str | 27 | character(len=MAX_BUFF_SIZE) :: str |
199 | 24 | end type buffer_t | 28 | end type buffer_t |
200 | 25 | 29 | ||
202 | 26 | public :: add_to_buffer | 30 | public :: add_to_buffer, add_to_buffer_escaping_markup |
203 | 27 | public :: print_buffer, str, char, len | 31 | public :: print_buffer, str, char, len |
204 | 28 | public :: operator (.equal.) | 32 | public :: operator (.equal.) |
205 | 29 | public :: buffer_nearly_full, reset_buffer | 33 | public :: buffer_nearly_full, reset_buffer |
206 | 30 | 34 | ||
208 | 31 | 35 | private | |
209 | 32 | !---------------------------------------------------------------- | 36 | !---------------------------------------------------------------- |
210 | 33 | interface add_to_buffer | 37 | interface add_to_buffer |
211 | 34 | module procedure add_str_to_buffer | 38 | module procedure add_str_to_buffer |
212 | @@ -97,9 +101,7 @@ | |||
213 | 97 | n = buffer%size | 101 | n = buffer%size |
214 | 98 | 102 | ||
215 | 99 | if (n> MAX_BUFF_SIZE) then | 103 | if (n> MAX_BUFF_SIZE) then |
219 | 100 | stop "Buffer overflow: long unbroken string of pcdata or attribute value..." | 104 | call wxml_error("Buffer overflow: long unbroken string of pcdata or attribute value...") |
217 | 101 | ! RETURN | ||
218 | 102 | ! | ||
220 | 103 | endif | 105 | endif |
221 | 104 | 106 | ||
222 | 105 | buffer%str(n:n) = c | 107 | buffer%str(n:n) = c |
223 | @@ -110,7 +112,7 @@ | |||
224 | 110 | character(len=*), intent(in) :: s | 112 | character(len=*), intent(in) :: s |
225 | 111 | type(buffer_t), intent(inout) :: buffer | 113 | type(buffer_t), intent(inout) :: buffer |
226 | 112 | 114 | ||
228 | 113 | integer :: n, len_s, last_pos | 115 | integer :: i, n, len_s, last_pos |
229 | 114 | 116 | ||
230 | 115 | len_s = len(s) | 117 | len_s = len(s) |
231 | 116 | last_pos = buffer%size | 118 | last_pos = buffer%size |
232 | @@ -118,13 +120,40 @@ | |||
233 | 118 | n = buffer%size | 120 | n = buffer%size |
234 | 119 | 121 | ||
235 | 120 | if (n> MAX_BUFF_SIZE) then | 122 | if (n> MAX_BUFF_SIZE) then |
238 | 121 | stop "Buffer overflow: long unbroken string of pcdata or attribute value..." | 123 | call wxml_error("Buffer overflow: long unbroken string of pcdata or attribute value...") |
237 | 122 | ! RETURN | ||
239 | 123 | endif | 124 | endif |
240 | 124 | 125 | ||
242 | 125 | buffer%str(last_pos+1:n) = s | 126 | if (len_s.gt.0) buffer%str(last_pos+1:n) = s |
243 | 126 | end subroutine add_str_to_buffer | 127 | end subroutine add_str_to_buffer |
244 | 127 | 128 | ||
245 | 129 | subroutine add_to_buffer_escaping_markup(s,buf) | ||
246 | 130 | character(len=*), intent(in) :: s | ||
247 | 131 | type(buffer_t), intent(inout) :: buf | ||
248 | 132 | |||
249 | 133 | integer :: len_s, i | ||
250 | 134 | character(len=1) :: c | ||
251 | 135 | |||
252 | 136 | len_s = len(s) | ||
253 | 137 | i = 0 | ||
254 | 138 | do | ||
255 | 139 | if (i==len_s) exit | ||
256 | 140 | i = i + 1 | ||
257 | 141 | c = s(i:i) | ||
258 | 142 | if (c == "<") then | ||
259 | 143 | call add_to_buffer("<",buf) | ||
260 | 144 | else if (c == "&") then | ||
261 | 145 | call add_to_buffer("&",buf) | ||
262 | 146 | else if (c == "'") then | ||
263 | 147 | call add_to_buffer("'",buf) | ||
264 | 148 | else if (c == '"') then | ||
265 | 149 | call add_to_buffer(""",buf) | ||
266 | 150 | else | ||
267 | 151 | call add_to_buffer(c,buf) | ||
268 | 152 | endif | ||
269 | 153 | enddo | ||
270 | 154 | |||
271 | 155 | end subroutine add_to_buffer_escaping_markup | ||
272 | 156 | |||
273 | 128 | !---------------------------------------------------------------- | 157 | !---------------------------------------------------------------- |
274 | 129 | subroutine reset_buffer(buffer) | 158 | subroutine reset_buffer(buffer) |
275 | 130 | type(buffer_t), intent(inout) :: buffer | 159 | type(buffer_t), intent(inout) :: buffer |
276 | 131 | 160 | ||
277 | === modified file 'wxml/m_wxml_core.f90' | |||
278 | --- wxml/m_wxml_core.f90 2014-09-04 09:28:10 +0000 | |||
279 | +++ wxml/m_wxml_core.f90 2016-01-30 12:34:50 +0000 | |||
280 | @@ -1,9 +1,14 @@ | |||
281 | 1 | module m_wxml_core | 1 | module m_wxml_core |
282 | 2 | 2 | ||
283 | 3 | use m_wxml_buffer | 3 | use m_wxml_buffer |
284 | 4 | use m_wxml_array_str, only: assign_array_to_str | ||
285 | 5 | use m_wxml_array_str, only: assign_str_to_array | ||
286 | 6 | use m_wxml_escape, only: check_Name | ||
287 | 4 | use m_wxml_elstack | 7 | use m_wxml_elstack |
288 | 5 | use m_wxml_dictionary | 8 | use m_wxml_dictionary |
289 | 6 | 9 | ||
290 | 10 | implicit none | ||
291 | 11 | |||
292 | 7 | logical, private, save :: pcdata_advance_line_default = .false. | 12 | logical, private, save :: pcdata_advance_line_default = .false. |
293 | 8 | logical, private, save :: pcdata_advance_space_default = .false. | 13 | logical, private, save :: pcdata_advance_space_default = .false. |
294 | 9 | 14 | ||
295 | @@ -13,19 +18,31 @@ | |||
296 | 13 | private | 18 | private |
297 | 14 | 19 | ||
298 | 15 | type, public :: xmlf_t | 20 | type, public :: xmlf_t |
302 | 16 | integer :: lun | 21 | character, pointer :: filename(:) |
303 | 17 | type(buffer_t) :: buffer | 22 | integer :: lun |
304 | 18 | type(elstack_t) :: stack | 23 | type(buffer_t) :: buffer |
305 | 24 | type(elstack_t) :: stack | ||
306 | 19 | type(wxml_dictionary_t) :: dict | 25 | type(wxml_dictionary_t) :: dict |
310 | 20 | logical :: start_tag_closed | 26 | logical :: start_tag_closed |
311 | 21 | logical :: root_element_output | 27 | logical :: root_element_output |
312 | 22 | logical :: indenting_requested | 28 | logical :: indenting_requested |
313 | 29 | logical :: inhibit_lf | ||
314 | 23 | end type xmlf_t | 30 | end type xmlf_t |
315 | 24 | 31 | ||
316 | 25 | public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close | 32 | public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close |
318 | 26 | public :: xml_AddPcdata, xml_AddAttribute, xml_AddXMLDeclaration | 33 | public :: xml_AddXMLDeclaration |
319 | 34 | public :: xml_AddXMLStylesheet | ||
320 | 35 | public :: xml_AddXMLPI | ||
321 | 27 | public :: xml_AddComment, xml_AddCdataSection | 36 | public :: xml_AddComment, xml_AddCdataSection |
323 | 28 | 37 | public :: xml_AddPcdata, xml_AddAttribute | |
324 | 38 | interface xml_AddPcdata | ||
325 | 39 | module procedure xml_AddPcdata_Ch | ||
326 | 40 | end interface | ||
327 | 41 | ! | ||
328 | 42 | interface xml_AddAttribute | ||
329 | 43 | module procedure xml_AddAttribute_Ch | ||
330 | 44 | end interface | ||
331 | 45 | ! | ||
332 | 29 | public :: xml_AddArray | 46 | public :: xml_AddArray |
333 | 30 | interface xml_AddArray | 47 | interface xml_AddArray |
334 | 31 | module procedure xml_AddArray_integer, & | 48 | module procedure xml_AddArray_integer, & |
335 | @@ -37,9 +54,28 @@ | |||
336 | 37 | private :: add_eol | 54 | private :: add_eol |
337 | 38 | private :: write_attributes | 55 | private :: write_attributes |
338 | 39 | 56 | ||
339 | 57 | !overload error handlers to allow file info | ||
340 | 58 | interface wxml_warning | ||
341 | 59 | module procedure wxml_warning_xf | ||
342 | 60 | end interface | ||
343 | 61 | interface wxml_error | ||
344 | 62 | module procedure wxml_error_xf | ||
345 | 63 | end interface | ||
346 | 64 | interface wxml_fatal | ||
347 | 65 | module procedure wxml_fatal_xf | ||
348 | 66 | end interface | ||
349 | 40 | 67 | ||
350 | 68 | ! | ||
351 | 69 | ! Heuristic (approximate) target for justification of output | ||
352 | 70 | ! Large unbroken pcdatas will go beyond this limit | ||
353 | 71 | ! | ||
354 | 41 | integer, private, parameter :: COLUMNS = 80 | 72 | integer, private, parameter :: COLUMNS = 80 |
355 | 42 | 73 | ||
356 | 74 | ! TOHW - This is the longest string that may be output without | ||
357 | 75 | ! a newline. The buffer must not be larger than this, but its size | ||
358 | 76 | ! can be tuned for performance. | ||
359 | 77 | integer, private, parameter :: xml_recl = 4096 | ||
360 | 78 | |||
361 | 43 | CONTAINS | 79 | CONTAINS |
362 | 44 | 80 | ||
363 | 45 | !------------------------------------------------------------------- | 81 | !------------------------------------------------------------------- |
364 | @@ -50,17 +86,30 @@ | |||
365 | 50 | 86 | ||
366 | 51 | integer :: iostat | 87 | integer :: iostat |
367 | 52 | 88 | ||
368 | 89 | allocate(xf%filename(len(filename))) | ||
369 | 90 | call assign_str_to_array(xf%filename,filename) | ||
370 | 91 | |||
371 | 53 | call get_unit(xf%lun,iostat) | 92 | call get_unit(xf%lun,iostat) |
373 | 54 | if (iostat /= 0) stop "cannot open file" | 93 | if (iostat /= 0) call wxml_fatal(xf, "cannot open file") |
374 | 94 | ! | ||
375 | 95 | ! Use large I/O buffer in case the O.S./Compiler combination | ||
376 | 96 | ! has hard-limits by default (i.e., NAGWare f95's 1024 byte limit) | ||
377 | 97 | ! This is related to the maximum size of the buffer. | ||
378 | 98 | ! TOHW - This is the longest string that may be output without | ||
379 | 99 | ! a newline. The buffer must not be larger than this, but its size | ||
380 | 100 | ! can be tuned for performance. | ||
381 | 101 | |||
382 | 55 | open(unit=xf%lun, file=filename, form="formatted", status="replace", & | 102 | open(unit=xf%lun, file=filename, form="formatted", status="replace", & |
387 | 56 | action="write", position="rewind") ! , recl=65536) | 103 | action="write", position="rewind", recl=xml_recl) |
388 | 57 | 104 | ||
389 | 58 | call reset_elstack(xf%stack) | 105 | call init_elstack(xf%stack) |
390 | 59 | call reset_dict(xf%dict) | 106 | |
391 | 107 | call init_dict(xf%dict) | ||
392 | 60 | call reset_buffer(xf%buffer) | 108 | call reset_buffer(xf%buffer) |
393 | 61 | 109 | ||
394 | 62 | xf%start_tag_closed = .true. | 110 | xf%start_tag_closed = .true. |
395 | 63 | xf%root_element_output = .false. | 111 | xf%root_element_output = .false. |
396 | 112 | xf%inhibit_lf = .false. | ||
397 | 64 | 113 | ||
398 | 65 | xf%indenting_requested = .false. | 114 | xf%indenting_requested = .false. |
399 | 66 | if (present(indent)) then | 115 | if (present(indent)) then |
400 | @@ -82,6 +131,48 @@ | |||
401 | 82 | end subroutine xml_AddXMLDeclaration | 131 | end subroutine xml_AddXMLDeclaration |
402 | 83 | 132 | ||
403 | 84 | !------------------------------------------------------------------- | 133 | !------------------------------------------------------------------- |
404 | 134 | subroutine xml_AddXMLStylesheet(xf, href, type, title, media, charset, alternate) | ||
405 | 135 | type(xmlf_t), intent(inout) :: xf | ||
406 | 136 | character(len=*), intent(in) :: href | ||
407 | 137 | character(len=*), intent(in) :: type | ||
408 | 138 | character(len=*), intent(in), optional :: title | ||
409 | 139 | character(len=*), intent(in), optional :: media | ||
410 | 140 | character(len=*), intent(in), optional :: charset | ||
411 | 141 | logical, intent(in), optional :: alternate | ||
412 | 142 | |||
413 | 143 | call add_eol(xf) | ||
414 | 144 | call add_to_buffer("<?xml-stylesheet href=""" //trim(href)// & | ||
415 | 145 | """ type=""" //trim(type)// """", xf%buffer) | ||
416 | 146 | |||
417 | 147 | if (present(title)) call add_to_buffer(" title="""//trim(title)// """", xf%buffer) | ||
418 | 148 | if (present(media)) call add_to_buffer(" media="""//trim(media)// """", xf%buffer) | ||
419 | 149 | if (present(charset)) call add_to_buffer(" charset="""//trim(charset)// """", xf%buffer) | ||
420 | 150 | if (present(alternate)) then | ||
421 | 151 | if (alternate) then | ||
422 | 152 | call add_to_buffer(" alternate=""yes""", xf%buffer) | ||
423 | 153 | else | ||
424 | 154 | call add_to_buffer(" alternate=""no""", xf%buffer) | ||
425 | 155 | endif | ||
426 | 156 | endif | ||
427 | 157 | call add_to_buffer(" ?>", xf%buffer) | ||
428 | 158 | |||
429 | 159 | end subroutine xml_AddXMLStylesheet | ||
430 | 160 | |||
431 | 161 | !------------------------------------------------------------------- | ||
432 | 162 | subroutine xml_AddXMLPI(xf, name, data) | ||
433 | 163 | type(xmlf_t), intent(inout) :: xf | ||
434 | 164 | character(len=*), intent(in) :: name | ||
435 | 165 | character(len=*), intent(in), optional :: data | ||
436 | 166 | |||
437 | 167 | call add_eol(xf) | ||
438 | 168 | call add_to_buffer("<?" // trim(name) // " ", xf%buffer) | ||
439 | 169 | if(present(data)) call add_to_buffer(data, xf%buffer) | ||
440 | 170 | call add_to_buffer(" ?>", xf%buffer) | ||
441 | 171 | |||
442 | 172 | end subroutine xml_AddXMLPI | ||
443 | 173 | |||
444 | 174 | |||
445 | 175 | !------------------------------------------------------------------- | ||
446 | 85 | subroutine xml_AddComment(xf,comment) | 176 | subroutine xml_AddComment(xf,comment) |
447 | 86 | type(xmlf_t), intent(inout) :: xf | 177 | type(xmlf_t), intent(inout) :: xf |
448 | 87 | character(len=*), intent(in) :: comment | 178 | character(len=*), intent(in) :: comment |
449 | @@ -94,14 +185,20 @@ | |||
450 | 94 | end subroutine xml_AddComment | 185 | end subroutine xml_AddComment |
451 | 95 | 186 | ||
452 | 96 | !------------------------------------------------------------------- | 187 | !------------------------------------------------------------------- |
454 | 97 | subroutine xml_AddCdataSection(xf,cdata) | 188 | subroutine xml_AddCdataSection(xf,cdata,line_feed) |
455 | 98 | type(xmlf_t), intent(inout) :: xf | 189 | type(xmlf_t), intent(inout) :: xf |
456 | 99 | character(len=*), intent(in) :: cdata | 190 | character(len=*), intent(in) :: cdata |
457 | 191 | logical, intent(in), optional :: line_feed | ||
458 | 100 | 192 | ||
459 | 101 | call close_start_tag(xf,">") | 193 | call close_start_tag(xf,">") |
460 | 194 | call dump_buffer(xf,line_feed) | ||
461 | 102 | call add_to_buffer("<![CDATA[", xf%buffer) | 195 | call add_to_buffer("<![CDATA[", xf%buffer) |
462 | 103 | call add_to_buffer(cdata, xf%buffer) | 196 | call add_to_buffer(cdata, xf%buffer) |
463 | 104 | call add_to_buffer("]]>", xf%buffer) | 197 | call add_to_buffer("]]>", xf%buffer) |
464 | 198 | call dump_buffer(xf,line_feed) | ||
465 | 199 | if (present(line_feed)) then | ||
466 | 200 | if (line_feed) xf%inhibit_lf = .true. | ||
467 | 201 | endif | ||
468 | 105 | end subroutine xml_AddCdataSection | 202 | end subroutine xml_AddCdataSection |
469 | 106 | 203 | ||
470 | 107 | !------------------------------------------------------------------- | 204 | !------------------------------------------------------------------- |
471 | @@ -110,10 +207,15 @@ | |||
472 | 110 | character(len=*), intent(in) :: name | 207 | character(len=*), intent(in) :: name |
473 | 111 | 208 | ||
474 | 112 | if (is_empty(xf%stack)) then | 209 | if (is_empty(xf%stack)) then |
476 | 113 | if (xf%root_element_output) stop "two root elements" | 210 | if (xf%root_element_output) call wxml_error(xf, "two root elements") |
477 | 114 | xf%root_element_output = .true. | 211 | xf%root_element_output = .true. |
478 | 115 | endif | 212 | endif |
479 | 116 | 213 | ||
480 | 214 | if (.not.check_Name(name)) then | ||
481 | 215 | call wxml_warning(xf, 'attribute name '//name//' is not valid') | ||
482 | 216 | endif | ||
483 | 217 | |||
484 | 218 | |||
485 | 117 | call close_start_tag(xf,">") | 219 | call close_start_tag(xf,">") |
486 | 118 | call push_elstack(name,xf%stack) | 220 | call push_elstack(name,xf%stack) |
487 | 119 | call add_eol(xf) | 221 | call add_eol(xf) |
488 | @@ -123,15 +225,13 @@ | |||
489 | 123 | 225 | ||
490 | 124 | end subroutine xml_NewElement | 226 | end subroutine xml_NewElement |
491 | 125 | !------------------------------------------------------------------- | 227 | !------------------------------------------------------------------- |
493 | 126 | subroutine xml_AddPcdata(xf,pcdata,space,line_feed) | 228 | subroutine xml_AddPcdata_Ch(xf,pcdata,space,line_feed) |
494 | 127 | type(xmlf_t), intent(inout) :: xf | 229 | type(xmlf_t), intent(inout) :: xf |
495 | 128 | character(len=*), intent(in) :: pcdata | 230 | character(len=*), intent(in) :: pcdata |
496 | 129 | logical, intent(in), optional :: space | 231 | logical, intent(in), optional :: space |
497 | 130 | logical, intent(in), optional :: line_feed | 232 | logical, intent(in), optional :: line_feed |
498 | 131 | 233 | ||
499 | 132 | logical :: advance_line , advance_space | 234 | logical :: advance_line , advance_space |
500 | 133 | integer :: n, i, jmax | ||
501 | 134 | integer, parameter :: chunk_size = 128 | ||
502 | 135 | 235 | ||
503 | 136 | advance_line = pcdata_advance_line_default | 236 | advance_line = pcdata_advance_line_default |
504 | 137 | if (present(line_feed)) then | 237 | if (present(line_feed)) then |
505 | @@ -144,7 +244,7 @@ | |||
506 | 144 | endif | 244 | endif |
507 | 145 | 245 | ||
508 | 146 | if (is_empty(xf%stack)) then | 246 | if (is_empty(xf%stack)) then |
510 | 147 | stop "pcdata outside element content" | 247 | call wxml_error(xf, "pcdata outside element content") |
511 | 148 | endif | 248 | endif |
512 | 149 | 249 | ||
513 | 150 | call close_start_tag(xf,">") | 250 | call close_start_tag(xf,">") |
514 | @@ -161,43 +261,32 @@ | |||
515 | 161 | endif | 261 | endif |
516 | 162 | endif | 262 | endif |
517 | 163 | if (advance_space) call add_to_buffer(" ",xf%buffer) | 263 | if (advance_space) call add_to_buffer(" ",xf%buffer) |
533 | 164 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.false.) | 264 | |
534 | 165 | ! | 265 | call add_to_buffer_escaping_markup(pcdata, xf%buffer) |
535 | 166 | ! We bypass the buffer for the bulk of the dump | 266 | |
536 | 167 | ! | 267 | end subroutine xml_AddPcdata_Ch |
522 | 168 | n = len(pcdata) | ||
523 | 169 | !print *, "writing pcdata of length: ", n | ||
524 | 170 | i = 1 | ||
525 | 171 | do | ||
526 | 172 | jmax = min(i+chunk_size-1,n) | ||
527 | 173 | ! print *, "writing chunk: ", i, jmax | ||
528 | 174 | write(unit=xf%lun,fmt="(a)",advance="no") pcdata(i:jmax) | ||
529 | 175 | if (jmax == n) exit | ||
530 | 176 | i = jmax + 1 | ||
531 | 177 | enddo | ||
532 | 178 | end subroutine xml_AddPcdata | ||
537 | 179 | 268 | ||
538 | 180 | !------------------------------------------------------------------- | 269 | !------------------------------------------------------------------- |
540 | 181 | subroutine xml_AddAttribute(xf,name,value) | 270 | subroutine xml_AddAttribute_Ch(xf,name,value) |
541 | 182 | type(xmlf_t), intent(inout) :: xf | 271 | type(xmlf_t), intent(inout) :: xf |
542 | 183 | character(len=*), intent(in) :: name | 272 | character(len=*), intent(in) :: name |
543 | 184 | character(len=*), intent(in) :: value | 273 | character(len=*), intent(in) :: value |
544 | 185 | 274 | ||
545 | 186 | if (is_empty(xf%stack)) then | 275 | if (is_empty(xf%stack)) then |
547 | 187 | stop "attributes outside element content" | 276 | call wxml_error(xf, "attributes outside element content") |
548 | 188 | endif | 277 | endif |
549 | 189 | 278 | ||
550 | 190 | if (xf%start_tag_closed) then | 279 | if (xf%start_tag_closed) then |
552 | 191 | stop "attributes outside start tag" | 280 | call wxml_error(xf, "attributes outside start tag") |
553 | 192 | endif | 281 | endif |
554 | 282 | |||
555 | 193 | if (has_key(xf%dict,name)) then | 283 | if (has_key(xf%dict,name)) then |
557 | 194 | stop "duplicate att name" | 284 | call wxml_error(xf, "duplicate att name") |
558 | 195 | endif | 285 | endif |
559 | 196 | 286 | ||
562 | 197 | call add_key_to_dict(trim(name),xf%dict) | 287 | call add_item_to_dict(xf%dict, name, value) |
561 | 198 | call add_value_to_dict(trim(value),xf%dict) | ||
563 | 199 | 288 | ||
565 | 200 | end subroutine xml_AddAttribute | 289 | end subroutine xml_AddAttribute_Ch |
566 | 201 | 290 | ||
567 | 202 | !----------------------------------------------------------- | 291 | !----------------------------------------------------------- |
568 | 203 | subroutine xml_EndElement(xf,name) | 292 | subroutine xml_EndElement(xf,name) |
569 | @@ -207,19 +296,19 @@ | |||
570 | 207 | character(len=100) :: current | 296 | character(len=100) :: current |
571 | 208 | 297 | ||
572 | 209 | if (is_empty(xf%stack)) then | 298 | if (is_empty(xf%stack)) then |
574 | 210 | stop "Out of elements to close" | 299 | call wxml_fatal(xf, "Out of elements to close") |
575 | 211 | endif | 300 | endif |
576 | 212 | 301 | ||
577 | 213 | call get_top_elstack(xf%stack,current) | 302 | call get_top_elstack(xf%stack,current) |
578 | 214 | if (current /= name) then | 303 | if (current /= name) then |
581 | 215 | print *, "current, name: ", trim(current), " ", trim(name) | 304 | call wxml_fatal(xf, 'Trying to close '//Trim(name)//' but '//Trim(current)//' is open.') |
580 | 216 | stop | ||
582 | 217 | endif | 305 | endif |
583 | 218 | if (.not. xf%start_tag_closed) then ! Empty element | 306 | if (.not. xf%start_tag_closed) then ! Empty element |
584 | 219 | if (len(xf%dict) > 0) call write_attributes(xf) | 307 | if (len(xf%dict) > 0) call write_attributes(xf) |
585 | 220 | call add_to_buffer(" />",xf%buffer) | 308 | call add_to_buffer(" />",xf%buffer) |
586 | 221 | xf%start_tag_closed = .true. | 309 | xf%start_tag_closed = .true. |
587 | 222 | else | 310 | else |
588 | 311 | ! This statement will introduce a newline after array data... | ||
589 | 223 | call add_eol(xf) | 312 | call add_eol(xf) |
590 | 224 | call add_to_buffer("</" // trim(name) // ">", xf%buffer) | 313 | call add_to_buffer("</" // trim(name) // ">", xf%buffer) |
591 | 225 | endif | 314 | endif |
592 | @@ -230,11 +319,21 @@ | |||
593 | 230 | !---------------------------------------------------------------- | 319 | !---------------------------------------------------------------- |
594 | 231 | 320 | ||
595 | 232 | subroutine xml_Close(xf) | 321 | subroutine xml_Close(xf) |
597 | 233 | type(xmlf_t), intent(in) :: xf | 322 | type(xmlf_t), intent(inout) :: xf |
598 | 323 | |||
599 | 324 | character(len=200) :: name | ||
600 | 325 | |||
601 | 326 | do | ||
602 | 327 | if (is_empty(xf%stack)) exit | ||
603 | 328 | call get_top_elstack(xf%stack,name) | ||
604 | 329 | call xml_EndElement(xf,trim(name)) | ||
605 | 330 | enddo | ||
606 | 234 | 331 | ||
607 | 235 | write(unit=xf%lun,fmt="(a)") char(xf%buffer) | 332 | write(unit=xf%lun,fmt="(a)") char(xf%buffer) |
608 | 236 | close(unit=xf%lun) | 333 | close(unit=xf%lun) |
609 | 237 | 334 | ||
610 | 335 | deallocate(xf%filename) | ||
611 | 336 | |||
612 | 238 | end subroutine xml_Close | 337 | end subroutine xml_Close |
613 | 239 | 338 | ||
614 | 240 | !================================================================== | 339 | !================================================================== |
615 | @@ -266,14 +365,24 @@ | |||
616 | 266 | type(xmlf_t), intent(inout) :: xf | 365 | type(xmlf_t), intent(inout) :: xf |
617 | 267 | 366 | ||
618 | 268 | integer :: indent_level | 367 | integer :: indent_level |
625 | 269 | character(len=100), parameter :: blanks = "" | 368 | |
626 | 270 | 369 | ||
627 | 271 | indent_level = len(xf%stack) - 1 | 370 | ! Flush with a linefeed except if a previous operation has raised |
628 | 272 | write(unit=xf%lun,fmt="(a)") char(xf%buffer) | 371 | ! the inhibit_lf flag |
629 | 273 | call reset_buffer(xf%buffer) | 372 | |
630 | 274 | 373 | if (xf%inhibit_lf) then | |
631 | 374 | call dump_buffer(xf,lf=.false.) | ||
632 | 375 | xf%inhibit_lf = .false. | ||
633 | 376 | else | ||
634 | 377 | call dump_buffer(xf,lf=.true.) | ||
635 | 378 | endif | ||
636 | 379 | |||
637 | 380 | ! In case we still have a zero-length stack, we must make | ||
638 | 381 | ! sure indent_level is not less than zero. | ||
639 | 382 | |||
640 | 383 | indent_level = max(len(xf%stack) - 1, 0) | ||
641 | 275 | if (xf%indenting_requested) & | 384 | if (xf%indenting_requested) & |
643 | 276 | call add_to_buffer(blanks(1:indent_level),xf%buffer) | 385 | call add_to_buffer(repeat(' ',indent_level),xf%buffer) |
644 | 277 | 386 | ||
645 | 278 | end subroutine add_eol | 387 | end subroutine add_eol |
646 | 279 | !------------------------------------------------------------ | 388 | !------------------------------------------------------------ |
647 | @@ -311,21 +420,19 @@ | |||
648 | 311 | subroutine write_attributes(xf) | 420 | subroutine write_attributes(xf) |
649 | 312 | type(xmlf_t), intent(inout) :: xf | 421 | type(xmlf_t), intent(inout) :: xf |
650 | 313 | 422 | ||
653 | 314 | integer :: i, status, size | 423 | integer :: i, status, size, key_len, value_len |
654 | 315 | character(len=100) :: key, value | 424 | character(len=200) :: key, value |
655 | 316 | 425 | ||
656 | 317 | do i = 1, len(xf%dict) | 426 | do i = 1, len(xf%dict) |
662 | 318 | call get_key(xf%dict,i,key,status) | 427 | call get_key(xf%dict,i,key,key_len,status) |
663 | 319 | call get_value(xf%dict,key,value,status) | 428 | call get_value(xf%dict,i,value,value_len,status) |
664 | 320 | key = adjustl(key) | 429 | size = key_len + value_len + 4 |
660 | 321 | value = adjustl(value) | ||
661 | 322 | size = len_trim(key) + len_trim(value) + 4 | ||
665 | 323 | if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf) | 430 | if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf) |
666 | 324 | call add_to_buffer(" ", xf%buffer) | 431 | call add_to_buffer(" ", xf%buffer) |
668 | 325 | call add_to_buffer(trim(key), xf%buffer) | 432 | call add_to_buffer(key(:key_len), xf%buffer) |
669 | 326 | call add_to_buffer("=", xf%buffer) | 433 | call add_to_buffer("=", xf%buffer) |
670 | 327 | call add_to_buffer("""",xf%buffer) | 434 | call add_to_buffer("""",xf%buffer) |
672 | 328 | call add_to_buffer(trim(value), xf%buffer) | 435 | call add_to_buffer_escaping_markup(value(:value_len), xf%buffer) |
673 | 329 | call add_to_buffer("""", xf%buffer) | 436 | call add_to_buffer("""", xf%buffer) |
674 | 330 | enddo | 437 | enddo |
675 | 331 | 438 | ||
676 | @@ -343,6 +450,7 @@ | |||
677 | 343 | write(xf%lun,format) a | 450 | write(xf%lun,format) a |
678 | 344 | else | 451 | else |
679 | 345 | write(xf%lun,"(6(i12))") a | 452 | write(xf%lun,"(6(i12))") a |
680 | 453 | xf%inhibit_lf = .true. | ||
681 | 346 | endif | 454 | endif |
682 | 347 | end subroutine xml_AddArray_integer | 455 | end subroutine xml_AddArray_integer |
683 | 348 | 456 | ||
684 | @@ -359,6 +467,7 @@ | |||
685 | 359 | else | 467 | else |
686 | 360 | write(xf%lun,"(4(es20.12))") a | 468 | write(xf%lun,"(4(es20.12))") a |
687 | 361 | endif | 469 | endif |
688 | 470 | xf%inhibit_lf = .true. | ||
689 | 362 | end subroutine xml_AddArray_real_dp | 471 | end subroutine xml_AddArray_real_dp |
690 | 363 | 472 | ||
691 | 364 | !------------------------------------------------------------------ | 473 | !------------------------------------------------------------------ |
692 | @@ -374,7 +483,57 @@ | |||
693 | 374 | else | 483 | else |
694 | 375 | write(xf%lun,"(4(es20.12))") a | 484 | write(xf%lun,"(4(es20.12))") a |
695 | 376 | endif | 485 | endif |
696 | 486 | xf%inhibit_lf = .true. | ||
697 | 377 | end subroutine xml_AddArray_real_sp | 487 | end subroutine xml_AddArray_real_sp |
698 | 378 | 488 | ||
699 | 489 | !--------------------------------------------------------- | ||
700 | 490 | ! Error handling/trapping routines: | ||
701 | 491 | |||
702 | 492 | subroutine wxml_warning_xf(xf, msg) | ||
703 | 493 | ! Emit warning, but carry on. | ||
704 | 494 | type(xmlf_t), intent(in) :: xf | ||
705 | 495 | character(len=*), intent(in) :: msg | ||
706 | 496 | |||
707 | 497 | write(6,'(a)') 'WARNING(wxml) in writing to file ', xmlf_name(xf) | ||
708 | 498 | write(6,'(a)') msg | ||
709 | 499 | |||
710 | 500 | end subroutine wxml_warning_xf | ||
711 | 501 | |||
712 | 502 | subroutine wxml_error_xf(xf, msg) | ||
713 | 503 | ! Emit error message, clean up file and stop. | ||
714 | 504 | type(xmlf_t), intent(inout) :: xf | ||
715 | 505 | character(len=*), intent(in) :: msg | ||
716 | 506 | |||
717 | 507 | write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) | ||
718 | 508 | write(6,'(a)') msg | ||
719 | 509 | |||
720 | 510 | call xml_Close(xf) | ||
721 | 511 | stop | ||
722 | 512 | |||
723 | 513 | end subroutine wxml_error_xf | ||
724 | 514 | |||
725 | 515 | subroutine wxml_fatal_xf(xf, msg) | ||
726 | 516 | !Emit error message and abort with coredump. Does not try to | ||
727 | 517 | !close file, so should be used from anything xml_Close might | ||
728 | 518 | !itself call (to avoid infinite recursion!) | ||
729 | 519 | |||
730 | 520 | type(xmlf_t), intent(in) :: xf | ||
731 | 521 | character(len=*), intent(in) :: msg | ||
732 | 522 | |||
733 | 523 | write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) | ||
734 | 524 | write(6,'(a)') msg | ||
735 | 525 | |||
736 | 526 | !call pxfabort | ||
737 | 527 | stop | ||
738 | 528 | |||
739 | 529 | end subroutine wxml_fatal_xf | ||
740 | 530 | |||
741 | 531 | function xmlf_name(xf) result(fn) | ||
742 | 532 | Type (xmlf_t), intent(in) :: xf | ||
743 | 533 | character(len=size(xf%filename)) :: fn | ||
744 | 534 | call assign_array_to_str(fn,xf%filename) | ||
745 | 535 | end function xmlf_name | ||
746 | 536 | |||
747 | 537 | |||
748 | 379 | end module m_wxml_core | 538 | end module m_wxml_core |
749 | 380 | 539 | ||
750 | 381 | 540 | ||
751 | === modified file 'wxml/m_wxml_dictionary.f90' | |||
752 | --- wxml/m_wxml_dictionary.f90 2014-09-04 09:28:10 +0000 | |||
753 | +++ wxml/m_wxml_dictionary.f90 2016-01-30 12:34:50 +0000 | |||
754 | @@ -1,24 +1,32 @@ | |||
755 | 1 | module m_wxml_dictionary | 1 | module m_wxml_dictionary |
756 | 2 | 2 | ||
757 | 3 | use m_wxml_escape, only : check_Name | ||
758 | 4 | use m_wxml_error, only : wxml_fatal | ||
759 | 5 | use m_wxml_array_str | ||
760 | 6 | |||
761 | 7 | implicit none | ||
762 | 8 | |||
763 | 3 | private | 9 | private |
764 | 4 | ! | 10 | ! |
765 | 5 | ! A very rough implementation for now | ||
766 | 6 | ! It uses fixed-length buffers for key/value pairs, | ||
767 | 7 | ! and the maximum number of dictionary items is hardwired. | ||
768 | 8 | |||
769 | 9 | integer, parameter, private :: MAX_ITEMS = 30 | 11 | integer, parameter, private :: MAX_ITEMS = 30 |
770 | 12 | |||
771 | 13 | type, private :: dict_item | ||
772 | 14 | character(len=1), pointer, dimension(:) :: key | ||
773 | 15 | character(len=1), pointer, dimension(:) :: value | ||
774 | 16 | end type dict_item | ||
775 | 17 | |||
776 | 10 | type, public :: wxml_dictionary_t | 18 | type, public :: wxml_dictionary_t |
777 | 11 | private | 19 | private |
778 | 12 | integer :: number_of_items ! = 0 | 20 | integer :: number_of_items ! = 0 |
781 | 13 | character(len=100), dimension(MAX_ITEMS) :: key | 21 | type(dict_item), dimension(MAX_ITEMS) :: items |
780 | 14 | character(len=100), dimension(MAX_ITEMS) :: value | ||
782 | 15 | end type wxml_dictionary_t | 22 | end type wxml_dictionary_t |
783 | 16 | 23 | ||
784 | 17 | ! | 24 | ! |
785 | 18 | ! Building procedures | 25 | ! Building procedures |
786 | 19 | ! | 26 | ! |
789 | 20 | public :: add_key_to_dict, add_value_to_dict, reset_dict | 27 | public :: init_dict |
790 | 21 | 28 | public :: reset_dict | |
791 | 29 | public :: add_item_to_dict | ||
792 | 22 | ! | 30 | ! |
793 | 23 | ! Query and extraction procedures | 31 | ! Query and extraction procedures |
794 | 24 | ! | 32 | ! |
795 | @@ -27,13 +35,13 @@ | |||
796 | 27 | module procedure number_of_entries | 35 | module procedure number_of_entries |
797 | 28 | end interface | 36 | end interface |
798 | 29 | public :: number_of_entries | 37 | public :: number_of_entries |
800 | 30 | public :: get_key | 38 | public :: get_key |
801 | 31 | public :: get_value | 39 | public :: get_value |
802 | 32 | public :: has_key | 40 | public :: has_key |
803 | 33 | public :: print_dict | 41 | public :: print_dict |
804 | 34 | ! | 42 | ! |
805 | 35 | interface get_value | 43 | interface get_value |
807 | 36 | module procedure wxml_get_value | 44 | module procedure wxml_get_value, wxml_get_value_i |
808 | 37 | end interface | 45 | end interface |
809 | 38 | 46 | ||
810 | 39 | CONTAINS | 47 | CONTAINS |
811 | @@ -53,14 +61,13 @@ | |||
812 | 53 | character(len=*), intent(in) :: key | 61 | character(len=*), intent(in) :: key |
813 | 54 | logical :: found | 62 | logical :: found |
814 | 55 | 63 | ||
816 | 56 | integer :: n, i | 64 | integer :: i |
817 | 57 | found = .false. | 65 | found = .false. |
824 | 58 | n = dict%number_of_items | 66 | do i = 1, dict%number_of_items |
825 | 59 | do i = 1, n | 67 | if (dict%items(i)%key .equal. key) then |
826 | 60 | if (dict%key(i) == key) then | 68 | found = .true. |
827 | 61 | found = .true. | 69 | exit |
828 | 62 | exit | 70 | endif |
823 | 63 | endif | ||
829 | 64 | enddo | 71 | enddo |
830 | 65 | end function has_key | 72 | end function has_key |
831 | 66 | 73 | ||
832 | @@ -71,79 +78,141 @@ | |||
833 | 71 | character(len=*), intent(out) :: value | 78 | character(len=*), intent(out) :: value |
834 | 72 | integer, intent(out) :: status | 79 | integer, intent(out) :: status |
835 | 73 | ! | 80 | ! |
837 | 74 | integer :: n, i | 81 | integer :: i |
838 | 75 | 82 | ||
839 | 76 | status = -1 | 83 | status = -1 |
847 | 77 | n = dict%number_of_items | 84 | do i = 1, dict%number_of_items |
848 | 78 | do i = 1, n | 85 | if (dict%items(i)%key .equal. key) then |
849 | 79 | if (dict%key(i) == key) then | 86 | call assign_array_to_str(value,dict%items(i)%value) |
850 | 80 | value = dict%value(i) | 87 | status = 0 |
851 | 81 | status = 0 | 88 | exit |
852 | 82 | RETURN | 89 | endif |
846 | 83 | endif | ||
853 | 84 | enddo | 90 | enddo |
854 | 85 | 91 | ||
855 | 86 | end subroutine wxml_get_value | 92 | end subroutine wxml_get_value |
856 | 87 | 93 | ||
857 | 94 | function get_value_len(dict, key) result(value_len) | ||
858 | 95 | type(wxml_dictionary_t), intent(in) :: dict | ||
859 | 96 | character(len=*), intent(in) :: key | ||
860 | 97 | integer :: value_len | ||
861 | 98 | |||
862 | 99 | integer :: i | ||
863 | 100 | |||
864 | 101 | value_len = 0 | ||
865 | 102 | do i = 1, dict%number_of_items | ||
866 | 103 | if (dict%items(i)%key .equal. key) then | ||
867 | 104 | value_len = size(dict%items(i)%value) | ||
868 | 105 | exit | ||
869 | 106 | endif | ||
870 | 107 | enddo | ||
871 | 108 | |||
872 | 109 | end function get_value_len | ||
873 | 110 | |||
874 | 111 | |||
875 | 88 | !------------------------------------------------------ | 112 | !------------------------------------------------------ |
877 | 89 | subroutine get_key(dict,i,key,status) | 113 | subroutine get_key(dict,i,key,key_len,status) |
878 | 90 | ! | 114 | ! |
879 | 91 | ! Get the i'th key | 115 | ! Get the i'th key |
880 | 92 | ! | 116 | ! |
881 | 93 | type(wxml_dictionary_t), intent(in) :: dict | 117 | type(wxml_dictionary_t), intent(in) :: dict |
882 | 94 | integer, intent(in) :: i | 118 | integer, intent(in) :: i |
883 | 95 | character(len=*), intent(out) :: key | 119 | character(len=*), intent(out) :: key |
884 | 120 | integer, intent(out) :: key_len | ||
885 | 96 | integer, intent(out) :: status | 121 | integer, intent(out) :: status |
886 | 97 | 122 | ||
889 | 98 | if (i <= dict%number_of_items) then | 123 | if (i>0 .and. i<=dict%number_of_items) then |
890 | 99 | key = dict%key(i) | 124 | call assign_array_to_str(key,dict%items(i)%key) |
891 | 125 | key_len = size(dict%items(i)%key) | ||
892 | 100 | status = 0 | 126 | status = 0 |
893 | 101 | else | 127 | else |
895 | 102 | key = "" | 128 | key = ' ' |
896 | 129 | key_len = 0 | ||
897 | 103 | status = -1 | 130 | status = -1 |
898 | 104 | endif | 131 | endif |
899 | 105 | 132 | ||
900 | 106 | end subroutine get_key | 133 | end subroutine get_key |
901 | 107 | |||
902 | 108 | !------------------------------------------------------ | 134 | !------------------------------------------------------ |
913 | 109 | subroutine add_key_to_dict(key,dict) | 135 | subroutine wxml_get_value_i(dict,i,value,value_len,status) |
914 | 110 | character(len=*), intent(in) :: key | 136 | ! |
915 | 111 | type(wxml_dictionary_t), intent(inout) :: dict | 137 | ! Get the i'th value |
916 | 112 | 138 | ! | |
917 | 113 | integer :: n | 139 | type(wxml_dictionary_t), intent(in) :: dict |
918 | 114 | 140 | integer, intent(in) :: i | |
919 | 115 | n = dict%number_of_items | 141 | character(len=*), intent(out) :: value |
920 | 116 | if (n == MAX_ITEMS) then | 142 | integer, intent(out) :: value_len |
921 | 117 | write(unit=0,fmt=*) "Dictionary capacity exceeded !" | 143 | integer, intent(out) :: status |
922 | 118 | RETURN | 144 | |
923 | 145 | if (i>0 .and. i<=dict%number_of_items) then | ||
924 | 146 | call assign_array_to_str(value,dict%items(i)%value) | ||
925 | 147 | value_len = size(dict%items(i)%value) | ||
926 | 148 | status = 0 | ||
927 | 149 | else | ||
928 | 150 | value = ' ' | ||
929 | 151 | value_len = 0 | ||
930 | 152 | status = -1 | ||
931 | 119 | endif | 153 | endif |
932 | 120 | 154 | ||
938 | 121 | n = n + 1 | 155 | end subroutine wxml_get_value_i |
939 | 122 | dict%key(n) = key | 156 | |
940 | 123 | dict%number_of_items = n | 157 | subroutine add_item_to_dict(dict, key, value) |
941 | 124 | 158 | ||
942 | 125 | end subroutine add_key_to_dict | 159 | type(wxml_dictionary_t), intent(inout) :: dict |
943 | 160 | character(len=*), intent(in) :: key | ||
944 | 161 | character(len=*), intent(in) :: value | ||
945 | 162 | |||
946 | 163 | character(len=len(key)) :: check_key | ||
947 | 164 | integer :: n, lenstr | ||
948 | 165 | |||
949 | 166 | n = dict%number_of_items | ||
950 | 167 | if (n == MAX_ITEMS) then | ||
951 | 168 | write(unit=0,fmt=*) "Dictionary capacity exceeded !" | ||
952 | 169 | RETURN | ||
953 | 170 | endif | ||
954 | 171 | |||
955 | 172 | ! keys may not have initial (or trailing; thus trim below) blanks: | ||
956 | 173 | !TOHW remove this check? shouldn't be passing blank-prefixed strings anyway. | ||
957 | 174 | check_key=adjustl(key) | ||
958 | 175 | if (.not.check_Name(trim(check_key))) then | ||
959 | 176 | call wxml_fatal('attribute name is invalid') | ||
960 | 177 | endif | ||
961 | 178 | |||
962 | 179 | n = n + 1 | ||
963 | 180 | lenstr=len_trim(check_key) | ||
964 | 181 | allocate(dict%items(n)%key(lenstr)) | ||
965 | 182 | call assign_str_to_array(dict%items(n)%key,check_key) | ||
966 | 183 | allocate(dict%items(n)%value(len(value))) | ||
967 | 184 | call assign_str_to_array(dict%items(n)%value,value) | ||
968 | 185 | |||
969 | 186 | dict%number_of_items = n | ||
970 | 187 | |||
971 | 188 | end subroutine add_item_to_dict | ||
972 | 126 | 189 | ||
973 | 127 | !------------------------------------------------------ | 190 | !------------------------------------------------------ |
988 | 128 | ! Assumes we build the dictionary in an orderly fashion, | 191 | subroutine init_dict(dict) |
989 | 129 | ! so one adds first the key and then immediately afterwards the value. | 192 | type(wxml_dictionary_t), intent(out) :: dict |
990 | 130 | ! | 193 | |
991 | 131 | subroutine add_value_to_dict(value,dict) | 194 | integer :: i |
992 | 132 | character(len=*), intent(in) :: value | 195 | |
993 | 133 | type(wxml_dictionary_t), intent(inout) :: dict | 196 | do i = 1, MAX_ITEMS |
994 | 134 | 197 | nullify(dict%items(i)%key) | |
995 | 135 | integer :: n | 198 | nullify(dict%items(i)%key) |
996 | 136 | 199 | enddo | |
997 | 137 | n = dict%number_of_items | 200 | |
998 | 138 | dict%value(n) = value | 201 | dict % number_of_items = 0 |
999 | 139 | 202 | ||
1000 | 140 | end subroutine add_value_to_dict | 203 | end subroutine init_dict |
1001 | 141 | 204 | ||
1002 | 142 | !------------------------------------------------------ | 205 | !------------------------------------------------------ |
1003 | 143 | subroutine reset_dict(dict) | 206 | subroutine reset_dict(dict) |
1005 | 144 | type(wxml_dictionary_t), intent(inout) :: dict | 207 | type(wxml_dictionary_t), intent(inout) :: dict |
1006 | 208 | |||
1007 | 209 | integer :: i | ||
1008 | 210 | do i = 1, dict%number_of_items | ||
1009 | 211 | deallocate(dict%items(i)%key) | ||
1010 | 212 | deallocate(dict%items(i)%value) | ||
1011 | 213 | enddo | ||
1012 | 145 | 214 | ||
1014 | 146 | dict%number_of_items = 0 | 215 | dict%number_of_items = 0 |
1015 | 147 | 216 | ||
1016 | 148 | end subroutine reset_dict | 217 | end subroutine reset_dict |
1017 | 149 | 218 | ||
1018 | @@ -154,7 +223,7 @@ | |||
1019 | 154 | integer :: i | 223 | integer :: i |
1020 | 155 | 224 | ||
1021 | 156 | do i = 1, dict%number_of_items | 225 | do i = 1, dict%number_of_items |
1023 | 157 | print *, trim(dict%key(i)), " = ", trim(dict%value(i)) | 226 | print *, dict%items(i)%key, " = ", dict%items(i)%value |
1024 | 158 | enddo | 227 | enddo |
1025 | 159 | 228 | ||
1026 | 160 | end subroutine print_dict | 229 | end subroutine print_dict |
1027 | 161 | 230 | ||
1028 | === modified file 'wxml/m_wxml_elstack.f90' | |||
1029 | --- wxml/m_wxml_elstack.f90 2014-09-04 09:28:10 +0000 | |||
1030 | +++ wxml/m_wxml_elstack.f90 2016-01-30 12:34:50 +0000 | |||
1031 | @@ -1,19 +1,30 @@ | |||
1032 | 1 | module m_wxml_elstack | 1 | module m_wxml_elstack |
1033 | 2 | 2 | ||
1034 | 3 | use m_wxml_error | ||
1035 | 4 | |||
1036 | 5 | implicit none | ||
1037 | 6 | |||
1038 | 3 | private | 7 | private |
1039 | 4 | 8 | ||
1040 | 5 | ! | 9 | ! |
1041 | 6 | ! Simple stack to keep track of which elements have appeared so far | 10 | ! Simple stack to keep track of which elements have appeared so far |
1042 | 7 | ! | 11 | ! |
1044 | 8 | integer, parameter, private :: STACK_SIZE = 20 | 12 | ! Initial stack size: |
1045 | 13 | integer, parameter, private :: STACK_SIZE_INIT = 10 | ||
1046 | 14 | ! Multiplier when stack is exceeded: | ||
1047 | 15 | real, parameter, private :: STACK_SIZE_MULT = 1.5 | ||
1048 | 16 | |||
1049 | 17 | type, private :: elstack_item | ||
1050 | 18 | character(len=100) :: data | ||
1051 | 19 | end type | ||
1052 | 9 | 20 | ||
1053 | 10 | type, public :: elstack_t | 21 | type, public :: elstack_t |
1054 | 11 | private | 22 | private |
1057 | 12 | integer :: n_items | 23 | integer :: n_items |
1058 | 13 | character(len=100), dimension(STACK_SIZE) :: data | 24 | type(elstack_item), pointer, dimension(:) :: stack |
1059 | 14 | end type elstack_t | 25 | end type elstack_t |
1060 | 15 | 26 | ||
1062 | 16 | public :: push_elstack, pop_elstack, reset_elstack, print_elstack | 27 | public :: push_elstack, pop_elstack, init_elstack, reset_elstack, print_elstack |
1063 | 17 | public :: get_top_elstack, is_empty, get_elstack_signature | 28 | public :: get_top_elstack, is_empty, get_elstack_signature |
1064 | 18 | public :: len | 29 | public :: len |
1065 | 19 | 30 | ||
1066 | @@ -30,14 +41,39 @@ | |||
1067 | 30 | CONTAINS | 41 | CONTAINS |
1068 | 31 | 42 | ||
1069 | 32 | !----------------------------------------------------------------- | 43 | !----------------------------------------------------------------- |
1070 | 44 | subroutine init_elstack(elstack) | ||
1071 | 45 | type(elstack_t), intent(inout) :: elstack | ||
1072 | 46 | |||
1073 | 47 | allocate(elstack%stack(STACK_SIZE_INIT)) | ||
1074 | 48 | elstack%n_items = 0 | ||
1075 | 49 | |||
1076 | 50 | end subroutine init_elstack | ||
1077 | 51 | |||
1078 | 52 | !----------------------------------------------------------------- | ||
1079 | 33 | subroutine reset_elstack(elstack) | 53 | subroutine reset_elstack(elstack) |
1081 | 34 | type(elstack_t), intent(inout) :: elstack | 54 | type(elstack_t), intent(inout) :: elstack |
1082 | 35 | 55 | ||
1084 | 36 | elstack%n_items = 0 | 56 | deallocate(elstack%stack) |
1085 | 57 | call init_elstack(elstack) | ||
1086 | 37 | 58 | ||
1087 | 38 | end subroutine reset_elstack | 59 | end subroutine reset_elstack |
1088 | 39 | 60 | ||
1089 | 40 | !----------------------------------------------------------------- | 61 | !----------------------------------------------------------------- |
1090 | 62 | subroutine resize_elstack(elstack) | ||
1091 | 63 | type(elstack_t), intent(inout) :: elstack | ||
1092 | 64 | type(elstack_item), pointer, dimension(:) :: temp | ||
1093 | 65 | integer :: s | ||
1094 | 66 | |||
1095 | 67 | s = size(elstack%stack) | ||
1096 | 68 | |||
1097 | 69 | temp=>elstack%stack | ||
1098 | 70 | allocate(elstack%stack(nint(s*STACK_SIZE_MULT))) | ||
1099 | 71 | elstack%stack(:s) = temp | ||
1100 | 72 | deallocate(temp) | ||
1101 | 73 | |||
1102 | 74 | end subroutine resize_elstack | ||
1103 | 75 | |||
1104 | 76 | !----------------------------------------------------------------- | ||
1105 | 41 | function is_empty_elstack(elstack) result(answer) | 77 | function is_empty_elstack(elstack) result(answer) |
1106 | 42 | type(elstack_t), intent(in) :: elstack | 78 | type(elstack_t), intent(in) :: elstack |
1107 | 43 | logical :: answer | 79 | logical :: answer |
1108 | @@ -61,11 +97,11 @@ | |||
1109 | 61 | integer :: n | 97 | integer :: n |
1110 | 62 | 98 | ||
1111 | 63 | n = elstack%n_items | 99 | n = elstack%n_items |
1114 | 64 | if (n == STACK_SIZE) then | 100 | if (n == size(elstack%stack)) then |
1115 | 65 | stop "*Element stack full" | 101 | call resize_elstack(elstack) |
1116 | 66 | endif | 102 | endif |
1117 | 67 | n = n + 1 | 103 | n = n + 1 |
1119 | 68 | elstack%data(n) = item | 104 | elstack%stack(n)%data = item |
1120 | 69 | elstack%n_items = n | 105 | elstack%n_items = n |
1121 | 70 | 106 | ||
1122 | 71 | end subroutine push_elstack | 107 | end subroutine push_elstack |
1123 | @@ -75,16 +111,13 @@ | |||
1124 | 75 | type(elstack_t), intent(inout) :: elstack | 111 | type(elstack_t), intent(inout) :: elstack |
1125 | 76 | character(len=*), intent(out) :: item | 112 | character(len=*), intent(out) :: item |
1126 | 77 | 113 | ||
1127 | 78 | ! | ||
1128 | 79 | ! We assume the elstack is not empty... (the user has called is_empty first) | ||
1129 | 80 | ! | ||
1130 | 81 | integer :: n | 114 | integer :: n |
1131 | 82 | 115 | ||
1132 | 83 | n = elstack%n_items | 116 | n = elstack%n_items |
1133 | 84 | if (n == 0) then | 117 | if (n == 0) then |
1135 | 85 | stop "*********Element stack empty" | 118 | call wxml_error("Element stack empty") |
1136 | 86 | endif | 119 | endif |
1138 | 87 | item = elstack%data(n) | 120 | item = elstack%stack(n)%data |
1139 | 88 | elstack%n_items = n - 1 | 121 | elstack%n_items = n - 1 |
1140 | 89 | 122 | ||
1141 | 90 | end subroutine pop_elstack | 123 | end subroutine pop_elstack |
1142 | @@ -97,16 +130,13 @@ | |||
1143 | 97 | type(elstack_t), intent(in) :: elstack | 130 | type(elstack_t), intent(in) :: elstack |
1144 | 98 | character(len=*), intent(out) :: item | 131 | character(len=*), intent(out) :: item |
1145 | 99 | 132 | ||
1146 | 100 | ! | ||
1147 | 101 | ! We assume the elstack is not empty... (the user has called is_empty first) | ||
1148 | 102 | ! | ||
1149 | 103 | integer :: n | 133 | integer :: n |
1150 | 104 | 134 | ||
1151 | 105 | n = elstack%n_items | 135 | n = elstack%n_items |
1152 | 106 | if (n == 0) then | 136 | if (n == 0) then |
1154 | 107 | stop "*********Element stack empty" | 137 | call wxml_error("Element stack empty") |
1155 | 108 | endif | 138 | endif |
1157 | 109 | item = elstack%data(n) | 139 | item = elstack%stack(n)%data |
1158 | 110 | 140 | ||
1159 | 111 | end subroutine get_top_elstack | 141 | end subroutine get_top_elstack |
1160 | 112 | 142 | ||
1161 | @@ -117,7 +147,7 @@ | |||
1162 | 117 | integer :: i | 147 | integer :: i |
1163 | 118 | 148 | ||
1164 | 119 | do i = elstack%n_items, 1, -1 | 149 | do i = elstack%n_items, 1, -1 |
1166 | 120 | write(unit=unit,fmt=*) trim(elstack%data(i)) | 150 | write(unit=unit,fmt=*) trim(elstack%stack(i)%data) |
1167 | 121 | enddo | 151 | enddo |
1168 | 122 | 152 | ||
1169 | 123 | end subroutine print_elstack | 153 | end subroutine print_elstack |
1170 | @@ -128,13 +158,13 @@ | |||
1171 | 128 | character(len=*), intent(out) :: string | 158 | character(len=*), intent(out) :: string |
1172 | 129 | integer :: i, length, j | 159 | integer :: i, length, j |
1173 | 130 | 160 | ||
1175 | 131 | string = "" | 161 | string = ' ' |
1176 | 132 | j = 0 | 162 | j = 0 |
1177 | 133 | do i = 1, elstack%n_items | 163 | do i = 1, elstack%n_items |
1179 | 134 | length = len_trim(elstack%data(i)) | 164 | length = len_trim(elstack%stack(i)%data) |
1180 | 135 | string(j+1:j+1) = "/" | 165 | string(j+1:j+1) = "/" |
1181 | 136 | j = j+1 | 166 | j = j+1 |
1183 | 137 | string(j+1:j+length) = trim(elstack%data(i)) | 167 | string(j+1:j+length) = trim(elstack%stack(i)%data) |
1184 | 138 | j = j + length | 168 | j = j + length |
1185 | 139 | enddo | 169 | enddo |
1186 | 140 | 170 | ||
1187 | 141 | 171 | ||
1188 | === added file 'wxml/m_wxml_overloads.f90' | |||
1189 | --- wxml/m_wxml_overloads.f90 1970-01-01 00:00:00 +0000 | |||
1190 | +++ wxml/m_wxml_overloads.f90 2016-01-30 12:34:50 +0000 | |||
1191 | @@ -0,0 +1,143 @@ | |||
1192 | 1 | module m_wxml_overloads | ||
1193 | 2 | |||
1194 | 3 | use m_wxml_text, only: str | ||
1195 | 4 | use m_wxml_core, only: xmlf_t | ||
1196 | 5 | use m_wxml_core, only: xml_AddPcData_Ch => xml_AddPcData | ||
1197 | 6 | use m_wxml_core, only: xml_AddAttribute_Ch => xml_AddAttribute | ||
1198 | 7 | |||
1199 | 8 | implicit none | ||
1200 | 9 | |||
1201 | 10 | integer, parameter :: sp = selected_real_kind(6,30) | ||
1202 | 11 | integer, parameter :: dp = selected_real_kind(14,100) | ||
1203 | 12 | |||
1204 | 13 | private | ||
1205 | 14 | |||
1206 | 15 | public :: xml_AddPcdata | ||
1207 | 16 | public :: xml_AddAttribute | ||
1208 | 17 | |||
1209 | 18 | interface xml_AddPcData | ||
1210 | 19 | module procedure xml_AddPcdata_SP | ||
1211 | 20 | module procedure xml_AddPcdata_DP | ||
1212 | 21 | module procedure xml_AddPcdata_Int | ||
1213 | 22 | module procedure xml_AddPcdata_Log | ||
1214 | 23 | end interface | ||
1215 | 24 | |||
1216 | 25 | interface xml_AddAttribute | ||
1217 | 26 | module procedure xml_AddAttribute_SP | ||
1218 | 27 | module procedure xml_AddAttribute_DP | ||
1219 | 28 | module procedure xml_AddAttribute_Int | ||
1220 | 29 | module procedure xml_AddAttribute_Log | ||
1221 | 30 | end interface | ||
1222 | 31 | |||
1223 | 32 | CONTAINS | ||
1224 | 33 | |||
1225 | 34 | !------------------------------------------------------------------- | ||
1226 | 35 | |||
1227 | 36 | subroutine xml_AddPcdata_SP(xf,pcdata,fmt, space,line_feed) | ||
1228 | 37 | type(xmlf_t), intent(inout) :: xf | ||
1229 | 38 | real(kind=sp), intent(in) :: pcdata | ||
1230 | 39 | logical, intent(in), optional :: space | ||
1231 | 40 | logical, intent(in), optional :: line_feed | ||
1232 | 41 | character(len=*), intent(in), optional :: fmt | ||
1233 | 42 | |||
1234 | 43 | call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed) | ||
1235 | 44 | |||
1236 | 45 | end subroutine xml_AddPcdata_SP | ||
1237 | 46 | |||
1238 | 47 | |||
1239 | 48 | subroutine xml_AddPcdata_DP(xf,pcdata,fmt,space,line_feed) | ||
1240 | 49 | type(xmlf_t), intent(inout) :: xf | ||
1241 | 50 | real(kind=dp), intent(in) :: pcdata | ||
1242 | 51 | character(len=*), optional :: fmt | ||
1243 | 52 | logical, intent(in), optional :: space | ||
1244 | 53 | logical, intent(in), optional :: line_feed | ||
1245 | 54 | |||
1246 | 55 | call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed) | ||
1247 | 56 | |||
1248 | 57 | end subroutine xml_AddPcdata_DP | ||
1249 | 58 | |||
1250 | 59 | |||
1251 | 60 | subroutine xml_AddPcdata_log(xf,pcdata,fmt,space,line_feed) | ||
1252 | 61 | type(xmlf_t), intent(inout) :: xf | ||
1253 | 62 | logical, intent(in) :: pcdata | ||
1254 | 63 | character(len=*), intent(in), optional :: fmt | ||
1255 | 64 | logical, intent(in), optional :: space | ||
1256 | 65 | logical, intent(in), optional :: line_feed | ||
1257 | 66 | |||
1258 | 67 | if (present(fmt)) then | ||
1259 | 68 | call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed) | ||
1260 | 69 | else | ||
1261 | 70 | call xml_AddPcdata_Ch(xf,trim(str(pcdata)),space,line_feed) | ||
1262 | 71 | endif | ||
1263 | 72 | |||
1264 | 73 | end subroutine xml_AddPcdata_log | ||
1265 | 74 | |||
1266 | 75 | |||
1267 | 76 | subroutine xml_AddPcdata_int(xf,pcdata,fmt,space,line_feed) | ||
1268 | 77 | type(xmlf_t), intent(inout) :: xf | ||
1269 | 78 | integer, intent(in) :: pcdata | ||
1270 | 79 | character(len=*), intent(in), optional :: fmt | ||
1271 | 80 | logical, intent(in), optional :: space | ||
1272 | 81 | logical, intent(in), optional :: line_feed | ||
1273 | 82 | |||
1274 | 83 | if (present(fmt)) then | ||
1275 | 84 | call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed) | ||
1276 | 85 | else | ||
1277 | 86 | call xml_AddPcdata_Ch(xf,trim(str(pcdata)),space,line_feed) | ||
1278 | 87 | endif | ||
1279 | 88 | |||
1280 | 89 | end subroutine xml_AddPcdata_int | ||
1281 | 90 | |||
1282 | 91 | |||
1283 | 92 | !------------------------------------------------------------------- | ||
1284 | 93 | |||
1285 | 94 | subroutine xml_AddAttribute_SP(xf,name,value,fmt) | ||
1286 | 95 | type(xmlf_t), intent(inout) :: xf | ||
1287 | 96 | character(len=*), intent(in) :: name | ||
1288 | 97 | real(kind=sp), intent(in) :: value | ||
1289 | 98 | character(len=*), intent(in), optional :: fmt | ||
1290 | 99 | |||
1291 | 100 | call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt))) | ||
1292 | 101 | |||
1293 | 102 | end subroutine xml_AddAttribute_SP | ||
1294 | 103 | |||
1295 | 104 | subroutine xml_AddAttribute_DP(xf,name,value,fmt) | ||
1296 | 105 | type(xmlf_t), intent(inout) :: xf | ||
1297 | 106 | character(len=*), intent(in) :: name | ||
1298 | 107 | real(kind=dp), intent(in) :: value | ||
1299 | 108 | character(len=*), intent(in), optional :: fmt | ||
1300 | 109 | |||
1301 | 110 | call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt))) | ||
1302 | 111 | |||
1303 | 112 | end subroutine xml_AddAttribute_DP | ||
1304 | 113 | |||
1305 | 114 | subroutine xml_AddAttribute_log(xf,name,value,fmt) | ||
1306 | 115 | type(xmlf_t), intent(inout) :: xf | ||
1307 | 116 | character(len=*), intent(in) :: name | ||
1308 | 117 | logical, intent(in) :: value | ||
1309 | 118 | character(len=*), intent(in), optional :: fmt | ||
1310 | 119 | |||
1311 | 120 | if (present(fmt)) then | ||
1312 | 121 | call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt))) | ||
1313 | 122 | else | ||
1314 | 123 | call xml_AddAttribute_Ch(xf,name,trim(str(value))) | ||
1315 | 124 | endif | ||
1316 | 125 | |||
1317 | 126 | end subroutine xml_AddAttribute_log | ||
1318 | 127 | |||
1319 | 128 | subroutine xml_AddAttribute_int(xf,name,value,fmt) | ||
1320 | 129 | type(xmlf_t), intent(inout) :: xf | ||
1321 | 130 | character(len=*), intent(in) :: name | ||
1322 | 131 | integer, intent(in) :: value | ||
1323 | 132 | character(len=*), intent(in), optional :: fmt | ||
1324 | 133 | |||
1325 | 134 | if (present(fmt)) then | ||
1326 | 135 | call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt))) | ||
1327 | 136 | else | ||
1328 | 137 | call xml_AddAttribute_Ch(xf,name,trim(str(value))) | ||
1329 | 138 | endif | ||
1330 | 139 | |||
1331 | 140 | end subroutine xml_AddAttribute_int | ||
1332 | 141 | |||
1333 | 142 | end module m_wxml_overloads | ||
1334 | 143 | |||
1335 | 0 | 144 | ||
1336 | === renamed file 'wxml/m_wxml_text.f90' => 'wxml/m_wxml_text.F90' | |||
1337 | --- wxml/m_wxml_text.f90 2014-09-04 14:11:50 +0000 | |||
1338 | +++ wxml/m_wxml_text.F90 2016-01-30 12:34:50 +0000 | |||
1339 | @@ -1,44 +1,68 @@ | |||
1340 | 1 | module m_wxml_text | 1 | module m_wxml_text |
1341 | 2 | |||
1342 | 3 | implicit none | ||
1343 | 2 | ! | 4 | ! |
1344 | 3 | integer, private, parameter :: sp = selected_real_kind(6,30) | 5 | integer, private, parameter :: sp = selected_real_kind(6,30) |
1345 | 4 | integer, private, parameter :: dp = selected_real_kind(14,100) | 6 | integer, private, parameter :: dp = selected_real_kind(14,100) |
1346 | 5 | ! | 7 | ! |
1347 | 6 | private | 8 | private |
1348 | 7 | |||
1349 | 8 | public :: str | 9 | public :: str |
1350 | 9 | 10 | ||
1351 | 10 | interface str | 11 | interface str |
1354 | 11 | module procedure str_integer, str_real_dp, str_real_sp, & | 12 | module procedure str_integer_fmt, str_integer, & |
1355 | 12 | str_logical | 13 | str_logical_fmt, str_logical, & |
1356 | 14 | str_real_dp, str_real_sp | ||
1357 | 13 | end interface | 15 | end interface |
1358 | 14 | private :: str_integer, str_real_dp, str_real_sp, str_logical | ||
1359 | 15 | 16 | ||
1360 | 16 | CONTAINS | 17 | CONTAINS |
1361 | 17 | 18 | ||
1365 | 18 | function str_integer(int,format) result(s) | 19 | function str_integer_fmt(i,format) result(s) |
1366 | 19 | integer, intent(in) :: int | 20 | integer, intent(in) :: i |
1367 | 20 | character(len=*), intent(in), optional :: format | 21 | character(len=*), intent(in) :: format |
1368 | 21 | character(len=100) :: s | 22 | character(len=100) :: s |
1369 | 22 | 23 | ||
1375 | 23 | if (present(format)) then | 24 | write(s,format) i |
1371 | 24 | write(s,format) int | ||
1372 | 25 | else | ||
1373 | 26 | write(s,"(i25)") int | ||
1374 | 27 | endif | ||
1376 | 28 | s = adjustl(s) | 25 | s = adjustl(s) |
1377 | 26 | end function str_integer_fmt | ||
1378 | 27 | |||
1379 | 28 | function str_integer(i) result(s) | ||
1380 | 29 | ! This will work correctly (return an appropriately-sized | ||
1381 | 30 | ! string) for integers i s.t. -99999999<=i<=999999999 | ||
1382 | 31 | integer, intent(in) :: i | ||
1383 | 32 | #ifndef WXML_INIT_FIX | ||
1384 | 33 | character(len=int(merge(log10(real(max(abs(i),1)))+1, & | ||
1385 | 34 | log10(real(max(abs(i),1)))+2, & | ||
1386 | 35 | sign(1,i)>0))) :: s | ||
1387 | 36 | #else | ||
1388 | 37 | ! Some compilers have trouble with the above | ||
1389 | 38 | character(len=int(log10(real(max(abs(i),1)))+2)) :: s | ||
1390 | 39 | #endif | ||
1391 | 40 | character(len=4) :: form | ||
1392 | 41 | |||
1393 | 42 | write(form,'(a,i1,a)') '(i',len(s),')' | ||
1394 | 43 | write(s, form) i | ||
1395 | 44 | |||
1396 | 29 | end function str_integer | 45 | end function str_integer |
1397 | 30 | 46 | ||
1401 | 31 | function str_logical(log,format) result(s) | 47 | function str_logical_fmt(l,format) result(s) |
1402 | 32 | logical, intent(in) :: log | 48 | logical, intent(in) :: l |
1403 | 33 | character(len=*), intent(in), optional :: format | 49 | character(len=*), intent(in) :: format |
1404 | 34 | character(len=100) :: s | 50 | character(len=100) :: s |
1405 | 35 | 51 | ||
1411 | 36 | if (present(format)) then | 52 | write(s,format) l |
1407 | 37 | write(s,format) log | ||
1408 | 38 | else | ||
1409 | 39 | write(s,"(l1)") log | ||
1410 | 40 | endif | ||
1412 | 41 | s = adjustl(s) | 53 | s = adjustl(s) |
1413 | 54 | |||
1414 | 55 | end function str_logical_fmt | ||
1415 | 56 | |||
1416 | 57 | function str_logical(l) result(s) | ||
1417 | 58 | logical, intent(in) :: l | ||
1418 | 59 | character(len=merge(4,5,l)) :: s | ||
1419 | 60 | |||
1420 | 61 | if (l) then | ||
1421 | 62 | s='true' | ||
1422 | 63 | else | ||
1423 | 64 | s='false' | ||
1424 | 65 | endif | ||
1425 | 42 | end function str_logical | 66 | end function str_logical |
1426 | 43 | 67 | ||
1427 | 44 | function str_real_dp(x,format) result(s) | 68 | function str_real_dp(x,format) result(s) |
1428 | @@ -47,10 +71,10 @@ | |||
1429 | 47 | character(len=100) :: s | 71 | character(len=100) :: s |
1430 | 48 | 72 | ||
1431 | 49 | if (present(format)) then | 73 | if (present(format)) then |
1433 | 50 | write(s,format) x | 74 | write(s,format) x |
1434 | 51 | else | 75 | else |
1435 | 52 | if (abs(nint(x)-x) .lt. epsilon(x)) then | 76 | if (abs(nint(x)-x) .lt. epsilon(x)) then |
1437 | 53 | write(s,"(f20.0)") x | 77 | write(s,"(i0)") nint(x) |
1438 | 54 | else | 78 | else |
1439 | 55 | write(s,"(g22.12)") x | 79 | write(s,"(g22.12)") x |
1440 | 56 | endif | 80 | endif |
1441 | @@ -67,7 +91,7 @@ | |||
1442 | 67 | write(s,format) x | 91 | write(s,format) x |
1443 | 68 | else | 92 | else |
1444 | 69 | if (abs(nint(x)-x) .lt. epsilon(x)) then | 93 | if (abs(nint(x)-x) .lt. epsilon(x)) then |
1446 | 70 | write(s,"(f20.0)") x | 94 | write(s,"(i0)") nint(x) |
1447 | 71 | else | 95 | else |
1448 | 72 | write(s,"(g22.12)") x | 96 | write(s,"(g22.12)") x |
1449 | 73 | endif | 97 | endif |
1450 | 74 | 98 | ||
1451 | === modified file 'wxml/makefile' | |||
1452 | --- wxml/makefile 2016-01-15 15:49:14 +0000 | |||
1453 | +++ wxml/makefile 2016-01-30 12:34:50 +0000 | |||
1454 | @@ -1,6 +1,8 @@ | |||
1455 | 1 | # | 1 | # |
1458 | 2 | OBJFILES= m_wxml_buffer.o m_wxml_dictionary.o m_wxml_elstack.o \ | 2 | OBJFILES= m_wxml_buffer.o m_wxml_array_str.o m_wxml_dictionary.o\ |
1459 | 3 | m_wxml_text.o m_wxml_core.o xmlf90_wxml.o | 3 | m_wxml_elstack.o \ |
1460 | 4 | m_wxml_text.o m_wxml_escape.o m_wxml_core.o \ | ||
1461 | 5 | m_wxml_overloads.o xmlf90_wxml.o m_wxml_error.o | ||
1462 | 4 | MODFILES=$(OBJFILES:.o=) | 6 | MODFILES=$(OBJFILES:.o=) |
1463 | 5 | 7 | ||
1464 | 6 | #------------------------------ | 8 | #------------------------------ |
1465 | @@ -10,4 +12,12 @@ | |||
1466 | 10 | 12 | ||
1467 | 11 | clean: | 13 | clean: |
1468 | 12 | rm -f *.o *.$(MOD_EXT) | 14 | rm -f *.o *.$(MOD_EXT) |
1469 | 15 | # DO NOT DELETE THIS LINE - used by make depend | ||
1470 | 16 | xmlf90_wxml.o: m_wxml_core.o m_wxml_overloads.o m_wxml_text.o | ||
1471 | 17 | m_wxml_buffer.o: m_wxml_error.o m_wxml_escape.o | ||
1472 | 18 | m_wxml_core.o: m_wxml_buffer.o m_wxml_dictionary.o m_wxml_elstack.o | ||
1473 | 19 | m_wxml_core.o: m_wxml_escape.o m_wxml_array_str.o | ||
1474 | 20 | m_wxml_dictionary.o: m_wxml_array_str.o m_wxml_escape.o | ||
1475 | 21 | m_wxml_elstack.o: m_wxml_error.o | ||
1476 | 22 | m_wxml_overloads.o: m_wxml_core.o m_wxml_text.o | ||
1477 | 13 | 23 | ||
1478 | 14 | 24 | ||
1479 | === modified file 'wxml/xmlf90_wxml.f90' | |||
1480 | --- wxml/xmlf90_wxml.f90 2016-01-15 15:49:14 +0000 | |||
1481 | +++ wxml/xmlf90_wxml.f90 2016-01-30 12:34:50 +0000 | |||
1482 | @@ -1,10 +1,8 @@ | |||
1483 | 1 | module xmlf90_wxml | 1 | module xmlf90_wxml |
1484 | 2 | 2 | ||
1485 | 3 | !use m_wxml_buffer | ||
1486 | 4 | !use m_wxml_dictionary | ||
1487 | 5 | !use m_wxml_elstack | ||
1488 | 6 | use m_wxml_text | 3 | use m_wxml_text |
1489 | 7 | use m_wxml_core | 4 | use m_wxml_core |
1490 | 5 | use m_wxml_overloads | ||
1491 | 8 | 6 | ||
1492 | 9 | public | 7 | public |
1493 | 10 | 8 |
The wxml test shows that there has been a regression: "real" attribute values are not trimmed.