From e585e8d6acbc146e978d1c2c5171987b6ba2fddf Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Sat, 9 Aug 2014 23:49:14 -0700
Subject: [PATCH] Fix ticket:101, implementing STREAM-ADVANCE-TO-COLUMN for
 FORMAT ~T.

 * code/format.lisp:
   * Add support for Gray streams for tabulation, calling
     STREAM-ADVANCE-TO-COLUMN as needed.
 * tests/gray-stream.lisp:
   * Add tests for absolute and relative tabulation. These are simple
     and just compare that lisp streams and Gray streams produce the
     same output.
 * general-info/release-20f.txt:
   * Update.
---
 src/code/format.lisp             | 76 +++++++++++++++++++++++++-------
 src/general-info/release-20f.txt |  1 +
 tests/gray-streams.lisp          | 73 ++++++++++++++++++++++++++++++
 3 files changed, 135 insertions(+), 15 deletions(-)

diff --git a/src/code/format.lisp b/src/code/format.lisp
index 704ec347a..7a2de48c7 100644
--- a/src/code/format.lisp
+++ b/src/code/format.lisp
@@ -2122,27 +2122,73 @@
       (decf n (length spaces)))
     (write-string spaces stream :end n)))
 
+;; CLHS 22.3.6.1 for relative tabulations says:
+;;
+;;   ... outputs COLREL spaces and then outputs the smallest
+;;   non-negative number of additional spaces necessary to move the
+;;   cursor to a column that is a multiple of COLINC.... If the
+;;   current output column cannot be determined, however, then colinc
+;;   is ignored, and exactly colrel spaces are output.
 (defun format-relative-tab (stream colrel colinc)
   (if (pp:pretty-stream-p stream)
       (pprint-tab :line-relative colrel colinc stream)
-      (let* ((cur (lisp::charpos stream))
-	     (spaces (if (and cur (plusp colinc))
-			 (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
-			 colrel)))
-	(output-spaces stream spaces))))
-
+      (flet ((advance-to-column ()
+	       (let* ((cur (lisp::charpos stream))
+		      (spaces (if (and cur (plusp colinc))
+				  (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
+				  colrel)))
+		 (output-spaces stream spaces))))
+	(lisp::stream-dispatch stream
+	  ;; simple-stream
+	  (advance-to-column)
+	  ;; lisp-stream
+	  (advance-to-column)
+	  ;; fundamental-stream
+	  (let ((cur (stream-line-column stream)))
+	    (cond ((and cur (plusp colinc))
+		   (stream-advance-to-column stream
+					     (+ cur
+						(* (floor (+ cur colrel) colinc)
+						   colinc))))
+		  (t
+		   (stream-advance-to-column stream (+ cur colrel)))))))))
+
+;; CLHS 22.3.6.1 says:
+;;
+;;   If the cursor is already at or beyond the column COLNUM, it will
+;;   output spaces to move it to COLNUM + k*COLINC for the smallest
+;;   positive integer k possible, unless COLINC is zero, in which case
+;;   no spaces are output.
 (defun format-absolute-tab (stream colnum colinc)
   (if (pp:pretty-stream-p stream)
       (pprint-tab :line colnum colinc stream)
-      (let ((cur (lisp::charpos stream)))
-	(cond ((null cur)
-	       (write-string "  " stream))
-	      ((< cur colnum)
-	       (output-spaces stream (- colnum cur)))
-	      (t
-	       (unless (zerop colinc)
-		 (output-spaces stream
-				(- colinc (rem (- cur colnum) colinc)))))))))
+      (flet ((advance-to-column ()
+	       (let ((cur (lisp::charpos stream)))
+		 (cond ((null cur)
+			(write-string "  " stream))
+		       ((< cur colnum)
+			(output-spaces stream (- colnum cur)))
+		       (t
+			(unless (zerop colinc)
+			  (output-spaces stream
+					 (- colinc (rem (- cur colnum) colinc)))))))))
+	(lisp::stream-dispatch stream
+	  ;; simple-stream. NOTE: Do we need to do soemthing better for
+	  ;; simple streams?
+	  (advance-to-column)
+	  ;; lisp-stream
+	  (advance-to-column)
+	  ;; fundamental-stream
+	  (let ((cur (stream-line-column stream)))
+	    (cond ((null cur)
+		   (write-string "  " stream))
+		  ((< cur colnum)
+		   (stream-advance-to-column stream colnum))
+		  (t
+		   (unless (zerop colinc)
+		     (let ((k (ceiling (- cur colnum) colinc)))
+		       (stream-advance-to-column stream
+						 (+ colnum (* k colinc))))))))))))
 
 (def-format-directive #\_ (colonp atsignp params)
   (expand-bind-defaults () params
diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt
index 388ca02f7..265b0b5cf 100644
--- a/src/general-info/release-20f.txt
+++ b/src/general-info/release-20f.txt
@@ -110,6 +110,7 @@ New in this release:
     * Ticket #105, fixed.
     * Ticket #84 fixed on x86.
     * Ticket #105 fixed.
+    * Ticket #101 fixed.
 
   * Other changes:
 
diff --git a/tests/gray-streams.lisp b/tests/gray-streams.lisp
index 7de3c1bf8..8afeb50d5 100644
--- a/tests/gray-streams.lisp
+++ b/tests/gray-streams.lisp
@@ -16,6 +16,9 @@
 (defparameter *test-file*
   (merge-pathnames #p"test-data.tmp" *test-path*))
 
+(defparameter *test-file-2*
+  (merge-pathnames #P"test-data-gray.tmp" *test-path*))
+
 (eval-when (:load-toplevel)
   (ensure-directories-exist *test-path* :verbose t))
 
@@ -37,3 +40,73 @@
 	    (file-length s))
        (close s)
        (delete-file *test-file*)))))
+
+(define-test format-abs-stream-advance
+  (:tag :trac)
+  ;; Create a lisp stream and a Gray stream and test format ~T on
+  ;; each. Compare the length of each file and declare success if the
+  ;; lengths are the same.
+  ;;
+  ;; FIXME: This doesn't actually test that STREAM-ADVANCE-TO-COLUMN
+  ;; was actually called. Another test should be added for that. We're
+  ;; testing functionality here. It was verified manually using TRACE
+  ;; that FORMAT on a Gray stream does in fact call
+  ;; STREAM-ADVANCE-TO-COLUMN
+  (assert-equal "18 18"
+   (let ((lisp-stream (open *test-file*
+			    :direction :output
+			    :if-exists :supersede))
+	 (gray-stream (open *test-file-2*
+			    :direction :output
+			    :if-exists :supersede
+			    :class 'lisp::character-output-stream)))
+     (unwind-protect
+	  (progn
+	    (format lisp-stream "~10T")
+	    (format lisp-stream "~8,10T")
+	    (format gray-stream "~10T")
+	    (format gray-stream "~8,10T")
+	    (force-output lisp-stream)
+	    (force-output gray-stream)
+	    (format nil "~D ~D"
+		    (file-position lisp-stream)
+		    (file-position gray-stream)))
+       (close lisp-stream)
+       (close gray-stream)
+       (delete-file *test-file*)
+       (delete-file *test-file-2*)))))
+
+(define-test format-rel-stream-advance
+  (:tag :trac)
+  ;; Create a lisp stream and a Gray stream and test format ~@T on
+  ;; each. Compare the length of each file and declare success if the
+  ;; lengths are the same.
+  ;;
+  ;; FIXME: This doesn't actually test that STREAM-ADVANCE-TO-COLUMN
+  ;; was actually called. Another test should be added for that. We're
+  ;; testing functionality here. It was verified manually using TRACE
+  ;; that FORMAT on a Gray stream does in fact call
+  ;; STREAM-ADVANCE-TO-COLUMN
+  (assert-equal "20 20"
+   (let ((lisp-stream (open *test-file*
+			    :direction :output
+			    :if-exists :supersede))
+	 (gray-stream (open *test-file-2*
+			    :direction :output
+			    :if-exists :supersede
+			    :class 'lisp::character-output-stream)))
+     (unwind-protect
+	  (progn
+	    (format lisp-stream "~10T")
+	    (format lisp-stream "~8,10@T")
+	    (format gray-stream "~10T")
+	    (format gray-stream "~8,10@T")
+	    (force-output lisp-stream)
+	    (force-output gray-stream)
+	    (format nil "~D ~D" 
+		    (file-position lisp-stream)
+		    (file-position gray-stream)))
+       (close lisp-stream)
+       (close gray-stream)
+       (delete-file *test-file*)
+       (delete-file *test-file-2*)))))
-- 
GitLab