X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=af346a515c237610e3ce3e60d3f30ae12658a7a3;hb=814fc23f60ba84318a3dfea112e6d98fd0293835;hp=a6ccaa774657921919aeead2e88d98cf58089e9f;hpb=718b3ccc610d1255f928fa75059f035638b57f94;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index a6ccaa7..af346a5 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. @@ -802,7 +802,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]~]" @@ -847,12 +847,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 +876,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 +898,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,8 +919,8 @@ (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 @@ -929,18 +928,23 @@ (declare (type (or null function) 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)) + (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 :function function))) + :type type + :test-fn (compute-test-fn type) + :priority priority + :fun function))) (do ((prev nil next) (next list (cdr next))) ((null next) @@ -960,6 +964,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 +974,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) @@ -1241,7 +1247,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 +1255,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 +1269,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 +1365,4 @@ (/show0 "leaving !PPRINT-COLD-INIT")) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) - (setf *pretty-printer* #'output-pretty-object) (setf *print-pretty* t))