(default-structure-print object stream *current-level-in-print*))
(t
(write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
+ (funcallable-instance
+ (cond
+ ((not (and (boundp '*print-object-is-disabled-p*)
+ *print-object-is-disabled-p*))
+ (print-object object stream))
+ (t (output-fun object stream))))
(function
- (unless (and (funcallable-instance-p object)
- (printed-as-funcallable-standard-class object stream))
- (output-fun object stream)))
+ (output-fun object stream))
(symbol
(output-symbol object stream))
(number
(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))
- (result (make-array 50 :element-type 'base-char
- :fill-pointer 0 :adjustable t)))
- (labels ((scale (r s m+ m-)
- (do ((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 (or (< (* (+ r m+) print-base) s)
- (and (not high-ok)
- (= (* (+ r m+) print-base) s))))
- (values k (generate r s m+ m-)))))))
- (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 (or (> (+ r m+) s)
- (and high-ok (= (+ r m+) s))))
- (when (or tc1 tc2)
- (go end))
- (vector-push-extend (char digit-characters d) result)
- (go loop)
- end
- (let ((d (cond
- ((and (not tc1) tc2) (1+ d))
- ((and tc1 (not tc2)) d)
- (t ; (and tc1 tc2)
- (if (< (* r 2) s) d (1+ d))))))
- (vector-push-extend (char digit-characters d) result)
- (return-from generate result)))))
- (initialize ()
- (let (r s m+ m-)
- (if (>= e 0)
- (let* ((be (expt float-radix e))
- (be1 (* be float-radix)))
- (if (/= f (expt float-radix (1- float-digits)))
- (setf r (* f be 2)
- s 2
- m+ be
- m- be)
- (setf r (* f be1 2)
- s (* float-radix 2)
- m+ be1
- m- be)))
- (if (or (= e min-e)
- (/= f (expt float-radix (1- float-digits))))
- (setf r (* f 2)
- s (* (expt float-radix (- e)) 2)
- m+ 1
- m- 1)
- (setf r (* f float-radix 2)
- s (* (expt float-radix (- 1 e)) 2)
- m+ float-radix
- m- 1)))
- (when position
- (when relativep
- (aver (> position 0))
- (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 (expt print-base k)))
- (setf position (- k position))
- (setf position (- k position 1))))))
- (let ((low (max m- (/ (* s (expt print-base position)) 2)))
- (high (max m+ (/ (* s (expt print-base position)) 2))))
- (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-)))))))
+ (low-ok (evenp f)))
+ (with-push-char (:element-type base-char)
+ (labels ((scale (r s m+ m-)
+ (do ((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 (or (< (* (+ r m+) print-base) s)
+ (and (not high-ok)
+ (= (* (+ r m+) print-base) s))))
+ (values k (generate r s m+ m-)))))))
+ (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 (or (> (+ r m+) s)
+ (and high-ok (= (+ r m+) s))))
+ (when (or tc1 tc2)
+ (go end))
+ (push-char (char digit-characters d))
+ (go loop)
+ end
+ (let ((d (cond
+ ((and (not tc1) tc2) (1+ d))
+ ((and tc1 (not tc2)) d)
+ (t ; (and tc1 tc2)
+ (if (< (* r 2) s) d (1+ d))))))
+ (push-char (char digit-characters d))
+ (return-from generate (get-pushed-string))))))
+ (initialize ()
+ (let (r s m+ m-)
+ (if (>= e 0)
+ (let* ((be (expt float-radix e))
+ (be1 (* be float-radix)))
+ (if (/= f (expt float-radix (1- float-digits)))
+ (setf r (* f be 2)
+ s 2
+ m+ be
+ m- be)
+ (setf r (* f be1 2)
+ s (* float-radix 2)
+ m+ be1
+ m- be)))
+ (if (or (= e min-e)
+ (/= f (expt float-radix (1- float-digits))))
+ (setf r (* f 2)
+ s (* (expt float-radix (- e)) 2)
+ m+ 1
+ m- 1)
+ (setf r (* f float-radix 2)
+ s (* (expt float-radix (- 1 e)) 2)
+ m+ float-radix
+ m- 1)))
+ (when position
+ (when relativep
+ (aver (> position 0))
+ (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 (expt print-base k)))
+ (setf position (- k position))
+ (setf position (- k position 1))))))
+ (let ((low (max m- (/ (* s (expt print-base position)) 2)))
+ (high (max m+ (/ (* s (expt print-base position)) 2))))
+ (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-))))))))
\f
;;; Given a non-negative floating point number, SCALE-EXPONENT returns
;;; a new floating point number Z in the range (0.1, 1.0] and an
projects / sbcl.git / blobdiff