Plaster

common-lisp
;; w = the width of the field to be printed ;; d = the number of digits to print after the decimal point ;; e = the number of digits to use when printing the exponent ;; k = a scale factor, defaults to one (not zero) (in-package :sb-format) (defun digits-to-subfstrs (string point-pos) (flet ((pad (length) (make-string length :initial-element #\0))) (let ((length (length string))) (cond ((< point-pos 0) (values "0" (concatenate 'string (pad (- point-pos)) string))) ((= point-pos 0) (values "0" string)) ((< 0 point-pos length) (values (subseq string 0 point-pos) (subseq string point-pos))) ((= point-pos length) (values string "0")) ((< length point-pos) (values (concatenate 'string string (pad (- point-pos length))) "0")) (t (bug "DIGITS-TO-FSTR was called with invalid args ~D, ~D." string point-pos)))))) (defun truncate-subfstr (string length) (if (<= (length string) length) string (let* ((subseq (subseq string 0 length)) (last-digit (parse-integer subseq :start (1- length) :end length))) (when (<= 5 last-digit) (setf (char subseq (1- length)) (char (prin1-to-string (1+ last-digit)) 0))) subseq))) (defun dbg (control &rest args) (apply #'format t control args) (fresh-line)) (defun format-exp-aux-2 (stream number w d e k ovf pad marker atsign) (declare (type float number)) (when (or (float-infinity-p number) (float-nan-p number)) (prin1 number stream) (return-from format-exp-aux-2)) (multiple-value-bind (expt numstr) (sb-impl::flonum-to-digits (abs number)) (dbg "Beginning with 0.~A * 10^~D." numstr (1+ expt)) (let* ((k (if (string= numstr "1") (1- k) k)) (expt (- expt k)) (estr (decimal-string (abs expt))) (elen (if e (max (length estr) e) (length estr))) (marker (or marker (format-exponent-marker number))) (sign-char (if (minusp expt) #\- #\+)) spaceleft) (when w (dbg "We print in a field of width ~S." w) ;; Account for exponent marker, exponent sign, and exponent length. (setf spaceleft (- w 2 elen)) ;; Account for float sign. (when (or atsign (= (float-sign-bit number) 1)) (decf spaceleft))) ;; Bail out early on exponent overflow. (when (and w ovf e (> elen e)) (dotimes (i w) (write-char ovf stream)) (return-from format-exp-aux-2)) (dbg "We have ~D spaces for the numstring." spaceleft) (multiple-value-bind (left right) (digits-to-subfstrs numstr (- 1 expt)) (dbg "Left/right: we have ~A.~A" left right) (when w (decf spaceleft (length left)) ; Part before the decimal point. (decf spaceleft 1) ; The decimal point. (when (and (< 1 (length right)) (< spaceleft (length right))) (setf right (truncate-subfstr right (max 1 d))) (dbg "Post-truncation left right: ~A.~A" left right))) (dbg "Final exponent is ~A." expt) (when w (decf spaceleft (length right))) (when (and w (< spaceleft 0) ovf) ;; Bail out early on significand overflow. (dotimes (i w) (write-char ovf stream)) (return-from format-exp-aux-2)) ;; Actual printing happens below. (when w (dotimes (i spaceleft) (write-char pad stream))) ; Printing field padding. (cond ; Number sign. ((= (float-sign-bit number) 1) (write-char #\- stream)) (atsign (write-char #\+ stream))) (write-string left stream) ; Part before the decimal point. (write-char #\. stream) ; The decimal point. (write-string right stream) ; Part after the decimal point. (write-char marker stream) ; Exponent marker. (write-char sign-char stream) ; Exponent sign. (when e (dotimes (i (- e (length estr))) (write-char #\0 stream))) ; Exponent padding. (write-string estr stream) ; Exponent. nil))))