1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (in-package :xuriella
)
32 (defstruct (decimal-format (:conc-name
"DF/"))
33 ;; picture string and output syntax:
34 (decimal-separator #\.
) ;active
35 (grouping-separator #\
,) ;active
36 (zero-digit #\
0) ;active
38 (per-mille (code-char #x2030
))
40 ;; picture string syntax only
42 (pattern-separator #\
;) ;active
44 ;; output syntax only:
49 (defstruct (picture (:conc-name
"PIC/"))
54 integer-part-grouping-positions
55 minimum-integer-part-size
56 fractional-part-grouping-positions
57 minimum-fractional-part-size
58 maximum-fractional-part-size
)
60 (defun df/active-characters
(df)
61 (format nil
"~C~C~C~C~C"
62 (df/decimal-separator df
)
63 (df/grouping-separator df
)
66 (df/pattern-separator df
)))
69 (let ((result (make-array 10))
70 (start (char-code (df/zero-digit df
))))
74 (setf (elt result i
) (code-char (+ start i
))))
77 (defun find-decimal-format (lname uri stylesheet
&optional
(errorp t
))
78 (or (gethash (cons lname uri
)
79 (stylesheet-decimal-formats stylesheet
))
81 (xslt-error "decimal format not found: ~A/~A" lname uri
))))
83 (defun (setf find-decimal-format
) (newval lname uri stylesheet
)
84 (setf (gethash (cons lname uri
)
85 (stylesheet-decimal-formats stylesheet
))
88 (xpath-sys:define-xpath-function
/lazy
90 (value picture
&optional format-name
)
91 (let ((namespaces *namespaces
*))
95 (let ((qname (funcall format-name ctx
)))
96 (multiple-value-bind (local-name uri
)
97 (decode-qname/runtime qname namespaces nil
)
98 (find-decimal-format local-name
101 (find-decimal-format "" "" *stylesheet
*))))
102 (multiple-value-bind (pos neg
)
103 (parse-picture (xpath:string-value
(funcall picture ctx
)) df
)
104 (format-number (xpath:number-value
(funcall value ctx
))
109 (defun test-format-number (value picture
)
110 (let ((df (make-decimal-format)))
111 (multiple-value-bind (pos neg
)
112 (parse-picture picture df
)
113 (format-number value pos neg df
))))
115 (defun parse-picture (picture df
)
116 (destructuring-bind (&optional positive negative
&rest erroneous
)
117 (split-sequence:split-sequence
118 (df/pattern-separator df
)
120 (unless (and positive
(not erroneous
))
121 (xpath:xpath-error
"invalid pattern separators"))
123 (setf negative
(concatenate 'string
124 (string (df/minus-sign df
))
126 (values (parse-sub-picture positive df
)
127 (parse-sub-picture negative df
))))
129 (defmacro df
/case
(df form
&rest clauses
)
134 for
(accessor . body
) in clauses
135 collect
`((eql (,accessor .df
) .form
) ,@body
)))))
137 (defun parse-integer-picture (picture df start end
)
138 (let ((integer-part-grouping-positions '())
139 (minimum-integer-part-size 0))
141 for i from start below end
142 for c
= (elt picture i
)
143 until
(eql c
(df/decimal-separator df
))
146 (df/grouping-separator
147 (push 0 integer-part-grouping-positions
))
149 (when integer-part-grouping-positions
150 (incf (car integer-part-grouping-positions
))))
152 (when integer-part-grouping-positions
153 (incf (car integer-part-grouping-positions
)))
154 (incf minimum-integer-part-size
)))
158 for pos in integer-part-grouping-positions
159 for accum
= pos then
(+ accum pos
)
161 minimum-integer-part-size
)))))
163 (defun parse-fractional-picture (picture df start end
)
164 (let ((fractional-part-grouping-positions '())
165 (minimum-fractional-part-size 0)
166 (maximum-fractional-part-size 0)
167 (current-grouping 0))
169 for i from start below end
170 for c
= (elt picture i
)
173 (df/grouping-separator
174 (push current-grouping fractional-part-grouping-positions
))
176 (incf current-grouping
)
177 (incf maximum-fractional-part-size
))
179 (incf current-grouping
)
180 (incf minimum-fractional-part-size
)
181 (incf maximum-fractional-part-size
))
182 (df/decimal-separator
))
184 (return (values (nreverse fractional-part-grouping-positions
)
185 minimum-fractional-part-size
186 maximum-fractional-part-size
)))))
188 (defun parse-sub-picture (picture df
)
189 (let ((active (df/active-characters df
)))
190 (flet ((activep (x) (find x active
)))
191 (let ((start (position-if #'activep picture
))
192 (last (position-if #'activep picture
:from-end t
)))
194 (xpath:xpath-error
"no digit-sign or zero-digit sign found"))
195 (let* ((end (1+ last
))
196 (result (make-picture
197 :percentp
(find (df/percent df
) picture
)
198 :per-mille-p
(find (df/per-mille df
) picture
)
199 :prefix
(subseq picture
0 start
)
200 :suffix
(subseq picture end
))))
202 (pic/integer-part-grouping-positions result
)
203 (pic/minimum-integer-part-size result
))
204 (parse-integer-picture picture df start end
))
205 (setf (values (pic/fractional-part-grouping-positions result
)
206 (pic/minimum-fractional-part-size result
)
207 (pic/maximum-fractional-part-size result
))
208 (parse-fractional-picture picture df start end
))
211 (defun format-number (value positive-picture negative-picture df
)
212 (if (xpath::nan-p value
)
214 (let ((picture (if (minusp value
) negative-picture positive-picture
)))
215 (if (xpath::inf-p value
)
219 (pic/suffix picture
))
220 (format-ordinary-number value picture df
)))))
222 (defun format-number-~f
(number picture df
)
223 (let* ((str (format nil
"~,vF"
224 (pic/maximum-fractional-part-size picture
)
226 (str (string-trim (string (df/zero-digit df
)) str
)) ;for 0.0
227 (digits (df/digits df
)))
231 (df/decimal-separator df
)
232 (elt digits
(- (char-code x
) #.
(char-code #\
0)))))
235 (defun make-grouping-test (positions)
237 (let ((first (car positions
)))
239 for expected
= first then
(+ expected first
)
241 always
(eql pos expected
))))
242 (let ((first (car positions
)))
244 (and (plusp x
) (zerop (mod x first
)))))
246 (and (plusp x
) (find x positions
)))))
248 (defun format-ordinary-number (value picture df
)
249 (let* ((adjusted-number
251 ((pic/percentp picture
)
253 ((pic/per-mille-p picture
)
257 (str (format-number-~f
(abs adjusted-number
) picture df
))
258 (left (position (df/decimal-separator df
) str
))
259 (right (1- (- (length str
) left
)))
260 (wanted-left (max left
(pic/minimum-integer-part-size picture
)))
261 (wanted-right (max right
(pic/minimum-fractional-part-size picture
)))
262 (zero (df/zero-digit df
))
263 (left-test (make-grouping-test
264 (pic/integer-part-grouping-positions picture
)))
265 (right-test (make-grouping-test
266 (pic/fractional-part-grouping-positions picture
))))
267 (with-output-to-string (s)
268 (write-string (pic/prefix picture
) s
)
270 for i from
(1- wanted-left
) downto
0
271 for index from
(- left wanted-left
)
274 (write-char (elt str index
) s
)
276 (when (funcall left-test i
)
277 (write-char (df/grouping-separator df
) s
)))
278 (when (plusp wanted-right
)
279 (write-char (df/decimal-separator df
) s
)
281 for i from
0 below wanted-right
282 for index from
(+ left
1)
284 (when (funcall right-test i
)
285 (write-char (df/grouping-separator df
) s
))
287 (write-char (elt str index
) s
)
288 (write-char zero s
))))
289 (write-string (pic/suffix picture
) s
))))