tests/gray-streams.impure.lisp

   1 ;;;; This file is for compiler tests which have side effects (e.g.
   2 ;;;; executing DEFUN) but which don't need any special side-effecting
   3 ;;;; environmental stuff (e.g. DECLAIM of particular optimization
   4 ;;;; settings). Similar tests which *do* expect special settings may
   5 ;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; While most of SBCL is derived from the CMU CL system, the test
  11 ;;;; files (like this one) were written from scratch after the fork
  12 ;;;; from CMU CL.
  13 ;;;;
  14 ;;;; This software is in the public domain and is provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  16 ;;;; more information.
  17
  18 (cl:in-package :cl-user)
  19 \f
  20 ;;;; class precedence tests
  21
  22 (assert (subtypep 'fundamental-stream 'stream))
  23 (assert (subtypep 'fundamental-stream 'standard-object))
  24
  25 (assert (subtypep 'fundamental-input-stream 'fundamental-stream))
  26 (assert (subtypep 'fundamental-output-stream 'fundamental-stream))
  27 (assert (subtypep 'fundamental-character-stream 'fundamental-stream))
  28 (assert (subtypep 'fundamental-binary-stream 'fundamental-stream))
  29
  30 (assert (subtypep 'fundamental-character-input-stream
  31                   'fundamental-input-stream))
  32 (assert (subtypep 'fundamental-character-input-stream
  33                   'fundamental-character-stream))
  34 (assert (subtypep 'fundamental-character-output-stream
  35                   'fundamental-output-stream))
  36 (assert (subtypep 'fundamental-character-output-stream
  37                   'fundamental-character-stream))
  38
  39 (assert (subtypep 'fundamental-binary-input-stream
  40                   'fundamental-input-stream))
  41 (assert (subtypep 'fundamental-binary-input-stream
  42                   'fundamental-binary-stream))
  43 (assert (subtypep 'fundamental-binary-output-stream
  44                   'fundamental-output-stream))
  45 (assert (subtypep 'fundamental-binary-output-stream
  46                   'fundamental-binary-stream))
  47
  48 (defvar *fundamental-input-stream-instance*
  49   (make-instance 'fundamental-input-stream))
  50
  51 (defvar *fundamental-output-stream-instance*
  52   (make-instance 'fundamental-output-stream))
  53
  54 (defvar *fundamental-character-stream-instance*
  55   (make-instance 'fundamental-character-stream))
  56
  57 (assert (input-stream-p *fundamental-input-stream-instance*))
  58 (assert (output-stream-p *fundamental-output-stream-instance*))
  59 (assert (eql (stream-element-type
  60               *fundamental-character-stream-instance*)
  61              'character))
  62 \f
  63 ;;;; example character input and output streams
  64
  65 (defclass character-output-stream (fundamental-character-output-stream)
  66   ((lisp-stream :initarg :lisp-stream
  67                 :accessor character-output-stream-lisp-stream)))
  68
  69 (defclass character-input-stream (fundamental-character-input-stream)
  70   ((lisp-stream :initarg :lisp-stream
  71                 :accessor character-input-stream-lisp-stream)))
  72 \f
  73 ;;;; example character output stream encapsulating a lisp-stream
  74
  75 (defun make-character-output-stream (lisp-stream)
  76   (make-instance 'character-output-stream :lisp-stream lisp-stream))
  77
  78 (defmethod open-stream-p ((stream character-output-stream))
  79   (open-stream-p (character-output-stream-lisp-stream stream)))
  80
  81 (defmethod close ((stream character-output-stream) &key abort)
  82   (close (character-output-stream-lisp-stream stream) :abort abort))
  83
  84 (defmethod input-stream-p ((stream character-output-stream))
  85   (input-stream-p (character-output-stream-lisp-stream stream)))
  86
  87 (defmethod output-stream-p ((stream character-output-stream))
  88   (output-stream-p (character-output-stream-lisp-stream stream)))
  89
  90 (defmethod stream-write-char ((stream character-output-stream) character)
  91   (write-char character (character-output-stream-lisp-stream stream)))
  92
  93 (defmethod stream-line-column ((stream character-output-stream))
  94   (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
  95
  96 (defmethod stream-line-length ((stream character-output-stream))
  97   (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
  98
  99 (defmethod stream-finish-output ((stream character-output-stream))
 100   (finish-output (character-output-stream-lisp-stream stream)))
 101
 102 (defmethod stream-force-output ((stream character-output-stream))
 103   (force-output (character-output-stream-lisp-stream stream)))
 104
 105 (defmethod stream-clear-output ((stream character-output-stream))
 106   (clear-output (character-output-stream-lisp-stream stream)))
 107 \f
 108 ;;;; example character input stream encapsulating a lisp-stream
 109
 110 (defun make-character-input-stream (lisp-stream)
 111   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 112
 113 (defmethod open-stream-p ((stream character-input-stream))
 114   (open-stream-p (character-input-stream-lisp-stream stream)))
 115
 116 (defmethod close ((stream character-input-stream) &key abort)
 117   (close (character-input-stream-lisp-stream stream) :abort abort))
 118
 119 (defmethod input-stream-p ((stream character-input-stream))
 120   (input-stream-p (character-input-stream-lisp-stream stream)))
 121
 122 (defmethod output-stream-p ((stream character-input-stream))
 123   (output-stream-p (character-input-stream-lisp-stream stream)))
 124
 125 (defmethod stream-read-char ((stream character-input-stream))
 126   (read-char (character-input-stream-lisp-stream stream) nil :eof))
 127
 128 (defmethod stream-unread-char ((stream character-input-stream) character)
 129   (unread-char character (character-input-stream-lisp-stream stream)))
 130
 131 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 132   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 133
 134 (defmethod stream-clear-input ((stream character-input-stream))
 135   (clear-input (character-input-stream-lisp-stream stream)))
 136 \f
 137 ;;;; tests for character i/o, using the above:
 138
 139 (let ((test-string (format nil
 140                            "~% This is a test.~& This is the second line.~
 141                              ~% This should be the third and last line.~%")))
 142   (with-input-from-string (foo test-string)
 143     (assert (equal
 144              (with-output-to-string (bar)
 145                (let ((our-char-input (make-character-input-stream foo))
 146                      (our-char-output (make-character-output-stream bar)))
 147                  (assert (open-stream-p our-char-input))
 148                  (assert (open-stream-p our-char-output))
 149                  (assert (input-stream-p our-char-input))
 150                  (assert (output-stream-p our-char-output))
 151                  (let ((test-char (read-char our-char-input)))
 152                    (assert (char-equal test-char (char test-string 0)))
 153                    (unread-char test-char our-char-input))
 154                  (do ((line #1=(read-line our-char-input nil nil nil) #1#))
 155                      ((not (listen our-char-input))
 156                       (format our-char-output "~A~%" line))
 157                    (format our-char-output "~A~%" line))
 158                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 159              test-string))))
 160
 161 (assert
 162   (equal
 163    (with-output-to-string (foo)
 164      (let ((our-char-output (make-character-output-stream foo)))
 165        (write-char #\a our-char-output)
 166        (finish-output our-char-output)
 167        (write-char #\  our-char-output)
 168        (force-output our-char-output)
 169        (fresh-line our-char-output)
 170        (write-char #\b our-char-output)
 171        (clear-output our-char-output)
 172        (terpri our-char-output)
 173        (assert (null (fresh-line our-char-output)))
 174        (write-char #\c our-char-output)))
 175    (format nil "a ~%b~%c")))
 176
 177 ;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic
 178 ;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some
 179 ;;; cases. Try to verify that we don't end up doing tests like that on
 180 ;;; bare Gray streams and thus bogusly omitting pretty-printing
 181 ;;; operations.
 182 (flet ((frob ()
 183          (with-output-to-string (string)
 184            (let ((gray-output-stream (make-character-output-stream string)))
 185              (format gray-output-stream
 186                      "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
 187   (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
 188   (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
 189
 190 ;;; tests for STREAM-READ-SEQUENCE/STREAM-WRITE-SEQUENCE for
 191 ;;; subclasses of FUNDAMENTAL-CHARACTER-INPUT-/OUTPUT-STREAM (i.e.,
 192 ;;; where the default methods are available)
 193 (let* ((test-string (format nil
 194                             "~% Testing for STREAM-*-SEQUENCE.~
 195                              ~& This is the second line.~
 196                              ~% This should be the third and last line.~%"))
 197        (test-string-len (length test-string))
 198        (output-test-string (make-string test-string-len)))
 199   ;; test for READ-/WRITE-SEQUENCE on strings/vectors
 200   (with-input-from-string (foo test-string)
 201     (assert (equal
 202              (with-output-to-string (bar)
 203                (let ((our-char-input (make-character-input-stream foo))
 204                      (our-char-output (make-character-output-stream bar)))
 205                  (read-sequence output-test-string our-char-input)
 206                  (assert (typep output-test-string 'string))
 207                  (write-sequence output-test-string our-char-output)
 208                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 209              test-string)))
 210   ;; test for READ-/WRITE-SEQUENCE on lists
 211   (let ((output-test-list (make-list test-string-len)))
 212     (with-input-from-string (foo test-string)
 213       (assert (equal
 214              (with-output-to-string (bar)
 215                (let ((our-char-input (make-character-input-stream foo))
 216                      (our-char-output (make-character-output-stream bar)))
 217                  (read-sequence output-test-list our-char-input)
 218                  (assert (typep output-test-list 'list))
 219                  (write-sequence output-test-list our-char-output)
 220                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 221              test-string)))))
 222 \f
 223 ;;;; example classes for binary output
 224
 225 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
 226   ((lisp-stream :initarg :lisp-stream
 227                 :accessor binary-to-char-output-stream-lisp-stream)))
 228
 229 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
 230   ((lisp-stream :initarg :lisp-stream
 231                 :accessor binary-to-char-input-stream-lisp-stream)))
 232
 233 (defmethod stream-element-type ((stream binary-to-char-output-stream))
 234   '(unsigned-byte 8))
 235 (defmethod stream-element-type ((stream binary-to-char-input-stream))
 236   '(unsigned-byte 8))
 237
 238 (defun make-binary-to-char-input-stream (lisp-stream)
 239   (make-instance 'binary-to-char-input-stream
 240                  :lisp-stream lisp-stream))
 241
 242 (defun make-binary-to-char-output-stream (lisp-stream)
 243   (make-instance 'binary-to-char-output-stream
 244                  :lisp-stream lisp-stream))
 245
 246 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
 247   (let ((char (read-char
 248                (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
 249     (if (eq char :eof)
 250         char
 251         (char-code char))))
 252
 253 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
 254   (let ((char (code-char integer)))
 255     (write-char char
 256                 (binary-to-char-output-stream-lisp-stream stream))))
 257 \f
 258 ;;;; tests using binary i/o, using the above
 259
 260 (let ((test-string (format nil
 261                            "~% This is a test.~& This is the second line.~
 262                              ~% This should be the third and last line.~%")))
 263   (with-input-from-string (foo test-string)
 264     (assert (equal
 265              (with-output-to-string (bar)
 266                (let ((our-bin-to-char-input (make-binary-to-char-input-stream
 267                                              foo))
 268                      (our-bin-to-char-output (make-binary-to-char-output-stream
 269                                               bar)))
 270                  (assert (open-stream-p our-bin-to-char-input))
 271                  (assert (open-stream-p our-bin-to-char-output))
 272                  (assert (input-stream-p our-bin-to-char-input))
 273                  (assert (output-stream-p our-bin-to-char-output))
 274                  (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
 275                      ((eq byte :eof))
 276                    (write-byte byte our-bin-to-char-output))))
 277              test-string))))
 278 \f
 279 ;;;; Voila!
 280
 281 (quit :unix-status 104) ; success