X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fpprint.lisp;h=24e7d9794f59d625174c899c515153d2ae6afcfb;hb=7a3dd48161181e84c2dae473586781c2c55d27d7;hp=9da5803dd159e83f0225dd8b70eecfca9d2a2f83;hpb=7b1b2c1b10e8a75f30c1a86b1d4cae787488ceef;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 9da5803..24e7d97 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -75,12 +75,12 @@ ;; Buffer holding the per-line prefix active at the buffer start. ;; Indentation is included in this. The length of this is stored ;; in the logical block stack. - (prefix (make-string initial-buffer-size) :type simple-string) + (prefix (make-string initial-buffer-size) :type (simple-array character (*))) ;; Buffer holding the total remaining suffix active at the buffer start. ;; The characters are right-justified in the buffer to make it easier ;; to output the buffer. The length is stored in the logical block ;; stack. - (suffix (make-string initial-buffer-size) :type simple-string) + (suffix (make-string initial-buffer-size) :type (simple-array character (*))) ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) ;; cons. Adding things to the queue is basically (setf (cdr head) (list @@ -813,7 +813,8 @@ line break." ;;;; pprint-dispatch tables -(defvar *initial-pprint-dispatch*) +(defvar *standard-pprint-dispatch-table*) +(defvar *initial-pprint-dispatch-table*) (defvar *building-initial-table* nil) (defstruct (pprint-dispatch-entry (:copier nil)) @@ -868,7 +869,7 @@ line break." ,x)))) (defvar *precompiled-pprint-dispatch-funs* (list (frob array (typep object 'array)) - (frob sharp-function (and (consp object) + (frob function-call (and (consp object) (symbolp (car object)) (fboundp (car object)))) (frob cons (typep object 'cons))))) @@ -920,7 +921,7 @@ line break." (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) - (let* ((orig (or table *initial-pprint-dispatch*)) + (let* ((orig (or table *initial-pprint-dispatch-table*)) (new (make-pprint-dispatch-table :entries (copy-list (pprint-dispatch-table-entries orig)))) (new-cons-entries (pprint-dispatch-table-cons-entries new))) @@ -931,7 +932,7 @@ line break." (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) - (let* ((table (or table *initial-pprint-dispatch*)) + (let* ((table (or table *initial-pprint-dispatch-table*)) (cons-entry (and (consp object) (gethash (car object) @@ -949,6 +950,11 @@ line break." (output-ugly-object object stream)) nil)))) +(defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation) + (when (eq pprint-dispatch *standard-pprint-dispatch-table*) + (cerror "Frob it anyway!" 'standard-pprint-dispatch-table-modified-error + :operation operation))) + (defun set-pprint-dispatch (type function &optional (priority 0) (table *print-pprint-dispatch*)) (declare (type (or null callable) function) @@ -956,6 +962,7 @@ line break." (type pprint-dispatch-table table)) (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...") (/hexstr type) + (assert-not-standard-pprint-dispatch-table table 'set-pprint-dispatch) (if function (if (cons-type-specifier-p type) (setf (gethash (second (second type)) @@ -996,14 +1003,15 @@ line break." ;;;; standard pretty-printing routines (defun pprint-array (stream array) - (cond ((or (and (null *print-array*) (null *print-readably*)) - (stringp array) - (bit-vector-p array)) + (cond ((and (null *print-array*) (null *print-readably*)) (output-ugly-object array stream)) ((and *print-readably* (not (array-readably-printable-p array))) - (let ((*print-readably* nil)) - (error 'print-not-readable :object array))) + (if *read-eval* + (if (vectorp array) + (sb!impl::output-unreadable-vector-readably array stream) + (sb!impl::output-unreadable-array-readably array stream)) + (print-not-readable-error array stream))) ((vectorp array) (pprint-vector stream array)) (t @@ -1132,7 +1140,10 @@ line break." (declare (ignore noise)) (if (and (consp list) (consp (cdr list)) - (cddr list)) + (cddr list) + ;; Filter out (FLET FOO :IN BAR) names. + (and (consp (cddr list)) + (not (eq :in (third list))))) (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") stream @@ -1207,6 +1218,8 @@ line break." (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) + (unless (listp (cdr list)) + (write-string ". " stream)) (pprint-newline :miser stream) (pprint-logical-block (stream (cdr list) :prefix "" :suffix "") (loop @@ -1254,6 +1267,17 @@ line break." stream list)) +(defun pprint-defmethod (stream list &rest noise) + (declare (ignore noise)) + (if (and (consp (cdr list)) + (consp (cddr list)) + (consp (third list))) + (pprint-defun stream list) + (funcall (formatter + "~:<~^~W~^ ~@_~:I~W~^ ~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") + stream + list))) + (defun pprint-defpackage (stream list &rest noise) (declare (ignore noise)) (funcall (formatter @@ -1354,7 +1378,7 @@ line break." (declare (ignore noise)) (destructuring-bind (loop-symbol . clauses) list (declare (ignore loop-symbol)) - (if (or (null clauses) (consp (car clauses))) + (if (or (atom clauses) (consp (car clauses))) (pprint-spread-fun-call stream list) (pprint-extended-loop stream list)))) @@ -1455,12 +1479,16 @@ line break." (defun !pprint-cold-init () (/show0 "entering !PPRINT-COLD-INIT") - (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) - (let ((*print-pprint-dispatch* *initial-pprint-dispatch*) + ;; Kludge: We set *STANDARD-PP-D-TABLE* to a new table even though + ;; it's going to be set to a copy of *INITIAL-PP-D-T* below because + ;; it's used in WITH-STANDARD-IO-SYNTAX, and condition reportery + ;; possibly performed in the following extent may use W-S-IO-SYNTAX. + (setf *standard-pprint-dispatch-table* (make-pprint-dispatch-table)) + (setf *initial-pprint-dispatch-table* (make-pprint-dispatch-table)) + (let ((*print-pprint-dispatch* *initial-pprint-dispatch-table*) (*building-initial-table* t)) - ;; printers for regular types (/show0 "doing SET-PPRINT-DISPATCH for regular types") - (set-pprint-dispatch 'array #'pprint-array) + (set-pprint-dispatch '(and array (not (or string bit-vector))) #'pprint-array) (set-pprint-dispatch '(cons (and symbol (satisfies mboundp))) #'pprint-macro-call -1) (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) @@ -1507,6 +1535,7 @@ line break." (define-modify-macro pprint-defun) (define-setf-expander pprint-defun) (defmacro pprint-defun) + (defmethod pprint-defmethod) (defpackage pprint-defpackage) (defparameter pprint-block) (defsetf pprint-defun) @@ -1568,5 +1597,8 @@ line break." (sb!impl::!backq-pp-cold-init) (/show0 "leaving !PPRINT-COLD-INIT")) - (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) + (setf *standard-pprint-dispatch-table* + (copy-pprint-dispatch *initial-pprint-dispatch-table*)) + (setf *print-pprint-dispatch* + (copy-pprint-dispatch *initial-pprint-dispatch-table*)) (setf *print-pretty* t))