fix for CCL's floating point fuckery - code adapted from SBCL

format-float-junk.lisp

;; Do not use - a proper fix was committed into my fork at phoe-trash/ccl.

(defconstant single-float-min-e
  (- 2 ccl::ieee-single-float-bias ccl::ieee-single-float-digits))
(defconstant double-float-min-e
  (- 2 ccl::ieee-double-float-bias ccl::ieee-double-float-digits))

;; TODO: maybe-inline %flonum-to-digits, we don't need the indirection
(declaim (inline %flonum-to-digits))
(defun %flonum-to-digits (char-fun
                          prologue-fun
                          epilogue-fun
                          float &optional position relativep)
  (let ((print-base 10)                 ; B
        (float-radix 2)                 ; b
        (float-digits (float-digits float)) ; p
        (min-e
          (etypecase float
            (single-float single-float-min-e)
            (double-float double-float-min-e))))
    (multiple-value-bind (f e)
        (integer-decode-float float)
      (let ( ;; FIXME: these even tests assume normal IEEE rounding
            ;; mode.  I wonder if we should cater for non-normal?
            (high-ok (evenp f))
            (low-ok (evenp f)))
        (labels ((scale (r s m+ m-)
                   (do ((r+m+ (+ r m+))
                        (k 0 (1+ k))
                        (s s (* s print-base)))
                       ((not (or (> r+m+ s)
                                 (and high-ok (= r+m+ s))))
                        (do ((k k (1- k))
                             (r r (* r print-base))
                             (m+ m+ (* m+ print-base))
                             (m- m- (* m- print-base)))
                            ((not (and (> r m-) ; Extension to handle zero
                                       (let ((x (* (+ r m+) print-base)))
                                         (or (< x s)
                                             (and (not high-ok)
                                                  (= x s))))))
                             (funcall prologue-fun k)
                             (generate r s m+ m-)
                             (funcall epilogue-fun k))))))
                 (generate (r s m+ m-)
                   (let (d tc1 tc2)
                     (tagbody
                      loop
                        (setf (values d r) (truncate (* r print-base) s))
                        (setf m+ (* m+ print-base))
                        (setf m- (* m- print-base))
                        (setf tc1 (or (< r m-) (and low-ok (= r m-))))
                        (setf tc2 (let ((r+m+ (+ r m+)))
                                    (or (> r+m+ s)
                                        (and high-ok (= r+m+ s)))))
                        (when (or tc1 tc2)
                          (go end))
                        (funcall char-fun d)
                        (go loop)
                      end
                        (let ((d (cond
                                   ((and (not tc1) tc2) (1+ d))
                                   ((and tc1 (not tc2)) d)
                                   ((< (* r 2) s)
                                    d)
                                   (t
                                    (1+ d)))))
                          (funcall char-fun d)))))
                 (initialize ()
                   (let (r s m+ m-)
                     (cond ((>= e 0)
                            (let ((be (expt float-radix e)))
                              (if (/= f (expt float-radix (1- float-digits)))
                                ;; multiply F by 2 first, avoding consing two bignums
                                (setf r (* f 2 be)
                                      s 2
                                      m+ be
                                      m- be)
                                (setf m- be
                                      m+ (* be float-radix)
                                      r (* f 2 m+)
                                      s (* float-radix 2)))))
                           ((or (= e min-e)
                                (/= f (expt float-radix (1- float-digits))))
                            (setf r (* f 2)
                                  s (expt float-radix (- 1 e))
                                  m+ 1
                                  m- 1))
                           (t
                            (setf r (* f float-radix 2)
                                  s (expt float-radix (- 2 e))
                                  m+ float-radix
                                  m- 1)))
                     (when position
                       (when relativep
                         (do ((k 0 (1+ k))
                              ;; running out of letters here
                              (l 1 (* l print-base)))
                             ((>= (* s l) (+ r m+))
                              ;; k is now \hat{k}
                              (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
                                     (* s l))
                                (setf position (- k position))
                                (setf position (- k position 1))))))
                       (let* ((x (/ (* s (expt print-base position)) 2))
                              (low (max m- x))
                              (high (max m+ x)))
                         (when (<= m- low)
                           (setf m- low)
                           (setf low-ok t))
                         (when (<= m+ high)
                           (setf m+ high)
                           (setf high-ok t))))
                     (values r s m+ m-))))
          (multiple-value-bind (r s m+ m-) (initialize)
            (scale r s m+ m-)))))))

