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:
cormanlisp-unsubscribe@xxxxxxxxxxxxxxx

 

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