X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=3aaaf74cc7a27268e9062dc93587a89ceb30d71c;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=c17846b9e0b1f5828c0a61be02c8d9de9c8ee881;hpb=8f41e246101ca3906d6c77da51c9de5601777b28;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index c17846b..3aaaf74 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -18,8 +18,8 @@ (defvar *print-readably* nil #!+sb-doc - "If true, all objects will printed readably. If readable printing is - impossible, an error will be signalled. This overrides the value of + "If true, all objects will be printed readably. If readable printing + is impossible, an error will be signalled. This overrides the value of *PRINT-ESCAPE*.") (defvar *print-escape* t #!+sb-doc @@ -30,7 +30,7 @@ "Should pretty printing be used?") (defvar *print-base* 10. #!+sb-doc - "the output base for RATIONALs (including integers)") + "The output base for RATIONALs (including integers).") (defvar *print-radix* nil #!+sb-doc "Should base be verified when printing RATIONALs?") @@ -56,10 +56,10 @@ "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?") (defvar *print-lines* nil #!+sb-doc - "the maximum number of lines to print per object") + "The maximum number of lines to print per object.") (defvar *print-right-margin* nil #!+sb-doc - "the position of the right margin in ems (for pretty-printing)") + "The position of the right margin in ems (for pretty-printing).") (defvar *print-miser-width* nil #!+sb-doc "If the remaining space between the current column and the right margin @@ -69,32 +69,40 @@ (defvar *print-pprint-dispatch*) #!+sb-doc (setf (fdocumentation '*print-pprint-dispatch* 'variable) - "the pprint-dispatch-table that controls how to pretty-print objects") + "The pprint-dispatch-table that controls how to pretty-print objects.") +(defvar *suppress-print-errors* nil + #!+sb-doc + "Suppress printer errors when the condition is of the type designated by this +variable: an unreadable object representing the error is printed instead.") (defmacro with-standard-io-syntax (&body body) #!+sb-doc "Bind the reader and printer control variables to values that enable READ to reliably read the results of PRINT. These values are: - *PACKAGE* the COMMON-LISP-USER package - *PRINT-ARRAY* T - *PRINT-BASE* 10 - *PRINT-CASE* :UPCASE - *PRINT-CIRCLE* NIL - *PRINT-ESCAPE* T - *PRINT-GENSYM* T - *PRINT-LENGTH* NIL - *PRINT-LEVEL* NIL - *PRINT-LINES* NIL - *PRINT-MISER-WIDTH* NIL - *PRINT-PRETTY* NIL - *PRINT-RADIX* NIL - *PRINT-READABLY* T - *PRINT-RIGHT-MARGIN* NIL - *READ-BASE* 10 - *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT - *READ-EVAL* T - *READ-SUPPRESS* NIL - *READTABLE* the standard readtable" + + *PACKAGE* the COMMON-LISP-USER package + *PRINT-ARRAY* T + *PRINT-BASE* 10 + *PRINT-CASE* :UPCASE + *PRINT-CIRCLE* NIL + *PRINT-ESCAPE* T + *PRINT-GENSYM* T + *PRINT-LENGTH* NIL + *PRINT-LEVEL* NIL + *PRINT-LINES* NIL + *PRINT-MISER-WIDTH* NIL + *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table + *PRINT-PRETTY* NIL + *PRINT-RADIX* NIL + *PRINT-READABLY* T + *PRINT-RIGHT-MARGIN* NIL + *READ-BASE* 10 + *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT + *READ-EVAL* T + *READ-SUPPRESS* NIL + *READTABLE* the standard readtable + SB-EXT:*SUPPRESS-PRINT-ERRORS* NIL +" `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) @@ -110,6 +118,7 @@ (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) + (*print-pprint-dispatch* sb!pretty::*standard-pprint-dispatch-table*) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) @@ -118,17 +127,34 @@ (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) - ;; FIXME: It doesn't seem like a good idea to expose our - ;; disaster-recovery *STANDARD-READTABLE* here. What if some - ;; enterprising user corrupts the disaster-recovery readtable - ;; by doing destructive readtable operations within - ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a - ;; COPY-READTABLE? The consing would be unfortunate, though. - (*readtable* *standard-readtable*)) + (*readtable* *standard-readtable*) + (*suppress-print-errors* nil)) (funcall function))) ;;;; routines to print objects + +;;; keyword variables shared by WRITE and WRITE-TO-STRING, and +;;; the bindings they map to. +(eval-when (:compile-toplevel :load-toplevel) + (defvar *printer-keyword-variables* + '(:escape *print-escape* + :radix *print-radix* + :base *print-base* + :circle *print-circle* + :pretty *print-pretty* + :level *print-level* + :length *print-length* + :case *print-case* + :array *print-array* + :gensym *print-gensym* + :readably *print-readably* + :right-margin *print-right-margin* + :miser-width *print-miser-width* + :lines *print-lines* + :pprint-dispatch *print-pprint-dispatch* + :suppress-errors *suppress-print-errors*))) + (defun write (object &key ((:stream stream) *standard-output*) ((:escape *print-escape*) *print-escape*) @@ -148,12 +174,42 @@ *print-miser-width*) ((:lines *print-lines*) *print-lines*) ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + *print-pprint-dispatch*) + ((:suppress-errors *suppress-print-errors*) + *suppress-print-errors*)) #!+sb-doc - "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*" + "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*." (output-object object (out-synonym-of stream)) object) +;;; Optimize common case of constant keyword arguments +(define-compiler-macro write (&whole form object &rest keys) + (let (bind ignore) + (do () + ((not (cdr keys)) + ;; Odd number of keys, punt + (when keys + (return-from write form))) + (let* ((key (pop keys)) + (value (pop keys)) + (variable (or (getf *printer-keyword-variables* key) + (when (eq :stream key) + 'stream) + (return-from write form)))) + (when (assoc variable bind) + ;; First key has precedence, but we still need to execute the + ;; argument, and in the right order. + (setf variable (gensym "IGNORE")) + (push variable ignore)) + (push (list variable value) bind))) + (unless (assoc 'stream bind) + (push (list 'stream '*standard-output*) bind)) + (once-only ((object object)) + `(let ,(nreverse bind) + ,@(when ignore `((declare (ignore ,@ignore)))) + (output-object ,object (out-synonym-of stream)) + ,object)))) + (defun prin1 (object &optional stream) #!+sb-doc "Output a mostly READable printed representation of OBJECT on the specified @@ -192,27 +248,54 @@ (values)) (defun write-to-string - (object &key - ((:escape *print-escape*) *print-escape*) - ((:radix *print-radix*) *print-radix*) - ((:base *print-base*) *print-base*) - ((:circle *print-circle*) *print-circle*) - ((:pretty *print-pretty*) *print-pretty*) - ((:level *print-level*) *print-level*) - ((:length *print-length*) *print-length*) - ((:case *print-case*) *print-case*) - ((:array *print-array*) *print-array*) - ((:gensym *print-gensym*) *print-gensym*) - ((:readably *print-readably*) *print-readably*) - ((:right-margin *print-right-margin*) *print-right-margin*) - ((:miser-width *print-miser-width*) *print-miser-width*) - ((:lines *print-lines*) *print-lines*) - ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + (object &key + ((:escape *print-escape*) *print-escape*) + ((:radix *print-radix*) *print-radix*) + ((:base *print-base*) *print-base*) + ((:circle *print-circle*) *print-circle*) + ((:pretty *print-pretty*) *print-pretty*) + ((:level *print-level*) *print-level*) + ((:length *print-length*) *print-length*) + ((:case *print-case*) *print-case*) + ((:array *print-array*) *print-array*) + ((:gensym *print-gensym*) *print-gensym*) + ((:readably *print-readably*) *print-readably*) + ((:right-margin *print-right-margin*) *print-right-margin*) + ((:miser-width *print-miser-width*) *print-miser-width*) + ((:lines *print-lines*) *print-lines*) + ((:pprint-dispatch *print-pprint-dispatch*) + *print-pprint-dispatch*) + ((:suppress-errors *suppress-print-errors*) + *suppress-print-errors*)) #!+sb-doc "Return the printed representation of OBJECT as a string." (stringify-object object)) +;;; Optimize common case of constant keyword arguments +(define-compiler-macro write-to-string (&whole form object &rest keys) + (let (bind ignore) + (do () + ((not (cdr keys)) + ;; Odd number of keys, punt + (when keys + (return-from write-to-string form))) + (let* ((key (pop keys)) + (value (pop keys)) + (variable (or (getf *printer-keyword-variables* key) + (return-from write-to-string form)))) + (when (assoc variable bind) + ;; First key has precedence, but we still need to execute the + ;; argument, and in the right order. + (setf variable (gensym "IGNORE")) + (push variable ignore)) + (push (list variable value) bind))) + (if bind + (once-only ((object object)) + `(let ,(nreverse bind) + ,@(when ignore `((declare (ignore ,@ignore)))) + (stringify-object ,object))) + `(stringify-object ,object)))) + (defun prin1-to-string (object) #!+sb-doc "Return the printed representation of OBJECT as a string with @@ -238,36 +321,54 @@ ;;;; support for the PRINT-UNREADABLE-OBJECT macro +(defun print-not-readable-error (object stream) + (restart-case + (error 'print-not-readable :object object) + (print-unreadably () + :report "Print unreadably." + (let ((*print-readably* nil)) + (output-object object stream) + object)) + (use-value (o) + :report "Supply an object to be printed instead." + :interactive + (lambda () + (read-evaluated-form "~@")) + (output-object o stream) + o))) + ;;; guts of PRINT-UNREADABLE-OBJECT (defun %print-unreadable-object (object stream type identity body) (declare (type (or null function) body)) - (when *print-readably* - (error 'print-not-readable :object object)) - (flet ((print-description () - (when type - (write (type-of object) :stream stream :circle nil - :level nil :length nil) - (write-char #\space stream)) - (when body - (funcall body)) - (when identity - (when (or body (not type)) - (write-char #\space stream)) - (write-char #\{ stream) - (write (get-lisp-obj-address object) :stream stream - :radix nil :base 16) - (write-char #\} stream)))) - (cond ((print-pretty-on-stream-p stream) - ;; Since we're printing prettily on STREAM, format the - ;; object within a logical block. PPRINT-LOGICAL-BLOCK does - ;; not rebind the stream when it is already a pretty stream, - ;; so output from the body will go to the same stream. - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (print-description))) - (t - (write-string "#<" stream) - (print-description) - (write-char #\> stream)))) + (if *print-readably* + (print-not-readable-error object stream) + (flet ((print-description () + (when type + (write (type-of object) :stream stream :circle nil + :level nil :length nil) + (write-char #\space stream) + (pprint-newline :fill stream)) + (when body + (funcall body)) + (when identity + (when (or body (not type)) + (write-char #\space stream)) + (pprint-newline :fill stream) + (write-char #\{ stream) + (write (get-lisp-obj-address object) :stream stream + :radix nil :base 16) + (write-char #\} stream)))) + (cond ((print-pretty-on-stream-p stream) + ;; Since we're printing prettily on STREAM, format the + ;; object within a logical block. PPRINT-LOGICAL-BLOCK does + ;; not rebind the stream when it is already a pretty stream, + ;; so output from the body will go to the same stream. + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (print-description))) + (t + (write-string "#<" stream) + (print-description) + (write-char #\> stream))))) nil) ;;;; OUTPUT-OBJECT -- the main entry point @@ -280,12 +381,41 @@ (and (symbolp x) (symbol-package x)))) +(defvar *in-print-error* nil) + ;;; Output OBJECT to STREAM observing all printer control variables. (defun output-object (object stream) (labels ((print-it (stream) (if *print-pretty* (sb!pretty:output-pretty-object object stream) (output-ugly-object object stream))) + (handle-it (stream) + (if *suppress-print-errors* + (handler-bind ((condition + (lambda (condition) nil + (when (typep condition *suppress-print-errors*) + (cond (*in-print-error* + (write-string "(error printing " stream) + (write-string *in-print-error* stream) + (write-string ")" stream)) + (t + ;; Give outer handlers a chance. + (with-simple-restart + (continue "Suppress the error.") + (signal condition)) + (let ((*print-readably* nil) + (*print-escape* t)) + (write-string + "#" stream)))) + (return-from handle-it object))))) + (print-it stream)) + (print-it stream))) (check-it (stream) (multiple-value-bind (marker initiate) (check-for-circularity object t) @@ -298,12 +428,12 @@ ;; otherwise (if marker (when (handle-circularity marker stream) - (print-it stream)) - (print-it stream)))))) + (handle-it stream)) + (handle-it stream)))))) (cond (;; Maybe we don't need to bother with circularity detection. (or (not *print-circle*) (uniquely-identified-by-print-p object)) - (print-it stream)) + (handle-it stream)) (;; If we have already started circularity detection, this ;; object might be a shared reference. If we have not, then ;; if it is a compound object it might contain a circular @@ -312,7 +442,7 @@ (compound-object-p object)) (check-it stream)) (t - (print-it stream))))) + (handle-it stream))))) ;;; a hack to work around recurring gotchas with printing while ;;; DEFGENERIC PRINT-OBJECT is being built @@ -358,10 +488,14 @@ (default-structure-print object stream *current-level-in-print*)) (t (write-string "#" 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 @@ -372,8 +506,6 @@ (output-float object stream)) (ratio (output-ratio object stream)) - (ratio - (output-ratio object stream)) (complex (output-complex object stream)))) (character @@ -392,6 +524,9 @@ (output-code-component object stream)) (fdefn (output-fdefn object stream)) + #!+sb-simd-pack + (simd-pack + (output-simd-pack object stream)) (t (output-random object stream)))) @@ -452,7 +587,8 @@ (defun output-symbol (object stream) (if (or *print-escape* *print-readably*) (let ((package (symbol-package object)) - (name (symbol-name object))) + (name (symbol-name object)) + (current (sane-package))) (cond ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols" ;; requires that keywords be printed with preceding colons @@ -461,19 +597,24 @@ (write-char #\: stream)) ;; Otherwise, if the symbol's home package is the current ;; one, then a prefix is never necessary. - ((eq package (sane-package))) + ((eq package current)) ;; Uninterned symbols print with a leading #:. ((null package) (when (or *print-gensym* *print-readably*) (write-string "#:" stream))) (t (multiple-value-bind (symbol accessible) - (find-symbol name (sane-package)) + (find-symbol name current) ;; If we can find the symbol by looking it up, it need not ;; be qualified. This can happen if the symbol has been ;; inherited from a package other than its home package. + ;; + ;; To preserve print-read consistency, use the local nickname if + ;; one exists. (unless (and accessible (eq symbol object)) - (output-symbol-name (package-name package) stream) + (let ((prefix (or (car (rassoc package (package-%local-nicknames current))) + (package-name package)))) + (output-symbol-name prefix stream)) (multiple-value-bind (symbol externalp) (find-external-symbol name package) (declare (ignore symbol)) @@ -859,6 +1000,13 @@ (incf length))) (write-char #\) stream))) +(defun output-unreadable-vector-readably (vector stream) + (declare (vector vector)) + (write-string "#." stream) + (write `(coerce ,(coerce vector '(vector t)) + '(simple-array ,(array-element-type vector) (*))) + :stream stream)) + (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) @@ -867,7 +1015,7 @@ (load-time-value (array-element-type (make-array 0 :element-type 'character)))))) - (error 'print-not-readable :object vector)) + (print-not-readable-error vector stream)) ((or *print-escape* *print-readably*) (write-char #\" stream) (quote-string vector stream) @@ -882,10 +1030,8 @@ ;; (Don't use OUTPUT-OBJECT here, since this code ;; has to work for all possible *PRINT-BASE* values.) (write-char (if (zerop bit) #\0 #\1) stream))) - (t - (when (and *print-readably* - (not (array-readably-printable-p vector))) - (error 'print-not-readable :object vector)) + ((or (not *print-readably*) + (array-readably-printable-p vector)) (descend-into (stream) (write-string "#(" stream) (dotimes (i (length vector)) @@ -893,7 +1039,11 @@ (write-char #\space stream)) (punt-print-if-too-long i stream) (output-object (aref vector i) stream)) - (write-string ")" stream))))) + (write-string ")" stream))) + (*read-eval* + (output-unreadable-vector-readably vector stream)) + (t + (print-not-readable-error vector stream)))) ;;; This function outputs a string quoting characters sufficiently ;;; so that someone can read it in again. Basically, put a slash in @@ -904,7 +1054,8 @@ ;; this for now. [noted by anonymous long ago] -- WHN 19991130 `(or (char= ,char #\\) (char= ,char #\")))) - (with-array-data ((data string) (start) (end (length string))) + (with-array-data ((data string) (start) (end) + :check-fill-pointer t) (do ((index start (1+ index))) ((>= index end)) (let ((char (schar data index))) @@ -932,19 +1083,45 @@ (*print-length* nil)) (print-unreadable-object (array stream :type t :identity t)))) -;;; Output the readable #A form of an array. -(defun output-array-guts (array stream) - (when (and *print-readably* - (not (array-readably-printable-p array))) - (error 'print-not-readable :object array)) - (write-char #\# stream) - (let ((*print-base* 10) - (*print-radix* nil)) - (output-integer (array-rank array) stream)) - (write-char #\A stream) +;;; Convert an array into a list that can be used with MAKE-ARRAY's +;;; :INITIAL-CONTENTS keyword argument. +(defun listify-array (array) (with-array-data ((data array) (start) (end)) (declare (ignore end)) - (sub-output-array-guts data (array-dimensions array) stream start))) + (labels ((listify (dimensions index) + (if (null dimensions) + (aref data index) + (let* ((dimension (car dimensions)) + (dimensions (cdr dimensions)) + (count (reduce #'* dimensions))) + (loop for i below dimension + collect (listify dimensions index) + do (incf index count)))))) + (listify (array-dimensions array) start)))) + +(defun output-unreadable-array-readably (array stream) + (write-string "#." stream) + (write `(make-array ',(array-dimensions array) + :element-type ',(array-element-type array) + :initial-contents ',(listify-array array)) + :stream stream)) + +;;; Output the readable #A form of an array. +(defun output-array-guts (array stream) + (cond ((or (not *print-readably*) + (array-readably-printable-p array)) + (write-char #\# stream) + (let ((*print-base* 10) + (*print-radix* nil)) + (output-integer (array-rank array) stream)) + (write-char #\A stream) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (sub-output-array-guts data (array-dimensions array) stream start))) + (*read-eval* + (output-unreadable-array-readably array stream)) + (t + (print-not-readable-error array stream)))) (defun sub-output-array-guts (array dimensions stream index) (declare (type (simple-array * (*)) array) (fixnum index)) @@ -978,17 +1155,17 @@ (2 #\b) (8 #\o) (16 #\x) - (t (%output-fixnum-in-base base 10 stream) + (t (%output-reasonable-integer-in-base base 10 stream) #\r)) stream)) -(defun %output-fixnum-in-base (n base stream) +(defun %output-reasonable-integer-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)) + (%output-reasonable-integer-in-base q base stream)) ;; Then as each recursive call unwinds, turn the ;; digit (in remainder) into a character and output ;; the character. @@ -996,21 +1173,89 @@ (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) stream))) +;;; *POWER-CACHE* is an alist mapping bases to power-vectors. It is +;;; filled and probed by POWERS-FOR-BASE. SCRUB-POWER-CACHE is called +;;; always prior a GC to drop overly large bignums from the cache. +;;; +;;; It doesn't need a lock, but if you work on SCRUB-POWER-CACHE or +;;; POWERS-FOR-BASE, see that you don't break the assumptions! +(defvar *power-cache* nil) + +(defconstant +power-cache-integer-length-limit+ 2048) + +(defun scrub-power-cache () + (let ((cache *power-cache*)) + (dolist (cell cache) + (let ((powers (cdr cell))) + (declare (simple-vector powers)) + (let ((too-big (position-if + (lambda (x) + (>= (integer-length x) + +power-cache-integer-length-limit+)) + powers))) + (when too-big + (setf (cdr cell) (subseq powers 0 too-big)))))) + ;; Since base 10 is overwhelmingly common, make sure it's at head. + ;; Try to keep other bases in a hopefully sensible order as well. + (if (eql 10 (caar cache)) + (setf *power-cache* cache) + ;; If we modify the list destructively we need to copy it, otherwise + ;; an alist lookup in progress might be screwed. + (setf *power-cache* (sort (copy-list cache) + (lambda (a b) + (declare (fixnum a b)) + (cond ((= 10 a) t) + ((= 10 b) nil) + ((= 16 a) t) + ((= 16 b) nil) + ((= 2 a) t) + ((= 2 b) nil) + (t (< a b)))) + :key #'car))))) + +;;; Compute (and cache) a power vector for a BASE and LIMIT: +;;; the vector holds integers for which +;;; (aref powers k) == (expt base (expt 2 k)) +;;; holds. +(defun powers-for-base (base limit) + (flet ((compute-powers (from) + (let (powers) + (do ((p from (* p p))) + ((> p limit) + ;; We don't actually need this, but we also + ;; prefer not to cons it up a second time... + (push p powers)) + (push p powers)) + (nreverse powers)))) + ;; Grab a local reference so that we won't stuff consed at the + ;; head by other threads -- or sorting by SCRUB-POWER-CACHE. + (let ((cache *power-cache*)) + (let ((cell (assoc base cache))) + (if cell + (let* ((powers (cdr cell)) + (len (length powers)) + (max (svref powers (1- len)))) + (if (> max limit) + powers + (let ((new + (concatenate 'vector powers + (compute-powers (* max max))))) + (setf (cdr cell) new) + new))) + (let ((powers (coerce (compute-powers base) 'vector))) + ;; Add new base to head: SCRUB-POWER-CACHE will later + ;; put it to a better place. + (setf *power-cache* (acons base powers cache)) + powers)))))) + ;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05 -(defun %output-bignum-in-base (n base stream) +(defun %output-huge-integer-in-base (n base stream) (declare (type bignum n) (type fixnum base)) - (let ((power (make-array 10 :adjustable t :fill-pointer 0))) - ;; Here there be the bottleneck for big bignums, in the (* p p). - ;; A special purpose SQUARE-BIGNUM might help a bit. See eg: Dan - ;; Zuras, "On Squaring and Multiplying Large Integers", ARITH-11: - ;; IEEE Symposium on Computer Arithmetic, 1993, pp. 260 to 271. - ;; Reprinted as "More on Multiplying and Squaring Large Integers", - ;; IEEE Transactions on Computers, volume 43, number 8, August - ;; 1994, pp. 899-908. - (do ((p base (* p p))) - ((> p n)) - (vector-push-extend p power)) - ;; (aref power k) == (expt base (expt 2 k)) + ;; POWER is a vector for which the following holds: + ;; (aref power k) == (expt base (expt 2 k)) + (let* ((power (powers-for-base base n)) + (k-start (or (position-if (lambda (x) (> x n)) power) + (bug "power-vector too short")))) (labels ((bisect (n k exactp) (declare (fixnum k)) ;; N is the number to bisect @@ -1032,15 +1277,19 @@ ;; doesn't get any leading zeros. (bisect q k exactp) (bisect r k (or exactp (plusp q)))))))) - (bisect n (fill-pointer power) nil)))) + (bisect n k-start nil)))) (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))) + ;; The ideal cutoff point between these two algorithms is almost + ;; certainly quite platform dependent: this gives 87 for 32 bit + ;; SBCL, which is about right at least for x86/Darwin. + (if (or (fixnump integer) + (< (integer-length integer) (* 3 sb!vm:n-positive-fixnum-bits))) + (%output-reasonable-integer-in-base integer base stream) + (%output-huge-integer-in-base integer base stream))) (defun output-integer (integer stream) (let ((base *print-base*)) @@ -1130,71 +1379,68 @@ ;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with ;; possibly-negative X. (setf x (abs x)) - (cond ((zerop x) - ;; Zero is a special case which FLOAT-STRING cannot handle. - (if fdigits - (let ((s (make-string (1+ fdigits) :initial-element #\0))) - (setf (schar s 0) #\.) - (values s (length s) t (zerop fdigits) 0)) - (values "." 1 t t 0))) - (t - (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 (- (+ (or fmin 0) - (if scale scale 0))))))) - (cond - ((>= (length (cadr w)) (length (cadr f))) - (values-list w)) - (t (values-list f)))) - (flonum-to-digits x))) - (let ((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) - (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)))))))) - -;;; implementation of figure 1 from Burger and Dybvig, 1996. As the -;;; implementation of the Dragon from Classic CMUCL (and previously in -;;; SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF -;;; ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE PAPER!", -;;; and in this case we have to add that even reading the paper might -;;; not bring immediate illumination as CSR has attempted to turn -;;; idiomatic Scheme into idiomatic Lisp. + (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 (- (+ (or fmin 0) + (if scale scale 0))))))) + (cond + ((>= (length (cadr w)) (length (cadr f))) + (values-list w)) + (t (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)))))) + +;;; implementation of figure 1 from Burger and Dybvig, 1996. It is +;;; extended in order to handle rounding. +;;; +;;; As the implementation of the Dragon from Classic CMUCL (and +;;; previously in SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN +;;; THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE +;;; PAPER!", and in this case we have to add that even reading the +;;; paper might not bring immediate illumination as CSR has attempted +;;; to turn idiomatic Scheme into idiomatic Lisp. ;;; ;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized ;;; algorithm, noticeably slow at finding the exponent. Figure 2 has @@ -1203,9 +1449,9 @@ ;;; possible extension for the enthusiastic: printing floats in bases ;;; other than base 10. (defconstant single-float-min-e - (nth-value 1 (decode-float least-positive-single-float))) + (- 2 sb!vm:single-float-bias sb!vm:single-float-digits)) (defconstant double-float-min-e - (nth-value 1 (decode-float least-positive-double-float))) + (- 2 sb!vm:double-float-bias sb!vm:double-float-digits)) #!+long-float (defconstant long-float-min-e (nth-value 1 (decode-float least-positive-long-float))) @@ -1226,91 +1472,91 @@ (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 (and (plusp (- r m-)) ; Extension to handle zero + (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-)))))))) ;;; 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 @@ -1336,7 +1582,20 @@ (values (float 0.0e0 original-x) 1) (let* ((ex (locally (declare (optimize (safety 0))) (the fixnum - (round (* exponent (log 2e0 10)))))) + (round (* exponent + ;; this is the closest double float + ;; to (log 2 10), but expressed so + ;; that we're not vulnerable to the + ;; host lisp's interpretation of + ;; arithmetic. (FIXME: it turns + ;; out that sbcl itself is off by 1 + ;; ulp in this value, which is a + ;; little unfortunate.) + (load-time-value + #!-long-float + (sb!kernel:make-double-float 1070810131 1352628735) + #!+long-float + (error "(log 2 10) not computed"))))))) (x (if (minusp ex) (if (float-denormalized-p x) #!-long-float @@ -1403,7 +1662,8 @@ (cond (*read-eval* (write-string "#." stream)) (*print-readably* - (error 'print-not-readable :object x)) + (return-from output-float-infinity + (print-not-readable-error x stream))) (t (write-string "#<" stream))) (write-string "SB-EXT:" stream) @@ -1518,6 +1778,58 @@ (print-unreadable-object (fdefn stream) (write-string "FDEFINITION object for " stream) (output-object (fdefn-name fdefn) stream))) + +#!+sb-simd-pack +(defun output-simd-pack (pack stream) + (declare (type simd-pack pack)) + (cond ((and *print-readably* *read-eval*) + (etypecase pack + ((simd-pack double-float) + (multiple-value-call #'format stream + "#.(~S ~S ~S)" + '%make-simd-pack-double + (%simd-pack-doubles pack))) + ((simd-pack single-float) + (multiple-value-call #'format stream + "#.(~S ~S ~S ~S ~S)" + '%make-simd-pack-single + (%simd-pack-singles pack))) + (t + (multiple-value-call #'format stream + "#.(~S #X~16,'0X #X~16,'0X)" + '%make-simd-pack-ub64 + (%simd-pack-ub64s pack))))) + (t + (print-unreadable-object (pack stream) + (flet ((all-ones-p (value start end &aux (mask (- (ash 1 end) (ash 1 start)))) + (= (logand value mask) mask)) + (split-num (value start) + (loop + for i from 0 to 3 + and v = (ash value (- start)) then (ash v -8) + collect (logand v #xFF)))) + (multiple-value-bind (low high) + (%simd-pack-ub64s pack) + (etypecase pack + ((simd-pack double-float) + (multiple-value-bind (v0 v1) (%simd-pack-doubles pack) + (format stream "~S~@{ ~:[~,13E~;~*TRUE~]~}" + 'simd-pack + (all-ones-p low 0 64) v0 + (all-ones-p high 0 64) v1))) + ((simd-pack single-float) + (multiple-value-bind (v0 v1 v2 v3) (%simd-pack-singles pack) + (format stream "~S~@{ ~:[~,7E~;~*TRUE~]~}" + 'simd-pack + (all-ones-p low 0 32) v0 + (all-ones-p low 32 64) v1 + (all-ones-p high 0 32) v2 + (all-ones-p high 32 64) v3))) + (t + (format stream "~S~@{ ~{ ~2,'0X~}~}" + 'simd-pack + (split-num low 0) (split-num low 32) + (split-num high 0) (split-num high 32)))))))))) ;;;; functions @@ -1532,15 +1844,15 @@ nil) (defun output-fun (object stream) - (let* ((*print-length* 3) ; in case we have to.. - (*print-level* 3) ; ..print an interpreted function definition - (name (%fun-name object)) - (proper-name-p (and (legal-fun-name-p name) (fboundp name) - (eq (fdefinition name) object)))) - (print-unreadable-object (object stream :identity (not proper-name-p)) - (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" - (closurep object) - name)))) + (let* ((*print-length* 4) ; in case we have to.. + (*print-level* 3) ; ..print an interpreted function definition + (name (%fun-name object)) + (proper-name-p (and (legal-fun-name-p name) (fboundp name) + (eq (fdefinition name) object)))) + (print-unreadable-object (object stream :identity (not proper-name-p)) + (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" + (closurep object) + name)))) ;;;; catch-all for unknown things