X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=9dd92d99fbf6afaceddcfc78be29022d516e7c47;hb=64ed946d513d0cd0508fea90cd3b44328e75df9a;hp=7331459d28c52a88b90f5935a521d8ae5e52cfcc;hpb=7ebe82f662f0fd0038479cbb057ec77867ab6f7e;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 7331459..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,19 +1300,65 @@ (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~^ ~_~}~:>") + (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>") stream list)) + +(defun pprint-data-list (stream list &rest noise) + (declare (ignore noise)) + (funcall (formatter "~:<~@{~W~^ ~:_~}~:>") stream list)) ;;;; 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 !pprint-cold-init () (/show0 "entering !PPRINT-COLD-INIT") @@ -1302,8 +1368,10 @@ ;; 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 '(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") @@ -1341,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) @@ -1359,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)