Merge lp:~albertog/xmlf90/wxml-upgrade into lp:xmlf90

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
Reviewer Review Type Date Requested Status
Alberto Garcia Approve
Review via email: mp+284429@code.launchpad.net

Description of the change

Updated wxml code, brought from the libpsml distribution.

To post a comment you must log in.
Revision history for this message
Alberto Garcia (albertog) wrote :

The wxml test shows that there has been a regression: "real" attribute values are not trimmed.

review: Needs Fixing
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
=== modified file 'Examples/wxml/m_pseudo_utils.f90'
--- Examples/wxml/m_pseudo_utils.f90 2016-01-15 15:49:14 +0000
+++ Examples/wxml/m_pseudo_utils.f90 2016-01-30 12:34:50 +0000
@@ -183,7 +183,8 @@
183call xml_AddAttribute(xf,"version","0.5")183call xml_AddAttribute(xf,"version","0.5")
184call xml_NewElement(xf,"header")184call xml_NewElement(xf,"header")
185call xml_AddAttribute(xf,"symbol",trim(p%name))185call xml_AddAttribute(xf,"symbol",trim(p%name))
186call xml_AddAttribute(xf,"zval",trim(str(p%zval)))186!call xml_AddAttribute(xf,"zval",trim(str(p%zval)))
187call xml_AddAttribute(xf,"zval",p%zval) ! Overloaded
187call xml_AddAttribute(xf,"creator",trim(p%creator))188call xml_AddAttribute(xf,"creator",trim(p%creator))
188call xml_AddAttribute(xf,"date",trim(p%date))189call xml_AddAttribute(xf,"date",trim(p%date))
189call xml_AddAttribute(xf,"flavor",trim(p%flavor))190call xml_AddAttribute(xf,"flavor",trim(p%flavor))
@@ -206,27 +207,27 @@
206call xml_NewElement(xf,"grid")207call xml_NewElement(xf,"grid")
207 call xml_AddAttribute(xf,"type","log")208 call xml_AddAttribute(xf,"type","log")
208 call xml_AddAttribute(xf,"units","bohr")209 call xml_AddAttribute(xf,"units","bohr")
209 call xml_AddAttribute(xf,"scale",trim(str(p%grid_scale)))210 call xml_AddAttribute(xf,"scale",p%grid_scale)
210 call xml_AddAttribute(xf,"step",trim(str(p%grid_step)))211 call xml_AddAttribute(xf,"step",p%grid_step)
211 call xml_AddAttribute(xf,"npts",trim(str(p%nr-1)))212 call xml_AddAttribute(xf,"npts",p%nr-1)
212call xml_EndElement(xf,"grid")213 call xml_EndElement(xf,"grid")
213214
214call xml_NewElement(xf,"semilocal")215call xml_NewElement(xf,"semilocal")
215216
216 call xml_AddAttribute(xf,"units","rydberg")217 call xml_AddAttribute(xf,"units","rydberg")
217 call xml_AddAttribute(xf,"format","r*V")218 call xml_AddAttribute(xf,"format","r*V")
218 call xml_AddAttribute(xf,"npots-down",trim(str(p%npotd)))219 call xml_AddAttribute(xf,"npots-down",p%npotd)
219 call xml_AddAttribute(xf,"npots-up",trim(str(p%npotu)))220 call xml_AddAttribute(xf,"npots-up",p%npotu)
220221
221 do i=1,p%npotd222 do i=1,p%npotd
222 call xml_NewElement(xf,"vps")223 call xml_NewElement(xf,"vps")
223 call xml_AddAttribute(xf,"principal-n", &224 call xml_AddAttribute(xf,"principal-n", &
224 trim(str(p%principal_n(p%ldown(i)))))225 p%principal_n(p%ldown(i)))
225 call xml_AddAttribute(xf,"l",trim(str(p%ldown(i))))226 call xml_AddAttribute(xf,"l",p%ldown(i))
226 call xml_AddAttribute(xf,"cutoff", &227 call xml_AddAttribute(xf,"cutoff", &
227 trim(str(p%cutoff(p%ldown(i)))))228 p%cutoff(p%ldown(i)))
228 call xml_AddAttribute(xf,"occupation", &229 call xml_AddAttribute(xf,"occupation", &
229 trim(str(p%occupation(p%ldown(i)))))230 p%occupation(p%ldown(i)))
230 call xml_AddAttribute(xf,"spin","-1")231 call xml_AddAttribute(xf,"spin","-1")
231232
232 call xml_NewElement(xf,"radfunc")233 call xml_NewElement(xf,"radfunc")
233234
=== modified file 'Examples/wxml/simple.f90'
--- Examples/wxml/simple.f90 2016-01-15 15:49:14 +0000
+++ Examples/wxml/simple.f90 2016-01-30 12:34:50 +0000
@@ -2,6 +2,8 @@
22
3use xmlf90_wxml3use xmlf90_wxml
44
5integer, parameter :: dp = selected_real_kind(15,100)
6
5type(xmlf_t) :: xf7type(xmlf_t) :: xf
68
7integer :: age = 349integer :: age = 34
@@ -12,12 +14,14 @@
1214
13call xml_AddXMLDeclaration(xf,"UTF-8")15call xml_AddXMLDeclaration(xf,"UTF-8")
14call xml_NewElement(xf,"john")16call xml_NewElement(xf,"john")
15call xml_AddAttribute(xf,"age",str(age))17call xml_AddAttribute(xf,"age",age) ! Overloaded int, with trimming
16call xml_NewElement(xf,"peter")18call xml_NewElement(xf,"peter")
19call xml_AddAttribute(xf,"with-blanks"," ..Ha.. ") ! String, no trimming
17call xml_NewElement(xf,"tim")20call xml_NewElement(xf,"tim")
18call xml_AddAttribute(xf,"age","37")21call xml_AddAttribute(xf,"age","37") ! String, no trimming
19call xml_AddAttribute(xf,"weight",str(123.45,"(f7.3)"))22call xml_AddAttribute(xf,"weight",123.45_dp,fmt="(f7.3)") ! Overloaded, trimming
20call xml_AddAttribute(xf,"cholesterol",str(167.0,format="(f8.0)"))23call xml_AddAttribute(xf,"cholesterol",167.0,fmt="(f8.0)") ! Overloaded, trimming
24call xml_AddAttribute(xf,"realdefault",137.01) ! Overloaded, default fmt, trimming
21call xml_EndElement(xf,"tim")25call xml_EndElement(xf,"tim")
22call xml_AddPcdata(xf,"Ping-pong")26call xml_AddPcdata(xf,"Ping-pong")
23call xml_AddPcdata(xf,"champion", line_feed=.false.)27call xml_AddPcdata(xf,"champion", line_feed=.false.)
2428
=== added file 'wxml/m_wxml_array_str.f90'
--- wxml/m_wxml_array_str.f90 1970-01-01 00:00:00 +0000
+++ wxml/m_wxml_array_str.f90 2016-01-30 12:34:50 +0000
@@ -0,0 +1,77 @@
1module m_wxml_array_str
2!
3! Utilities for character to character array
4! conversions and tests of equality.
5!
6interface operator (.equal.)
7 module procedure compare_array_str
8end interface
9!
10! Not supported by all compilers...
11! interface assignment (=)
12! module procedure assign_array_to_str !!!! , assign_str_to_array
13! end interface
14
15public :: operator(.equal.) !!!! , assignment(=)
16public :: assign_array_to_str , assign_str_to_array
17private
18
19CONTAINS
20!-------------------------------------------------------------
21subroutine assign_array_to_str(str,s)
22implicit none
23character(len=1), dimension(:), intent(in) :: s
24character(len=*), intent(out) :: str
25
26integer :: i, lstr
27
28lstr = len(str)
29do i = 1, min(size(s),lstr)
30 str(i:i) = s(i)
31enddo
32do i = size(s)+1, lstr
33 str(i:i) = " "
34enddo
35end subroutine assign_array_to_str
36
37!-------------------------------------------------------------
38! The NAG and Intel compilers cannot distinguish this from the
39! intrinsic assignment... so we resort to using an explicit
40! subroutine call.
41!
42subroutine assign_str_to_array(s,str)
43implicit none
44character(len=1), dimension(:), intent(out) :: s
45character(len=*), intent(in) :: str
46
47integer :: i, lstr
48
49lstr = len(str)
50do i = 1, min(size(s),lstr)
51 s(i) = str(i:i)
52enddo
53
54end subroutine assign_str_to_array
55
56!-------------------------------------------------------------
57function compare_array_str(s,str) result(equal) ! .equal. generic
58implicit none
59character(len=1), dimension(:), intent(in) :: s
60character(len=*), intent(in) :: str
61logical :: equal
62integer :: lens, lenstr, i
63
64
65equal = .false.
66lens = size(s)
67lenstr = len(str)
68if (lens .ne. lenstr) return
69
70do i = 1, lens
71 if (s(i) .ne. str(i:i)) return
72enddo
73equal = .true.
74
75end function compare_array_str
76
77end module m_wxml_array_str
078
=== modified file 'wxml/m_wxml_buffer.f90'
--- wxml/m_wxml_buffer.f90 2014-09-04 09:28:10 +0000
+++ wxml/m_wxml_buffer.f90 2016-01-30 12:34:50 +0000
@@ -1,5 +1,9 @@
1module m_wxml_buffer1module m_wxml_buffer
22
3use m_wxml_error
4
5implicit none
6
3!7!
4! At this point we use a fixed-size buffer. 8! At this point we use a fixed-size buffer.
5! Note however that buffer overflows will only be9! Note however that buffer overflows will only be
@@ -9,13 +13,13 @@
9! There is code in the parser module m_fsm to avoid buffer overflows13! There is code in the parser module m_fsm to avoid buffer overflows
10! caused by pcdata values.14! caused by pcdata values.
11!15!
12! This module is re-used from the parser package.16! This module is re-used from the parser package, except the size.
13! Most of the routines are superfluous at this point.17! Most of the routines are superfluous at this point.
14!18!
15! In a forthcoming implementation it could be made dynamical...19! In a forthcoming implementation it could be made dynamical...
16!20!
17integer, parameter, public :: MAX_BUFF_SIZE = 200021integer, parameter, public :: MAX_BUFF_SIZE = 10000
18integer, parameter, private :: BUFF_SIZE_WARNING = 175022integer, parameter, private :: BUFF_SIZE_WARNING = 9500
19!23!
20type, public :: buffer_t24type, public :: buffer_t
21private25private
@@ -23,12 +27,12 @@
23 character(len=MAX_BUFF_SIZE) :: str27 character(len=MAX_BUFF_SIZE) :: str
24end type buffer_t28end type buffer_t
2529
26public :: add_to_buffer30public :: add_to_buffer, add_to_buffer_escaping_markup
27public :: print_buffer, str, char, len31public :: print_buffer, str, char, len
28public :: operator (.equal.)32public :: operator (.equal.)
29public :: buffer_nearly_full, reset_buffer33public :: buffer_nearly_full, reset_buffer
3034
3135private
32!----------------------------------------------------------------36!----------------------------------------------------------------
33interface add_to_buffer37interface add_to_buffer
34 module procedure add_str_to_buffer38 module procedure add_str_to_buffer
@@ -97,9 +101,7 @@
97n = buffer%size101n = buffer%size
98102
99if (n> MAX_BUFF_SIZE) then103if (n> MAX_BUFF_SIZE) then
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...")
101! RETURN
102!
103endif105endif
104106
105buffer%str(n:n) = c107buffer%str(n:n) = c
@@ -110,7 +112,7 @@
110character(len=*), intent(in) :: s112character(len=*), intent(in) :: s
111type(buffer_t), intent(inout) :: buffer113type(buffer_t), intent(inout) :: buffer
112114
113integer :: n, len_s, last_pos115integer :: i, n, len_s, last_pos
114116
115len_s = len(s)117len_s = len(s)
116last_pos = buffer%size118last_pos = buffer%size
@@ -118,13 +120,40 @@
118n = buffer%size120n = buffer%size
119121
120if (n> MAX_BUFF_SIZE) then122if (n> MAX_BUFF_SIZE) then
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...")
122! RETURN
123endif124endif
124125
125buffer%str(last_pos+1:n) = s126if (len_s.gt.0) buffer%str(last_pos+1:n) = s
126end subroutine add_str_to_buffer127end subroutine add_str_to_buffer
127128
129subroutine add_to_buffer_escaping_markup(s,buf)
130character(len=*), intent(in) :: s
131type(buffer_t), intent(inout) :: buf
132
133integer :: len_s, i
134character(len=1) :: c
135
136len_s = len(s)
137i = 0
138do
139 if (i==len_s) exit
140 i = i + 1
141 c = s(i:i)
142 if (c == "<") then
143 call add_to_buffer("&lt;",buf)
144 else if (c == "&") then
145 call add_to_buffer("&amp;",buf)
146 else if (c == "'") then
147 call add_to_buffer("&apos;",buf)
148 else if (c == '"') then
149 call add_to_buffer("&quot;",buf)
150 else
151 call add_to_buffer(c,buf)
152 endif
153enddo
154
155end subroutine add_to_buffer_escaping_markup
156
128!----------------------------------------------------------------157!----------------------------------------------------------------
129subroutine reset_buffer(buffer)158subroutine reset_buffer(buffer)
130type(buffer_t), intent(inout) :: buffer159type(buffer_t), intent(inout) :: buffer
131160
=== modified file 'wxml/m_wxml_core.f90'
--- wxml/m_wxml_core.f90 2014-09-04 09:28:10 +0000
+++ wxml/m_wxml_core.f90 2016-01-30 12:34:50 +0000
@@ -1,9 +1,14 @@
1module m_wxml_core1module m_wxml_core
22
3use m_wxml_buffer3use m_wxml_buffer
4use m_wxml_array_str, only: assign_array_to_str
5use m_wxml_array_str, only: assign_str_to_array
6use m_wxml_escape, only: check_Name
4use m_wxml_elstack7use m_wxml_elstack
5use m_wxml_dictionary8use m_wxml_dictionary
69
10implicit none
11
7logical, private, save :: pcdata_advance_line_default = .false.12logical, private, save :: pcdata_advance_line_default = .false.
8logical, private, save :: pcdata_advance_space_default = .false.13logical, private, save :: pcdata_advance_space_default = .false.
914
@@ -13,19 +18,31 @@
13private18private
1419
15type, public :: xmlf_t20type, public :: xmlf_t
16 integer :: lun21 character, pointer :: filename(:)
17 type(buffer_t) :: buffer22 integer :: lun
18 type(elstack_t) :: stack23 type(buffer_t) :: buffer
24 type(elstack_t) :: stack
19 type(wxml_dictionary_t) :: dict25 type(wxml_dictionary_t) :: dict
20 logical :: start_tag_closed26 logical :: start_tag_closed
21 logical :: root_element_output27 logical :: root_element_output
22 logical :: indenting_requested28 logical :: indenting_requested
29 logical :: inhibit_lf
23end type xmlf_t30end type xmlf_t
2431
25public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close32public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close
26public :: xml_AddPcdata, xml_AddAttribute, xml_AddXMLDeclaration33public :: xml_AddXMLDeclaration
34public :: xml_AddXMLStylesheet
35public :: xml_AddXMLPI
27public :: xml_AddComment, xml_AddCdataSection36public :: xml_AddComment, xml_AddCdataSection
2837public :: xml_AddPcdata, xml_AddAttribute
38interface xml_AddPcdata
39 module procedure xml_AddPcdata_Ch
40end interface
41!
42interface xml_AddAttribute
43 module procedure xml_AddAttribute_Ch
44end interface
45!
29public :: xml_AddArray46public :: xml_AddArray
30interface xml_AddArray47interface xml_AddArray
31 module procedure xml_AddArray_integer, &48 module procedure xml_AddArray_integer, &
@@ -37,9 +54,28 @@
37private :: add_eol54private :: add_eol
38private :: write_attributes55private :: write_attributes
3956
57!overload error handlers to allow file info
58interface wxml_warning
59 module procedure wxml_warning_xf
60end interface
61interface wxml_error
62 module procedure wxml_error_xf
63end interface
64interface wxml_fatal
65 module procedure wxml_fatal_xf
66end interface
4067
68!
69! Heuristic (approximate) target for justification of output
70! Large unbroken pcdatas will go beyond this limit
71!
41integer, private, parameter :: COLUMNS = 8072integer, private, parameter :: COLUMNS = 80
4273
74! TOHW - This is the longest string that may be output without
75! a newline. The buffer must not be larger than this, but its size
76! can be tuned for performance.
77integer, private, parameter :: xml_recl = 4096
78
43CONTAINS79CONTAINS
4480
45!-------------------------------------------------------------------81!-------------------------------------------------------------------
@@ -50,17 +86,30 @@
5086
51integer :: iostat87integer :: iostat
5288
89allocate(xf%filename(len(filename)))
90call assign_str_to_array(xf%filename,filename)
91
53call get_unit(xf%lun,iostat)92call get_unit(xf%lun,iostat)
54if (iostat /= 0) stop "cannot open file"93if (iostat /= 0) call wxml_fatal(xf, "cannot open file")
94!
95! Use large I/O buffer in case the O.S./Compiler combination
96! has hard-limits by default (i.e., NAGWare f95's 1024 byte limit)
97! This is related to the maximum size of the buffer.
98! TOHW - This is the longest string that may be output without
99! a newline. The buffer must not be larger than this, but its size
100! can be tuned for performance.
101
55open(unit=xf%lun, file=filename, form="formatted", status="replace", &102open(unit=xf%lun, file=filename, form="formatted", status="replace", &
56 action="write", position="rewind") ! , recl=65536)103 action="write", position="rewind", recl=xml_recl)
57104
58call reset_elstack(xf%stack)105call init_elstack(xf%stack)
59call reset_dict(xf%dict)106
107call init_dict(xf%dict)
60call reset_buffer(xf%buffer)108call reset_buffer(xf%buffer)
61109
62xf%start_tag_closed = .true.110xf%start_tag_closed = .true.
63xf%root_element_output = .false.111xf%root_element_output = .false.
112xf%inhibit_lf = .false.
64113
65xf%indenting_requested = .false.114xf%indenting_requested = .false.
66if (present(indent)) then115if (present(indent)) then
@@ -82,6 +131,48 @@
82end subroutine xml_AddXMLDeclaration131end subroutine xml_AddXMLDeclaration
83132
84!-------------------------------------------------------------------133!-------------------------------------------------------------------
134subroutine xml_AddXMLStylesheet(xf, href, type, title, media, charset, alternate)
135type(xmlf_t), intent(inout) :: xf
136character(len=*), intent(in) :: href
137character(len=*), intent(in) :: type
138character(len=*), intent(in), optional :: title
139character(len=*), intent(in), optional :: media
140character(len=*), intent(in), optional :: charset
141logical, intent(in), optional :: alternate
142
143call add_eol(xf)
144call add_to_buffer("<?xml-stylesheet href=""" //trim(href)// &
145 """ type=""" //trim(type)// """", xf%buffer)
146
147if (present(title)) call add_to_buffer(" title="""//trim(title)// """", xf%buffer)
148if (present(media)) call add_to_buffer(" media="""//trim(media)// """", xf%buffer)
149if (present(charset)) call add_to_buffer(" charset="""//trim(charset)// """", xf%buffer)
150if (present(alternate)) then
151 if (alternate) then
152 call add_to_buffer(" alternate=""yes""", xf%buffer)
153 else
154 call add_to_buffer(" alternate=""no""", xf%buffer)
155 endif
156endif
157call add_to_buffer(" ?>", xf%buffer)
158
159end subroutine xml_AddXMLStylesheet
160
161!-------------------------------------------------------------------
162subroutine xml_AddXMLPI(xf, name, data)
163type(xmlf_t), intent(inout) :: xf
164character(len=*), intent(in) :: name
165character(len=*), intent(in), optional :: data
166
167call add_eol(xf)
168call add_to_buffer("<?" // trim(name) // " ", xf%buffer)
169if(present(data)) call add_to_buffer(data, xf%buffer)
170call add_to_buffer(" ?>", xf%buffer)
171
172end subroutine xml_AddXMLPI
173
174
175!-------------------------------------------------------------------
85subroutine xml_AddComment(xf,comment)176subroutine xml_AddComment(xf,comment)
86type(xmlf_t), intent(inout) :: xf177type(xmlf_t), intent(inout) :: xf
87character(len=*), intent(in) :: comment178character(len=*), intent(in) :: comment
@@ -94,14 +185,20 @@
94end subroutine xml_AddComment185end subroutine xml_AddComment
95186
96!-------------------------------------------------------------------187!-------------------------------------------------------------------
97subroutine xml_AddCdataSection(xf,cdata)188subroutine xml_AddCdataSection(xf,cdata,line_feed)
98type(xmlf_t), intent(inout) :: xf189type(xmlf_t), intent(inout) :: xf
99character(len=*), intent(in) :: cdata190character(len=*), intent(in) :: cdata
191logical, intent(in), optional :: line_feed
100192
101call close_start_tag(xf,">")193call close_start_tag(xf,">")
194call dump_buffer(xf,line_feed)
102call add_to_buffer("<![CDATA[", xf%buffer)195call add_to_buffer("<![CDATA[", xf%buffer)
103call add_to_buffer(cdata, xf%buffer)196call add_to_buffer(cdata, xf%buffer)
104call add_to_buffer("]]>", xf%buffer)197call add_to_buffer("]]>", xf%buffer)
198call dump_buffer(xf,line_feed)
199if (present(line_feed)) then
200 if (line_feed) xf%inhibit_lf = .true.
201endif
105end subroutine xml_AddCdataSection202end subroutine xml_AddCdataSection
106203
107!-------------------------------------------------------------------204!-------------------------------------------------------------------
@@ -110,10 +207,15 @@
110character(len=*), intent(in) :: name207character(len=*), intent(in) :: name
111208
112if (is_empty(xf%stack)) then209if (is_empty(xf%stack)) then
113 if (xf%root_element_output) stop "two root elements"210 if (xf%root_element_output) call wxml_error(xf, "two root elements")
114 xf%root_element_output = .true.211 xf%root_element_output = .true.
115endif212endif
116213
214if (.not.check_Name(name)) then
215 call wxml_warning(xf, 'attribute name '//name//' is not valid')
216endif
217
218
117call close_start_tag(xf,">")219call close_start_tag(xf,">")
118call push_elstack(name,xf%stack)220call push_elstack(name,xf%stack)
119call add_eol(xf)221call add_eol(xf)
@@ -123,15 +225,13 @@
123225
124end subroutine xml_NewElement226end subroutine xml_NewElement
125!-------------------------------------------------------------------227!-------------------------------------------------------------------
126subroutine xml_AddPcdata(xf,pcdata,space,line_feed)228subroutine xml_AddPcdata_Ch(xf,pcdata,space,line_feed)
127type(xmlf_t), intent(inout) :: xf229type(xmlf_t), intent(inout) :: xf
128character(len=*), intent(in) :: pcdata230character(len=*), intent(in) :: pcdata
129logical, intent(in), optional :: space231logical, intent(in), optional :: space
130logical, intent(in), optional :: line_feed232logical, intent(in), optional :: line_feed
131233
132logical :: advance_line , advance_space234logical :: advance_line , advance_space
133integer :: n, i, jmax
134integer, parameter :: chunk_size = 128
135235
136advance_line = pcdata_advance_line_default 236advance_line = pcdata_advance_line_default
137if (present(line_feed)) then237if (present(line_feed)) then
@@ -144,7 +244,7 @@
144endif244endif
145245
146if (is_empty(xf%stack)) then246if (is_empty(xf%stack)) then
147 stop "pcdata outside element content"247 call wxml_error(xf, "pcdata outside element content")
148endif248endif
149249
150call close_start_tag(xf,">")250call close_start_tag(xf,">")
@@ -161,43 +261,32 @@
161 endif261 endif
162endif262endif
163if (advance_space) call add_to_buffer(" ",xf%buffer)263if (advance_space) call add_to_buffer(" ",xf%buffer)
164if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.false.)264
165!265call add_to_buffer_escaping_markup(pcdata, xf%buffer)
166! We bypass the buffer for the bulk of the dump266
167!267end subroutine xml_AddPcdata_Ch
168n = len(pcdata)
169!print *, "writing pcdata of length: ", n
170i = 1
171do
172 jmax = min(i+chunk_size-1,n)
173! print *, "writing chunk: ", i, jmax
174 write(unit=xf%lun,fmt="(a)",advance="no") pcdata(i:jmax)
175 if (jmax == n) exit
176 i = jmax + 1
177enddo
178end subroutine xml_AddPcdata
179268
180!-------------------------------------------------------------------269!-------------------------------------------------------------------
181subroutine xml_AddAttribute(xf,name,value)270subroutine xml_AddAttribute_Ch(xf,name,value)
182type(xmlf_t), intent(inout) :: xf271type(xmlf_t), intent(inout) :: xf
183character(len=*), intent(in) :: name272character(len=*), intent(in) :: name
184character(len=*), intent(in) :: value273character(len=*), intent(in) :: value
185274
186if (is_empty(xf%stack)) then275if (is_empty(xf%stack)) then
187 stop "attributes outside element content"276 call wxml_error(xf, "attributes outside element content")
188endif277endif
189278
190if (xf%start_tag_closed) then279if (xf%start_tag_closed) then
191 stop "attributes outside start tag"280 call wxml_error(xf, "attributes outside start tag")
192endif281endif
282
193if (has_key(xf%dict,name)) then283if (has_key(xf%dict,name)) then
194 stop "duplicate att name"284 call wxml_error(xf, "duplicate att name")
195endif285endif
196286
197call add_key_to_dict(trim(name),xf%dict)287call add_item_to_dict(xf%dict, name, value)
198call add_value_to_dict(trim(value),xf%dict)
199288
200end subroutine xml_AddAttribute289end subroutine xml_AddAttribute_Ch
201290
202!-----------------------------------------------------------291!-----------------------------------------------------------
203subroutine xml_EndElement(xf,name)292subroutine xml_EndElement(xf,name)
@@ -207,19 +296,19 @@
207character(len=100) :: current296character(len=100) :: current
208297
209if (is_empty(xf%stack)) then298if (is_empty(xf%stack)) then
210 stop "Out of elements to close"299 call wxml_fatal(xf, "Out of elements to close")
211endif300endif
212301
213call get_top_elstack(xf%stack,current)302call get_top_elstack(xf%stack,current)
214if (current /= name) then303if (current /= name) then
215 print *, "current, name: ", trim(current), " ", trim(name)304 call wxml_fatal(xf, 'Trying to close '//Trim(name)//' but '//Trim(current)//' is open.')
216 stop
217endif305endif
218if (.not. xf%start_tag_closed) then ! Empty element306if (.not. xf%start_tag_closed) then ! Empty element
219 if (len(xf%dict) > 0) call write_attributes(xf)307 if (len(xf%dict) > 0) call write_attributes(xf)
220 call add_to_buffer(" />",xf%buffer)308 call add_to_buffer(" />",xf%buffer)
221 xf%start_tag_closed = .true.309 xf%start_tag_closed = .true.
222else310else
311 ! This statement will introduce a newline after array data...
223 call add_eol(xf)312 call add_eol(xf)
224 call add_to_buffer("</" // trim(name) // ">", xf%buffer)313 call add_to_buffer("</" // trim(name) // ">", xf%buffer)
225endif314endif
@@ -230,11 +319,21 @@
230!----------------------------------------------------------------319!----------------------------------------------------------------
231320
232subroutine xml_Close(xf)321subroutine xml_Close(xf)
233type(xmlf_t), intent(in) :: xf322type(xmlf_t), intent(inout) :: xf
323
324character(len=200) :: name
325
326do
327 if (is_empty(xf%stack)) exit
328 call get_top_elstack(xf%stack,name)
329 call xml_EndElement(xf,trim(name))
330enddo
234331
235write(unit=xf%lun,fmt="(a)") char(xf%buffer)332write(unit=xf%lun,fmt="(a)") char(xf%buffer)
236close(unit=xf%lun)333close(unit=xf%lun)
237334
335deallocate(xf%filename)
336
238end subroutine xml_Close337end subroutine xml_Close
239338
240!==================================================================339!==================================================================
@@ -266,14 +365,24 @@
266type(xmlf_t), intent(inout) :: xf365type(xmlf_t), intent(inout) :: xf
267366
268integer :: indent_level367integer :: indent_level
269character(len=100), parameter :: blanks = ""368
270369
271indent_level = len(xf%stack) - 1370! Flush with a linefeed except if a previous operation has raised
272write(unit=xf%lun,fmt="(a)") char(xf%buffer)371! the inhibit_lf flag
273call reset_buffer(xf%buffer)372
274373if (xf%inhibit_lf) then
374 call dump_buffer(xf,lf=.false.)
375 xf%inhibit_lf = .false.
376else
377 call dump_buffer(xf,lf=.true.)
378endif
379
380! In case we still have a zero-length stack, we must make
381! sure indent_level is not less than zero.
382
383indent_level = max(len(xf%stack) - 1, 0)
275if (xf%indenting_requested) &384if (xf%indenting_requested) &
276 call add_to_buffer(blanks(1:indent_level),xf%buffer)385 call add_to_buffer(repeat(' ',indent_level),xf%buffer)
277386
278end subroutine add_eol387end subroutine add_eol
279!------------------------------------------------------------388!------------------------------------------------------------
@@ -311,21 +420,19 @@
311subroutine write_attributes(xf)420subroutine write_attributes(xf)
312type(xmlf_t), intent(inout) :: xf421type(xmlf_t), intent(inout) :: xf
313422
314integer :: i, status, size423integer :: i, status, size, key_len, value_len
315character(len=100) :: key, value424character(len=200) :: key, value
316425
317do i = 1, len(xf%dict)426do i = 1, len(xf%dict)
318 call get_key(xf%dict,i,key,status)427 call get_key(xf%dict,i,key,key_len,status)
319 call get_value(xf%dict,key,value,status)428 call get_value(xf%dict,i,value,value_len,status)
320 key = adjustl(key)429 size = key_len + value_len + 4
321 value = adjustl(value)
322 size = len_trim(key) + len_trim(value) + 4
323 if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf)430 if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf)
324 call add_to_buffer(" ", xf%buffer)431 call add_to_buffer(" ", xf%buffer)
325 call add_to_buffer(trim(key), xf%buffer)432 call add_to_buffer(key(:key_len), xf%buffer)
326 call add_to_buffer("=", xf%buffer)433 call add_to_buffer("=", xf%buffer)
327 call add_to_buffer("""",xf%buffer)434 call add_to_buffer("""",xf%buffer)
328 call add_to_buffer(trim(value), xf%buffer)435 call add_to_buffer_escaping_markup(value(:value_len), xf%buffer)
329 call add_to_buffer("""", xf%buffer)436 call add_to_buffer("""", xf%buffer)
330enddo437enddo
331438
@@ -343,6 +450,7 @@
343 write(xf%lun,format) a450 write(xf%lun,format) a
344 else451 else
345 write(xf%lun,"(6(i12))") a452 write(xf%lun,"(6(i12))") a
453 xf%inhibit_lf = .true.
346 endif454 endif
347 end subroutine xml_AddArray_integer455 end subroutine xml_AddArray_integer
348456
@@ -359,6 +467,7 @@
359 else467 else
360 write(xf%lun,"(4(es20.12))") a468 write(xf%lun,"(4(es20.12))") a
361 endif469 endif
470 xf%inhibit_lf = .true.
362 end subroutine xml_AddArray_real_dp471 end subroutine xml_AddArray_real_dp
363472
364!------------------------------------------------------------------473!------------------------------------------------------------------
@@ -374,7 +483,57 @@
374 else483 else
375 write(xf%lun,"(4(es20.12))") a484 write(xf%lun,"(4(es20.12))") a
376 endif485 endif
486 xf%inhibit_lf = .true.
377 end subroutine xml_AddArray_real_sp487 end subroutine xml_AddArray_real_sp
378488
489!---------------------------------------------------------
490! Error handling/trapping routines:
491
492 subroutine wxml_warning_xf(xf, msg)
493 ! Emit warning, but carry on.
494 type(xmlf_t), intent(in) :: xf
495 character(len=*), intent(in) :: msg
496
497 write(6,'(a)') 'WARNING(wxml) in writing to file ', xmlf_name(xf)
498 write(6,'(a)') msg
499
500 end subroutine wxml_warning_xf
501
502 subroutine wxml_error_xf(xf, msg)
503 ! Emit error message, clean up file and stop.
504 type(xmlf_t), intent(inout) :: xf
505 character(len=*), intent(in) :: msg
506
507 write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf)
508 write(6,'(a)') msg
509
510 call xml_Close(xf)
511 stop
512
513 end subroutine wxml_error_xf
514
515 subroutine wxml_fatal_xf(xf, msg)
516 !Emit error message and abort with coredump. Does not try to
517 !close file, so should be used from anything xml_Close might
518 !itself call (to avoid infinite recursion!)
519
520 type(xmlf_t), intent(in) :: xf
521 character(len=*), intent(in) :: msg
522
523 write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf)
524 write(6,'(a)') msg
525
526 !call pxfabort
527 stop
528
529 end subroutine wxml_fatal_xf
530
531 function xmlf_name(xf) result(fn)
532 Type (xmlf_t), intent(in) :: xf
533 character(len=size(xf%filename)) :: fn
534 call assign_array_to_str(fn,xf%filename)
535 end function xmlf_name
536
537
379end module m_wxml_core538end module m_wxml_core
380539
381540
=== modified file 'wxml/m_wxml_dictionary.f90'
--- wxml/m_wxml_dictionary.f90 2014-09-04 09:28:10 +0000
+++ wxml/m_wxml_dictionary.f90 2016-01-30 12:34:50 +0000
@@ -1,24 +1,32 @@
1module m_wxml_dictionary1module m_wxml_dictionary
22
3 use m_wxml_escape, only : check_Name
4 use m_wxml_error, only : wxml_fatal
5 use m_wxml_array_str
6
7 implicit none
8
3private9private
4!10!
5! A very rough implementation for now
6! It uses fixed-length buffers for key/value pairs,
7! and the maximum number of dictionary items is hardwired.
8
9integer, parameter, private :: MAX_ITEMS = 3011integer, parameter, private :: MAX_ITEMS = 30
12
13type, private :: dict_item
14 character(len=1), pointer, dimension(:) :: key
15 character(len=1), pointer, dimension(:) :: value
16end type dict_item
17
10type, public :: wxml_dictionary_t18type, public :: wxml_dictionary_t
11private19private
12 integer :: number_of_items ! = 020 integer :: number_of_items ! = 0
13 character(len=100), dimension(MAX_ITEMS) :: key21 type(dict_item), dimension(MAX_ITEMS) :: items
14 character(len=100), dimension(MAX_ITEMS) :: value
15end type wxml_dictionary_t22end type wxml_dictionary_t
1623
17!24!
18! Building procedures25! Building procedures
19!26!
20public :: add_key_to_dict, add_value_to_dict, reset_dict27public :: init_dict
2128public :: reset_dict
29public :: add_item_to_dict
22!30!
23! Query and extraction procedures31! Query and extraction procedures
24!32!
@@ -27,13 +35,13 @@
27 module procedure number_of_entries35 module procedure number_of_entries
28end interface36end interface
29public :: number_of_entries37public :: number_of_entries
30public :: get_key38public :: get_key
31public :: get_value39public :: get_value
32public :: has_key40public :: has_key
33public :: print_dict41public :: print_dict
34!42!
35interface get_value43interface get_value
36 module procedure wxml_get_value44 module procedure wxml_get_value, wxml_get_value_i
37end interface45end interface
3846
39CONTAINS47CONTAINS
@@ -53,14 +61,13 @@
53character(len=*), intent(in) :: key61character(len=*), intent(in) :: key
54logical :: found62logical :: found
5563
56integer :: n, i64integer :: i
57found = .false.65found = .false.
58n = dict%number_of_items66do i = 1, dict%number_of_items
59do i = 1, n67 if (dict%items(i)%key .equal. key) then
60 if (dict%key(i) == key) then68 found = .true.
61 found = .true.69 exit
62 exit70 endif
63 endif
64enddo71enddo
65end function has_key72end function has_key
6673
@@ -71,79 +78,141 @@
71character(len=*), intent(out) :: value78character(len=*), intent(out) :: value
72integer, intent(out) :: status79integer, intent(out) :: status
73!80!
74integer :: n, i81integer :: i
7582
76status = -183status = -1
77n = dict%number_of_items84do i = 1, dict%number_of_items
78do i = 1, n85 if (dict%items(i)%key .equal. key) then
79 if (dict%key(i) == key) then86 call assign_array_to_str(value,dict%items(i)%value)
80 value = dict%value(i)87 status = 0
81 status = 088 exit
82 RETURN89 endif
83 endif
84enddo90enddo
8591
86end subroutine wxml_get_value92end subroutine wxml_get_value
8793
94function get_value_len(dict, key) result(value_len)
95 type(wxml_dictionary_t), intent(in) :: dict
96 character(len=*), intent(in) :: key
97 integer :: value_len
98
99 integer :: i
100
101 value_len = 0
102 do i = 1, dict%number_of_items
103 if (dict%items(i)%key .equal. key) then
104 value_len = size(dict%items(i)%value)
105 exit
106 endif
107 enddo
108
109end function get_value_len
110
111
88!------------------------------------------------------112!------------------------------------------------------
89subroutine get_key(dict,i,key,status)113subroutine get_key(dict,i,key,key_len,status)
90!114!
91! Get the i'th key115! Get the i'th key
92!116!
93type(wxml_dictionary_t), intent(in) :: dict117type(wxml_dictionary_t), intent(in) :: dict
94integer, intent(in) :: i118integer, intent(in) :: i
95character(len=*), intent(out) :: key119character(len=*), intent(out) :: key
120integer, intent(out) :: key_len
96integer, intent(out) :: status121integer, intent(out) :: status
97122
98if (i <= dict%number_of_items) then123if (i>0 .and. i<=dict%number_of_items) then
99 key = dict%key(i)124 call assign_array_to_str(key,dict%items(i)%key)
125 key_len = size(dict%items(i)%key)
100 status = 0126 status = 0
101else127else
102 key = ""128 key = ' '
129 key_len = 0
103 status = -1130 status = -1
104endif131endif
105132
106end subroutine get_key133end subroutine get_key
107
108!------------------------------------------------------134!------------------------------------------------------
109subroutine add_key_to_dict(key,dict)135subroutine wxml_get_value_i(dict,i,value,value_len,status)
110character(len=*), intent(in) :: key136!
111type(wxml_dictionary_t), intent(inout) :: dict137! Get the i'th value
112138!
113integer :: n139type(wxml_dictionary_t), intent(in) :: dict
114140integer, intent(in) :: i
115n = dict%number_of_items141character(len=*), intent(out) :: value
116if (n == MAX_ITEMS) then142integer, intent(out) :: value_len
117 write(unit=0,fmt=*) "Dictionary capacity exceeded !"143integer, intent(out) :: status
118 RETURN144
145if (i>0 .and. i<=dict%number_of_items) then
146 call assign_array_to_str(value,dict%items(i)%value)
147 value_len = size(dict%items(i)%value)
148 status = 0
149else
150 value = ' '
151 value_len = 0
152 status = -1
119endif153endif
120154
121n = n + 1155end subroutine wxml_get_value_i
122dict%key(n) = key156
123dict%number_of_items = n157subroutine add_item_to_dict(dict, key, value)
124158
125end subroutine add_key_to_dict159 type(wxml_dictionary_t), intent(inout) :: dict
160 character(len=*), intent(in) :: key
161 character(len=*), intent(in) :: value
162
163 character(len=len(key)) :: check_key
164 integer :: n, lenstr
165
166 n = dict%number_of_items
167 if (n == MAX_ITEMS) then
168 write(unit=0,fmt=*) "Dictionary capacity exceeded !"
169 RETURN
170 endif
171
172! keys may not have initial (or trailing; thus trim below) blanks:
173!TOHW remove this check? shouldn't be passing blank-prefixed strings anyway.
174 check_key=adjustl(key)
175 if (.not.check_Name(trim(check_key))) then
176 call wxml_fatal('attribute name is invalid')
177 endif
178
179 n = n + 1
180 lenstr=len_trim(check_key)
181 allocate(dict%items(n)%key(lenstr))
182 call assign_str_to_array(dict%items(n)%key,check_key)
183 allocate(dict%items(n)%value(len(value)))
184 call assign_str_to_array(dict%items(n)%value,value)
185
186 dict%number_of_items = n
187
188end subroutine add_item_to_dict
126189
127!------------------------------------------------------190!------------------------------------------------------
128! Assumes we build the dictionary in an orderly fashion,191subroutine init_dict(dict)
129! so one adds first the key and then immediately afterwards the value.192 type(wxml_dictionary_t), intent(out) :: dict
130!193
131subroutine add_value_to_dict(value,dict)194 integer :: i
132character(len=*), intent(in) :: value195
133type(wxml_dictionary_t), intent(inout) :: dict196 do i = 1, MAX_ITEMS
134197 nullify(dict%items(i)%key)
135integer :: n198 nullify(dict%items(i)%key)
136199 enddo
137n = dict%number_of_items200
138dict%value(n) = value201 dict % number_of_items = 0
139202
140end subroutine add_value_to_dict203end subroutine init_dict
141204
142!------------------------------------------------------205!------------------------------------------------------
143subroutine reset_dict(dict)206subroutine reset_dict(dict)
144type(wxml_dictionary_t), intent(inout) :: dict207 type(wxml_dictionary_t), intent(inout) :: dict
208
209 integer :: i
210 do i = 1, dict%number_of_items
211 deallocate(dict%items(i)%key)
212 deallocate(dict%items(i)%value)
213 enddo
145214
146dict%number_of_items = 0215 dict%number_of_items = 0
147216
148end subroutine reset_dict217end subroutine reset_dict
149218
@@ -154,7 +223,7 @@
154integer :: i223integer :: i
155224
156do i = 1, dict%number_of_items225do i = 1, dict%number_of_items
157 print *, trim(dict%key(i)), " = ", trim(dict%value(i))226 print *, dict%items(i)%key, " = ", dict%items(i)%value
158enddo227enddo
159228
160end subroutine print_dict229end subroutine print_dict
161230
=== modified file 'wxml/m_wxml_elstack.f90'
--- wxml/m_wxml_elstack.f90 2014-09-04 09:28:10 +0000
+++ wxml/m_wxml_elstack.f90 2016-01-30 12:34:50 +0000
@@ -1,19 +1,30 @@
1module m_wxml_elstack1module m_wxml_elstack
22
3use m_wxml_error
4
5implicit none
6
3private7private
48
5!9!
6! Simple stack to keep track of which elements have appeared so far10! Simple stack to keep track of which elements have appeared so far
7!11!
8integer, parameter, private :: STACK_SIZE = 2012! Initial stack size:
13integer, parameter, private :: STACK_SIZE_INIT = 10
14! Multiplier when stack is exceeded:
15real, parameter, private :: STACK_SIZE_MULT = 1.5
16
17type, private :: elstack_item
18 character(len=100) :: data
19end type
920
10type, public :: elstack_t21type, public :: elstack_t
11private22private
12 integer :: n_items23 integer :: n_items
13 character(len=100), dimension(STACK_SIZE) :: data24 type(elstack_item), pointer, dimension(:) :: stack
14end type elstack_t25end type elstack_t
1526
16public :: push_elstack, pop_elstack, reset_elstack, print_elstack27public :: push_elstack, pop_elstack, init_elstack, reset_elstack, print_elstack
17public :: get_top_elstack, is_empty, get_elstack_signature28public :: get_top_elstack, is_empty, get_elstack_signature
18public :: len29public :: len
1930
@@ -30,14 +41,39 @@
30CONTAINS41CONTAINS
3142
32!-----------------------------------------------------------------43!-----------------------------------------------------------------
44subroutine init_elstack(elstack)
45 type(elstack_t), intent(inout) :: elstack
46
47 allocate(elstack%stack(STACK_SIZE_INIT))
48 elstack%n_items = 0
49
50end subroutine init_elstack
51
52!-----------------------------------------------------------------
33subroutine reset_elstack(elstack)53subroutine reset_elstack(elstack)
34type(elstack_t), intent(inout) :: elstack54 type(elstack_t), intent(inout) :: elstack
3555
36elstack%n_items = 056 deallocate(elstack%stack)
57 call init_elstack(elstack)
3758
38end subroutine reset_elstack59end subroutine reset_elstack
3960
40!-----------------------------------------------------------------61!-----------------------------------------------------------------
62subroutine resize_elstack(elstack)
63 type(elstack_t), intent(inout) :: elstack
64 type(elstack_item), pointer, dimension(:) :: temp
65 integer :: s
66
67 s = size(elstack%stack)
68
69 temp=>elstack%stack
70 allocate(elstack%stack(nint(s*STACK_SIZE_MULT)))
71 elstack%stack(:s) = temp
72 deallocate(temp)
73
74end subroutine resize_elstack
75
76!-----------------------------------------------------------------
41function is_empty_elstack(elstack) result(answer)77function is_empty_elstack(elstack) result(answer)
42type(elstack_t), intent(in) :: elstack78type(elstack_t), intent(in) :: elstack
43logical :: answer79logical :: answer
@@ -61,11 +97,11 @@
61integer :: n97integer :: n
6298
63n = elstack%n_items99n = elstack%n_items
64if (n == STACK_SIZE) then100if (n == size(elstack%stack)) then
65 stop "*Element stack full"101 call resize_elstack(elstack)
66endif102endif
67n = n + 1103n = n + 1
68elstack%data(n) = item104elstack%stack(n)%data = item
69elstack%n_items = n105elstack%n_items = n
70106
71end subroutine push_elstack107end subroutine push_elstack
@@ -75,16 +111,13 @@
75type(elstack_t), intent(inout) :: elstack111type(elstack_t), intent(inout) :: elstack
76character(len=*), intent(out) :: item112character(len=*), intent(out) :: item
77113
78!
79! We assume the elstack is not empty... (the user has called is_empty first)
80!
81integer :: n114integer :: n
82115
83n = elstack%n_items116n = elstack%n_items
84if (n == 0) then117if (n == 0) then
85 stop "*********Element stack empty"118 call wxml_error("Element stack empty")
86endif119endif
87item = elstack%data(n)120item = elstack%stack(n)%data
88elstack%n_items = n - 1121elstack%n_items = n - 1
89122
90end subroutine pop_elstack123end subroutine pop_elstack
@@ -97,16 +130,13 @@
97type(elstack_t), intent(in) :: elstack130type(elstack_t), intent(in) :: elstack
98character(len=*), intent(out) :: item131character(len=*), intent(out) :: item
99132
100!
101! We assume the elstack is not empty... (the user has called is_empty first)
102!
103integer :: n133integer :: n
104134
105n = elstack%n_items135n = elstack%n_items
106if (n == 0) then136if (n == 0) then
107 stop "*********Element stack empty"137 call wxml_error("Element stack empty")
108endif138endif
109item = elstack%data(n)139item = elstack%stack(n)%data
110140
111end subroutine get_top_elstack141end subroutine get_top_elstack
112142
@@ -117,7 +147,7 @@
117integer :: i147integer :: i
118148
119do i = elstack%n_items, 1, -1149do i = elstack%n_items, 1, -1
120 write(unit=unit,fmt=*) trim(elstack%data(i))150 write(unit=unit,fmt=*) trim(elstack%stack(i)%data)
121enddo151enddo
122152
123end subroutine print_elstack153end subroutine print_elstack
@@ -128,13 +158,13 @@
128character(len=*), intent(out) :: string158character(len=*), intent(out) :: string
129integer :: i, length, j159integer :: i, length, j
130160
131string = ""161string = ' '
132j = 0162j = 0
133do i = 1, elstack%n_items163do i = 1, elstack%n_items
134 length = len_trim(elstack%data(i))164 length = len_trim(elstack%stack(i)%data)
135 string(j+1:j+1) = "/"165 string(j+1:j+1) = "/"
136 j = j+1166 j = j+1
137 string(j+1:j+length) = trim(elstack%data(i))167 string(j+1:j+length) = trim(elstack%stack(i)%data)
138 j = j + length168 j = j + length
139enddo169enddo
140170
141171
=== added file 'wxml/m_wxml_overloads.f90'
--- wxml/m_wxml_overloads.f90 1970-01-01 00:00:00 +0000
+++ wxml/m_wxml_overloads.f90 2016-01-30 12:34:50 +0000
@@ -0,0 +1,143 @@
1module m_wxml_overloads
2
3 use m_wxml_text, only: str
4 use m_wxml_core, only: xmlf_t
5 use m_wxml_core, only: xml_AddPcData_Ch => xml_AddPcData
6 use m_wxml_core, only: xml_AddAttribute_Ch => xml_AddAttribute
7
8 implicit none
9
10 integer, parameter :: sp = selected_real_kind(6,30)
11 integer, parameter :: dp = selected_real_kind(14,100)
12
13 private
14
15 public :: xml_AddPcdata
16 public :: xml_AddAttribute
17
18 interface xml_AddPcData
19 module procedure xml_AddPcdata_SP
20 module procedure xml_AddPcdata_DP
21 module procedure xml_AddPcdata_Int
22 module procedure xml_AddPcdata_Log
23 end interface
24
25 interface xml_AddAttribute
26 module procedure xml_AddAttribute_SP
27 module procedure xml_AddAttribute_DP
28 module procedure xml_AddAttribute_Int
29 module procedure xml_AddAttribute_Log
30 end interface
31
32CONTAINS
33
34 !-------------------------------------------------------------------
35
36 subroutine xml_AddPcdata_SP(xf,pcdata,fmt, space,line_feed)
37 type(xmlf_t), intent(inout) :: xf
38 real(kind=sp), intent(in) :: pcdata
39 logical, intent(in), optional :: space
40 logical, intent(in), optional :: line_feed
41 character(len=*), intent(in), optional :: fmt
42
43 call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed)
44
45 end subroutine xml_AddPcdata_SP
46
47
48 subroutine xml_AddPcdata_DP(xf,pcdata,fmt,space,line_feed)
49 type(xmlf_t), intent(inout) :: xf
50 real(kind=dp), intent(in) :: pcdata
51 character(len=*), optional :: fmt
52 logical, intent(in), optional :: space
53 logical, intent(in), optional :: line_feed
54
55 call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed)
56
57 end subroutine xml_AddPcdata_DP
58
59
60 subroutine xml_AddPcdata_log(xf,pcdata,fmt,space,line_feed)
61 type(xmlf_t), intent(inout) :: xf
62 logical, intent(in) :: pcdata
63 character(len=*), intent(in), optional :: fmt
64 logical, intent(in), optional :: space
65 logical, intent(in), optional :: line_feed
66
67 if (present(fmt)) then
68 call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed)
69 else
70 call xml_AddPcdata_Ch(xf,trim(str(pcdata)),space,line_feed)
71 endif
72
73 end subroutine xml_AddPcdata_log
74
75
76 subroutine xml_AddPcdata_int(xf,pcdata,fmt,space,line_feed)
77 type(xmlf_t), intent(inout) :: xf
78 integer, intent(in) :: pcdata
79 character(len=*), intent(in), optional :: fmt
80 logical, intent(in), optional :: space
81 logical, intent(in), optional :: line_feed
82
83 if (present(fmt)) then
84 call xml_AddPcdata_Ch(xf,trim(str(pcdata,fmt)),space,line_feed)
85 else
86 call xml_AddPcdata_Ch(xf,trim(str(pcdata)),space,line_feed)
87 endif
88
89 end subroutine xml_AddPcdata_int
90
91
92 !-------------------------------------------------------------------
93
94 subroutine xml_AddAttribute_SP(xf,name,value,fmt)
95 type(xmlf_t), intent(inout) :: xf
96 character(len=*), intent(in) :: name
97 real(kind=sp), intent(in) :: value
98 character(len=*), intent(in), optional :: fmt
99
100 call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt)))
101
102 end subroutine xml_AddAttribute_SP
103
104 subroutine xml_AddAttribute_DP(xf,name,value,fmt)
105 type(xmlf_t), intent(inout) :: xf
106 character(len=*), intent(in) :: name
107 real(kind=dp), intent(in) :: value
108 character(len=*), intent(in), optional :: fmt
109
110 call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt)))
111
112 end subroutine xml_AddAttribute_DP
113
114 subroutine xml_AddAttribute_log(xf,name,value,fmt)
115 type(xmlf_t), intent(inout) :: xf
116 character(len=*), intent(in) :: name
117 logical, intent(in) :: value
118 character(len=*), intent(in), optional :: fmt
119
120 if (present(fmt)) then
121 call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt)))
122 else
123 call xml_AddAttribute_Ch(xf,name,trim(str(value)))
124 endif
125
126 end subroutine xml_AddAttribute_log
127
128 subroutine xml_AddAttribute_int(xf,name,value,fmt)
129 type(xmlf_t), intent(inout) :: xf
130 character(len=*), intent(in) :: name
131 integer, intent(in) :: value
132 character(len=*), intent(in), optional :: fmt
133
134 if (present(fmt)) then
135 call xml_AddAttribute_Ch(xf,name,trim(str(value,fmt)))
136 else
137 call xml_AddAttribute_Ch(xf,name,trim(str(value)))
138 endif
139
140 end subroutine xml_AddAttribute_int
141
142end module m_wxml_overloads
143
0144
=== renamed file 'wxml/m_wxml_text.f90' => 'wxml/m_wxml_text.F90'
--- wxml/m_wxml_text.f90 2014-09-04 14:11:50 +0000
+++ wxml/m_wxml_text.F90 2016-01-30 12:34:50 +0000
@@ -1,44 +1,68 @@
1module m_wxml_text1module m_wxml_text
2
3implicit none
2!4!
3integer, private, parameter :: sp = selected_real_kind(6,30)5integer, private, parameter :: sp = selected_real_kind(6,30)
4integer, private, parameter :: dp = selected_real_kind(14,100)6integer, private, parameter :: dp = selected_real_kind(14,100)
5!7!
6private8private
7
8public :: str9public :: str
910
10interface str11interface str
11 module procedure str_integer, str_real_dp, str_real_sp, &12 module procedure str_integer_fmt, str_integer, &
12 str_logical13 str_logical_fmt, str_logical, &
14 str_real_dp, str_real_sp
13end interface15end interface
14private :: str_integer, str_real_dp, str_real_sp, str_logical
1516
16CONTAINS17CONTAINS
1718
18 function str_integer(int,format) result(s)19 function str_integer_fmt(i,format) result(s)
19 integer, intent(in) :: int20 integer, intent(in) :: i
20 character(len=*), intent(in), optional :: format21 character(len=*), intent(in) :: format
21 character(len=100) :: s22 character(len=100) :: s
2223
23 if (present(format)) then24 write(s,format) i
24 write(s,format) int
25 else
26 write(s,"(i25)") int
27 endif
28 s = adjustl(s)25 s = adjustl(s)
26 end function str_integer_fmt
27
28 function str_integer(i) result(s)
29 ! This will work correctly (return an appropriately-sized
30 ! string) for integers i s.t. -99999999<=i<=999999999
31 integer, intent(in) :: i
32#ifndef WXML_INIT_FIX
33 character(len=int(merge(log10(real(max(abs(i),1)))+1, &
34 log10(real(max(abs(i),1)))+2, &
35 sign(1,i)>0))) :: s
36#else
37! Some compilers have trouble with the above
38 character(len=int(log10(real(max(abs(i),1)))+2)) :: s
39#endif
40 character(len=4) :: form
41
42 write(form,'(a,i1,a)') '(i',len(s),')'
43 write(s, form) i
44
29 end function str_integer45 end function str_integer
3046
31 function str_logical(log,format) result(s)47 function str_logical_fmt(l,format) result(s)
32 logical, intent(in) :: log48 logical, intent(in) :: l
33 character(len=*), intent(in), optional :: format49 character(len=*), intent(in) :: format
34 character(len=100) :: s50 character(len=100) :: s
3551
36 if (present(format)) then52 write(s,format) l
37 write(s,format) log
38 else
39 write(s,"(l1)") log
40 endif
41 s = adjustl(s)53 s = adjustl(s)
54
55 end function str_logical_fmt
56
57 function str_logical(l) result(s)
58 logical, intent(in) :: l
59 character(len=merge(4,5,l)) :: s
60
61 if (l) then
62 s='true'
63 else
64 s='false'
65 endif
42 end function str_logical66 end function str_logical
4367
44 function str_real_dp(x,format) result(s)68 function str_real_dp(x,format) result(s)
@@ -47,10 +71,10 @@
47 character(len=100) :: s71 character(len=100) :: s
4872
49 if (present(format)) then73 if (present(format)) then
50 write(s,format) x74 write(s,format) x
51 else75 else
52 if (abs(nint(x)-x) .lt. epsilon(x)) then76 if (abs(nint(x)-x) .lt. epsilon(x)) then
53 write(s,"(f20.0)") x77 write(s,"(i0)") nint(x)
54 else78 else
55 write(s,"(g22.12)") x79 write(s,"(g22.12)") x
56 endif80 endif
@@ -67,7 +91,7 @@
67 write(s,format) x91 write(s,format) x
68 else92 else
69 if (abs(nint(x)-x) .lt. epsilon(x)) then93 if (abs(nint(x)-x) .lt. epsilon(x)) then
70 write(s,"(f20.0)") x94 write(s,"(i0)") nint(x)
71 else95 else
72 write(s,"(g22.12)") x96 write(s,"(g22.12)") x
73 endif97 endif
7498
=== modified file 'wxml/makefile'
--- wxml/makefile 2016-01-15 15:49:14 +0000
+++ wxml/makefile 2016-01-30 12:34:50 +0000
@@ -1,6 +1,8 @@
1#1#
2OBJFILES= m_wxml_buffer.o m_wxml_dictionary.o m_wxml_elstack.o \2OBJFILES= m_wxml_buffer.o m_wxml_array_str.o m_wxml_dictionary.o\
3 m_wxml_text.o m_wxml_core.o xmlf90_wxml.o3 m_wxml_elstack.o \
4 m_wxml_text.o m_wxml_escape.o m_wxml_core.o \
5 m_wxml_overloads.o xmlf90_wxml.o m_wxml_error.o
4MODFILES=$(OBJFILES:.o=)6MODFILES=$(OBJFILES:.o=)
57
6#------------------------------8#------------------------------
@@ -10,4 +12,12 @@
1012
11clean:13clean:
12 rm -f *.o *.$(MOD_EXT)14 rm -f *.o *.$(MOD_EXT)
15# DO NOT DELETE THIS LINE - used by make depend
16xmlf90_wxml.o: m_wxml_core.o m_wxml_overloads.o m_wxml_text.o
17m_wxml_buffer.o: m_wxml_error.o m_wxml_escape.o
18m_wxml_core.o: m_wxml_buffer.o m_wxml_dictionary.o m_wxml_elstack.o
19m_wxml_core.o: m_wxml_escape.o m_wxml_array_str.o
20m_wxml_dictionary.o: m_wxml_array_str.o m_wxml_escape.o
21m_wxml_elstack.o: m_wxml_error.o
22m_wxml_overloads.o: m_wxml_core.o m_wxml_text.o
1323
1424
=== modified file 'wxml/xmlf90_wxml.f90'
--- wxml/xmlf90_wxml.f90 2016-01-15 15:49:14 +0000
+++ wxml/xmlf90_wxml.f90 2016-01-30 12:34:50 +0000
@@ -1,10 +1,8 @@
1module xmlf90_wxml1module xmlf90_wxml
22
3!use m_wxml_buffer
4!use m_wxml_dictionary
5!use m_wxml_elstack
6use m_wxml_text3use m_wxml_text
7use m_wxml_core4use m_wxml_core
5use m_wxml_overloads
86
9public7public
108

Subscribers

People subscribed via source and target branches

to all changes: