(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)))
(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)
(< (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))
(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))
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
;;; 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")
(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)