X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=bc265100fc1823ac0baec422d65f7f097374f6ea;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=b9beee2b7eb3dca4305242a5f26b0519cb57d6c4;hpb=398c7bf8d47d979a1879cf67d596c2827a98b0d9;p=sbcl.git diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index b9beee2..bc26510 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -119,7 +119,7 @@ (defun pretty-out (stream char) (declare (type pretty-stream stream) - (type base-char char)) + (type character char)) (cond ((char= char #\newline) (enqueue-newline stream :literal)) (t @@ -364,21 +364,23 @@ ;;;; tab support (defun compute-tab-size (tab section-start column) - (let ((origin (if (tab-sectionp tab) section-start 0)) - (colnum (tab-colnum tab)) - (colinc (tab-colinc tab))) + (let* ((origin (if (tab-sectionp tab) section-start 0)) + (colnum (tab-colnum tab)) + (colinc (tab-colinc tab)) + (position (- column origin))) (cond ((tab-relativep tab) (unless (<= colinc 1) - (let ((newposn (+ column colnum))) + (let ((newposn (+ position colnum))) (let ((rem (rem newposn colinc))) (unless (zerop rem) (incf colnum (- colinc rem)))))) colnum) - ((<= column (+ colnum origin)) - (- (+ colnum origin) column)) - (t + ((< position colnum) + (- colnum position)) + ((zerop colinc) 0) + (t (- colinc - (rem (- column origin) colinc)))))) + (rem (- position colnum) colinc)))))) (defun index-column (index stream) (let ((column (pretty-stream-buffer-start-column stream)) @@ -660,15 +662,15 @@ *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do nothing if not. KIND can be one of: :LINEAR - A line break is inserted if and only if the immediatly - containing section cannot be printed on one line. + containing section cannot be printed on one line. :MISER - Same as LINEAR, but only if ``miser-style'' is in effect. - (See *PRINT-MISER-WIDTH*.) + (See *PRINT-MISER-WIDTH*.) :FILL - A line break is inserted if and only if either: (a) the following section cannot be printed on the end of the - current line, + current line, (b) the preceding section was not printed on a single line, or (c) the immediately containing section cannot be printed on one - line and miser-style is in effect. + line and miser-style is in effect. :MANDATORY - A line break is always inserted. When a line break is inserted by any type of conditional newline, any blanks that immediately precede the conditional newline are ommitted @@ -689,15 +691,15 @@ #!+sb-doc "Specify the indentation to use in the current logical block if STREAM (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream - and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indention + and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indentation to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: :BLOCK - Indent relative to the column the current logical block - started on. + started on. :CURRENT - Indent relative to the current column. - The new indention value does not take effect until the following line + The new indentation value does not take effect until the following line break." (declare (type (member :block :current) relative-to) - (type integer n) + (type real n) (type (or stream (member t nil)) stream) (values null)) (let ((stream (case stream @@ -705,7 +707,7 @@ ((nil) *standard-output*) (t stream)))) (when (print-pretty-on-stream-p stream) - (enqueue-indent stream relative-to n))) + (enqueue-indent stream relative-to (truncate n)))) nil) (defun pprint-tab (kind colnum colinc &optional stream) @@ -806,7 +808,7 @@ ;; T iff one of the original entries. (initial-p *building-initial-table* :type (member t nil)) ;; and the associated function - (fun (missing-arg) :type function)) + (fun (missing-arg) :type callable)) (def!method print-object ((entry pprint-dispatch-entry) stream) (print-unreadable-object (entry stream :type t) (format stream "type=~S, priority=~S~@[ [initial]~]" @@ -924,37 +926,32 @@ (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...") (/hexstr type) (if function - ;; 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) + (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)) @@ -1102,10 +1099,19 @@ (defun pprint-flet (stream list &rest noise) (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") - stream - list)) + (if (cddr list) + (funcall (formatter + "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") + stream + list) + ;; for printing function names like (flet foo) + (pprint-logical-block (stream list :prefix "(" :suffix ")") + (pprint-exit-if-list-exhausted) + (write (pprint-pop) :stream stream) + (loop + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (write (pprint-pop) :stream stream))))) (defun pprint-let (stream list &rest noise) (declare (ignore noise))