X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=9dd92d99fbf6afaceddcfc78be29022d516e7c47;hb=f8c8f81c3e10865a40ea6ceb79be0a045a6e6e4e;hp=9fb162e599aaf983324d72228ad8940f327e9ce1;hpb=230707c1899c1c008f7ce2ad97e2fd04849f7443;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 9fb162e..9dd92d9 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -138,7 +138,7 @@ (unless (= start end) (sb!impl::string-dispatch (simple-base-string #!+sb-unicode - (simple-array character)) + (simple-array character (*))) string ;; For POSITION transform (declare (optimize (speed 2))) @@ -707,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) @@ -859,14 +863,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 sharp-function (and (consp object) + (symbolp (car object)) + (fboundp (car object)))) + (frob cons (typep object 'cons))))) (defun compute-test-fn (type) (let ((was-cons nil)) @@ -903,7 +908,15 @@ (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)) @@ -1225,6 +1238,13 @@ 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 @@ -1280,6 +1300,43 @@ (pprint-fill stream (pprint-pop)) (pprint-tagbody-guts stream))) +;;; Each clause in this list will get its own line. +(defvar *loop-seperating-clauses* + '(:and + :where :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-loop (stream list &rest noise) + (declare (ignore noise)) + (destructuring-bind (loop-symbol . clauses) list + (write-char #\( stream) + (output-object loop-symbol stream) + (when clauses + (write-char #\space stream) + (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) + 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)))) + (write-char #\) stream))) + (defun pprint-fun-call (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>") @@ -1295,8 +1352,13 @@ ;;; 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 !pprint-cold-init () (/show0 "entering !PPRINT-COLD-INIT") @@ -1347,6 +1409,7 @@ (define-modify-macro pprint-defun) (define-setf-expander pprint-defun) (defmacro pprint-defun) + (defpackage pprint-defpackage) (defparameter pprint-block) (defsetf pprint-defun) (defstruct pprint-block) @@ -1365,7 +1428,7 @@ (etypecase pprint-typecase) #+nil (handler-bind ...) #+nil (handler-case ...) - #+nil (loop ...) + (loop pprint-loop) (multiple-value-bind pprint-progv) (multiple-value-setq pprint-block) (pprint-logical-block pprint-block)