/
parse-number.lisp
373 lines (357 loc) · 17.8 KB
/
parse-number.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;; Defines functions to parse any number type, without using the reader
;;;;
;;;; Author: Matthew Danish -- mrd.debian.org
;;;;
;;;; Copyright 2002 Matthew Danish.
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;; 1. Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above copyright
;;;; notice, this list of conditions and the following disclaimer in the
;;;; documentation and/or other materials provided with the distribution.
;;;; 3. Neither the name of the author nor the names of its contributors
;;;; may be used to endorse or promote products derived from this software
;;;; without specific prior written permission.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;;; SUCH DAMAGE.
(defpackage #:org.mapcar.parse-number
(:use #:common-lisp)
(:nicknames #:parse-number)
(:export #:parse-number
#:parse-real-number
#:parse-positive-real-number
#:invalid-number
#:invalid-number-value
#:invalid-number-reason))
(in-package #:org.mapcar.parse-number)
(define-condition invalid-number (parse-error)
((value :reader invalid-number-value
:initarg :value
:initform nil)
(reason :reader invalid-number-reason
:initarg :reason
:initform "Not specified"))
(:report (lambda (c s)
(format s "Invalid number: ~S [Reason: ~A]"
(invalid-number-value c)
(invalid-number-reason c)))))
(declaim (type cons *white-space-characters*))
(defparameter *white-space-characters*
'(#\Space #\Tab #\Return #\Linefeed)
"A list of all of the whitespace characters.")
(declaim (inline white-space-p))
(defun white-space-p (x)
"Is the given character a whitespace character?"
(declare (optimize (speed 3) (safety 0))
(type character x))
(and (find x *white-space-characters*) t))
(declaim (inline parse-integer-and-places))
(defun parse-integer-and-places (string start end &key (radix 10))
"Parse an integer and return a 'parsed-integer'. This is an object
whose numerical value can be accessed with the function
number-value and whose length can be accessed with the function
place."
(declare (optimize (speed 3) (safety 1))
(type string string)
(type fixnum start end radix))
(multiple-value-bind (integer end-pos)
(if (= start end)
(values 0 0)
(parse-integer string
:start start
:end end
:radix radix))
;; cl:parse-integer will consume trailing whitespace, thus end-pos may be
;; larger than the number of digits. Instead of trimming whitespace
;; beforehand we count it here
(let ((relevant-digits (- end-pos start
(loop :for pos :from (- end-pos 1) :downto start
:while (member (char string pos)
*white-space-characters*)
:count 1))))
(cons integer relevant-digits))))
(defun parse-integers (string start end splitting-points &key (radix 10))
"Parse a string containing multiple integers where SPLITTING-POINTS
is a list of locations where each location is inbetween
consecutive integers. This will return a list of parsed-integers.
The last parsed-integer will have a negative value for its length."
(declare (optimize (speed 3) (safety 1))
(type string string)
(type fixnum start end radix))
(values-list (loop for left = start then (1+ right)
for point in splitting-points
for right = point
collect (parse-integer-and-places string
left
right
:radix radix)
into integers
finally (return
(nconc integers
(list
(parse-integer-and-places string
left
end
:radix radix
)))))))
(declaim (inline number-value places))
(defun number-value (x) "Get the value of a parsed-integer." (car x))
(defun places (x) "Get the length of a parsed-integer." (cdr x))
;; Numbers which could've been parsed, but intentionally crippled not to:
;; #xFF.AA
;; #o12e3
;; Numbers which CL doesn't parse, but this does:
;; #10r3.2
;; #2r 11
(defun parse-number (string &key (start 0) (end nil) (radix 10)
((:float-format *read-default-float-format*)
*read-default-float-format*))
"Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec."
(flet ((invalid-number (reason)
(error 'invalid-number
:value (subseq string start end)
:reason reason)))
(let ((end (or end (length string))))
(if (and (eql (char string start) #\#)
(member (char string (1+ start)) '(#\C #\c)))
(let ((\(-pos (position #\( string :start start :end end))
(\)-pos (position #\) string :start start :end end)))
(when (or (not \(-pos)
(not \)-pos)
(position #\( string :start (1+ \(-pos) :end end)
(position #\) string :start (1+ \)-pos) :end end))
(invalid-number "Mismatched/missing parenthesis"))
(let ((real-pos (position-if-not #'white-space-p string
:start (1+ \(-pos) :end \)-pos)))
(unless real-pos
(invalid-number "Missing real part"))
(let ((delimiting-space (position-if #'white-space-p string
:start (1+ real-pos)
:end \)-pos)))
(unless delimiting-space
(invalid-number "Missing imaginary part"))
(let ((img-pos (position-if-not #'white-space-p string
:start (1+ delimiting-space)
:end \)-pos)))
(unless img-pos
(invalid-number "Missing imaginary part"))
(let ((img-end-pos (position-if #'white-space-p string
:start (1+ img-pos)
:end \)-pos)))
(complex (parse-real-number string
:start real-pos
:end delimiting-space
:radix radix)
(parse-real-number string
:start img-pos
:end (or img-end-pos
\)-pos)
:radix radix)))))))
(parse-real-number string :start start :end end :radix radix)))))
(defun parse-real-number (string &key (start 0) (end nil) (radix 10)
((:float-format *read-default-float-format*)
*read-default-float-format*))
"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."
(let ((end (or end (length string))))
(case (char string start)
((#\-)
(* -1 (parse-positive-real-number string
:start (1+ start)
:end end
:radix radix)))
((#\#)
(case (char string (1+ start))
((#\x #\X)
(parse-real-number string
:start (+ start 2)
:end end
:radix 16))
((#\b #\B)
(parse-real-number string
:start (+ start 2)
:end end
:radix 2))
((#\o #\O)
(parse-real-number string
:start (+ start 2)
:end end
:radix 8))
(t (if (digit-char-p (char string (1+ start)))
(let ((r-pos (position #\r string
:start (1+ start)
:end end
:key #'char-downcase)))
(unless r-pos
(error 'invalid-number
:value (subseq string start end)
:reason "Missing R in #radixR"))
(parse-real-number string
:start (1+ r-pos)
:end end
:radix (parse-integer string
:start (1+ start)
:end r-pos)))))))
(t (parse-positive-real-number string
:start start
:end end
:radix radix)))))
(defun base-for-exponent-marker (char)
"Return the base for an exponent-marker."
(case char
((#\d #\D)
10.0d0)
((#\e #\E)
(coerce 10 *read-default-float-format*))
((#\f #\F)
10.0f0)
((#\s #\S)
10.0s0)
((#\l #\L)
10.0l0)))
(defun make-float/frac (radix exp-marker whole-place frac-place exp-place)
"Create a float using EXP-MARKER as the exponent-marker and the
parsed-integers WHOLE-PLACE, FRAC-PLACE, and EXP-PLACE as the
integer part, fractional part, and exponent respectively."
(let* ((base (base-for-exponent-marker exp-marker))
(exp (expt base (number-value exp-place))))
(+ (* exp (number-value whole-place))
(/ (* exp (number-value frac-place))
(expt (float radix base)
(places frac-place))))))
(defun make-float/whole (exp-marker whole-place exp-place)
"Create a float where EXP-MARKER is the exponent-marker and the
parsed-integers WHOLE-PLACE and EXP-PLACE as the integer part and
the exponent respectively."
(* (number-value whole-place)
(expt (base-for-exponent-marker exp-marker)
(number-value exp-place))))
(defun parse-positive-real-number (string &key (start 0) (end nil) (radix 10)
((:float-format *read-default-float-format*)
*read-default-float-format*))
"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."
(let ((end (or end (length string)))
(first-char (char string start)))
(flet ((invalid-number (reason)
(error 'invalid-number
:value (subseq string start end)
:reason reason)))
(when (position-if #'white-space-p string
:start (position-if-not #'white-space-p string
:start start
:end end)
:end (position-if-not #'white-space-p string
:start start
:end end
:from-end t))
(invalid-number "Whitespace inside the number"))
(case first-char
((#\-)
(invalid-number "Invalid usage of -"))
((#\/)
(invalid-number "/ at beginning of number"))
((#\d #\D #\e #\E #\l #\L #\f #\F #\s #\S)
(when (= radix 10)
(invalid-number "Exponent-marker at beginning of number"))))
(let (/-pos .-pos exp-pos exp-marker)
(loop for index from start below end
for char = (char string index)
do (case char
((#\/)
(if /-pos
(invalid-number "Multiple /'s in number")
(setf /-pos index)))
((#\.)
(if .-pos
(invalid-number "Multiple .'s in number")
(setf .-pos index)))
((#\e #\E #\f #\F #\s #\S #\l #\L #\d #\D)
;; We should only execute this if the base is
;; not used for the given radix (ie the digit
;; e is valid in base 15 and up).
(when (>= (+ 10
(- (char-code (char-upcase char))
(char-code #\A)))
radix)
(when exp-pos
(invalid-number
"Multiple exponent-markers in number"))
(setf exp-pos index)
(setf exp-marker (char-downcase char)))))
when (eql index (1- end))
do (case char
((#\/)
(invalid-number "/ at end of number"))
((#\d #\D #\e #\E #\s #\S #\l #\L #\f #\F)
(when (= radix 10)
(invalid-number "Exponent-marker at end of number")))))
(cond ((and /-pos .-pos)
(invalid-number "Both . and / cannot be present simultaneously"))
((and /-pos exp-pos)
(invalid-number "Both an exponent-marker and / cannot be present simultaneously"))
((and .-pos exp-pos)
(if (< exp-pos .-pos)
(invalid-number "Exponent-markers must occur after . in number")
(if (/= radix 10)
(invalid-number "Only decimal numbers can contain exponent-markers or decimal points")
(multiple-value-bind (whole-place frac-place exp-place)
(parse-integers string start end
(list .-pos exp-pos)
:radix radix)
(make-float/frac radix exp-marker whole-place frac-place exp-place)))))
(exp-pos
(if (/= radix 10)
(invalid-number "Only decimals can contain exponent-markers")
(multiple-value-bind (whole-place exp-place)
(parse-integers string start end
(list exp-pos)
:radix radix)
(make-float/whole exp-marker whole-place exp-place))))
(/-pos
(multiple-value-bind (numerator denominator)
(parse-integers string start end
(list /-pos)
:radix radix)
(if (>= (number-value denominator) 0)
(/ (number-value numerator)
(number-value denominator))
(invalid-number "Misplaced - sign"))))
(.-pos
(if (/= radix 10)
(invalid-number "Only decimal numbers can contain decimal points")
(multiple-value-bind (whole-part frac-part)
(parse-integers string start end
(list .-pos)
:radix 10)
(cond
((minusp (places frac-part))
(if (and (zerop (number-value whole-part))
(zerop (places whole-part)))
(invalid-number "Only the . is present")
(number-value whole-part)))
((>= (number-value frac-part) 0)
(coerce (+ (number-value whole-part)
(/ (number-value frac-part)
(expt 10 (places frac-part))))
*read-default-float-format*))
(t
(invalid-number "Misplaced - sign"))))))
(t
(values (parse-integer string
:start start
:end end
:radix radix))))))))