X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=f938d30bb370c9677a4996fad7525e165f1677a7;hb=dbe82b489260b2ef76e916d0aeaee8b3850f5f52;hp=787cd5300147f03da798edc8e1e15034865e12ae;hpb=b217b7cf91187be54b758210a4b0ab5503952771;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 787cd53..f938d30 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -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)) @@ -1154,7 +1161,7 @@ line break." (defun pprint-progn (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list)) + (pprint-linear stream list)) (defun pprint-progv (stream list &rest noise) (declare (ignore noise)) @@ -1166,11 +1173,14 @@ line break." (funcall (formatter "~:<~^~W~^~3I ~:_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>") stream list)) +(defvar *pprint-quote-with-syntactic-sugar* t) + (defun pprint-quote (stream list &rest noise) (declare (ignore noise)) (if (and (consp list) (consp (cdr list)) - (null (cddr list))) + (null (cddr list)) + *pprint-quote-with-syntactic-sugar*) (case (car list) (function (write-string "#'" stream) @@ -1182,6 +1192,21 @@ line break." (pprint-fill stream list))) (pprint-fill stream list))) +(defun pprint-declare (stream list &rest noise) + (declare (ignore noise)) + ;; Make sure to print (DECLARE (FUNCTION F)) not (DECLARE #'A). + (let ((*pprint-quote-with-syntactic-sugar* nil)) + (pprint-spread-fun-call stream list))) + +;;; Try to print every variable-value pair on one line; if that doesn't +;;; work print the value indented by 2 spaces: +;;; +;;; (setq foo bar +;;; quux xoo) +;;; vs. +;;; (setf foo +;;; (long form ...) +;;; quux xoo) (defun pprint-setq (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") @@ -1190,25 +1215,18 @@ line break." (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :miser stream) - (if (and (consp (cdr list)) (consp (cddr list))) - (loop - (pprint-indent :current 2 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (pprint-indent :current -2 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream)) - (progn - (pprint-indent :current 0 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (output-object (pprint-pop) stream))))) + (pprint-logical-block (stream (cdr list) :prefix "" :suffix "") + (loop + (pprint-indent :block 2 stream) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :fill stream) + (pprint-indent :block 0 stream) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :mandatory stream))))) ;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL) (defmacro pprint-tagbody-guts (stream) @@ -1243,6 +1261,15 @@ line break." stream list)) +(defun pprint-defmethod (stream list &rest noise) + (declare (ignore noise)) + (if (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 @@ -1308,7 +1335,7 @@ line break." ;;; Each clause in this list will get its own line. (defvar *loop-seperating-clauses* '(:and - :where :for + :with :for :initially :finally :do :doing :collect :collecting @@ -1322,8 +1349,12 @@ line break." :for :while :until :repeat :always :never :thereis )) -(defun pprint-extended-loop-clauses (stream clauses) - (pprint-logical-block (stream clauses :prefix "" :suffix "") +(defun pprint-extended-loop (stream list) + (pprint-logical-block (stream list :prefix "(" :suffix ")") + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-indent :current 0 stream) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) @@ -1335,36 +1366,18 @@ line break." do (pprint-exit-if-list-exhausted) do (write-char #\space stream)))) -(defun pprint-simple-loop-clauses (stream clauses) - (pprint-logical-block (stream clauses :prefix "" :suffix "") - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (loop for thing = (pprint-pop) do - (when (consp thing) - (pprint-newline :mandatory stream)) - (output-object thing stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream)))) - (defun pprint-loop (stream list &rest noise) (declare (ignore noise)) (destructuring-bind (loop-symbol . clauses) list - (write-char #\( stream) - (output-object loop-symbol stream) - (cond ((null clauses)) - ((symbolp (car clauses)) - (write-char #\space stream) - (pprint-extended-loop-clauses stream clauses)) - (t - (write-char #\space stream) - (pprint-simple-loop-clauses stream clauses))) - (write-char #\) stream))) + (declare (ignore loop-symbol)) + (if (or (null clauses) (consp (car clauses))) + (pprint-spread-fun-call stream list) + (pprint-extended-loop stream list)))) (defun pprint-if (stream list &rest noise) (declare (ignore noise)) ;; Indent after the ``predicate'' form, and the ``then'' form. - (funcall (formatter "~:<~^~W~^ ~:_~:I~W~^ ~:@_~:I~@{~W~^ ~:@_~}~:>") + (funcall (formatter "~:<~^~W~^ ~:I~W~^ ~:@_~@{~W~^ ~:@_~}~:>") stream list)) @@ -1374,9 +1387,17 @@ line break." stream list)) +(defun pprint-spread-fun-call (stream list &rest noise) + (declare (ignore noise)) + ;; Similiar to PPRINT-FUN-CALL but emit a mandatory newline after + ;; each parameter. I.e. spread out each parameter on its own line. + (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:@_~}~:>") + stream + list)) + (defun pprint-data-list (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~@{~W~^ ~:_~}~:>") stream list)) + (pprint-fill stream list)) ;;; Returns an Emacs-style indent spec: an integer N, meaning indent ;;; the first N arguments specially then indent any further arguments @@ -1415,8 +1436,8 @@ line break." (cond ;; Place the very first argument next to the macro name ((zerop indent) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted)) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted)) ;; Indent any other non-body argument by the same ;; amount. It's what Emacs seems to do, too. (t @@ -1450,10 +1471,14 @@ 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 '(cons (and symbol (satisfies mboundp))) @@ -1467,6 +1492,7 @@ line break." (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR") (dolist (magic-form '((lambda pprint-lambda) + (declare pprint-declare) ;; special forms (block pprint-block) @@ -1474,6 +1500,7 @@ line break." (eval-when pprint-block) (flet pprint-flet) (function pprint-quote) + (if pprint-if) (labels pprint-flet) (let pprint-let) (let* pprint-let) @@ -1490,16 +1517,17 @@ line break." (tagbody pprint-tagbody) (throw pprint-block) (unwind-protect pprint-block) - (if pprint-if) ;; macros (case pprint-case) (ccase pprint-case) (ctypecase pprint-typecase) + (declaim pprint-declare) (defconstant pprint-block) (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) @@ -1547,7 +1575,11 @@ line break." (with-output-to-string pprint-block) (with-package-iterator pprint-block) (with-simple-restart pprint-block) - (with-standard-io-syntax pprint-progn))) + (with-standard-io-syntax pprint-progn) + + ;; sbcl specific + (sb!int:dx-flet pprint-flet) + )) (set-pprint-dispatch `(cons (eql ,(first magic-form))) (symbol-function (second magic-form)))) @@ -1557,5 +1589,7 @@ 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* *initial-pprint-dispatch-table*) (setf *print-pretty* t))