diff --git a/code/burger-dybvig.lisp b/code/burger-dybvig.lisp index f5293de..c08a1fe 100644 --- a/code/burger-dybvig.lisp +++ b/code/burger-dybvig.lisp @@ -224,7 +224,9 @@ ;;; to find an approximate value of k, then we find the exact ;;; one by a small search around the appriximation. (defun scale (r &optional high-ok) - (let* ((try (1- (ceiling (log (coerce r 'long-float) 10)))) + (let* ((try (1- (ceiling (log (max least-positive-long-float + (min most-positive-long-float + (coerce r 'long-float))) 10)))) (expt (expt 10 try))) (loop while (or (and high-ok (< r expt)) (and (not high-ok) (<= r expt))) @@ -341,69 +343,73 @@ ;;; Burger & Dybvig paper. It is not modeled after their Scheme code, ;;; but reimplements the algorithm they present in Common Lisp. (defun burger-dybvig-2 (x) - (multiple-value-bind (f e) - (integer-decode-float x) - ;; adjust mantissa and exponent - (when (< (float-precision x) (float-digits x)) - (let ((shift (- (float-digits x) (integer-length f)))) - (setf f (ash f shift)) - (decf e shift))) - (let (r s m+ m- - (high-ok #+(or clasp sbcl) (evenp f) #-(or clasp sbcl) nil) - (low-ok #+(or clasp sbcl) (evenp f) #-(or clasp sbcl) nil)) - (if (>= e 0) - (progn (if (= (decode-float x) 0.5) - (setf m- (expt 2 e) - m+ (* m- 2) - s 4 - r (* f m+ 2)) - (setf m- (expt 2 e) - m+ m- - s 2 - r (* f m+ 2)))) - (progn (if (and (= (decode-float x) 0.5) - (= (float-precision x) - (float-precision (predecessor x)))) - (setf m- 1 - m+ 2 - s (* (expt 2 (- 1 e)) 2) - r (* f 4)) - (setf m- 1 - m+ 1 - s (* (expt 2 (- e)) 2) - r (* f 2))))) - (let ((k (scale (/ (+ r m+) s) high-ok))) - (if (>= k 0) - (setf s (* s (expt 10 k))) - (let ((coeff (expt 10 (- k)))) - (setf r (* r coeff) - m+ (* m+ coeff) - m- (* m- coeff)))) - (prog ((result (make-array 16 :adjustable t - :fill-pointer 0 - :initial-element 0 - :element-type '(integer 0 9))) - tc1 tc2) - next - (multiple-value-bind (quotient remainder) - (floor (* r 10) s) - (setf r remainder - m+ (* m+ 10) - m- (* m- 10) - tc1 (if low-ok (<= r m-) (< r m-)) - tc2 (if high-ok - (>= (+ r m+) s) - (> (+ r m+) s))) - (when (or tc1 tc2) - (vector-push-extend (if (or (and (not tc1) tc2) - (not (or (and tc1 (not tc2)) - (< (* r 2) s)))) - (1+ quotient) - quotient) - result) - (return (values result k))) - (vector-push-extend quotient result) - (go next))))))) + (if (zerop x) + (values #(0) -1) + (multiple-value-bind (f e) + (integer-decode-float x) + ;; adjust mantissa and exponent + (when (< (float-precision x) (float-digits x)) + (let ((shift (- (float-digits x) (integer-length f)))) + (setf f (ash f shift)) + (decf e shift))) + (let (r s m+ m- + (high-ok #+(or clasp sbcl) (evenp f) + #-(or clasp sbcl) nil) + (low-ok #+(or clasp sbcl) (evenp f) + #-(or clasp sbcl) nil)) + (if (>= e 0) + (progn (if (= (decode-float x) 0.5) + (setf m- (expt 2 e) + m+ (* m- 2) + s 4 + r (* f m+ 2)) + (setf m- (expt 2 e) + m+ m- + s 2 + r (* f m+ 2)))) + (progn (if (and (= (decode-float x) 0.5) + (= (float-precision x) + (float-precision (predecessor x)))) + (setf m- 1 + m+ 2 + s (* (expt 2 (- 1 e)) 2) + r (* f 4)) + (setf m- 1 + m+ 1 + s (* (expt 2 (- e)) 2) + r (* f 2))))) + (let ((k (scale (/ (+ r m+) s) high-ok))) + (if (>= k 0) + (setf s (* s (expt 10 k))) + (let ((coeff (expt 10 (- k)))) + (setf r (* r coeff) + m+ (* m+ coeff) + m- (* m- coeff)))) + (prog ((result (make-array 16 :adjustable t + :fill-pointer 0 + :initial-element 0 + :element-type '(integer 0 9))) + tc1 tc2) + next + (multiple-value-bind (quotient remainder) + (floor (* r 10) s) + (setf r remainder + m+ (* m+ 10) + m- (* m- 10) + tc1 (if low-ok (<= r m-) (< r m-)) + tc2 (if high-ok + (>= (+ r m+) s) + (> (+ r m+) s))) + (when (or tc1 tc2) + (vector-push-extend (if (or (and (not tc1) tc2) + (not (or (and tc1 (not tc2)) + (< (* r 2) s)))) + (1+ quotient) + quotient) + result) + (return (values result k))) + (vector-push-extend quotient result) + (go next)))))))) ;;; Test that the two implemetations above give the same result ;;; for all single floats. Running this test may take a few days diff --git a/code/control-string-compiler.lisp b/code/control-string-compiler.lisp index 52c63a1..feead70 100644 --- a/code/control-string-compiler.lisp +++ b/code/control-string-compiler.lisp @@ -54,6 +54,6 @@ append (compile-directive client item))) (defun compile-control-string (client control-string) - (let ((items (structure-items (split-control-string control-string) nil))) + (let ((items (structure-items (split-control-string control-string)))) `(progn ,@(loop for item across items collect (compile-item client item))))) diff --git a/code/floating-point-printers.lisp b/code/floating-point-printers.lisp index e035bf0..5bbc06a 100644 --- a/code/floating-point-printers.lisp +++ b/code/floating-point-printers.lisp @@ -72,8 +72,6 @@ (padchar :type character :default-value #\Space))) -(defparameter *digits* "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") - (defun print-fixed-arg (client value digits exponent colonp at-signp w d k overflowchar padchar) (declare (ignore client colonp)) @@ -200,6 +198,7 @@ :default-value nil))) (defun print-exponent-arg (client value digits exponent colonp at-signp w d e k overflowchar padchar exponentchar) + (declare (ignore colonp)) (let ((decimal (make-instance 'decimal :digits digits)) sign len exp) @@ -209,7 +208,8 @@ (setf sign (cond ((minusp (float-sign value)) #\-) ((and at-signp (plusp value)) #\+))) - (setf exponent (if (zerop (aref decimal-digits 0)) + (setf exponent (if (or (zerop (length decimal-digits)) + (zerop (aref decimal-digits 0))) 0 (+ exponent (- k)))) (setf exp (let ((*print-base* 10) @@ -288,12 +288,12 @@ (print-decimal decimal) (write-char (or exponentchar (if (typep value *read-default-float-format*) - #\e + #+abcl #\E #-abcl #\e (etypecase value - (short-float #\s) - (single-float #\f) - (double-float #\d) - (long-float #\l)))) + (short-float #+abcl #\S #-abcl #\s) + (single-float #+abcl #\F #-abcl #\f) + (double-float #+abcl #\D #-abcl #\d) + (long-float #+abcl #\L #-abcl #\l)))) *destination*) (write-char (if (minusp exponent) #\- #\+) *destination*) (write-string exp *destination*)) diff --git a/code/format.lisp b/code/format.lisp index 523a393..2ced1ba 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -241,7 +241,7 @@ (defun format-with-runtime-arguments (client control-string) (catch *inner-tag* (interpret-items client - (structure-items (split-control-string control-string) nil)))) + (structure-items (split-control-string control-string))))) (defun format (client destination control &rest args) (let ((*destination* (cond ((or (streamp destination) diff --git a/code/formatter.lisp b/code/formatter.lisp index a73f2a7..dfbd570 100644 --- a/code/formatter.lisp +++ b/code/formatter.lisp @@ -2,13 +2,14 @@ (defun formatter (client control-string) (check-type control-string string) - (let ((items (structure-items (split-control-string control-string) nil))) + (let ((items (structure-items (split-control-string control-string)))) `(lambda (*destination* &rest args) (with-arguments args ,@(compile-items client items) (consume-remaining-arguments))))) (defun format-compiler-macro (client form destination control-string args) + (declare (ignore form)) `(format ,(incless:client-form client) ,destination ,(if (stringp control-string) (formatter client control-string) diff --git a/code/layout-control.lisp b/code/layout-control.lisp index 96c16ff..688a445 100644 --- a/code/layout-control.lisp +++ b/code/layout-control.lisp @@ -111,6 +111,7 @@ (defun print-justification (client pad-left pad-right extra-space line-len mincol colinc minpad padchar newline-segment segments) + (declare (ignore client)) (when (and (not pad-left) (not pad-right) (null (cdr segments))) (setf pad-left t)) (let* ((pad-count (1- (length segments))) diff --git a/code/pretty-printer-operations.lisp b/code/pretty-printer-operations.lisp index 61e4dc7..4f4ae32 100644 --- a/code/pretty-printer-operations.lisp +++ b/code/pretty-printer-operations.lisp @@ -218,7 +218,7 @@ (position #\/ control-string :start start :end end))) (when (null position-of-trailing-slash) (error 'end-of-control-string-error - :control-string string + :control-string control-string :tilde-position start :why "expected a trailing slash")) (1+ position-of-trailing-slash))) diff --git a/code/structure-items.lisp b/code/structure-items.lisp index de7505f..448ae28 100644 --- a/code/structure-items.lisp +++ b/code/structure-items.lisp @@ -4,7 +4,7 @@ end (clauses (list nil))) -(defun structure-items (items end) +(defun structure-items (items) (loop with result = (list (make-group)) for item in (reverse items) finally (reduce (lambda (req it) @@ -28,53 +28,3 @@ (push nil (group-clauses (car result))))) (check-directive-syntax item) do (push item (car (group-clauses (car result)))))) - -#|(defun structure-items (items end) - (loop with result = '() - with first = (car items) - do (cond ((null items) - (if (null end) - (return (values (coerce (nreverse result) 'vector) - '())) - (error 'unmatched-directive - :directive first - :control-string (control-string first) - :tilde-position (start first)))) - ((stringp (car items)) - (push (pop items) result)) - ((find (directive-character (car items)) - ">)}]") - (if (eql (directive-character (car items)) end) - (progn (push (pop items) result) - (return (values (coerce (nreverse result) 'vector) - items))) - (error 'nesting-violation - :directive (car items)))) - ((find (directive-character (car items)) - "<({[") - (let ((item (pop items))) - (multiple-value-bind (nested-items rest) - (structure-items items - (ecase (directive-character item) - (#\< #\>) (#\( #\)) (#\{ #\}) (#\[ #\]))) - (setf items rest) - (ecase (directive-character item) - (#\< (if (colonp (aref nested-items (1- (length nested-items)))) - (change-class item 'logical-block-directive - :items nested-items) - (change-class item 'justification-directive - :items nested-items))) - (#\( (change-class item 'case-conversion-directive - :items nested-items)) - (#\{ (change-class item 'iteration-directive - :items nested-items)) - (#\[ (change-class item 'conditional-directive - :items nested-items))) - (check-directive-syntax item) - (push item result)))) - (t - (let ((item (pop items))) - (specialize-directive item) - (check-directive-syntax item) - (push item result)))))) -|# diff --git a/code/utilities.lisp b/code/utilities.lisp index ca741a5..87d79ab 100644 --- a/code/utilities.lisp +++ b/code/utilities.lisp @@ -97,3 +97,5 @@ (write-char (char-downcase char) (target stream))) (t (write-char char (target stream))))))) + +(defparameter *digits* "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")