contrib/sb-simple-streams/strategy.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;; This code is in the public domain.
   4
   5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
   6 ;;; who placed the code in the public domain.  Sbcl port by Rudi
   7 ;;; Schlatte.
   8
   9 (in-package "SB-SIMPLE-STREAMS")
  10
  11
  12 (defun refill-buffer (stream blocking)
  13   (with-stream-class (simple-stream stream)
  14     (let* ((unread (sm last-char-read-size stream))
  15            (buffer (sm buffer stream)))
  16       (unless (zerop unread)
  17         ;; Keep last read character at beginning of buffer
  18         (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
  19       (let ((bytes (device-read stream nil unread nil blocking)))
  20         (declare (type fixnum bytes))
  21         (setf (sm buffpos stream) unread
  22               (sm buffer-ptr stream) (if (plusp bytes)
  23                                          (+ bytes unread)
  24                                          unread))
  25         bytes))))
  26
  27 (defun sc-flush-buffer (stream blocking)
  28   (with-stream-class (single-channel-simple-stream stream)
  29     (let ((ptr 0)
  30           (bytes (sm buffpos stream)))
  31       (declare (type fixnum ptr bytes))
  32       (loop
  33         (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return))
  34         (let ((bytes-written (device-write stream nil ptr nil blocking)))
  35           (declare (fixnum bytes-written))
  36           (when (minusp bytes-written)
  37             (error "DEVICE-WRITE error."))
  38           (incf ptr bytes-written))))))
  39
  40 (defun dc-flush-buffer (stream blocking)
  41   (with-stream-class (dual-channel-simple-stream stream)
  42     (let ((ptr 0)
  43           (bytes (sm outpos stream)))
  44       (declare (type fixnum ptr bytes))
  45       (loop
  46         (when (>= ptr bytes) (setf (sm outpos stream) 0) (return))
  47         (let ((bytes-written (device-write stream nil ptr nil blocking)))
  48           (declare (fixnum bytes-written))
  49           (when (minusp bytes-written)
  50             (error "DEVICE-WRITE error."))
  51           (incf ptr bytes-written))))))
  52
  53 ;;;
  54 ;;; SINGLE-CHANNEL STRATEGY FUNCTIONS
  55 ;;;
  56
  57 (declaim (ftype j-read-char-fn sc-read-char))
  58 (defun sc-read-char (stream eof-error-p eof-value blocking)
  59   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
  60   (with-stream-class (single-channel-simple-stream stream)
  61     ;; if stream is open for read-write, may need to flush the buffer
  62     (let* ((buffer (sm buffer stream))
  63            (ptr (sm buffpos stream))
  64            (code (if (< ptr (sm buffer-ptr stream))
  65                      (progn
  66                        (setf (sm buffpos stream) (1+ ptr))
  67                        (bref buffer ptr))
  68                      (let ((bytes (refill-buffer stream blocking)))
  69                        (declare (type fixnum bytes))
  70                        (unless (minusp bytes)
  71                          (let ((ptr (sm buffpos stream)))
  72                            (setf (sm buffpos stream) (1+ ptr))
  73                            (bref buffer ptr))))))
  74            (char (if code (code-char code) nil))
  75            (ctrl (sm control-in stream)))
  76       (when code
  77         (setf (sm last-char-read-size stream) 1)
  78         (when (and (< code 32) ctrl (svref ctrl code))
  79           ;; Does this have to be a function, or can it be a symbol?
  80           (setq char (funcall (the (or symbol function) (svref ctrl code))
  81                               stream char))))
  82       (if (null char)
  83           (sb-impl::eof-or-lose stream eof-error-p eof-value)
  84           char))))
  85
  86 (declaim (ftype j-read-char-fn sc-read-char--buffer))
  87 (defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
  88   (declare (ignore blocking)) ;; everything is already in the buffer
  89   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
  90   (with-stream-class (single-channel-simple-stream stream)
  91     (let* ((buffer (sm buffer stream))
  92            (ptr (sm buffpos stream))
  93            (code (when (< ptr (sm buffer-ptr stream))
  94                    (setf (sm buffpos stream) (1+ ptr))
  95                    (bref buffer ptr)))
  96            (char (if code (code-char code) nil))
  97            (ctrl (sm control-in stream)))
  98       (when code
  99         (setf (sm last-char-read-size stream) 1)
 100         (when (and (< code 32) ctrl (svref ctrl code))
 101           ;; Does this have to be a function, or can it be a symbol?
 102           (setq char (funcall (the (or symbol function) (svref ctrl code))
 103                               stream char))))
 104       (if (null char)
 105           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 106           char))))
 107
 108 (declaim (ftype j-read-chars-fn sc-read-chars))
 109 (defun sc-read-chars (stream string search start end blocking)
 110   ;; string is filled from START to END, or until SEARCH is found
 111   ;; Return two values: count of chars read and
 112   ;;  NIL if SEARCH was not found
 113   ;;  T is SEARCH was found
 114   ;;  :EOF if eof encountered before end
 115   (declare (type simple-stream stream)
 116            (type string string)
 117            (type (or null character) search)
 118            (type fixnum start end)
 119            (type boolean blocking)
 120            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 121   (with-stream-class (single-channel-simple-stream stream)
 122     (setf (sm last-char-read-size stream) 0)
 123     ;; Should arrange for the last character to be unreadable
 124     (do ((buffer (sm buffer stream))
 125          (ptr (sm buffpos stream))
 126          (max (sm buffer-ptr stream))
 127          (posn start (1+ posn))
 128          (count 0 (1+ count)))
 129         ((= posn end) (setf (sm buffpos stream) ptr) (values count nil))
 130       (declare (type fixnum ptr max posn count))
 131       (let* ((code (if (< ptr max)
 132                        (prog1
 133                            (bref buffer ptr)
 134                          (incf ptr))
 135                        (let ((bytes (refill-buffer stream blocking)))
 136                          (declare (type fixnum bytes))
 137                          (setf ptr (sm buffpos stream)
 138                                max (sm buffer-ptr stream))
 139                          (when (plusp bytes)
 140                            (prog1
 141                                (bref buffer ptr)
 142                              (incf ptr))))))
 143              (char (if code (code-char code) nil))
 144              (ctrl (sm control-in stream)))
 145         (when (and code (< code 32) ctrl (svref ctrl code))
 146           (setq char (funcall (the (or symbol function) (svref ctrl code))
 147                               stream char)))
 148         (cond ((null char)
 149                (setf (sm buffpos stream) ptr)
 150                (return (values count :eof)))
 151               ((and search (char= char search))
 152                (setf (sm buffpos stream) ptr)
 153                (return (values count t)))
 154               (t
 155                (setf (char string posn) char)))))))
 156
 157 (declaim (ftype j-read-chars-fn sc-read-chars--buffer))
 158 (defun sc-read-chars--buffer (stream string search start end blocking)
 159   (declare (type simple-stream stream)
 160            (type string string)
 161            (type (or null character) search)
 162            (type fixnum start end)
 163            (type boolean blocking)
 164            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 165   ;; TODO: what about the blocking parameter?
 166   (with-stream-class (single-channel-simple-stream stream)
 167     (do ((buffer (sm buffer stream))
 168          (ptr (sm buffpos stream))
 169          (max (sm buffer-ptr stream))
 170          (posn start (1+ posn))
 171          (count 0 (1+ count)))
 172         ((= posn end)
 173          (setf (sm buffpos stream) ptr)
 174          (unless (zerop count) (setf (sm last-char-read-size stream) 1))
 175          (values count nil))
 176       (declare (type fixnum ptr max posn count))
 177       (let* ((code (when (< ptr max)
 178                      (prog1
 179                          (bref buffer ptr)
 180                        (incf ptr))))
 181              (char (if code (code-char code) nil))
 182              (ctrl (sm control-in stream)))
 183         (when (and code (< code 32) ctrl (svref ctrl code))
 184           (setq char (funcall (the (or symbol function) (svref ctrl code))
 185                               stream char)))
 186         (cond ((null char)
 187                (setf (sm buffpos stream) ptr)
 188                (unless (zerop count) (setf (sm last-char-read-size stream) 1))
 189                (return (values count :eof)))
 190               ((and search (char= char search))
 191                (setf (sm buffpos stream) ptr)
 192                ;; Unread of last char must unread the search character, too
 193                ;; If no characters were read, just add the length of the
 194                ;; search char to that of the previously read char.
 195                (if (zerop count)
 196                    (incf (sm last-char-read-size stream))
 197                    (setf (sm last-char-read-size stream) 2))
 198                (return (values count t)))
 199               (t
 200                (setf (char string posn) char)))))))
 201
 202 (declaim (ftype j-unread-char-fn sc-unread-char))
 203 (defun sc-unread-char (stream relaxed)
 204   (declare (ignore relaxed))
 205   (with-stream-class (single-channel-simple-stream stream)
 206     (let ((unread (sm last-char-read-size stream)))
 207       (if (>= (sm buffpos stream) unread)
 208           (decf (sm buffpos stream) unread)
 209           (error "Unreading needs work"))
 210       (setf (sm last-char-read-size stream) 0))))
 211
 212 (declaim (ftype j-write-char-fn sc-write-char))
 213 (defun sc-write-char (character stream)
 214   (with-stream-class (single-channel-simple-stream stream)
 215     (let* ((buffer (sm buffer stream))
 216            (ptr (sm buffpos stream))
 217            (code (char-code character))
 218            (ctrl (sm control-out stream)))
 219       (when (and (< code 32) ctrl (svref ctrl code)
 220                  (funcall (the (or symbol function) (svref ctrl code))
 221                           stream character))
 222         (return-from sc-write-char character))
 223       ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
 224       (unless (< ptr (sm buffer-ptr stream))
 225         (sc-flush-buffer stream t)
 226         (setf ptr (sm buffpos stream)))
 227       (setf (bref buffer ptr) code)
 228       (setf (sm buffpos stream) (1+ ptr))))
 229   character)
 230
 231 (declaim (ftype j-write-chars-fn sc-write-chars))
 232 (defun sc-write-chars (string stream start end)
 233   (with-stream-class (single-channel-simple-stream stream)
 234     (do ((buffer (sm buffer stream))
 235          (ptr (sm buffpos stream))
 236          ;; xxx buffer-ptr or buf-len?  TODO: look them up in the
 237          ;; docs; was: buffer-ptr, but it's initialized to 0 in
 238          ;; (device-open file-simple-stream); buf-len seems to work(tm)
 239          (max #+nil(sm buffer-ptr stream) ;; or buf-len?
 240               (sm buf-len stream))
 241          (ctrl (sm control-out stream))
 242          (posn start (1+ posn))
 243          (count 0 (1+ count)))
 244         ((>= posn end) (setf (sm buffpos stream) ptr) count)
 245       (declare (type fixnum ptr max posn count))
 246       (let* ((char (char string posn))
 247              (code (char-code char)))
 248         (unless (and (< code 32) ctrl (svref ctrl code)
 249                      (funcall (the (or symbol function) (svref ctrl code))
 250                               stream char))
 251           (if (< ptr max)
 252               (progn
 253                 (setf (bref buffer ptr) code)
 254                 (incf ptr))
 255               (progn
 256                 (sc-flush-buffer stream t)
 257                 (setf ptr (sm buffpos stream)))))))))
 258
 259 (declaim (ftype j-listen-fn sc-listen))
 260 (defun sc-listen (stream)
 261   (with-stream-class (single-channel-simple-stream stream)
 262     (or (< (sm buffpos stream) (sm buffer-ptr stream))
 263         (case (device-read stream nil 0 0 nil)
 264           ((0 -2) nil)
 265           (-1 #| latch EOF |# nil)
 266           (-3 t)
 267           (t (error "DEVICE-READ error."))))))
 268
 269 ;;;
 270 ;;; DUAL-CHANNEL STRATEGY FUNCTIONS
 271 ;;;
 272
 273 (declaim (ftype j-read-char-fn dc-read-char))
 274 (defun dc-read-char (stream eof-error-p eof-value blocking)
 275   ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 276   (with-stream-class (dual-channel-simple-stream stream)
 277     ;; if interactive flag is set, finish-output first
 278     (let* ((buffer (sm buffer stream))
 279            (ptr (sm buffpos stream))
 280            (code (if (< ptr (sm buffer-ptr stream))
 281                      (progn
 282                        (setf (sm buffpos stream) (1+ ptr))
 283                        (bref buffer ptr))
 284                      (let ((bytes (refill-buffer stream blocking)))
 285                        (declare (type fixnum bytes))
 286                        (unless (minusp bytes)
 287                          (let ((ptr (sm buffpos stream)))
 288                            (setf (sm buffpos stream) (1+ ptr))
 289                            (bref buffer ptr))))))
 290            (char (if code (code-char code) nil))
 291            (ctrl (sm control-in stream)))
 292       (when code
 293         (setf (sm last-char-read-size stream) 1)
 294         (when (and (< code 32) ctrl (svref ctrl code))
 295           ;; Does this have to be a function, or can it be a symbol?
 296           (setq char (funcall (the (or symbol function) (svref ctrl code))
 297                               stream char)))
 298         #|(let ((column (sm charpos stream)))
 299           (declare (type (or null fixnum) column))
 300           (when column
 301             (setf (sm charpos stream) (1+ column))))|#)
 302       (if (null char)
 303           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 304           char))))
 305
 306 (declaim (ftype j-read-chars-fn dc-read-chars))
 307 (defun dc-read-chars (stream string search start end blocking)
 308   (declare (type dual-channel-simple-stream stream)
 309            (type string string)
 310            (type (or null character) search)
 311            (type fixnum start end)
 312            (type boolean blocking)
 313            #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
 314   (with-stream-class (dual-channel-simple-stream stream)
 315     ;; if interactive flag is set, finish-output first
 316     (setf (sm last-char-read-size stream) 0)
 317     ;; Should arrange for the last character to be unreadable
 318     (do ((buffer (sm buffer stream))
 319          (ptr (sm buffpos stream))
 320          (max (sm buffer-ptr stream))
 321          (posn start (1+ posn))
 322          (count 0 (1+ count)))
 323         ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
 324       (declare (type fixnum ptr max posn count))
 325       (let* ((code (if (< ptr max)
 326                        (prog1
 327                            (bref buffer ptr)
 328                          (incf ptr))
 329                        (let ((bytes (refill-buffer stream blocking)))
 330                          (declare (type fixnum bytes))
 331                          (setf ptr (sm buffpos stream)
 332                                max (sm buffer-ptr stream))
 333                          (when (plusp bytes)
 334                            (prog1
 335                                (bref buffer ptr)
 336                              (incf ptr))))))
 337              (char (if code (code-char code) nil))
 338              (ctrl (sm control-in stream)))
 339         (when (and code (< code 32) ctrl (svref ctrl code))
 340           (setq char (funcall (the (or symbol function) (svref ctrl code))
 341                               stream char)))
 342         #|(let ((column (sm charpos stream)))
 343           (declare (type (or null fixnum) column))
 344           (when column
 345             (setf (sm charpos stream) (1+ column))))|#
 346         (cond ((null char)
 347                (setf (sm buffpos stream) ptr)
 348                (return (values count :eof)))
 349               ((and search (char= char search))
 350                (setf (sm buffpos stream) ptr)
 351                (return (values count t)))
 352               (t
 353                (setf (char string posn) char)))))))
 354
 355 (declaim (ftype j-unread-char-fn dc-unread-char))
 356 (defun dc-unread-char (stream relaxed)
 357   (declare (ignore relaxed))
 358   (with-stream-class (dual-channel-simple-stream stream)
 359     (let ((unread (sm last-char-read-size stream)))
 360       (if (>= (sm buffpos stream) unread)
 361           (decf (sm buffpos stream) unread)
 362           (error "Unreading needs work"))
 363       (setf (sm last-char-read-size stream) 0))))
 364
 365 (declaim (ftype j-write-char-fn dc-write-char))
 366 (defun dc-write-char (character stream)
 367   (with-stream-class (dual-channel-simple-stream stream)
 368     (let* ((buffer (sm out-buffer stream))
 369            (ptr (sm outpos stream))
 370            (code (char-code character))
 371            (ctrl (sm control-out stream)))
 372       (when (and (< code 32) ctrl (svref ctrl code)
 373                  (funcall (the (or symbol function) (svref ctrl code))
 374                           stream character))
 375         (return-from dc-write-char character))
 376       (unless (< ptr (sm max-out-pos stream))
 377         (dc-flush-buffer stream t)
 378         (setf ptr (sm outpos stream)))
 379       (progn
 380         (setf (bref buffer ptr) code)
 381         (setf (sm outpos stream) (1+ ptr))
 382         )))
 383   character)
 384
 385 (declaim (ftype j-write-chars-fn dc-write-chars))
 386 (defun dc-write-chars (string stream start end)
 387   (with-stream-class (dual-channel-simple-stream stream)
 388     (do ((buffer (sm out-buffer stream))
 389          (ptr (sm outpos stream))
 390          (max (sm max-out-pos stream))
 391          (ctrl (sm control-out stream))
 392          (posn start (1+ posn))
 393          (count 0 (1+ count)))
 394         ((>= posn end) (setf (sm outpos stream) ptr) count)
 395       (declare (type fixnum ptr max posn count))
 396       (let* ((char (char string posn))
 397              (code (char-code char)))
 398         (unless (and (< code 32) ctrl (svref ctrl code)
 399                      (funcall (the (or symbol function) (svref ctrl code))
 400                               stream char))
 401           (if (< ptr max)
 402               (progn
 403                 (setf (bref buffer ptr) code)
 404                 (incf ptr))
 405               (progn
 406                 (dc-flush-buffer stream t)
 407                 (setf ptr (sm outpos stream)))))))))
 408
 409 (declaim (ftype j-listen-fn dc-listen))
 410 (defun dc-listen (stream)
 411   (with-stream-class (dual-channel-simple-stream stream)
 412     (or (< (sm buffpos stream) (sm buffer-ptr stream))
 413         (case (device-read stream nil 0 0 nil)
 414           ((0 -2) nil)
 415           (-1 #| latch EOF |# nil)
 416           (-3 t)
 417           (t (error "DEVICE-READ error."))))))
 418
 419 ;;;
 420 ;;; STRING STRATEGY FUNCTIONS
 421 ;;;
 422
 423 (declaim (ftype j-read-char-fn string-read-char))
 424 (defun string-read-char (stream eof-error-p eof-value blocking)
 425   (declare (type string-input-simple-stream stream) (ignore blocking)
 426            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 427   (with-stream-class (string-input-simple-stream stream)
 428     (when (any-stream-instance-flags stream :eof)
 429       (sb-impl::eof-or-lose stream eof-error-p eof-value))
 430     (let* ((ptr (sm buffpos stream))
 431            (char (if (< ptr (sm buffer-ptr stream))
 432                      (schar (sm buffer stream) ptr)
 433                      nil)))
 434       (if (null char)
 435           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 436           (progn
 437             (setf (sm last-char-read-size stream) 1)
 438             ;; do string-streams do control-in processing?
 439             #|(let ((column (sm charpos stream)))
 440               (declare (type (or null fixnum) column))
 441               (when column
 442                 (setf (sm charpos stream) (1+ column))))|#
 443             char)))))
 444
 445
 446 (declaim (ftype j-read-char-fn composing-crlf-read-char))
 447 (defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
 448   ;; TODO: what about the eof-error-p parameter?
 449   (with-stream-class (simple-stream stream)
 450     (let* ((melded-stream (sm melded-stream stream))
 451            (char (funcall-stm-handler j-read-char melded-stream nil stream
 452                                       blocking)))
 453       ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
 454       ;; character was available...
 455       (when (eql char #\Return)
 456         (let ((next (funcall-stm-handler j-read-char melded-stream
 457                                          nil stream blocking)))
 458           ;; if NEXT is STREAM, we hit EOF, so we should just return the
 459           ;; #\Return (and mark the stream :EOF?  At least unread if we
 460           ;; got a soft EOF, from a terminal, etc.
 461           ;; if NEXT is NIL, blocking is NIL and there's a CR but no
 462           ;; LF available on the stream: have to unread the CR and
 463           ;; return NIL, letting the CR be reread later.
 464           ;;
 465           ;; If we did get a linefeed, adjust the last-char-read-size
 466           ;; so that an unread of the resulting newline will unread both
 467           ;; the linefeed _and_ the carriage return.
 468           (if (eql next #\Linefeed)
 469               (setq char #\Newline)
 470               (funcall-stm-handler j-unread-char melded-stream nil))))
 471       ;; do control-in processing on whatever character we've got
 472       char)))
 473
 474 (declaim (ftype j-unread-char-fn composing-crlf-unread-char))
 475 (defun composing-crlf-unread-char (stream relaxed)
 476   (declare (ignore relaxed))
 477   (with-stream-class (simple-stream stream)
 478     (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
 479
 480 ;;;
 481 ;;;
 482 ;;;
 483
 484 (defun install-single-channel-character-strategy (stream external-format
 485                                                          access)
 486   (declare (ignore external-format))
 487   ;; ACCESS is usually NIL
 488   ;; May be "undocumented" values: stream::buffer, stream::mapped
 489   ;;   to install strategies suitable for direct buffer streams
 490   ;;   (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
 491   ;; (Avoids checking "mode" flags by installing special strategy)
 492   (with-stream-class (single-channel-simple-stream stream)
 493     (if (or (eq access 'buffer) (eq access 'mapped))
 494         (setf (sm j-read-char stream) #'sc-read-char--buffer
 495               (sm j-read-chars stream) #'sc-read-chars--buffer
 496               (sm j-unread-char stream) #'sc-unread-char
 497               (sm j-write-char stream) #'sc-write-char
 498               (sm j-write-chars stream) #'sc-write-chars
 499               (sm j-listen stream) #'sc-listen)
 500         (setf (sm j-read-char stream) #'sc-read-char
 501               (sm j-read-chars stream) #'sc-read-chars
 502               (sm j-unread-char stream) #'sc-unread-char
 503               (sm j-write-char stream) #'sc-write-char
 504               (sm j-write-chars stream) #'sc-write-chars
 505               (sm j-listen stream) #'sc-listen)))
 506   stream)
 507
 508 (defun install-dual-channel-character-strategy (stream external-format)
 509   (declare (ignore external-format))
 510   (with-stream-class (dual-channel-simple-stream stream)
 511     (setf (sm j-read-char stream) #'dc-read-char
 512           (sm j-read-chars stream) #'dc-read-chars
 513           (sm j-unread-char stream) #'dc-unread-char
 514           (sm j-write-char stream) #'dc-write-char
 515           (sm j-write-chars stream) #'dc-write-chars
 516           (sm j-listen stream) #'dc-listen))
 517   stream)
 518
 519 (defun install-string-character-strategy (stream)
 520   (with-stream-class (string-simple-stream stream)
 521     (setf (sm j-read-char stream) #'string-read-char))
 522   stream)