X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=24e7d9794f59d625174c899c515153d2ae6afcfb;hb=a566e334e16d9cd0ff4f6858d796442305fd0f99;hp=aadf41ae46a6c0f3e210ef728f6707ee3d583c2f;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index aadf41a..24e7d97 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -134,33 +134,48 @@ (type simple-string string) (type index start) (type (or index null) end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (end (or end (length string)))) + (let* ((end (or end (length string)))) (unless (= start end) - (let ((newline (position #\newline string :start start :end end))) - (cond - (newline - (pretty-sout stream string start newline) - (enqueue-newline stream :literal) - (pretty-sout stream string (1+ newline) end)) - (t - (let ((chars (- end start))) - (loop - (let* ((available (ensure-space-in-buffer stream chars)) - (count (min available chars)) - (fill-pointer (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-pointer count))) - (replace (pretty-stream-buffer stream) - string - :start1 fill-pointer :end1 new-fill-ptr - :start2 start) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf chars count) - (when (zerop count) - (return)) - (incf start count)))))))))) + (sb!impl::string-dispatch (simple-base-string + #!+sb-unicode + (simple-array character (*))) + string + ;; For POSITION transform + (declare (optimize (speed 2))) + (let ((newline (position #\newline string :start start :end end))) + (cond + (newline + (pretty-sout stream string start newline) + (enqueue-newline stream :literal) + (pretty-sout stream string (1+ newline) end)) + (t + (let ((chars (- end start))) + (loop + (let* ((available (ensure-space-in-buffer stream chars)) + (count (min available chars)) + (fill-pointer (pretty-stream-buffer-fill-pointer + stream)) + (new-fill-ptr (+ fill-pointer count))) + (if (typep string 'simple-base-string) + ;; FIXME: Reimplementing REPLACE, since it + ;; can't be inlined and we don't have a + ;; generic "simple-array -> simple-array" + ;; transform for it. + (loop for i from fill-pointer below new-fill-ptr + for j from start + with target = (pretty-stream-buffer stream) + do (setf (aref target i) + (aref string j))) + (replace (pretty-stream-buffer stream) + string + :start1 fill-pointer :end1 new-fill-ptr + :start2 start)) + (setf (pretty-stream-buffer-fill-pointer stream) + new-fill-ptr) + (decf chars count) + (when (zerop count) + (return)) + (incf start count))))))))))) (defun pretty-misc (stream op &optional arg1 arg2) (declare (ignore stream op arg1 arg2))) @@ -310,8 +325,8 @@ (defstruct (block-start (:include section-start) (:copier nil)) (block-end nil :type (or null block-end)) - (prefix nil :type (or null (simple-array character (*)))) - (suffix nil :type (or null (simple-array character (*))))) + (prefix nil :type (or null simple-string)) + (suffix nil :type (or null simple-string))) (defun start-logical-block (stream prefix per-line-p suffix) ;; (In the PPRINT-LOGICAL-BLOCK form which calls us, @@ -322,19 +337,22 @@ ;; trivial, so it should always be a string.) (declare (type string suffix)) (when prefix - (setq prefix (coerce prefix '(simple-array character (*)))) + (unless (typep prefix 'simple-string) + (setq prefix (coerce prefix '(simple-array character (*))))) (pretty-sout stream prefix 0 (length prefix))) + (unless (typep suffix 'simple-string) + (setq suffix (coerce suffix '(simple-array character (*))))) (let* ((pending-blocks (pretty-stream-pending-blocks stream)) (start (enqueue stream block-start :prefix (and per-line-p prefix) - :suffix (coerce suffix '(simple-array character (*))) + :suffix suffix :depth (length pending-blocks)))) (setf (pretty-stream-pending-blocks stream) (cons start pending-blocks)))) (defstruct (block-end (:include queued-op) (:copier nil)) - (suffix nil :type (or null (simple-array character (*))))) + (suffix nil :type (or null simple-string))) (defun end-logical-block (stream) (let* ((start (pop (pretty-stream-pending-blocks stream))) @@ -689,15 +707,19 @@ (defun pprint-indent (relative-to n &optional stream) #!+sb-doc - "Specify the indentation to use in the current logical block if STREAM - (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream - and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indentation - to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: + "Specify the indentation to use in the current logical block if +STREAM \(which defaults to *STANDARD-OUTPUT*) is a pretty-printing +stream and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the +indentation to use (in ems, the width of an ``m'') and RELATIVE-TO can +be either: + :BLOCK - Indent relative to the column the current logical block started on. + :CURRENT - Indent relative to the current column. - The new indentation value does not take effect until the following line - break." + +The new indentation value does not take effect until the following +line break." (declare (type (member :block :current) relative-to) (type real n) (type (or stream (member t nil)) stream) @@ -791,7 +813,8 @@ ;;;; 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)) @@ -841,14 +864,15 @@ (< (pprint-dispatch-entry-priority e1) (pprint-dispatch-entry-priority e2))))) -(macrolet ((frob (x) - `(cons ',x (lambda (object) ,x)))) +(macrolet ((frob (name x) + `(cons ',x (named-lambda ,(symbolicate "PPRINT-DISPATCH-" name) (object) + ,x)))) (defvar *precompiled-pprint-dispatch-funs* - (list (frob (typep object 'array)) - (frob (and (consp object) - (symbolp (car object)) - (fboundp (car object)))) - (frob (typep object 'cons))))) + (list (frob array (typep object 'array)) + (frob function-call (and (consp object) + (symbolp (car object)) + (fboundp (car object)))) + (frob cons (typep object 'cons))))) (defun compute-test-fn (type) (let ((was-cons nil)) @@ -885,11 +909,19 @@ (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs* :test #'equal))) (t - (compile nil `(lambda (object) ,expr)))))))) + (let ((name (symbolicate "PPRINT-DISPATCH-" + (if (symbolp type) + type + (write-to-string type + :escape t + :pretty nil + :readably nil))))) + (compile nil `(named-lambda ,name (object) + ,expr))))))))) (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))) @@ -900,7 +932,7 @@ (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) @@ -918,6 +950,11 @@ (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) @@ -925,6 +962,7 @@ (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)) @@ -965,14 +1003,15 @@ ;;;; 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 @@ -1101,7 +1140,10 @@ (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 @@ -1123,18 +1165,26 @@ (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)) (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>") stream list)) +(defun pprint-prog2 (stream list &rest noise) + (declare (ignore noise)) + (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) @@ -1146,6 +1196,21 @@ (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 ")") @@ -1153,26 +1218,21 @@ (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) - (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) @@ -1207,6 +1267,24 @@ 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 + "~:<~W~^ ~3I~:_~W~^~1I~@{~:@_~:<~^~W~^ ~:I~@_~@{~W~^ ~_~}~:>~}~:>") + stream + list)) + (defun pprint-destructuring-bind (stream list &rest noise) (declare (ignore noise)) (funcall (formatter @@ -1262,35 +1340,167 @@ (pprint-fill stream (pprint-pop)) (pprint-tagbody-guts stream))) +;;; Each clause in this list will get its own line. +(defvar *loop-seperating-clauses* + '(:and + :with :for + :initially :finally + :do :doing + :collect :collecting + :append :appending + :nconc :nconcing + :count :counting + :sum :summing + :maximize :maximizing + :minimize :minimizing + :if :when :unless :end + :for :while :until :repeat :always :never :thereis + )) + +(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) + (loop for thing = (pprint-pop) + when (and (symbolp thing) + (member thing *loop-seperating-clauses* :test #'string=)) + do (pprint-newline :mandatory stream) + do (output-object thing stream) + do (pprint-exit-if-list-exhausted) + do (write-char #\space stream)))) + +(defun pprint-loop (stream list &rest noise) + (declare (ignore noise)) + (destructuring-bind (loop-symbol . clauses) list + (declare (ignore loop-symbol)) + (if (or (atom 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~^ ~:@_~@{~W~^ ~:@_~}~:>") + stream + list)) + (defun pprint-fun-call (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") + (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>") + 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)) + (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 +;;; like a body. +(defun macro-indentation (name) + (labels ((proper-list-p (list) + (not (nth-value 1 (ignore-errors (list-length list))))) + (macro-arglist (name) + (%simple-fun-arglist (macro-function name))) + (clean-arglist (arglist) + "Remove &whole, &enviroment, and &aux elements from ARGLIST." + (cond ((null arglist) '()) + ((member (car arglist) '(&whole &environment)) + (clean-arglist (cddr arglist))) + ((eq (car arglist) '&aux) + '()) + (t (cons (car arglist) (clean-arglist (cdr arglist))))))) + (let ((arglist (macro-arglist name))) + (if (proper-list-p arglist) ; guard against dotted arglists + (position '&body (remove '&optional (clean-arglist arglist))) + nil)))) + +;;; Pretty-Print macros by looking where &BODY appears in a macro's +;;; lambda-list. +(defun pprint-macro-call (stream list &rest noise) + (declare (ignore noise)) + (let ((indentation (and (car list) (macro-indentation (car list))))) + (unless indentation + (return-from pprint-macro-call + (pprint-fun-call stream list))) + (pprint-logical-block (stream list :prefix "(" :suffix ")") + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (loop for indent from 0 below indentation do + (cond + ;; Place the very first argument next to the macro name + ((zerop indent) + (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 + (pprint-indent :block 3 stream) + (pprint-newline :mandatory stream) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted)))) + ;; Indent back for the body. + (pprint-indent :block 1 stream) + (pprint-newline :mandatory stream) + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream))))) ;;;; the interface seen by regular (ugly) printer and initialization routines ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when ;;; *PRINT-PRETTY* is true. (defun output-pretty-object (object stream) - (with-pretty-stream (stream) - (funcall (pprint-dispatch object) stream object))) + (multiple-value-bind (fun pretty) (pprint-dispatch object) + (if pretty + (with-pretty-stream (stream) + (funcall fun stream object)) + ;; No point in consing up a pretty stream if we are not using pretty + ;; printing the object after all. + (output-ugly-object object stream)))) + +(defun mboundp (name) + (and (fboundp name) (macro-function name) t)) (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 symbol) + (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))) #'pprint-fun-call -1) + (set-pprint-dispatch '(cons symbol) + #'pprint-data-list -2) (set-pprint-dispatch 'cons #'pprint-fill -2) ;; cons cells with interesting things for the car (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR") (dolist (magic-form '((lambda pprint-lambda) + (declare pprint-declare) ;; special forms (block pprint-block) @@ -1298,6 +1508,7 @@ (eval-when pprint-block) (flet pprint-flet) (function pprint-quote) + (if pprint-if) (labels pprint-flet) (let pprint-let) (let* pprint-let) @@ -1319,10 +1530,13 @@ (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) (defstruct pprint-block) @@ -1341,15 +1555,15 @@ (etypecase pprint-typecase) #+nil (handler-bind ...) #+nil (handler-case ...) - #+nil (loop ...) - (multiple-value-bind pprint-progv) + (loop pprint-loop) + (multiple-value-bind pprint-prog2) (multiple-value-setq pprint-block) (pprint-logical-block pprint-block) (print-unreadable-object pprint-block) (prog pprint-prog) (prog* pprint-prog) (prog1 pprint-block) - (prog2 pprint-progv) + (prog2 pprint-prog2) (psetf pprint-setq) (psetq pprint-setq) #+nil (restart-bind ...) @@ -1369,7 +1583,11 @@ (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)))) @@ -1379,5 +1597,8 @@ (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))