tests/stream.impure-cload.lisp

   1 ;;;; tests related to Lisp streams
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 ;;; The unread and clear-input functions on input streams need to
  17 ;;; sneak past the old CMU CL encapsulation. As explained by DTC in
  18 ;;; the checkin message for his CMU CL patch ca. April 2001,
  19 ;;;   These streams encapsulate other input streams which may
  20 ;;;   have an input buffer so they need to call unread-char
  21 ;;;   and clear-input on the encapsulated stream rather than
  22 ;;;   directly calling the encapsulated streams misc method
  23 ;;;   as the misc methods are below the layer of the input buffer.
  24 ;;;
  25 ;;; The code below tests only UNREAD-CHAR. It would be nice to test
  26 ;;; CLEAR-INPUT too, but I'm not sure how to do it cleanly and
  27 ;;; portably in a noninteractive test. -- WHN 2001-05-05
  28 (defparameter *scratch-file-name* "sbcl-wrapped-stream-test-data.tmp")
  29 (defvar *scratch-file-stream*)
  30 (dolist (scratch-file-length '(1 ; everyone's favorite corner case
  31                                200123)) ; hopefully much bigger than buffer
  32   (format t "/SCRATCH-FILE-LENGTH=~W~%" scratch-file-length)
  33   (with-open-file (s *scratch-file-name* :direction :output)
  34     (dotimes (i scratch-file-length)
  35       (write-char #\x s)))
  36   (dolist (wrap-named-stream-fn
  37            ;; All kinds of wrapped input streams have the same issue.
  38            (list (lambda (wrapped-stream-name)
  39                    (make-synonym-stream wrapped-stream-name))
  40                  (lambda (wrapped-stream-name)
  41                    (make-two-way-stream (symbol-value wrapped-stream-name)
  42                                         *standard-output*))
  43                  (lambda (wrapped-stream-name)
  44                    (make-concatenated-stream (symbol-value wrapped-stream-name)
  45                                              (make-string-input-stream "")))))
  46     (format t "/WRAP-NAMED-STREAM-FN=~S~%" wrap-named-stream-fn)
  47     (with-open-file (*scratch-file-stream* *scratch-file-name*
  48                                            :direction :input)
  49       (let ((ss (funcall wrap-named-stream-fn '*scratch-file-stream*)))
  50         (flet ((expect (thing-expected)
  51                  (let ((thing-found (read-char ss nil nil)))
  52                    (unless (eql thing-found thing-expected)
  53                      (error "expected ~S, found ~S"
  54                             thing-expected thing-found)))))
  55           (dotimes (i scratch-file-length)
  56             (expect #\x)
  57             (unread-char #\y ss)
  58             (expect #\y)
  59             (unread-char #\z ss)
  60             (expect #\z))
  61           (expect nil))))) ; i.e. end of file
  62   (delete-file *scratch-file-name*))