;; As long as no one comes up with a non-obscure way of detecting this
;; sleaziness, fixing this nonconformity will probably have a low
;; priority. -- WHN 2001-11-25
- (fixnum
- (output-integer object stream))
(list
(if (null object)
(output-symbol object stream)
;;; character has. At characters have at least one bit set, so we can
;;; search for any character with a positive test.
(defvar *character-attributes*
- (make-array char-code-limit
+ (make-array 160 ; FIXME
:element-type '(unsigned-byte 16)
:initial-element 0))
-(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
*character-attributes*))
;;; constants which are a bit-mask for each interesting character attribute
(set-bit #\/ slash-attribute)
;; Mark anything not explicitly allowed as funny.
- (dotimes (i char-code-limit)
+ (dotimes (i 160) ; FIXME
(when (zerop (aref *character-attributes* i))
(setf (aref *character-attributes* i) funny-attribute))))
;;; For each character, the value of the corresponding element is the
;;; lowest base in which that character is a digit.
(defvar *digit-bases*
- (make-array char-code-limit
+ (make-array 128 ; FIXME
:element-type '(unsigned-byte 8)
:initial-element 36))
-(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
*digit-bases*))
(dotimes (i 36)
(let ((char (digit-char i 36)))
,(if at-end '(go TEST-SIGN) '(return nil)))
(setq current (schar name index)
code (char-code current)
- bits (aref attributes code))
+ bits (cond ; FIXME
+ ((< code 160) (aref attributes code))
+ ((upper-case-p current) uppercase-attribute)
+ ((lower-case-p current) lowercase-attribute)
+ (t other-attribute)))
(incf index)
(go ,tag)))
(test (&rest attributes)
attributes))
bits)))))
(digitp ()
- `(< (the fixnum (aref bases code)) base)))
+ `(and (< code 128) ; FIXME
+ (< (the fixnum (aref bases code)) base))))
(prog ((len (length name))
(attributes *character-attributes*)
letter-attribute)))
(do ((i (1- index) (1+ i)))
((= i len) (return-from symbol-quotep nil))
- (unless (zerop (logand (aref attributes (char-code (schar name i)))
+ (unless (zerop (logand (let* ((char (schar name i))
+ (code (char-code char)))
+ (cond
+ ((< code 160) (aref attributes code))
+ ((upper-case-p char) uppercase-attribute)
+ ((lower-case-p char) lowercase-attribute)
+ (t other-attribute)))
mask))
(return-from symbol-quotep t))))
\f
;;;; integer, ratio, and complex printing (i.e. everything but floats)
+(defun %output-radix (base stream)
+ (write-char #\# stream)
+ (write-char (case base
+ (2 #\b)
+ (8 #\o)
+ (16 #\x)
+ (t (%output-fixnum-in-base base 10 stream)
+ #\r))
+ stream))
+
+(defun %output-fixnum-in-base (n base stream)
+ (multiple-value-bind (q r)
+ (truncate n base)
+ ;; Recurse until you have all the digits pushed on
+ ;; the stack.
+ (unless (zerop q)
+ (%output-fixnum-in-base q base stream))
+ ;; Then as each recursive call unwinds, turn the
+ ;; digit (in remainder) into a character and output
+ ;; the character.
+ (write-char
+ (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)
+ stream)))
+
+(defun %output-bignum-in-base (n base stream)
+ (labels ((bisect (n power)
+ (if (fixnump n)
+ (%output-fixnum-in-base n base stream)
+ (let ((k (truncate power 2)))
+ (multiple-value-bind (q r) (truncate n (expt base k))
+ (bisect q (- power k))
+ (let ((npower (if (zerop r) 0 (truncate (log r base)))))
+ (dotimes (z (- k npower 1))
+ (write-char #\0 stream))
+ (bisect r npower)))))))
+ (bisect n (truncate (log n base)))))
+
+(defun %output-integer-in-base (integer base stream)
+ (when (minusp integer)
+ (write-char #\- stream)
+ (setf integer (- integer)))
+ (if (fixnump integer)
+ (%output-fixnum-in-base integer base stream)
+ (%output-bignum-in-base integer base stream)))
+
(defun output-integer (integer stream)
- ;; FIXME: This UNLESS form should be pulled out into something like
- ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
- ;; *PACKAGE* variable.
- (unless (and (fixnump *print-base*)
- (< 1 *print-base* 37))
- (let ((obase *print-base*))
- (setq *print-base* 10.)
- (error "~A is not a reasonable value for *PRINT-BASE*." obase)))
- (when (and (not (= *print-base* 10.))
- *print-radix*)
- ;; First print leading base information, if any.
- (write-char #\# stream)
- (write-char (case *print-base*
- (2. #\b)
- (8. #\o)
- (16. #\x)
- (T (let ((fixbase *print-base*)
- (*print-base* 10.)
- (*print-radix* ()))
- (sub-output-integer fixbase stream))
- #\r))
- stream))
- ;; Then output a minus sign if the number is negative, then output
- ;; the absolute value of the number.
- (cond ((bignump integer) (print-bignum integer stream))
- ((< integer 0)
- (write-char #\- stream)
- (sub-output-integer (- integer) stream))
- (t
- (sub-output-integer integer stream)))
- ;; Print any trailing base information, if any.
- (if (and (= *print-base* 10.) *print-radix*)
- (write-char #\. stream)))
-
-(defun sub-output-integer (integer stream)
- (let ((quotient ())
- (remainder ()))
- ;; Recurse until you have all the digits pushed on the stack.
- (if (not (zerop (multiple-value-setq (quotient remainder)
- (truncate integer *print-base*))))
- (sub-output-integer quotient stream))
- ;; Then as each recursive call unwinds, turn the digit (in remainder)
- ;; into a character and output the character.
- (write-char (code-char (if (and (> remainder 9.)
- (> *print-base* 10.))
- (+ (char-code #\A) (- remainder 10.))
- (+ (char-code #\0) remainder)))
- stream)))
-\f
-;;;; bignum printing
-
-;;; *BASE-POWER* holds the number that we keep dividing into the
-;;; bignum for each *print-base*. We want this number as close to
-;;; *most-positive-fixnum* as possible, i.e. (floor (log
-;;; most-positive-fixnum *print-base*)).
-(defparameter *base-power* (make-array 37 :initial-element nil))
-
-;;; *FIXNUM-POWER--1* holds the number of digits for each *PRINT-BASE*
-;;; that fit in the corresponding *base-power*.
-(defparameter *fixnum-power--1* (make-array 37 :initial-element nil))
-
-;;; Print the bignum to the stream. We first generate the correct
-;;; value for *base-power* and *fixnum-power--1* if we have not
-;;; already. Then we call bignum-print-aux to do the printing.
-(defun print-bignum (big stream)
- (unless (aref *base-power* *print-base*)
- (do ((power-1 -1 (1+ power-1))
- (new-divisor *print-base* (* new-divisor *print-base*))
- (divisor 1 new-divisor))
- ((not (fixnump new-divisor))
- (setf (aref *base-power* *print-base*) divisor)
- (setf (aref *fixnum-power--1* *print-base*) power-1))))
- (bignum-print-aux (cond ((minusp big)
- (write-char #\- stream)
- (- big))
- (t big))
- (aref *base-power* *print-base*)
- (aref *fixnum-power--1* *print-base*)
- stream)
- big)
-
-(defun bignum-print-aux (big divisor power-1 stream)
- (multiple-value-bind (newbig fix) (truncate big divisor)
- (if (fixnump newbig)
- (sub-output-integer newbig stream)
- (bignum-print-aux newbig divisor power-1 stream))
- (do ((zeros power-1 (1- zeros))
- (base-power *print-base* (* base-power *print-base*)))
- ((> base-power fix)
- (dotimes (i zeros) (write-char #\0 stream))
- (sub-output-integer fix stream)))))
+ (let ((base *print-base*))
+ (when (and (/= base 10) *print-radix*)
+ (%output-radix base stream))
+ (%output-integer-in-base integer base stream)
+ (when (and *print-radix* (= base 10))
+ (write-char #\. stream))))
(defun output-ratio (ratio stream)
- (when *print-radix*
- (write-char #\# stream)
- (case *print-base*
- (2 (write-char #\b stream))
- (8 (write-char #\o stream))
- (16 (write-char #\x stream))
- (t (write *print-base* :stream stream :radix nil :base 10)
- (write-char #\r stream))))
- (let ((*print-radix* nil))
- (output-integer (numerator ratio) stream)
+ (let ((base *print-base*))
+ (when *print-radix*
+ (%output-radix base stream))
+ (%output-integer-in-base (numerator ratio) base stream)
(write-char #\/ stream)
- (output-integer (denominator ratio) stream)))
+ (%output-integer-in-base (denominator ratio) base stream)))
(defun output-complex (complex stream)
(write-string "#C(" stream)
+ ;; FIXME: Could this just be OUTPUT-NUMBER?
(output-object (realpart complex) stream)
(write-char #\space stream)
(output-object (imagpart complex) stream)
;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
-(declaim (type (simple-array character (10)) *digits*))
-(defvar *digits* "0123456789")
-
(defun flonum-to-string (x &optional width fdigits scale fmin)
(cond ((zerop x)
;; Zero is a special case which FLOAT-STRING cannot handle.
(defun float-string (fraction exponent precision width fdigits scale fmin)
(let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
(digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high
+ (digit-characters "0123456789")
(digit-string (make-array 50
:element-type 'base-char
:fill-pointer 0
;; Stop when either precision is exhausted or we have printed as
;; many fraction digits as permitted.
(when (or low high (and cutoff (<= k cutoff))) (return))
- (vector-push-extend (char *digits* u) digit-string)
+ (vector-push-extend (char digit-characters u) digit-string)
(incf digits))
;; If cutoff occurred before first digit, then no digits are
;; generated at all.
(when (or (not cutoff) (>= k cutoff))
;; Last digit may need rounding
- (vector-push-extend (char *digits*
+ (vector-push-extend (char digit-characters
(cond ((and low (not high)) u)
((and high (not low)) (1+ u))
(t (if (<= (ash r 1) s) u (1+ u)))))
(let ((print-base 10) ; B
(float-radix 2) ; b
(float-digits (float-digits v)) ; p
+ (digit-characters "0123456789")
(min-e
(etypecase v
(single-float single-float-min-e)
(m+ m+ (* m+ print-base))
(m- m- (* m- print-base)))
((not (or (< (* (+ r m+) print-base) s)
- (and high-ok (= (* (+ 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)
(and high-ok (= (+ r m+) s))))
(when (or tc1 tc2)
(go end))
- (vector-push-extend (char *digits* d) result)
+ (vector-push-extend (char digit-characters d) result)
(go loop)
end
(let ((d (cond
((and tc1 (not tc2)) d)
(t ; (and tc1 tc2)
(if (< (* r 2) s) d (1+ d))))))
- (vector-push-extend (char *digits* d) result)
+ (vector-push-extend (char digit-characters d) result)
(return-from generate result))))))
(if (>= e 0)
(if (/= f (expt float-radix (1- float-digits)))
projects / sbcl.git / blobdiff