/[cl-l10n]/cl-l10n/parse-number.lisp
ViewVC logotype

Contents of /cl-l10n/parse-number.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Dec 17 10:06:43 2004 UTC (9 years, 4 months ago) by sross
Branch: MAIN
Changes since 1.1: +0 -11 lines
Changelog 2004-12-17
1 ;;;; -*- Mode: Lisp -*-
2 ;;;; Defines functions to parse any number type, without using the reader
3 ;;;; Version: 1.0
4 ;;;; Author: Matthew Danish -- mrd.debian.org
5 ;;;;
6 ;;;; Copyright 2002 Matthew Danish.
7 ;;;; All rights reserved.
8 ;;;;
9 ;;;; Redistribution and use in source and binary forms, with or without
10 ;;;; modification, are permitted provided that the following conditions
11 ;;;; are met:
12 ;;;; 1. Redistributions of source code must retain the above copyright
13 ;;;; notice, this list of conditions and the following disclaimer.
14 ;;;; 2. Redistributions in binary form must reproduce the above copyright
15 ;;;; notice, this list of conditions and the following disclaimer in the
16 ;;;; documentation and/or other materials provided with the distribution.
17 ;;;; 3. Neither the name of the author nor the names of its contributors
18 ;;;; may be used to endorse or promote products derived from this software
19 ;;;; without specific prior written permission.
20 ;;;;
21 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
22 ;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23 ;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24 ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
25 ;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
27 ;;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28 ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29 ;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
30 ;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
31 ;;;; SUCH DAMAGE.
32
33 (in-package #:cl-l10n)
34
35 (define-condition invalid-number ()
36 ((value :reader value
37 :initarg :value
38 :initform nil)
39 (reason :reader reason
40 :initarg :reason
41 :initform "Not specified"))
42 (:report (lambda (c s)
43 (format s "Invalid number: ~S [Reason: ~A]"
44 (value c) (reason c)))))
45
46 (declaim (inline parse-integer-and-places))
47 (defun parse-integer-and-places (string start end &key (radix 10))
48 #+optimizations
49 (declare (optimize (speed 3))
50 (type simple-base-string string)
51 (type fixnum start end radix))
52 (multiple-value-bind (integer end-pos)
53 (if (= start end)
54 (values 0 0)
55 (parse-integer string
56 :start start
57 :end end
58 :radix radix))
59 (cons integer (- end-pos start))))
60
61 (defun parse-integers (string start end splitting-points &key (radix 10))
62 #+optimizations
63 (declare (optimize (speed 3))
64 (type simple-base-string string)
65 (type fixnum start end radix))
66 (values-list (loop for left = start then (1+ right)
67 for point in splitting-points
68 for right = point
69 collect (parse-integer-and-places string
70 left
71 right
72 :radix radix)
73 into integers
74 finally (return
75 (nconc integers
76 (list
77 (parse-integer-and-places string
78 left
79 end
80 :radix radix
81 )))))))
82
83 (declaim (inline number-value places))
84 (defun number-value (x) (car x))
85 (defun places (x) (cdr x))
86
87 (declaim (type cons *white-space-characters*))
88 (defparameter *white-space-characters*
89 '(#\Space #\Tab #\Return #\Linefeed))
90
91 (declaim (inline white-space-p))
92 (defun white-space-p (x)
93 #+optimizations
94 (declare (optimize (speed 3) (safety 0))
95 (type character x))
96 (and (find x *white-space-characters*) t))
97
98 ;; Numbers which could've been parsed, but intentionally crippled not to:
99 ;; #xFF.AA
100 ;; #o12e3
101
102 ;; Numbers which CL doesn't parse, but this does:
103 ;; #10r3.2
104 ;; #2r 11
105
106 (defun %parse-number (string &key (start 0) (end nil) (radix 10))
107 "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec."
108 (flet ((invalid-number (reason)
109 (error 'invalid-number
110 :value (subseq string start end)
111 :reason reason)))
112 (let ((end (or end (length string))))
113 (if (and (eql (char string start) #\#)
114 (member (char string (1+ start)) '(#\C #\c)))
115 (let ((\(-pos (position #\( string :start start :end end))
116 (\)-pos (position #\) string :start start :end end)))
117 (when (or (not \(-pos)
118 (not \)-pos)
119 (position #\( string :start (1+ \(-pos) :end end)
120 (position #\) string :start (1+ \)-pos) :end end))
121 (invalid-number "Mismatched/missing parenthesis"))
122 (let ((real-pos (position-if-not #'white-space-p string
123 :start (1+ \(-pos) :end \)-pos)))
124 (unless real-pos
125 (invalid-number "Missing real part"))
126 (let ((delimiting-space (position-if #'white-space-p string
127 :start (1+ real-pos)
128 :end \)-pos)))
129 (unless delimiting-space
130 (invalid-number "Missing imaginary part"))
131 (let ((img-pos (position-if-not #'white-space-p string
132 :start (1+ delimiting-space)
133 :end \)-pos)))
134 (unless img-pos
135 (invalid-number "Missing imaginary part"))
136 (let ((img-end-pos (position-if #'white-space-p string
137 :start (1+ img-pos)
138 :end \)-pos)))
139 (complex (parse-real-number string
140 :start real-pos
141 :end delimiting-space
142 :radix radix)
143 (parse-real-number string
144 :start img-pos
145 :end (or img-end-pos
146 \)-pos)
147 :radix radix)))))))
148 (parse-real-number string :start start :end end :radix radix)))))
149
150 (defun parse-real-number (string &key (start 0) (end nil) (radix 10))
151 "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec -- except for complex numbers."
152 (let ((end (or end (length string))))
153 (case (char string start)
154 ((#\-)
155 (* -1 (parse-positive-real-number string
156 :start (1+ start)
157 :end end
158 :radix radix)))
159 ((#\#)
160 (case (char string (1+ start))
161 ((#\x #\X)
162 (parse-real-number string
163 :start (+ start 2)
164 :end end
165 :radix 16))
166 ((#\b #\B)
167 (parse-real-number string
168 :start (+ start 2)
169 :end end
170 :radix 2))
171 ((#\o #\O)
172 (parse-real-number string
173 :start (+ start 2)
174 :end end
175 :radix 8))
176 (t (if (digit-char-p (char string (1+ start)))
177 (let ((r-pos (position #\r string
178 :start (1+ start)
179 :end end
180 :key #'char-downcase)))
181 (unless r-pos
182 (error 'invalid-number
183 :value (subseq string start end)
184 :reason "Missing R in #radixR"))
185 (parse-real-number string
186 :start (1+ r-pos)
187 :end end
188 :radix (parse-integer string
189 :start (1+ start)
190 :end r-pos)))))))
191 (t (parse-positive-real-number string
192 :start start
193 :end end
194 :radix radix)))))
195
196 (defun parse-positive-real-number (string &key (start 0) (end nil) (radix 10))
197 "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec -- except for complex numbers and negative numbers."
198 (let ((end (or end (length string)))
199 (first-char (char string start)))
200 (flet ((invalid-number (reason)
201 (error 'invalid-number
202 :value (subseq string start end)
203 :reason reason))
204 (base-for-exponent-marker (char)
205 (case char
206 ((#\d #\D)
207 10.0d0)
208 ((#\e #\E)
209 10)
210 ((#\s #\S)
211 10.0s0)
212 ((#\l #\L)
213 10.0l0)
214 ((#\f #\F)
215 10.0f0))))
216 (case first-char
217 ((#\-)
218 (invalid-number "Invalid usage of -"))
219 ((#\/)
220 (invalid-number "/ at beginning of number"))
221 ((#\d #\D #\e #\E #\l #\L #\f #\F #\s #\S)
222 (when (= radix 10)
223 (invalid-number "Exponent-marker at beginning of number"))))
224 (let (/-pos .-pos exp-pos exp-marker)
225 (loop for index from start below end
226 for char = (char string index)
227 do (case char
228 ((#\/)
229 (if /-pos
230 (invalid-number "Multiple /'s in number")
231 (setf /-pos index)))
232 ((#\.)
233 (if .-pos
234 (invalid-number "Multiple .'s in number")
235 (setf .-pos index)))
236 ((#\e #\E #\f #\F #\s #\S #\l #\L #\d #\D)
237 (when (= radix 10)
238 (when exp-pos
239 (invalid-number
240 "Multiple exponent-markers in number"))
241 (setf exp-pos index)
242 (setf exp-marker (char-downcase char)))))
243 when (eql index (1- end))
244 do (case char
245 ((#\/)
246 (invalid-number "/ at end of number"))
247 ((#\d #\D #\e #\E #\s #\S #\l #\L #\f #\F)
248 (when (= radix 10)
249 (invalid-number "Exponent-marker at end of number")))))
250 (cond ((and /-pos .-pos)
251 (invalid-number "Both . and / cannot be present simultaneously"))
252 ((and /-pos exp-pos)
253 (invalid-number "Both an exponent-marker and / cannot be present simultaneously"))
254 ((and .-pos exp-pos)
255 (if (< exp-pos .-pos)
256 (invalid-number "Exponent-markers must occur after . in number")
257 (if (/= radix 10)
258 (invalid-number "Only decimal numbers can contain exponent-markers or decimal points")
259 (multiple-value-bind (whole-place frac-place exp-place)
260 (parse-integers string start end
261 (list .-pos exp-pos)
262 :radix radix)
263 (* (+ (number-value whole-place)
264 (/ (number-value frac-place)
265 (expt radix
266 (places frac-place))))
267 (expt (base-for-exponent-marker exp-marker)
268 (number-value exp-place)))))))
269 (exp-pos
270 (if (/= radix 10)
271 (invalid-number "Only decimals can contain exponent-markers")
272 (multiple-value-bind (whole-place exp-place)
273 (parse-integers string start end
274 (list exp-pos)
275 :radix radix)
276 (* (number-value whole-place)
277 (expt (base-for-exponent-marker exp-marker)
278 (number-value exp-place))))))
279 (/-pos
280 (multiple-value-bind (numerator denominator)
281 (parse-integers string start end
282 (list /-pos)
283 :radix radix)
284 (if (>= (number-value denominator) 0)
285 (/ (number-value numerator)
286 (number-value denominator))
287 (invalid-number "Misplaced - sign"))))
288 (.-pos
289 (if (/= radix 10)
290 (invalid-number "Only decimal numbers can contain decimal points")
291 (multiple-value-bind (whole-part frac-part)
292 (parse-integers string start end
293 (list .-pos)
294 :radix radix)
295 (if (>= (number-value frac-part) 0)
296 (+ (number-value whole-part)
297 (/ (number-value frac-part)
298 (expt 10.0 (places frac-part))))
299 (invalid-number "Misplaced - sign")))))
300 (t
301 (values (parse-integer string
302 :start start
303 :end end
304 :radix radix))))))))
305
306

  ViewVC Help
Powered by ViewVC 1.1.5