X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=d17ccfcafa4488e031c1814a1b5ee5a7a86e5283;hb=2768ed83de59354b21ea61de3dea358c53d1ae05;hp=5a2ea1c3e37ce25d94808bde2f7b19bc0c47628a;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 5a2ea1c..d17ccfc 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -14,10 +14,10 @@ ;;;; pretty streams ;;; There are three different units for measuring character positions: -;;; COLUMN - offset (if characters) from the start of the current line. -;;; INDEX - index into the output buffer. -;;; POSN - some position in the stream of characters cycling through -;;; the output buffer. +;;; COLUMN - offset (if characters) from the start of the current line +;;; INDEX - index into the output buffer +;;; POSN - some position in the stream of characters cycling through +;;; the output buffer (deftype column () '(and fixnum unsigned-byte)) ;;; The INDEX type is picked up from the kernel package. @@ -28,13 +28,14 @@ (defconstant default-line-length 80) -(defstruct (pretty-stream (:include sb!sys:lisp-stream - (:out #'pretty-out) - (:sout #'pretty-sout) - (:misc #'pretty-misc)) - (:constructor make-pretty-stream (target))) +(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. - (target (required-argument) :type stream) + (target (missing-arg) :type stream) ;; Line length we should format to. Cached here so we don't have to keep ;; extracting it from the target stream. (line-length (or *print-right-margin* @@ -55,9 +56,20 @@ ;; zero, but if we end up with a very long line with no breaks in it we ;; might have to output part of it. Then this will no longer be zero. (buffer-start-column (or (sb!impl::charpos target) 0) :type column) - ;; The line number we are currently on. Used for *print-lines* abrevs and - ;; to tell when sections have been split across multiple lines. + ;; The line number we are currently on. Used for *PRINT-LINES* + ;; abbreviations and to tell when sections have been split across + ;; multiple lines. (line-number 0 :type index) + ;; the value of *PRINT-LINES* captured at object creation time. We + ;; use this, instead of the dynamic *PRINT-LINES*, to avoid + ;; weirdness like + ;; (let ((*print-lines* 50)) + ;; (pprint-logical-block .. + ;; (dotimes (i 10) + ;; (let ((*print-lines* 8)) + ;; (print (aref possiblybigthings i) prettystream))))) + ;; terminating the output of the entire logical blockafter 8 lines. + (print-lines *print-lines* :type (or index null) :read-only t) ;; Stack of logical blocks in effect at the buffer start. (blocks (list (make-logical-block)) :type list) ;; Buffer holding the per-line prefix active at the buffer start. @@ -97,6 +109,11 @@ (declare (type posn posn) (type pretty-stream stream) (values posn)) (index-column (posn-index posn stream) stream)) + +;;; Is it OK to do pretty printing on this stream at this time? +(defun print-pretty-on-stream-p (stream) + (and (pretty-stream-p stream) + *print-pretty*)) ;;;; stream interface routines @@ -147,7 +164,7 @@ ;;;; logical blocks -(defstruct logical-block +(defstruct (logical-block (:copier nil)) ;; The column this logical block started in. (start-column 0 :type column) ;; The column the current section started in. @@ -235,13 +252,12 @@ ;;;; the pending operation queue -(defstruct (queued-op (:constructor nil)) +(defstruct (queued-op (:constructor nil) + (:copier nil)) (posn 0 :type posn)) (defmacro enqueue (stream type &rest args) - (let ((constructor (intern (concatenate 'string - "MAKE-" - (symbol-name type))))) + (let ((constructor (symbolicate "MAKE-" type))) (once-only ((stream stream) (entry `(,constructor :posn (index-posn @@ -259,13 +275,14 @@ ,entry)))) (defstruct (section-start (:include queued-op) - (:constructor nil)) + (:constructor nil) + (:copier nil)) (depth 0 :type index) (section-end nil :type (or null newline block-end))) -(defstruct (newline - (:include section-start)) - (kind (required-argument) +(defstruct (newline (:include section-start) + (:copier nil)) + (kind (missing-arg) :type (member :linear :fill :miser :literal :mandatory))) (defun enqueue-newline (stream kind) @@ -279,16 +296,16 @@ (setf (section-start-section-end entry) newline)))) (maybe-output stream (or (eq kind :literal) (eq kind :mandatory)))) -(defstruct (indentation - (:include queued-op)) - (kind (required-argument) :type (member :block :current)) +(defstruct (indentation (:include queued-op) + (:copier nil)) + (kind (missing-arg) :type (member :block :current)) (amount 0 :type fixnum)) (defun enqueue-indent (stream kind amount) (enqueue stream indentation :kind kind :amount amount)) -(defstruct (block-start - (:include section-start)) +(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))) @@ -297,22 +314,23 @@ ;; (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)))) -(defstruct (block-end - (:include queued-op)) +(defstruct (block-end (:include queued-op) + (:copier nil)) (suffix nil :type (or null simple-string))) (defun end-logical-block (stream) @@ -323,8 +341,8 @@ (pretty-sout stream suffix 0 (length suffix))) (setf (block-start-block-end start) end))) -(defstruct (tab - (:include queued-op)) +(defstruct (tab (:include queued-op) + (:copier nil)) (sectionp nil :type (member t nil)) (relativep nil :type (member t nil)) (colnum 0 :type column) @@ -497,8 +515,8 @@ (ecase (fits-on-line-p stream (block-start-section-end next) force-newlines-p) ((t) - ;; Just nuke the whole logical block and make it look like one - ;; nice long literal. + ;; Just nuke the whole logical block and make it look + ;; like one nice long literal. (let ((end (block-start-block-end next))) (expand-tabs stream end) (setf tail (cdr (member end tail))))) @@ -526,8 +544,10 @@ (defun fits-on-line-p (stream until force-newlines-p) (let ((available (pretty-stream-line-length stream))) - (when (and (not *print-readably*) *print-lines* - (= *print-lines* (pretty-stream-line-number stream))) + (when (and (not *print-readably*) + (pretty-stream-print-lines stream) + (= (pretty-stream-print-lines stream) + (pretty-stream-line-number stream))) (decf available 3) ; for the `` ..'' (decf available (logical-block-suffix-length (car (pretty-stream-blocks stream))))) @@ -561,7 +581,8 @@ (let ((line-number (pretty-stream-line-number stream))) (incf line-number) (when (and (not *print-readably*) - *print-lines* (>= line-number *print-lines*)) + (pretty-stream-print-lines stream) + (>= line-number (pretty-stream-print-lines stream))) (write-string " .." target) (let ((suffix-length (logical-block-suffix-length (car (pretty-stream-blocks stream))))) @@ -657,7 +678,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (pretty-stream-p stream) + (when (print-pretty-on-stream-p stream) (enqueue-newline stream kind))) nil) @@ -680,7 +701,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (pretty-stream-p stream) + (when (print-pretty-on-stream-p stream) (enqueue-indent stream relative-to n))) nil) @@ -705,7 +726,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (pretty-stream-p stream) + (when (print-pretty-on-stream-p stream) (enqueue-tab stream kind colnum colinc))) nil) @@ -768,21 +789,21 @@ (defvar *initial-pprint-dispatch*) (defvar *building-initial-table* nil) -(defstruct pprint-dispatch-entry - ;; The type specifier for this entry. - (type (required-argument) :type t) - ;; A function to test to see whether an object is of this time. Pretty must - ;; just (lambda (obj) (typep object type)) except that we handle the - ;; CONS type specially so that (cons (member foo)) works. We don't - ;; bother computing this for entries in the CONS hash table, because - ;; we don't need it. +(defstruct (pprint-dispatch-entry (:copier nil)) + ;; the type specifier for this entry + (type (missing-arg) :type t) + ;; a function to test to see whether an object is of this time. + ;; Pretty must just (LAMBDA (OBJ) (TYPEP OBJECT TYPE)) except that + ;; we handle the CONS type specially so that (CONS (MEMBER FOO)) + ;; works. We don't bother computing this for entries in the CONS + ;; hash table, because we don't need it. (test-fn nil :type (or function null)) - ;; The priority for this guy. + ;; the priority for this guy (priority 0 :type real) ;; T iff one of the original entries. (initial-p *building-initial-table* :type (member t nil)) - ;; And the associated function. - (function (required-argument) :type function)) + ;; and the associated 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]~]" @@ -790,7 +811,7 @@ (pprint-dispatch-entry-priority entry) (pprint-dispatch-entry-initial-p entry)))) -(defstruct pprint-dispatch-table +(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) @@ -827,12 +848,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) @@ -856,12 +877,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))) @@ -869,15 +890,8 @@ (let ((expr (compute-test-expr type 'object))) (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs* :test #'equal))) - ((fboundp 'compile) - (compile nil `(lambda (object) ,expr))) - (was-cons - (warn "CONS PPRINT dispatch ignored w/o compiler loaded:~% ~S" - type) - #'(lambda (object) (declare (ignore object)) nil)) (t - (let ((ttype (sb!kernel:specifier-type type))) - #'(lambda (object) (sb!kernel:%typep object ttype))))))))) + (compile nil `(lambda (object) ,expr)))))))) (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) @@ -885,8 +899,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)) @@ -905,9 +919,9 @@ (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 @@ -915,18 +929,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) @@ -946,6 +965,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 @@ -955,7 +975,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) @@ -986,7 +1007,7 @@ (index index) (step (reduce #'* dims)) (count 0)) - (loop + (loop (pprint-pop) (output-guts stream index dims) (when (= (incf count) dim) @@ -1227,7 +1248,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 @@ -1235,8 +1256,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))) @@ -1249,8 +1270,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") @@ -1345,5 +1366,4 @@ (/show0 "leaving !PPRINT-COLD-INIT")) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) - (setf *pretty-printer* #'output-pretty-object) (setf *print-pretty* t))