Re: 2D or not 2E

  The code for cl::%chars-to-float is destructively modifying
a list containing the input characters, switching the 'D' to an 'E',
canonicalizing the string into a standard floating point format.

Unfortunately, the characters do not always parse out into a float,
but the damage has been done.

Try this (the original patch described herein is already incorporated
into 2.01) (caveat emptor):

(in-package :lisp)

;;; JP Massar.  11/15/02
;;; Patch for problem with reader.
;;; If reader reads '2d it errors out, trying
;;; to interpret it as a floating point number instead
;;; of a symbol.

;;; Example:
#|
'2d
;;; An error occurred in function CHECK-CHARACTER:
;;; Error: Not a character: NIL
|#

;;; The problem was if this function is given a two character
;;; list like (#\2 #\D) it interprets the #\D as an exponent
;;; and looks at the next character, assuming there must be one
;;; even when there isn't.

;;; JP Massar.  03/08/03
;;; Another patch because the input argument CHARS was being
;;; destructively modified and this was apparently causing
;;; problems elsewhere:  e.g., '2d-h --> 2E-H.
;;; The problematic line is indicated below.

;;; The hack solution is to make a copy of the input list.
;;; There is probably a better solution that does not cons.

(defun %chars-to-float (chars)
   (let* ((default-format *read-default-float-format*)
	 ;; Here's where we make the copy of the input list.
	 (chars (copy-list chars))
	 (c chars)
	 (digits 0)
	 (precision 'single-float)
	 (exp-digits 0)
	 (decimal 0))
     (unless (member default-format '(short-float double-float single-float))
       (setf default-format 'single-float))
     (unless (listp chars) (error "Expected a list of characters"))
				
     ;; skip +/- if present
     (if (or (char= (car c) #\+) (char= (car c) #\-))
	(setf c (cdr c)))
		
     ;; check mantissa
     (do ((char (car c)(car c)))
	((null c))
       (if (digit-char-p char)
	  (incf digits)
	(if (char= char #\.)
	    (if (> (incf decimal) 1)
		;; more than one decimal point!			
		(return-from %chars-to-float nil))	
	  (return)))
       (setf c (cdr c)))
		
     (if (= digits 0)
	(return-from %chars-to-float nil))
		
     ;; get exponent
     (if c
	(let ((char (char-upcase (car c))))
	  (if (member char '(#\E #\F #\L #\S #\D))
	      (progn
		(setf precision
		  (cond
		   ((char= char #\E) default-format)
		   ((char= char #\D) 'double-float)
		   ((char= char #\S) 'short-float)
		   ((char= char #\F) 'single-float)
		   ((char= char #\L) 'double-float)))
		;; HERE IS THE ORIGINAL FIX
		(when (null (cdr c)) (return-from %chars-to-float nil))
		;; *** WARNING, THIS USED TO DESTRUCTIVELY MODIFY ARGUMENT ***
		(setf (car c) #\E)
		(setf c (cdr c))
						

		;; allow +/- on exponent
		(if (or (char= (car c) #\+) (char= (car c) #\-))
		    (setf c (cdr c)))
					
		;; check exponent digits
		(do ((char (car c)(car c)))
		    ((or (null c)(not (digit-char-p char))))
		  (if (digit-char-p char)
		      (incf exp-digits))
		  (setf c (cdr c)))
		(if (= exp-digits 0)
		    (return-from %chars-to-float nil))))))
		
     (unless (null c)
       (return-from %chars-to-float nil))	;; extra chars at end
		
     (let ((d (c-atof
	      (ct:lisp-string-to-c-string (concatenate 'string chars)))))
       (case precision
	(double-float d)
	(single-float (float d 0f0))
	(short-float (float d 0s0))))))


------------------------ Yahoo! Groups Sponsor ---------------------~-->
Get 128 Bit SSL Encryption!
http://us.click.yahoo.com/xaxhjB/hdqFAA/xGHJAA/SyjtlB/TM
---------------------------------------------------------------------~->

To unsubscribe from this group, send an email to:
[email protected]

 

Your use of Yahoo! Groups is subject to http://docs.yahoo.com/info/terms/