X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=9b3f51e1907e47a0ea5d9b8364ff29ec006cab6d;hb=aa61c7571b33b86981301f34d3acdb66666f53a3;hp=ec285d799399e6efb74bd30c2b903a5ffa096c3c;hpb=5b06386093fe448abe3a9086fae4f8e15709d8a3;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index ec285d7..9b3f51e 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,14 +28,14 @@ (defconstant default-line-length 80) -(defstruct (pretty-stream (:include sb!kernel:lisp-stream +(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* @@ -56,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. @@ -271,7 +282,7 @@ (defstruct (newline (:include section-start) (:copier nil)) - (kind (required-argument) + (kind (missing-arg) :type (member :linear :fill :miser :literal :mandatory))) (defun enqueue-newline (stream kind) @@ -287,7 +298,7 @@ (defstruct (indentation (:include queued-op) (:copier nil)) - (kind (required-argument) :type (member :block :current)) + (kind (missing-arg) :type (member :block :current)) (amount 0 :type fixnum)) (defun enqueue-indent (stream kind amount) @@ -532,8 +543,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))))) @@ -567,7 +580,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))))) @@ -775,20 +789,20 @@ (defvar *building-initial-table* nil) (defstruct (pprint-dispatch-entry (:copier nil)) - ;; 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. + ;; 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]~]" @@ -904,7 +918,7 @@ (when (funcall (pprint-dispatch-entry-test-fn entry) object) (return entry))))) (if entry - (values (pprint-dispatch-entry-function entry) t) + (values (pprint-dispatch-entry-fun entry) t) (values #'(lambda (stream object) (output-ugly-object object stream)) nil)))) @@ -918,14 +932,17 @@ (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) @@ -1234,8 +1251,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)))