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-RESULT - 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 ;;; EOF-VALUE - the result returned from READ-FORM when hitting eof
  25 ;;; UNREAD-FORM - ditto for unread-char
  26 ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
  27 ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
  28 ;;;                     (this will default to EOF-RESULT)
  29 (sb!xc:defmacro generalized-peeking-mechanism
  30     (peek-type eof-value char-var read-form read-eof unread-form
  31      &optional (skipped-char-form nil) (eof-detected-form nil))
  32   `(let ((,char-var ,read-form))
  33     (cond ((eql ,char-var ,read-eof)
  34            ,(if eof-detected-form
  35                 eof-detected-form
  36                 eof-value))
  37           ((characterp ,peek-type)
  38            (do ((,char-var ,char-var ,read-form))
  39                ((or (eql ,char-var ,read-eof)
  40                     ;; CHAR= will type-check for us
  41                     (char= ,char-var ,peek-type))
  42                 (cond ((eql ,char-var ,read-eof)
  43                        ,(if eof-detected-form
  44                             eof-detected-form
  45                             eof-value))
  46                       (t ,unread-form
  47                          ,char-var)))
  48              ,skipped-char-form))
  49           ((eql ,peek-type t)
  50            (do ((,char-var ,char-var ,read-form))
  51                ((or (eql ,char-var ,read-eof)
  52                     ;; whitespace[2]p will type-check for us
  53                     (not (whitespace[2]p ,char-var)))
  54                 (cond ((eql ,char-var ,read-eof)
  55                        ,(if eof-detected-form
  56                             eof-detected-form
  57                             eof-value))
  58                       (t ,unread-form
  59                          ,char-var)))
  60              ,skipped-char-form))
  61           ((null ,peek-type)
  62            ,unread-form
  63            ,char-var)
  64           (t
  65            (bug "Impossible case reached in PEEK-CHAR")))))
  66
  67 ;;; rudi (2004-08-09): There was an inline declaration for read-char,
  68 ;;; unread-char, read-byte, listen here that was removed because these
  69 ;;; functions are redefined when simple-streams are loaded.
  70
  71 #!-sb-fluid (declaim (inline ansi-stream-peek-char))
  72 (defun ansi-stream-peek-char (peek-type stream eof-error-p eof-value
  73                               recursive-p)
  74   (cond ((typep stream 'echo-stream)
  75          (echo-misc stream
  76                     :peek-char
  77                     peek-type
  78                     (list eof-error-p eof-value)))
  79         (t
  80          (generalized-peeking-mechanism
  81           peek-type eof-value char
  82           (ansi-stream-read-char stream eof-error-p :eof recursive-p)
  83           :eof
  84           (ansi-stream-unread-char char stream)))))
  85
  86 (defun peek-char (&optional (peek-type nil)
  87                             (stream *standard-input*)
  88                             (eof-error-p t)
  89                             eof-value
  90                             recursive-p)
  91   (declare (type (or character boolean) peek-type) (explicit-check))
  92   (let ((stream (in-stream-from-designator stream)))
  93     (if (ansi-stream-p stream)
  94         (ansi-stream-peek-char peek-type stream eof-error-p eof-value
  95                                recursive-p)
  96         ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
  97         (let ((char
  98                (generalized-peeking-mechanism
  99                 peek-type :eof char
 100                 (if (null peek-type)
 101                     (stream-peek-char stream)
 102                     (stream-read-char stream))
 103                 :eof
 104                 (if (null peek-type)
 105                     ()
 106                     (stream-unread-char stream char))
 107                 ()
 108                 (eof-or-lose stream eof-error-p eof-value))))
 109           (if (eq char eof-value)
 110               char
 111               (the character char))))))
 112
 113 (defun echo-misc (stream operation &optional arg1 arg2)
 114   (let* ((in (two-way-stream-input-stream stream))
 115          (out (two-way-stream-output-stream stream)))
 116     (case operation
 117       (:listen
 118        (if (ansi-stream-p in)
 119            (or (/= (the fixnum (ansi-stream-in-index in))
 120                    +ansi-stream-in-buffer-length+)
 121                (funcall (ansi-stream-misc in) in :listen))
 122            (stream-misc-dispatch in :listen)))
 123       (:unread (setf (echo-stream-unread-stuff stream) t)
 124                (unread-char arg1 in))
 125       (:element-type
 126        (let ((in-type (stream-element-type in))
 127              (out-type (stream-element-type out)))
 128          (if (equal in-type out-type)
 129              in-type
 130              `(and ,in-type ,out-type))))
 131       (:element-mode
 132        (let ((in-mode (stream-element-mode in))
 133              (out-mode (stream-element-mode out)))
 134          (when (equal in-mode out-mode)
 135            in-mode)))
 136       (:close
 137        (set-closed-flame stream))
 138       (:peek-char
 139        ;; For the special case of peeking into an echo-stream
 140        ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE)
 141        ;; returns peeked-char, eof-value, or errors end-of-file
 142        ;;
 143        ;; Note: This code could be moved into PEEK-CHAR if desired.
 144        ;; I am unsure whether this belongs with echo-streams because it is
 145        ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
 146        ;; -- mrd 2002-11-18
 147        ;;
 148        ;; UNREAD-P indicates whether the next character on IN was one
 149        ;; that was previously unread.  In that case, we need to ensure
 150        ;; that the semantics for UNREAD-CHAR are held; the character
 151        ;; should not be echoed again.
 152        (let ((unread-p nil)
 153              ;; The first peek shouldn't touch the unread-stuff slot.
 154              (initial-peek-p t))
 155          (flet ((outfn (c)
 156                   (unless unread-p
 157                     (if (ansi-stream-p out)
 158                         (funcall (ansi-stream-out out) out c)
 159                         ;; gray-stream
 160                         (stream-write-char out c))))
 161                 (infn ()
 162                   (if initial-peek-p
 163                       (setf unread-p (echo-stream-unread-stuff stream))
 164                       (setf (echo-stream-unread-stuff stream) nil))
 165                   (setf initial-peek-p nil)
 166                   (read-char in (first arg2) :eof)))
 167            (generalized-peeking-mechanism
 168             arg1 (second arg2) char
 169             (infn)
 170             :eof
 171             (unread-char char in)
 172             (outfn char)))))
 173       (t
 174        (or (if (ansi-stream-p in)
 175                (funcall (ansi-stream-misc in) in operation arg1 arg2)
 176                (stream-misc-dispatch in operation arg1 arg2))
 177            (if (ansi-stream-p out)
 178                (funcall (ansi-stream-misc out) out operation arg1 arg2)
 179                (stream-misc-dispatch out operation arg1 arg2)))))))