(defun flonum-to-digits (float &optional position relativep)
  (let ((digit-characters "0123456789"))
    (let* ((result-size 28)
           (result-string (make-array result-size :element-type 'base-char))
           (pointer 0))
      (declare (type (integer 0 #.array-dimension-limit) result-size)
               (type (integer 0 #.(1- array-dimension-limit)) pointer)
               (type (simple-array base-char (*)) result-string))
      (flet ((push-char (char)
               (when (= pointer result-size)
                 (let ((old result-string))
                   (setf result-size (* 2 (+ result-size 2))
                         result-string
                         (make-array result-size :element-type 'base-char))
                   (replace result-string old)))
               (setf (char result-string pointer) char)
               (incf pointer))
             (get-pushed-string nil
               (let ((string result-string) (size pointer))
                 (setf result-size 0 pointer 0 result-string "")
                 (ccl::shrink-vector string size)
                 string)))
        (%flonum-to-digits
         (lambda (d) (push-char (char digit-characters d)))
         (lambda (k) k)
         (lambda (k) (values k (get-pushed-string)))
         float
         position
         relativep)))))

(defun %flonum-to-string (x &optional width fdigits scale fmin)
  (declare (type float x))
  (multiple-value-bind (e string)
      (if fdigits
        (flonum-to-digits x (min (- (+ fdigits (or scale 0)))
                                 (- (or fmin 0))))
        (if (and width (> width 1))
          (let ((w (multiple-value-list
                    (flonum-to-digits x
                                      (max 1
                                           (+ (1- width)
                                              (if (and scale (minusp scale))
                                                scale 0)))
                                      t)))
                (f (multiple-value-list
                    (flonum-to-digits x (- (+ 1 (or fmin 0)
                                              (if scale scale 0)))))))
            (print (list w f))
            (if (>= (length (cadr w)) (length (cadr f)))
              (values-list w)
              (values-list f)))
          (flonum-to-digits x)))
    (let ((e (if (zerop x)
               e
               (+ e (or scale 0))))
          (stream (make-string-output-stream)))
      (if (plusp e)
        (progn
          (write-string string stream :end (min (length string) e))
          (dotimes (i (- e (length string)))
            (write-char #\0 stream))
          (write-char #\. stream)
          (write-string string stream :start (min (length string) e))
          (when fdigits
            (dotimes (i (- fdigits
                           (- (length string)
                              (min (length string) e))))
              (write-char #\0 stream))))
        (progn
          (write-string "." stream)
          (dotimes (i (- e))
            (write-char #\0 stream))
          (write-string string stream :end (when fdigits
                                             (min (length string)
                                                  (max (or fmin 0)
                                                       (+ fdigits e)))))
          (when fdigits
            (dotimes (i (+ fdigits e (- (length string))))
              (write-char #\0 stream)))))
      (let ((string (get-output-stream-string stream)))
        (values string (length string)
                (char= (char string 0) #\.)
                (char= (char string (1- (length string))) #\.)
                (position #\. string))))))

(defun format-fixed-aux (stream number w d k ovf pad atsign)
  (declare (type float number))
  (if (ccl::nan-or-infinity-p number)
    (prin1 number stream)
    (let ((spaceleft w))
      (when (and w (or atsign (minusp number)))
        (decf spaceleft))
      (multiple-value-bind (str len lpoint tpoint)
          (%flonum-to-string (abs number) spaceleft d k)
        ;; if caller specifically requested no fraction digits, suppress the
        ;; optional trailing zero
        (when (and d (zerop d))
          (setq tpoint nil))
        (when w
          (decf spaceleft len)
          ;; optional leading zero
          (when lpoint
            (if (or (> spaceleft 0) tpoint) ;force at least one digit
              (decf spaceleft)
              (setq lpoint nil)))
          ;; optional trailing zero
          (when tpoint
            (if (or t (> spaceleft 0))
              (decf spaceleft)
              (setq tpoint nil))))
        (cond ((and w (< spaceleft 0) ovf)
               ;; field width overflow
               (dotimes (i w)
                 (write-char ovf stream))
               t)
              (t
               (when w
                 (dotimes (i spaceleft)
                   (write-char pad stream)))
               (if (minusp number)
                 (write-char #\- stream)
                 (when atsign
                   (write-char #\+ stream)))
               (when lpoint
                 (write-char #\0 stream))
               (write-string str stream)
               (when tpoint
                 (write-char #\0 stream))
               nil))))))

(defun flonum-to-string (x &optional width fdigits scale fmin)
  ;; Wrapper around %FLONUM-TO-STRING, which is FLONUM-TO-STRING adapted
  ;; from SBCL.
  ;; DIGIT-STRING   - The decimal representation of X, with decimal point.
  ;; DIGIT-LENGTH   - The length of the string DIGIT-STRING.
  ;; LEADING-POINT  - True if the first character of DIGIT-STRING is the decimal point.
  ;; TRAILING-POINT - True if the last character of DIGIT-STRING is the decimal point.
  ;; POINT-POS      - The position of the digit preceding the decimal
  ;;                  point. Zero indicates point before first digit.
  (multiple-value-bind (digit-string digit-length leading-point trailing-point point-pos)
      (%flonum-to-string x width fdigits scale fmin)
    (declare (ignore trailing-point leading-point))
    (let ((before-pt point-pos)
          (after-pt (- (1+ point-pos) digit-length)))
      (values digit-string before-pt after-pt))))