X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=5032ecb699b7033fa1e9870aec42534154fe0b64;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=b9beee2b7eb3dca4305242a5f26b0519cb57d6c4;hpb=398c7bf8d47d979a1879cf67d596c2827a98b0d9;p=sbcl.git

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index b9beee2..5032ecb 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -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))
@@ -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.
      :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))