Skip to content

Commit

Permalink
Import version 1.0 from release tarball.
Browse files Browse the repository at this point in the history
  • Loading branch information
@sionescu
sionescu committed Jan 18, 2011
0 parents commit be4ad91
Show file tree
Hide file tree
Showing 2 changed files with 335 additions and 0 deletions.
11 changes: 11 additions & 0 deletions parse-number.asd
@@ -0,0 +1,11 @@
;; -*- Lisp -*-

(defpackage #:parse-number-system
(:use #:common-lisp #:asdf))

(in-package #:parse-number-system)

(defsystem parse-number
:author "Matthew Danish"
:version "1.0"
:components ((:file "parse-number")))
324 changes: 324 additions & 0 deletions parse-number.lisp
@@ -0,0 +1,324 @@
;;;; -*- Mode: Lisp -*-
;;;; Defines functions to parse any number type, without using the reader
;;;; Version: 1.0
;;;; 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))

(in-package #:org.mapcar.parse-number)

(define-condition invalid-number ()
((value :reader value
:initarg :value
:initform nil)
(reason :reader reason
:initarg :reason
:initform "Not specified"))
(:report (lambda (c s)
(format s "Invalid number: ~S [Reason: ~A]"
(value c) (reason c)))))

(declaim (inline parse-integer-and-places))
(defun parse-integer-and-places (string start end &key (radix 10))
#+optimizations
(declare (optimize (speed 3))
(type simple-base-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))
(cons integer (- end-pos start))))

(defun parse-integers (string start end splitting-points &key (radix 10))
#+optimizations
(declare (optimize (speed 3))
(type simple-base-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) (car x))
(defun places (x) (cdr x))

(declaim (type cons *white-space-characters*))
(defparameter *white-space-characters*
'(#\Space #\Tab #\Return #\Linefeed))

(declaim (inline white-space-p))
(defun white-space-p (x)
#+optimizations
(declare (optimize (speed 3) (safety 0))
(type character x))
(and (find x *white-space-characters*) t))

;; 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))
"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))
"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 parse-positive-real-number (string &key (start 0) (end nil) (radix 10))
"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))
(base-for-exponent-marker (char)
(case char
((#\d #\D)
10.0d0)
((#\e #\E)
10)
((#\s #\S)
10.0s0)
((#\l #\L)
10.0l0)
((#\f #\F)
10.0f0))))
(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)
(when (= radix 10)
(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)
(* (+ (number-value whole-place)
(/ (number-value frac-place)
(expt radix
(places frac-place))))
(expt (base-for-exponent-marker exp-marker)
(number-value 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)
(* (number-value whole-place)
(expt (base-for-exponent-marker exp-marker)
(number-value 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 radix)
(if (>= (number-value frac-part) 0)
(+ (number-value whole-part)
(/ (number-value frac-part)
(expt 10.0 (places frac-part))))
(invalid-number "Misplaced - sign")))))
(t
(values (parse-integer string
:start start
:end end
:radix radix))))))))

(defparameter *test-values*
'("1" "-1" "1034" "-364" "80/335" "3.5333" "2.4E4" "6.8d3" "#xFF" "#b-1000" "#o-101/75" "13.09s3" "35.66l5" "21.4f2" "#C(1 2)" "#c ( #xF #o-1 ) " "#c(1d1 2s1)" "#16rFF" "#9r10" "#C(#9r44/61 4f4)"))

(defun run-tests ()
(format t "~&~16@A (~16@A) = ~16A~%~%"
"String value" "READ value" "Parsed value")
(dolist (value *test-values*)
(format t "~&~16@A (~16@A) = ~16A~%"
value
(read-from-string value)
(parse-number value))))

0 comments on commit be4ad91

Please sign in to comment.