X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fgray-streams.impure.lisp;h=ab827debdfc3c3db90856724d6f6cfc82d4f6d3e;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=5f96206cb1a491999df607cfd7b4d28bd3e76549;hpb=bbfeb9a341eb81fdd80146f38548437b211dc280;p=sbcl.git

diff --git a/tests/gray-streams.impure.lisp b/tests/gray-streams.impure.lisp
index 5f96206..ab827de 100644
--- a/tests/gray-streams.impure.lisp
+++ b/tests/gray-streams.impure.lisp
@@ -1,8 +1,4 @@
-;;;; This file is for compiler tests which have side effects (e.g.
-;;;; executing DEFUN) but which don't need any special side-effecting
-;;;; environmental stuff (e.g. DECLAIM of particular optimization
-;;;; settings). Similar tests which *do* expect special settings may
-;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
+;;;; tests related to Gray streams
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -10,7 +6,7 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
@@ -64,24 +60,24 @@
 
 (defclass character-output-stream (fundamental-character-output-stream)
   ((lisp-stream :initarg :lisp-stream
-		:accessor character-output-stream-lisp-stream)))
-  
+                :accessor character-output-stream-lisp-stream)
+   (position :initform 42 :accessor character-output-stream-position)))
+
 (defclass character-input-stream (fundamental-character-input-stream)
   ((lisp-stream :initarg :lisp-stream
-		:accessor character-input-stream-lisp-stream)))
-  
+                :accessor character-input-stream-lisp-stream)))
+
 ;;;; example character output stream encapsulating a lisp-stream
 
 (defun make-character-output-stream (lisp-stream)
-  (declare (type sb-kernel:lisp-stream lisp-stream))
   (make-instance 'character-output-stream :lisp-stream lisp-stream))
-  
+
 (defmethod open-stream-p ((stream character-output-stream))
   (open-stream-p (character-output-stream-lisp-stream stream)))
-  
+
 (defmethod close ((stream character-output-stream) &key abort)
   (close (character-output-stream-lisp-stream stream) :abort abort))
-  
+
 (defmethod input-stream-p ((stream character-output-stream))
   (input-stream-p (character-output-stream-lisp-stream stream)))
 
@@ -105,11 +101,15 @@
 
 (defmethod stream-clear-output ((stream character-output-stream))
   (clear-output (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-file-position ((stream character-output-stream) &optional new-value)
+  (if new-value
+      (setf (character-output-stream-position stream) new-value)
+      (character-output-stream-position stream)))
 
 ;;;; example character input stream encapsulating a lisp-stream
 
 (defun make-character-input-stream (lisp-stream)
-  (declare (type sb-kernel:lisp-stream lisp-stream))
   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 
 (defmethod open-stream-p ((stream character-input-stream))
@@ -133,14 +133,6 @@
 (defmethod stream-read-char-no-hang ((stream character-input-stream))
   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 
-#+nil
-(defmethod stream-peek-char ((stream character-input-stream))
-  (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
-
-#+nil
-(defmethod stream-listen ((stream character-input-stream))
-  (listen (character-input-stream-lisp-stream stream)))
-
 (defmethod stream-clear-input ((stream character-input-stream))
   (clear-input (character-input-stream-lisp-stream stream)))
 
@@ -183,16 +175,62 @@
        (assert (null (fresh-line our-char-output)))
        (write-char #\c our-char-output)))
    (format nil "a ~%b~%c")))
+
+;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic
+;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some
+;;; cases. Try to verify that we don't end up doing tests like that on
+;;; bare Gray streams and thus bogusly omitting pretty-printing
+;;; operations.
+(flet ((frob ()
+         (with-output-to-string (string)
+           (let ((gray-output-stream (make-character-output-stream string)))
+             (format gray-output-stream
+                     "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
+  (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
+  (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
+
+;;; tests for STREAM-READ-SEQUENCE/STREAM-WRITE-SEQUENCE for
+;;; subclasses of FUNDAMENTAL-CHARACTER-INPUT-/OUTPUT-STREAM (i.e.,
+;;; where the default methods are available)
+(let* ((test-string (format nil
+                            "~% Testing for STREAM-*-SEQUENCE.~
+                             ~& This is the second line.~
+                             ~% This should be the third and last line.~%"))
+       (test-string-len (length test-string))
+       (output-test-string (make-string test-string-len)))
+  ;; test for READ-/WRITE-SEQUENCE on strings/vectors
+  (with-input-from-string (foo test-string)
+    (assert (equal
+             (with-output-to-string (bar)
+               (let ((our-char-input (make-character-input-stream foo))
+                     (our-char-output (make-character-output-stream bar)))
+                 (read-sequence output-test-string our-char-input)
+                 (assert (typep output-test-string 'string))
+                 (write-sequence output-test-string our-char-output)
+                 (assert (null (peek-char nil our-char-input nil nil nil)))))
+             test-string)))
+  ;; test for READ-/WRITE-SEQUENCE on lists
+  (let ((output-test-list (make-list test-string-len)))
+    (with-input-from-string (foo test-string)
+      (assert (equal
+             (with-output-to-string (bar)
+               (let ((our-char-input (make-character-input-stream foo))
+                     (our-char-output (make-character-output-stream bar)))
+                 (read-sequence output-test-list our-char-input)
+                 (assert (typep output-test-list 'list))
+                 (write-sequence output-test-list our-char-output)
+                 (assert (null (peek-char nil our-char-input nil nil nil)))))
+             test-string)))))
 
 ;;;; example classes for binary output
 
 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
   ((lisp-stream :initarg :lisp-stream
-		:accessor binary-to-char-output-stream-lisp-stream)))
-  
+                :accessor binary-to-char-output-stream-lisp-stream)))
+
 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
   ((lisp-stream :initarg :lisp-stream
-		:accessor binary-to-char-input-stream-lisp-stream)))
+                :accessor binary-to-char-input-stream-lisp-stream)))
 
 (defmethod stream-element-type ((stream binary-to-char-output-stream))
   '(unsigned-byte 8))
@@ -200,39 +238,37 @@
   '(unsigned-byte 8))
 
 (defun make-binary-to-char-input-stream (lisp-stream)
-  (declare (type sb-kernel:lisp-stream lisp-stream))
   (make-instance 'binary-to-char-input-stream
-		 :lisp-stream lisp-stream))
+                 :lisp-stream lisp-stream))
 
 (defun make-binary-to-char-output-stream (lisp-stream)
-  (declare (type sb-kernel:lisp-stream lisp-stream))
   (make-instance 'binary-to-char-output-stream
-		 :lisp-stream lisp-stream))
-  
+                 :lisp-stream lisp-stream))
+
 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
   (let ((char (read-char
-	       (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
+               (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
     (if (eq char :eof)
-	char
-	(char-code char))))
+        char
+        (char-code char))))
 
 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
   (let ((char (code-char integer)))
     (write-char char
-		(binary-to-char-output-stream-lisp-stream stream))))
-      
+                (binary-to-char-output-stream-lisp-stream stream))))
+
 ;;;; tests using binary i/o, using the above
 
 (let ((test-string (format nil
                            "~% This is a test.~& This is the second line.~
-                             ~% This should be the third and last line.~%")))
+                            ~% This should be the third and last line.~%")))
   (with-input-from-string (foo test-string)
     (assert (equal
              (with-output-to-string (bar)
                (let ((our-bin-to-char-input (make-binary-to-char-input-stream
-					     foo))
+                                             foo))
                      (our-bin-to-char-output (make-binary-to-char-output-stream
-					      bar)))
+                                              bar)))
                  (assert (open-stream-p our-bin-to-char-input))
                  (assert (open-stream-p our-bin-to-char-output))
                  (assert (input-stream-p our-bin-to-char-input))
@@ -241,7 +277,62 @@
                      ((eq byte :eof))
                    (write-byte byte our-bin-to-char-output))))
              test-string))))
+
 
-;;;; Voila!
 
-(quit :unix-status 104) ; success
+;;; Minimal test of file-position
+(let ((stream (make-instance 'character-output-stream)))
+  (assert (= (file-position stream) 42))
+  (assert (file-position stream 50))
+  (assert (= (file-position stream) 50)))
+
+;;; Using gray streams as parts of two-way-, concatenate-, and synonym-streams.
+
+(defvar *gray-binary-data*
+  (let ((vector (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0)))
+    (dotimes (i (length vector))
+      (setf (aref vector i) (random 256)))
+    vector))
+
+(defun vector-hop-or-eof (vector)
+  (let ((pos (fill-pointer vector)))
+    (if (< pos (array-total-size vector))
+        (prog1
+            (aref vector pos)
+          (incf (fill-pointer vector)))
+        :eof)))
+
+(defclass part-of-composite-stream (fundamental-binary-input-stream)
+  ())
+
+(defmethod stream-read-byte ((stream part-of-composite-stream))
+  (vector-hop-or-eof *gray-binary-data*))
+
+(defmethod stream-element-type ((stream part-of-composite-stream))
+  '(unsigned-byte 8))
+
+(defvar *part-of-composite* (make-instance 'part-of-composite-stream))
+
+(defun test-composite-reads (&rest streams)
+  (dolist (stream streams)
+    (setf (fill-pointer *gray-binary-data*) 0)
+    (let ((binary-buffer (make-array 1024 :element-type '(unsigned-byte 8))))
+      (assert (eql 1024 (read-sequence binary-buffer stream)))
+      (dotimes (i 1024)
+        (unless (eql (aref *gray-binary-data* i)
+                     (aref binary-buffer i))
+          (error "wanted ~S at ~S, got ~S (~S)"
+                 (aref *gray-binary-data* i)
+                 i
+                 (aref binary-buffer i)
+                 stream))))))
+
+(test-composite-reads
+ (make-two-way-stream *part-of-composite* *standard-output*)
+ (make-concatenated-stream *part-of-composite*)
+ (make-synonym-stream '*part-of-composite*))
+
+;;; Using STREAM-FILE-POSITION on an ANSI-STREAM
+(with-output-to-string (s)
+  (assert (zerop (file-position s)))
+  (assert (zerop (stream-file-position s))))