Skip to content

Instantly share code, notes, and snippets.

@phoe
Last active November 21, 2019 11:58
Show Gist options
  • Save phoe/cadbbf4d22a2d81949b634a135b571e7 to your computer and use it in GitHub Desktop.
Save phoe/cadbbf4d22a2d81949b634a135b571e7 to your computer and use it in GitHub Desktop.
fix for CCL's floating point fuckery - code adapted from SBCL
;; 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))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment