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   (declare (type sb-kernel:lisp-stream lisp-stream))
  77   (make-instance 'character-output-stream :lisp-stream lisp-stream))
  78
  79 (defmethod open-stream-p ((stream character-output-stream))
  80   (open-stream-p (character-output-stream-lisp-stream stream)))
  81
  82 (defmethod close ((stream character-output-stream) &key abort)
  83   (close (character-output-stream-lisp-stream stream) :abort abort))
  84
  85 (defmethod input-stream-p ((stream character-output-stream))
  86   (input-stream-p (character-output-stream-lisp-stream stream)))
  87
  88 (defmethod output-stream-p ((stream character-output-stream))
  89   (output-stream-p (character-output-stream-lisp-stream stream)))
  90
  91 (defmethod stream-write-char ((stream character-output-stream) character)
  92   (write-char character (character-output-stream-lisp-stream stream)))
  93
  94 (defmethod stream-line-column ((stream character-output-stream))
  95   (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
  96
  97 (defmethod stream-line-length ((stream character-output-stream))
  98   (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
  99
 100 (defmethod stream-finish-output ((stream character-output-stream))
 101   (finish-output (character-output-stream-lisp-stream stream)))
 102
 103 (defmethod stream-force-output ((stream character-output-stream))
 104   (force-output (character-output-stream-lisp-stream stream)))
 105
 106 (defmethod stream-clear-output ((stream character-output-stream))
 107   (clear-output (character-output-stream-lisp-stream stream)))
 108 \f
 109 ;;;; example character input stream encapsulating a lisp-stream
 110
 111 (defun make-character-input-stream (lisp-stream)
 112   (declare (type sb-kernel:lisp-stream lisp-stream))
 113   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 114
 115 (defmethod open-stream-p ((stream character-input-stream))
 116   (open-stream-p (character-input-stream-lisp-stream stream)))
 117
 118 (defmethod close ((stream character-input-stream) &key abort)
 119   (close (character-input-stream-lisp-stream stream) :abort abort))
 120
 121 (defmethod input-stream-p ((stream character-input-stream))
 122   (input-stream-p (character-input-stream-lisp-stream stream)))
 123
 124 (defmethod output-stream-p ((stream character-input-stream))
 125   (output-stream-p (character-input-stream-lisp-stream stream)))
 126
 127 (defmethod stream-read-char ((stream character-input-stream))
 128   (read-char (character-input-stream-lisp-stream stream) nil :eof))
 129
 130 (defmethod stream-unread-char ((stream character-input-stream) character)
 131   (unread-char character (character-input-stream-lisp-stream stream)))
 132
 133 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 134   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 135
 136 #+nil
 137 (defmethod stream-peek-char ((stream character-input-stream))
 138   (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
 139
 140 #+nil
 141 (defmethod stream-listen ((stream character-input-stream))
 142   (listen (character-input-stream-lisp-stream stream)))
 143
 144 (defmethod stream-clear-input ((stream character-input-stream))
 145   (clear-input (character-input-stream-lisp-stream stream)))
 146 \f
 147 ;;;; tests for character i/o, using the above:
 148
 149 (let ((test-string (format nil
 150                            "~% This is a test.~& This is the second line.~
 151                              ~% This should be the third and last line.~%")))
 152   (with-input-from-string (foo test-string)
 153     (assert (equal
 154              (with-output-to-string (bar)
 155                (let ((our-char-input (make-character-input-stream foo))
 156                      (our-char-output (make-character-output-stream bar)))
 157                  (assert (open-stream-p our-char-input))
 158                  (assert (open-stream-p our-char-output))
 159                  (assert (input-stream-p our-char-input))
 160                  (assert (output-stream-p our-char-output))
 161                  (let ((test-char (read-char our-char-input)))
 162                    (assert (char-equal test-char (char test-string 0)))
 163                    (unread-char test-char our-char-input))
 164                  (do ((line #1=(read-line our-char-input nil nil nil) #1#))
 165                      ((not (listen our-char-input))
 166                       (format our-char-output "~A~%" line))
 167                    (format our-char-output "~A~%" line))
 168                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 169              test-string))))
 170
 171 (assert
 172   (equal
 173    (with-output-to-string (foo)
 174      (let ((our-char-output (make-character-output-stream foo)))
 175        (write-char #\a our-char-output)
 176        (finish-output our-char-output)
 177        (write-char #\  our-char-output)
 178        (force-output our-char-output)
 179        (fresh-line our-char-output)
 180        (write-char #\b our-char-output)
 181        (clear-output our-char-output)
 182        (terpri our-char-output)
 183        (assert (null (fresh-line our-char-output)))
 184        (write-char #\c our-char-output)))
 185    (format nil "a ~%b~%c")))
 186 \f
 187 ;;;; example classes for binary output
 188
 189 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
 190   ((lisp-stream :initarg :lisp-stream
 191                 :accessor binary-to-char-output-stream-lisp-stream)))
 192
 193 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
 194   ((lisp-stream :initarg :lisp-stream
 195                 :accessor binary-to-char-input-stream-lisp-stream)))
 196
 197 (defmethod stream-element-type ((stream binary-to-char-output-stream))
 198   '(unsigned-byte 8))
 199 (defmethod stream-element-type ((stream binary-to-char-input-stream))
 200   '(unsigned-byte 8))
 201
 202 (defun make-binary-to-char-input-stream (lisp-stream)
 203   (declare (type sb-kernel:lisp-stream lisp-stream))
 204   (make-instance 'binary-to-char-input-stream
 205                  :lisp-stream lisp-stream))
 206
 207 (defun make-binary-to-char-output-stream (lisp-stream)
 208   (declare (type sb-kernel:lisp-stream lisp-stream))
 209   (make-instance 'binary-to-char-output-stream
 210                  :lisp-stream lisp-stream))
 211
 212 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
 213   (let ((char (read-char
 214                (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
 215     (if (eq char :eof)
 216         char
 217         (char-code char))))
 218
 219 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
 220   (let ((char (code-char integer)))
 221     (write-char char
 222                 (binary-to-char-output-stream-lisp-stream stream))))
 223 \f
 224 ;;;; tests using binary i/o, using the above
 225
 226 (let ((test-string (format nil
 227                            "~% This is a test.~& This is the second line.~
 228                              ~% This should be the third and last line.~%")))
 229   (with-input-from-string (foo test-string)
 230     (assert (equal
 231              (with-output-to-string (bar)
 232                (let ((our-bin-to-char-input (make-binary-to-char-input-stream
 233                                              foo))
 234                      (our-bin-to-char-output (make-binary-to-char-output-stream
 235                                               bar)))
 236                  (assert (open-stream-p our-bin-to-char-input))
 237                  (assert (open-stream-p our-bin-to-char-output))
 238                  (assert (input-stream-p our-bin-to-char-input))
 239                  (assert (output-stream-p our-bin-to-char-output))
 240                  (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
 241                      ((eq byte :eof))
 242                    (write-byte byte our-bin-to-char-output))))
 243              test-string))))
 244 \f
 245 ;;;; Voila!
 246
 247 (quit :unix-status 104) ; success