/[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.4 - (hide annotations)
Thu Mar 31 13:53:42 2005 UTC (9 years ago) by sross
Branch: MAIN
Changes since 1.3: +5 -5 lines
Changelog 2005-03-31
1 sross 1.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 sross 1.4 (define-condition parser-error (error)
36 sross 1.1 ((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 sross 1.4 (cl:format s "Unable to parse: ~S [Reason: ~A]"
44 sross 1.3 (value c) (reason c)))))
45 sross 1.1
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 sross 1.4 (error 'parser-error
110 sross 1.1 :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 sross 1.4 (error 'parser-error
183 sross 1.1 :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 sross 1.4 (error 'parser-error
202 sross 1.1 :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