src/code/target-stream.lisp

   1 ;;;; os-independent stream functions requiring reader machinery
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 ;;; In the interest of ``once and only once'' this macro contains the
  15 ;;; framework necessary to implement a peek-char function, which has
  16 ;;; two special-cases (one for gray streams and one for echo streams)
  17 ;;; in addition to the normal case.
  18 ;;;
  19 ;;; All arguments are forms which will be used for a specific purpose
  20 ;;; PEEK-TYPE - the current peek-type as defined by ANSI CL
  21 ;;; EOF-VALUE - the eof-value argument to peek-char
  22 ;;; CHAR-VAR - the variable which will be used to store the current character
  23 ;;; READ-FORM - the form which will be used to read a character
  24 ;;; UNREAD-FORM - ditto for unread-char
  25 ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
  26 ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
  27 ;;;                     (this will default to CHAR-VAR)
  28 (eval-when (:compile-toplevel :execute)
  29   (sb!xc:defmacro generalized-peeking-mechanism
  30       (peek-type eof-value char-var read-form unread-form
  31        &optional (skipped-char-form nil) (eof-detected-form nil))
  32     `(let ((,char-var ,read-form))
  33       (cond ((eql ,char-var ,eof-value)
  34              ,(if eof-detected-form
  35                   eof-detected-form
  36                   char-var))
  37             ((characterp ,peek-type)
  38              (do ((,char-var ,char-var ,read-form))
  39                  ((or (eql ,char-var ,eof-value)
  40                       (char= ,char-var ,peek-type))
  41                   (cond ((eql ,char-var ,eof-value)
  42                          ,(if eof-detected-form
  43                               eof-detected-form
  44                               char-var))
  45                         (t ,unread-form
  46                            ,char-var)))
  47                ,skipped-char-form))
  48             ((eql ,peek-type t)
  49              (do ((,char-var ,char-var ,read-form))
  50                  ((or (eql ,char-var ,eof-value)
  51                       (not (whitespacep ,char-var)))
  52                   (cond ((eql ,char-var ,eof-value)
  53                          ,(if eof-detected-form
  54                               eof-detected-form
  55                               char-var))
  56                         (t ,unread-form
  57                            ,char-var)))
  58                ,skipped-char-form))
  59             ((null ,peek-type)
  60              ,unread-form
  61              ,char-var)
  62             (t
  63              (bug "Impossible case reached in PEEK-CHAR"))))))
  64
  65 ;;; rudi (2004-08-09): There was an inline declaration for read-char,
  66 ;;; unread-char, read-byte, listen here that was removed because these
  67 ;;; functions are redefined when simple-streams are loaded.
  68
  69 #!-sb-fluid (declaim (inline ansi-stream-peek-char))
  70 (defun ansi-stream-peek-char (peek-type stream eof-error-p eof-value
  71                               recursive-p)
  72   (cond ((typep stream 'echo-stream)
  73          (echo-misc stream
  74                     :peek-char
  75                     peek-type
  76                     (list eof-error-p eof-value)))
  77         (t
  78          (generalized-peeking-mechanism
  79           peek-type eof-value char
  80           (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
  81           (ansi-stream-unread-char char stream)))))
  82
  83 (defun peek-char (&optional (peek-type nil)
  84                             (stream *standard-input*)
  85                             (eof-error-p t)
  86                             eof-value
  87                             recursive-p)
  88   (the (or character boolean) peek-type)
  89   (let ((stream (in-synonym-of stream)))
  90     (if (ansi-stream-p stream)
  91         (ansi-stream-peek-char peek-type stream eof-error-p eof-value
  92                                recursive-p)
  93         ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
  94         (generalized-peeking-mechanism
  95          peek-type :eof char
  96          (if (null peek-type)
  97              (stream-peek-char stream)
  98              (stream-read-char stream))
  99          (if (null peek-type)
 100              ()
 101              (stream-unread-char stream char))
 102          ()
 103          (eof-or-lose stream eof-error-p eof-value)))))
 104
 105 (defun echo-misc (stream operation &optional arg1 arg2)
 106   (let* ((in (two-way-stream-input-stream stream))
 107          (out (two-way-stream-output-stream stream)))
 108     (case operation
 109       (:listen
 110        (or (not (null (echo-stream-unread-stuff stream)))
 111            (if (ansi-stream-p in)
 112                (or (/= (the fixnum (ansi-stream-in-index in))
 113                        +ansi-stream-in-buffer-length+)
 114                    (funcall (ansi-stream-misc in) in :listen))
 115                (stream-misc-dispatch in :listen))))
 116       (:unread (push arg1 (echo-stream-unread-stuff stream)))
 117       (:element-type
 118        (let ((in-type (stream-element-type in))
 119              (out-type (stream-element-type out)))
 120          (if (equal in-type out-type)
 121              in-type `(and ,in-type ,out-type))))
 122       (:close
 123        (set-closed-flame stream))
 124       (:peek-char
 125        ;; For the special case of peeking into an echo-stream
 126        ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE)
 127        ;; returns peeked-char, eof-value, or errors end-of-file
 128        ;;
 129        ;; Note: This code could be moved into PEEK-CHAR if desired.
 130        ;; I am unsure whether this belongs with echo-streams because it is
 131        ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
 132        ;; -- mrd 2002-11-18
 133        ;;
 134        ;; UNREAD-CHAR-P indicates whether the current character was one
 135        ;; that was previously unread.  In that case, we need to ensure that
 136        ;; the semantics for UNREAD-CHAR are held; the character should
 137        ;; not be echoed again.
 138        (let ((unread-char-p nil))
 139          (flet ((outfn (c)
 140                   (unless unread-char-p
 141                     (if (ansi-stream-p out)
 142                         (funcall (ansi-stream-out out) out c)
 143                         ;; gray-stream
 144                         (stream-write-char out c))))
 145                 (infn ()
 146                   ;; Obtain input from unread buffer or input stream,
 147                   ;; and set the flag appropriately.
 148                   (cond ((not (null (echo-stream-unread-stuff stream)))
 149                          (setf unread-char-p t)
 150                          (pop (echo-stream-unread-stuff stream)))
 151                         (t
 152                          (setf unread-char-p nil)
 153                          (read-char in (first arg2) (second arg2))))))
 154            (generalized-peeking-mechanism
 155             arg1 (second arg2) char
 156             (infn)
 157             (unread-char char in)
 158             (outfn char)))))
 159       (t
 160        (or (if (ansi-stream-p in)
 161                (funcall (ansi-stream-misc in) in operation arg1 arg2)
 162                (stream-misc-dispatch in operation arg1 arg2))
 163            (if (ansi-stream-p out)
 164                (funcall (ansi-stream-misc out) out operation arg1 arg2)
 165                (stream-misc-dispatch out operation arg1 arg2)))))))
 166