X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=b9beee2b7eb3dca4305242a5f26b0519cb57d6c4;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=d5ab150dd8dd7632ab937b05726255e0cd3ba3da;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index d5ab150..b9beee2 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -28,10 +28,10 @@ (defconstant default-line-length 80) -(defstruct (pretty-stream (:include sb!kernel:lisp-stream - (:out #'pretty-out) - (:sout #'pretty-sout) - (:misc #'pretty-misc)) +(defstruct (pretty-stream (:include sb!kernel:ansi-stream + (out #'pretty-out) + (sout #'pretty-sout) + (misc #'pretty-misc)) (:constructor make-pretty-stream (target)) (:copier nil)) ;; Where the output is going to finally go. @@ -44,7 +44,7 @@ :type column) ;; A simple string holding all the text that has been output but not yet ;; printed. - (buffer (make-string initial-buffer-size) :type simple-string) + (buffer (make-string initial-buffer-size) :type (simple-array character (*))) ;; The index into BUFFER where more text should be put. (buffer-fill-pointer 0 :type index) ;; Whenever we output stuff from the buffer, we shift the remaining noise @@ -75,12 +75,12 @@ ;; Buffer holding the per-line prefix active at the buffer start. ;; Indentation is included in this. The length of this is stored ;; in the logical block stack. - (prefix (make-string initial-buffer-size) :type simple-string) + (prefix (make-string initial-buffer-size) :type (simple-array character (*))) ;; Buffer holding the total remaining suffix active at the buffer start. ;; The characters are right-justified in the buffer to make it easier ;; to output the buffer. The length is stored in the logical block ;; stack. - (suffix (make-string initial-buffer-size) :type simple-string) + (suffix (make-string initial-buffer-size) :type (simple-array character (*))) ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) ;; cons. Adding things to the queue is basically (setf (cdr head) (list @@ -134,7 +134,10 @@ (type simple-string string) (type index start) (type (or index null) end)) - (let ((end (or end (length string)))) + (let* ((string (if (typep string '(simple-array character (*))) + string + (coerce string '(simple-array character (*))))) + (end (or end (length string)))) (unless (= start end) (let ((newline (position #\newline string :start start :end end))) (cond @@ -307,30 +310,31 @@ (defstruct (block-start (:include section-start) (:copier nil)) (block-end nil :type (or null block-end)) - (prefix nil :type (or null simple-string)) - (suffix nil :type (or null simple-string))) + (prefix nil :type (or null (simple-array character (*)))) + (suffix nil :type (or null (simple-array character (*))))) (defun start-logical-block (stream prefix per-line-p suffix) ;; (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-array character (*)))) (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-array character (*))) :depth (length pending-blocks)))) (setf (pretty-stream-pending-blocks stream) (cons start pending-blocks)))) (defstruct (block-end (:include queued-op) (:copier nil)) - (suffix nil :type (or null simple-string))) + (suffix nil :type (or null (simple-array character (*))))) (defun end-logical-block (stream) (let* ((start (pop (pretty-stream-pending-blocks stream))) @@ -802,7 +806,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 +814,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 +840,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 +869,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,8 +891,8 @@ (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)) @@ -918,40 +911,50 @@ (when (funcall (pprint-dispatch-entry-test-fn entry) object) (return entry))))) (if entry - (values (pprint-dispatch-entry-function entry) t) - (values #'(lambda (stream object) - (output-ugly-object object stream)) + (values (pprint-dispatch-entry-fun entry) t) + (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)) @@ -959,6 +962,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 @@ -968,7 +972,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) @@ -999,7 +1004,7 @@ (index index) (step (reduce #'* dims)) (count 0)) - (loop + (loop (pprint-pop) (output-guts stream index dims) (when (= (incf count) dim) @@ -1012,6 +1017,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)) @@ -1240,7 +1254,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 @@ -1248,8 +1262,8 @@ ;;;; 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) (with-pretty-stream (stream) (funcall (pprint-dispatch object) stream object))) @@ -1262,8 +1276,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") @@ -1358,5 +1372,4 @@ (/show0 "leaving !PPRINT-COLD-INIT")) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) - (setf *pretty-printer* #'output-pretty-object) (setf *print-pretty* t))