/[cl-screen]/cl-screen/parse-float.lisp
ViewVC logotype

Contents of /cl-screen/parse-float.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Tue May 15 21:53:01 2007 UTC (6 years, 11 months ago) by jconnors
Branch: MAIN
CVS Tags: HEAD
Committing for version 0.9.
1 ;;; Thu Aug 25 00:56:39 1994 by Mark Kantrowitz <mkant@SKEEZER.OZ.CS.CMU.EDU>
2 ;;; atof.cl -- 7824 bytes
3
4 ;;; ****************************************************************
5 ;;; PARSE-FLOAT -- equivalent of C's atof **************************
6 ;;; ****************************************************************
7 ;;;
8 ;;; This program is based loosely on the CMU Common Lisp implementation
9 ;;; of PARSE-INTEGER.
10 ;;;
11 ;;; ORIGIN: ftp.cs.cmu.edu:/user/ai/lang/lisp/code/math/atof/
12 ;;;
13 ;;; Copyright (c) 1994 by Mark Kantrowitz
14 ;;;
15 ;;; This material was developed by Mark Kantrowitz of the School of
16 ;;; Computer Science, Carnegie Mellon University.
17 ;;;
18 ;;; Permission to use, copy, modify, and distribute this material is
19 ;;; hereby granted, subject to the following terms and conditions.
20 ;;;
21 ;;; In case it be determined by a court of competent jurisdiction that any
22 ;;; provision herein contained is illegal, invalid or unenforceable, such
23 ;;; determination shall solely affect such provision and shall not affect
24 ;;; or impair the remaining provisions of this document.
25 ;;;
26 ;;; 1. All copies of the software, derivative works or modified versions,
27 ;;; and any portions thereof, must include this entire copyright and
28 ;;; permission notice, without modification. The full notice must also
29 ;;; appear in supporting documentation.
30 ;;;
31 ;;; 2. Users of this material agree to make their best efforts to inform
32 ;;; Mark Kantrowitz of noteworthy uses of this material. Correspondence
33 ;;; should be provided to Mark at:
34 ;;;
35 ;;; Mark Kantrowitz
36 ;;; School of Computer Science
37 ;;; Carnegie Mellon University
38 ;;; 5000 Forbes Avenue
39 ;;; Pittsburgh, PA 15213-3891
40 ;;;
41 ;;; E-mail: mkant@cs.cmu.edu
42 ;;;
43 ;;; 3. This software and derivative works may be distributed (but not
44 ;;; offered for sale) to third parties, provided such third parties
45 ;;; agree to abide by the terms and conditions of this notice. If you
46 ;;; modify this software, you must cause the modified file(s) to carry
47 ;;; a change log describing the changes, who made the changes, and the
48 ;;; date of the changes.
49 ;;;
50 ;;; 4. All materials developed as a consequence of the use of this material
51 ;;; shall duly acknowledge such use, in accordance with the usual standards
52 ;;; of acknowledging credit in academic research.
53 ;;;
54 ;;; 5. Neither the name of Mark Kantrowitz nor any adaptation thereof may
55 ;;; be used to endorse or promote products derived from this software
56 ;;; or arising from its use without specific prior written permission
57 ;;; in each case.
58 ;;;
59 ;;; 6. Users of this software hereby grant back to Mark Kantrowitz and
60 ;;; Carnegie Mellon University a non-exclusive, unrestricted, royalty-free
61 ;;; right and license under any changes, enhancements or extensions made
62 ;;; to the core functions of the software, including but not limited to
63 ;;; those affording compatibility with other hardware or software
64 ;;; environments. Users further agree to use their best efforts to return to
65 ;;; Mark Kantrowitz any such changes, enhancements or extensions that they
66 ;;; make.
67 ;;;
68 ;;; THE SOFTWARE IS PROVIDED "AS IS" AND MARK KANTROWITZ DISCLAIMS ALL
69 ;;; EXPRESS OR IMPLIED WARRANTIES WITH REGARD TO THIS MATERIAL (INCLUDING
70 ;;; SOFTWARE CONTAINED THEREIN), INCLUDING, WITHOUT LIMITATION, ALL
71 ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
72 ;;; PURPOSE. IN NO EVENT SHALL MARK KANTROWITZ BE LIABLE FOR ANY SPECIAL,
73 ;;; DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
74 ;;; RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
75 ;;; CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
76 ;;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE (INCLUDING BUT
77 ;;; NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR
78 ;;; LOSSES SUSTAINED BY THIRD PARTIES OR A FAILURE OF THE PROGRAM TO
79 ;;; OPERATE AS DOCUMENTED). MARK KANTROWITZ IS UNDER NO OBLIGATION TO
80 ;;; PROVIDE ANY SERVICES, BY WAY OF MAINTENANCE, UPDATE, OR OTHERWISE.
81 ;;;
82
83 ;;; Change Log:
84 ;;; 26-AUG-94 mk Suggestions from Richard Lynch: Check for builtin
85 ;;; whitespacep before defining (MCL, CMU CL), add #\newline
86 ;;; to *whitespace-chars*.
87
88
89 (in-package :cl-screen)
90
91 (eval-when (compile load eval)
92
93 (unless (fboundp 'whitespacep)
94 (defparameter *whitespace-chars*
95 '(#\space #\tab #\newline #\return #\linefeed #\page))
96
97 (defun whitespacep (char)
98 (find char *whitespace-chars*))))
99
100 (defun parse-float (string &key (start 0) end (radix 10) junk-allowed)
101 "Converts a substring of STRING, as delimited by START and END, to a
102 floating point number, if possible. START and END default to the
103 beginning and end of the string. RADIX must be between 2 and 36.
104 A floating point number will be returned if the string consists of an
105 optional string of spaces and an optional sign, followed by a string
106 of digits optionally containing a decimal point, and an optional e or
107 E followed by an optionally signed integer. The use of e/E to indicate
108 an exponent only works for RADIX = 10. Returns the floating point
109 number, if any, and the index for the first character after the number."
110
111 ;; END defaults to the end of the string
112 ;; We don't accomplish this by sticking (end (length string)) in the
113 ;; lambda list because I've encountered too many implementations that
114 ;; don't handle such properly. Also, this will work ok if somebody calls
115 ;; the function with :end nil.
116 (setq end (or end (length string)))
117
118 ;; Skip over whitespace. If there's nothing but whitespace, signal an error.
119 (let ((index (or (position-if-not #'whitespacep string :start start :end end)
120 (if junk-allowed
121 (return-from parse-float (values nil end))
122 (error "No non-whitespace characters in number."))))
123 (minusp nil) (decimalp nil) (found-digit nil)
124 (before-decimal 0) (after-decimal 0) (decimal-counter 0)
125 (exponent 0)
126 (result 0))
127 (declare (fixnum index))
128
129 ;; Take care of optional sign.
130 (let ((char (char string index)))
131 (cond ((char= char #\-)
132 (setq minusp t)
133 (incf index))
134 ((char= char #\+)
135 (incf index))))
136
137 (loop
138 (when (= index end) (return nil))
139 (let* ((char (char string index))
140 (weight (digit-char-p char radix)))
141 (cond ((and weight (not decimalp))
142 ;; A digit before the decimal point
143 (setq before-decimal (+ weight (* before-decimal radix))
144 found-digit t))
145 ((and weight decimalp)
146 ;; A digit after the decimal point
147 (setq after-decimal (+ weight (* after-decimal radix))
148 found-digit t)
149 (incf decimal-counter))
150 ((and (char= char #\.) (not decimalp))
151 ;; The decimal point
152 (setq decimalp t))
153 ((and (char-equal char #\e) (= radix 10))
154 ;; E is for exponent
155 (multiple-value-bind (num idx)
156 (parse-integer string :start (1+ index) :end end
157 :radix radix :junk-allowed junk-allowed)
158 (setq exponent (or num 0)
159 index idx)
160 (when (= index end) (return nil))))
161 (junk-allowed (return nil))
162 ((whitespacep char)
163 (when (position-if-not #'whitespacep string
164 :start (1+ index) :end end)
165 (error "There's junk in this string: ~S." string))
166 (return nil))
167 (t
168 (error "There's junk in this string: ~S." string))))
169 (incf index))
170
171 ;; Cobble up the resulting number
172 (setq result (float (* (+ before-decimal
173 (* after-decimal
174 (expt radix (- decimal-counter))))
175 (expt radix exponent))))
176
177 ;; Return the result
178 (values
179 (if found-digit
180 (if minusp (- result) result)
181 (if junk-allowed
182 nil
183 (error "There's no digits in this string: ~S" string)))
184 index)))
185
186 ;;; *EOF*

  ViewVC Help
Powered by ViewVC 1.1.5