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 (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 ((.readtable. *readtable*)
  51                 (,char-var ,char-var ,read-form))
  52                ((or (eql ,char-var ,read-eof)
  53                     ;; whitespace[2]p will type-check for us
  54                     (not (whitespace[2]p ,char-var .readtable.)))
  55                 (cond ((eql ,char-var ,read-eof)
  56                        ,(if eof-detected-form
  57                             eof-detected-form
  58                             eof-value))
  59                       (t ,unread-form
  60                          ,char-var)))
  61              ,skipped-char-form))
  62           ((null ,peek-type)
  63            ,unread-form
  64            ,char-var)
  65           (t
  66            (bug "Impossible case reached in PEEK-CHAR")))))
  67
  68 ;;; rudi (2004-08-09): There was an inline declaration for read-char,
  69 ;;; unread-char, read-byte, listen here that was removed because these
  70 ;;; functions are redefined when simple-streams are loaded.
  71
  72 (declaim (inline ansi-stream-peek-char))
  73 (defun ansi-stream-peek-char (peek-type stream eof-error-p eof-value
  74                               recursive-p)
  75   (cond ((ansi-stream-cin-buffer stream)
  76          (prepare-for-fast-read-char stream
  77            (declare (ignore %frc-method%))
  78            (case peek-type
  79              ((nil)
  80               (block nil
  81                 (if (= %frc-index% +ansi-stream-in-buffer-length+)
  82                     (let ((index-or-nil (fast-read-char-refill %frc-stream% eof-error-p)))
  83                       (when (null index-or-nil)
  84                         (return eof-value))
  85                       (aref %frc-buffer% (truly-the (mod #.+ansi-stream-in-buffer-length+)
  86                                                     index-or-nil)))
  87                     (aref %frc-buffer% %frc-index%))))
  88              ((t)
  89               (let ((rt *readtable*))
  90                 (prog1
  91                     (loop
  92                      (when (= %frc-index% +ansi-stream-in-buffer-length+)
  93                        (let ((index-or-nil (fast-read-char-refill %frc-stream% eof-error-p)))
  94                          (when (null index-or-nil)
  95                            (return eof-value))
  96                          (setf %frc-index% (truly-the (mod #.+ansi-stream-in-buffer-length+)
  97                                                       index-or-nil))))
  98                      (let ((char (aref %frc-buffer% %frc-index%)))
  99                        (if (whitespace[2]p char rt)
 100                            (incf %frc-index%)
 101                            (return char))))
 102                   (done-with-fast-read-char))))
 103              (t
 104               (prog1
 105                   (loop
 106                    (when (= %frc-index% +ansi-stream-in-buffer-length+)
 107                      (let ((index-or-nil (fast-read-char-refill %frc-stream% eof-error-p)))
 108                        (when (null index-or-nil)
 109                          (return eof-value))
 110                        (setf %frc-index% (truly-the (mod #.+ansi-stream-in-buffer-length+)
 111                                                     index-or-nil))))
 112                    (let ((char (aref %frc-buffer% %frc-index%)))
 113                      (if (char= char peek-type)
 114                          (return char)
 115                          (incf %frc-index%))))
 116                 (done-with-fast-read-char))))))
 117         ((typep stream 'string-input-stream)
 118          (let ((limit (string-input-stream-limit stream))
 119                (string (string-input-stream-string stream))
 120                (index (string-input-stream-index stream)))
 121            (declare (optimize (sb-c:insert-array-bounds-checks 0)))
 122            (case peek-type
 123              ((nil)
 124               (if (>= index limit)
 125                   (eof-or-lose stream eof-error-p eof-value)
 126                   (char string index)))
 127              ((t)
 128               (let ((rt *readtable*))
 129                 (prog1
 130                     (loop
 131                      (when (>= index limit)
 132                        (return (eof-or-lose stream eof-error-p eof-value)))
 133                      (let ((char (char string index)))
 134                        (if (whitespace[2]p char rt)
 135                            (incf index)
 136                            (return char))))
 137                   (setf (string-input-stream-index stream) index))))
 138              (t
 139               (prog1
 140                   (loop
 141                    (when (>= index limit)
 142                      (return (eof-or-lose stream eof-error-p eof-value)))
 143                    (let ((char (char string index)))
 144                      (if (char= char peek-type)
 145                          (return char)
 146                          (incf index))))
 147                 (setf (string-input-stream-index stream) index))))))
 148         ((typep stream 'echo-stream)
 149          (echo-stream-peek-char stream peek-type eof-error-p eof-value))
 150         (t
 151          (generalized-peeking-mechanism
 152              peek-type eof-value char
 153              (ansi-stream-read-char stream eof-error-p :eof recursive-p)
 154              :eof
 155              (ansi-stream-unread-char char stream)))))
 156
 157 (defun peek-char (&optional (peek-type nil)
 158                             (stream *standard-input*)
 159                             (eof-error-p t)
 160                             eof-value
 161                             recursive-p)
 162   (declare (type (or character boolean) peek-type) (explicit-check))
 163   (stream-api-dispatch (stream :input)
 164     :simple (let ((char (s-%peek-char stream peek-type eof-error-p eof-value)))
 165               ;; simple-streams -%PEEK-CHAR always ignored RECURSIVE-P
 166               ;; so I removed it from the call.
 167               (if (eq char eof-value) char (the character char)))
 168     :native
 169         (ansi-stream-peek-char peek-type stream eof-error-p eof-value
 170                                recursive-p)
 171     :gray
 172         (let ((char
 173                (generalized-peeking-mechanism
 174                 peek-type :eof char
 175                 (if (null peek-type)
 176                     (stream-peek-char stream)
 177                     (stream-read-char stream))
 178                 :eof
 179                 (if (null peek-type)
 180                     ()
 181                     (stream-unread-char stream char))
 182                 ()
 183                 (eof-or-lose stream eof-error-p eof-value))))
 184           (if (eq char eof-value)
 185               char
 186               (the character char)))))
 187
 188 (defun echo-misc (stream operation arg1)
 189   (let* ((in (two-way-stream-input-stream stream))
 190          (out (two-way-stream-output-stream stream)))
 191     (stream-misc-case (operation)
 192       (:listen
 193        (if (ansi-stream-p in)
 194            (%ansi-stream-listen in)
 195            (stream-misc-dispatch in operation arg1)))
 196       (:unread (setf (echo-stream-unread-stuff stream) t)
 197                (unread-char arg1 in))
 198       (:element-type
 199        (let ((in-type (stream-element-type in))
 200              (out-type (stream-element-type out)))
 201          (if (equal in-type out-type)
 202              in-type
 203              `(and ,in-type ,out-type))))
 204       (:element-mode
 205        (let ((in-mode (stream-element-mode in))
 206              (out-mode (stream-element-mode out)))
 207          (when (equal in-mode out-mode)
 208            in-mode)))
 209       (:close
 210        (set-closed-flame stream))
 211       (t
 212        (or (if (ansi-stream-p in)
 213                (call-ansi-stream-misc in operation arg1)
 214                (stream-misc-dispatch in operation arg1))
 215            (if (ansi-stream-p out)
 216                (call-ansi-stream-misc out operation arg1)
 217                (stream-misc-dispatch out operation arg1)))))))
 218
 219 (defun echo-stream-peek-char (stream peek-type eof-error-p eof-value)
 220   (let* ((in (two-way-stream-input-stream stream))
 221          (out (two-way-stream-output-stream stream)))
 222        ;; returns peeked-char, eof-value, or errors end-of-file
 223        ;;
 224        ;; Note: This code could be moved into PEEK-CHAR if desired.
 225        ;; I am unsure whether this belongs with echo-streams because it is
 226        ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
 227        ;; -- mrd 2002-11-18
 228        ;;
 229        ;; UNREAD-P indicates whether the next character on IN was one
 230        ;; that was previously unread.  In that case, we need to ensure
 231        ;; that the semantics for UNREAD-CHAR are held; the character
 232        ;; should not be echoed again.
 233        (let ((unread-p nil)
 234              ;; The first peek shouldn't touch the unread-stuff slot.
 235              (initial-peek-p t))
 236          (flet ((outfn (c)
 237                   (unless unread-p
 238                     (if (ansi-stream-p out)
 239                         (funcall (ansi-stream-cout out) out c)
 240                         ;; gray-stream
 241                         (stream-write-char out c))))
 242                 (infn ()
 243                   (if initial-peek-p
 244                       (setf unread-p (echo-stream-unread-stuff stream))
 245                       (setf (echo-stream-unread-stuff stream) nil))
 246                   (setf initial-peek-p nil)
 247                   (read-char in eof-error-p :eof)))
 248            (generalized-peeking-mechanism
 249             peek-type eof-value char
 250             (infn)
 251             :eof
 252             (unread-char char in)
 253             (outfn char))))))
 254
 255 ;;; Stop wasting space with unnecessarily preserved inline definitions.
 256 ;;; ANSI-STREAM-LISTEN, %ANSI-STREAM-LISTEN, ANSI-STREAM-CLEAR-INPUT
 257 ;;; are needed for sb-simple-streams.
 258 ;;; Maybe everything else can just get dropped entirely, the symbol and its
 259 ;;; function, instead of just the inline sexpr.
 260 (dolist (name '(!ansi-stream-ftell
 261                 ansi-stream-read-line ansi-stream-read-char
 262                 ansi-stream-unread-char
 263                 ansi-stream-read-char-no-hang
 264                 ansi-stream-read-byte read-n-bytes
 265                 read-char unread-char read-byte
 266                 read-sequence/read-function write-sequence/write-function
 267                 stream-element-mode))
 268   (clear-info :function :inlinep name)
 269   (clear-info :function :inlining-data name))
 270 ;;; Can all the ANSI- function names be removed now? Maybe?
 271 (push '("SB-IMPL" ansi-stream-peek-char ansi-stream-unread-char)
 272       *!removable-symbols*)
 273 ;;; These two wants to get invoked by simple-streams but would get tree-shaken out
 274 ;;; were they not externalized.
 275 (export '(sb-impl::in-stream-from-designator sb-impl::eof-or-lose)
 276         'sb-impl)