X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=b87e9ee0400d9ef3e834083f8aad37fd57f2a3d6;hb=cd13034f9415f64cdaa05893a4ac5ff1e95c97bd;hp=a6ccaa774657921919aeead2e88d98cf58089e9f;hpb=718b3ccc610d1255f928fa75059f035638b57f94;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index a6ccaa7..b87e9ee 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -29,9 +29,9 @@ (defconstant default-line-length 80) (defstruct (pretty-stream (:include sb!kernel:ansi-stream - (:out #'pretty-out) - (:sout #'pretty-sout) - (:misc #'pretty-misc)) + (out #'pretty-out) + (sout #'pretty-sout) + (misc #'pretty-misc)) (:constructor make-pretty-stream (target)) (:copier nil)) ;; Where the output is going to finally go. @@ -314,16 +314,17 @@ ;; (In the PPRINT-LOGICAL-BLOCK form which calls us, ;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior, ;; and might end up being NIL.) - (declare (type (or null string prefix))) + (declare (type (or null string) prefix)) ;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is ;; trivial, so it should always be a string.) (declare (type string suffix)) (when prefix + (setq prefix (coerce prefix 'simple-string)) (pretty-sout stream prefix 0 (length prefix))) (let* ((pending-blocks (pretty-stream-pending-blocks stream)) (start (enqueue stream block-start :prefix (and per-line-p prefix) - :suffix suffix + :suffix (coerce suffix 'simple-string) :depth (length pending-blocks)))) (setf (pretty-stream-pending-blocks stream) (cons start pending-blocks)))) @@ -802,7 +803,7 @@ ;; T iff one of the original entries. (initial-p *building-initial-table* :type (member t nil)) ;; and the associated function - (function (missing-arg) :type function)) + (fun (missing-arg) :type function)) (def!method print-object ((entry pprint-dispatch-entry) stream) (print-unreadable-object (entry stream :type t) (format stream "type=~S, priority=~S~@[ [initial]~]" @@ -810,17 +811,6 @@ (pprint-dispatch-entry-priority entry) (pprint-dispatch-entry-initial-p entry)))) -(defstruct (pprint-dispatch-table (:copier nil)) - ;; A list of all the entries (except for CONS entries below) in highest - ;; to lowest priority. - (entries nil :type list) - ;; A hash table mapping things to entries for type specifiers of the - ;; form (CONS (MEMBER )). If the type specifier is of this form, - ;; we put it in this hash table instead of the regular entries table. - (cons-entries (make-hash-table :test 'eql))) -(def!method print-object ((table pprint-dispatch-table) stream) - (print-unreadable-object (table stream :type t :identity t))) - (defun cons-type-specifier-p (spec) (and (consp spec) (eq (car spec) 'cons) @@ -847,12 +837,12 @@ (pprint-dispatch-entry-priority e2))))) (macrolet ((frob (x) - `(cons ',x #'(lambda (object) ,x)))) + `(cons ',x (lambda (object) ,x)))) (defvar *precompiled-pprint-dispatch-funs* (list (frob (typep object 'array)) (frob (and (consp object) - (and (typep (car object) 'symbol) - (typep (car object) '(satisfies fboundp))))) + (symbolp (car object)) + (fboundp (car object)))) (frob (typep object 'cons))))) (defun compute-test-fn (type) @@ -876,12 +866,12 @@ (destructuring-bind (type) (cdr type) `(not ,(compute-test-expr type object)))) (and - `(and ,@(mapcar #'(lambda (type) - (compute-test-expr type object)) + `(and ,@(mapcar (lambda (type) + (compute-test-expr type object)) (cdr type)))) (or - `(or ,@(mapcar #'(lambda (type) - (compute-test-expr type object)) + `(or ,@(mapcar (lambda (type) + (compute-test-expr type object)) (cdr type)))) (t `(typep ,object ',type))) @@ -898,14 +888,13 @@ (new (make-pprint-dispatch-table :entries (copy-list (pprint-dispatch-table-entries orig)))) (new-cons-entries (pprint-dispatch-table-cons-entries new))) - (maphash #'(lambda (key value) - (setf (gethash key new-cons-entries) value)) + (maphash (lambda (key value) + (setf (gethash key new-cons-entries) value)) (pprint-dispatch-table-cons-entries orig)) new)) (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) - (/show0 "entering PPRINT-DISPATCH") (let* ((table (or table *initial-pprint-dispatch*)) (cons-entry (and (consp object) @@ -920,39 +909,49 @@ (return entry))))) (if entry (values (pprint-dispatch-entry-fun entry) t) - (values #'(lambda (stream object) - (output-ugly-object object stream)) + (values (lambda (stream object) + (output-ugly-object object stream)) nil)))) (defun set-pprint-dispatch (type function &optional (priority 0) (table *print-pprint-dispatch*)) - (declare (type (or null function) function) + (declare (type (or null callable) function) (type real priority) (type pprint-dispatch-table table)) + (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...") + (/hexstr type) (if function - (if (cons-type-specifier-p type) - (setf (gethash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (make-pprint-dispatch-entry :type type :priority priority - :function function)) - (let ((list (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)) - (entry (make-pprint-dispatch-entry - :type type :test-fn (compute-test-fn type) - :priority priority :function function))) - (do ((prev nil next) - (next list (cdr next))) - ((null next) - (if prev - (setf (cdr prev) (list entry)) - (setf list (list entry)))) - (when (entry< (car next) entry) - (if prev - (setf (cdr prev) (cons entry next)) - (setf list (cons entry next))) - (return))) - (setf (pprint-dispatch-table-entries table) list))) + ;; KLUDGE: this impairs debuggability, and probably isn't even + ;; conforming -- maybe we should not coerce to function, but + ;; cater downstream (in PPRINT-DISPATCH-ENTRY) for having + ;; callables here. + (let ((function (%coerce-callable-to-fun function))) + (if (cons-type-specifier-p type) + (setf (gethash (second (second type)) + (pprint-dispatch-table-cons-entries table)) + (make-pprint-dispatch-entry :type type + :priority priority + :fun function)) + (let ((list (delete type (pprint-dispatch-table-entries table) + :key #'pprint-dispatch-entry-type + :test #'equal)) + (entry (make-pprint-dispatch-entry + :type type + :test-fn (compute-test-fn type) + :priority priority + :fun function))) + (do ((prev nil next) + (next list (cdr next))) + ((null next) + (if prev + (setf (cdr prev) (list entry)) + (setf list (list entry)))) + (when (entry< (car next) entry) + (if prev + (setf (cdr prev) (cons entry next)) + (setf list (cons entry next))) + (return))) + (setf (pprint-dispatch-table-entries table) list)))) (if (cons-type-specifier-p type) (remhash (second (second type)) (pprint-dispatch-table-cons-entries table)) @@ -960,6 +959,7 @@ (delete type (pprint-dispatch-table-entries table) :key #'pprint-dispatch-entry-type :test #'equal)))) + (/show0 "about to return NIL from SET-PPRINT-DISPATCH") nil) ;;;; standard pretty-printing routines @@ -969,7 +969,8 @@ (stringp array) (bit-vector-p array)) (output-ugly-object array stream)) - ((and *print-readably* (not (eq (array-element-type array) t))) + ((and *print-readably* + (not (array-readably-printable-p array))) (let ((*print-readably* nil)) (error 'print-not-readable :object array))) ((vectorp array) @@ -1000,7 +1001,7 @@ (index index) (step (reduce #'* dims)) (count 0)) - (loop + (loop (pprint-pop) (output-guts stream index dims) (when (= (incf count) dim) @@ -1013,6 +1014,15 @@ (defun pprint-lambda-list (stream lambda-list &rest noise) (declare (ignore noise)) + (when (and (consp lambda-list) + (member (car lambda-list) *backq-tokens*)) + ;; if this thing looks like a backquoty thing, then we don't want + ;; to destructure it, we want to output it straight away. [ this + ;; is the exception to the normal processing: if we did this + ;; generally we would find lambda lists such as (FUNCTION FOO) + ;; being printed as #'FOO ] -- CSR, 2003-12-07 + (output-object lambda-list stream) + (return-from pprint-lambda-list nil)) (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")") (let ((state :required) (first t)) @@ -1241,7 +1251,7 @@ (pprint-fill stream (pprint-pop)) (pprint-tagbody-guts stream))) -(defun pprint-function-call (stream list &rest noise) +(defun pprint-fun-call (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") stream @@ -1249,10 +1259,9 @@ ;;;; the interface seen by regular (ugly) printer and initialization routines -;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is -;;; bound to T. +;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when +;;; *PRINT-PRETTY* is true. (defun output-pretty-object (object stream) - (/show0 "entering OUTPUT-PRETTY-OBJECT") (with-pretty-stream (stream) (funcall (pprint-dispatch object) stream object))) @@ -1264,8 +1273,8 @@ ;; 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 fboundp))) - #'pprint-function-call -1) + (set-pprint-dispatch '(cons symbol) + #'pprint-fun-call -1) (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") @@ -1360,5 +1369,4 @@ (/show0 "leaving !PPRINT-COLD-INIT")) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) - (setf *pretty-printer* #'output-pretty-object) (setf *print-pretty* t))