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           (unless (< ptr max)
 252             ;; need to update buffpos before control leaves this
 253             ;; function in any way
 254             (setf (sm buffpos stream) ptr)
 255             (sc-flush-buffer stream t)
 256             (setf ptr (sm buffpos stream)))
 257           (setf (bref buffer ptr) code)
 258           (incf ptr))))))
 259
 260 (declaim (ftype j-listen-fn sc-listen))
 261 (defun sc-listen (stream)
 262   (with-stream-class (single-channel-simple-stream stream)
 263     (or (< (sm buffpos stream) (sm buffer-ptr stream))
 264         (case (device-read stream nil 0 0 nil)
 265           ((0 -2) nil)
 266           (-1 #| latch EOF |# nil)
 267           (-3 t)
 268           (t (error "DEVICE-READ error."))))))
 269
 270 ;;;
 271 ;;; DUAL-CHANNEL STRATEGY FUNCTIONS
 272 ;;;
 273
 274 (declaim (ftype j-read-char-fn dc-read-char))
 275 (defun dc-read-char (stream eof-error-p eof-value blocking)
 276   ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 277   (with-stream-class (dual-channel-simple-stream stream)
 278     ;; if interactive flag is set, finish-output first
 279     (let* ((buffer (sm buffer stream))
 280            (ptr (sm buffpos stream))
 281            (code (if (< ptr (sm buffer-ptr stream))
 282                      (progn
 283                        (setf (sm buffpos stream) (1+ ptr))
 284                        (bref buffer ptr))
 285                      (let ((bytes (refill-buffer stream blocking)))
 286                        (declare (type fixnum bytes))
 287                        (unless (minusp bytes)
 288                          (let ((ptr (sm buffpos stream)))
 289                            (setf (sm buffpos stream) (1+ ptr))
 290                            (bref buffer ptr))))))
 291            (char (if code (code-char code) nil))
 292            (ctrl (sm control-in stream)))
 293       (when code
 294         (setf (sm last-char-read-size stream) 1)
 295         (when (and (< code 32) ctrl (svref ctrl code))
 296           ;; Does this have to be a function, or can it be a symbol?
 297           (setq char (funcall (the (or symbol function) (svref ctrl code))
 298                               stream char)))
 299         #|(let ((column (sm charpos stream)))
 300           (declare (type (or null fixnum) column))
 301           (when column
 302             (setf (sm charpos stream) (1+ column))))|#)
 303       (if (null char)
 304           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 305           char))))
 306
 307 (declaim (ftype j-read-chars-fn dc-read-chars))
 308 (defun dc-read-chars (stream string search start end blocking)
 309   (declare (type dual-channel-simple-stream stream)
 310            (type string string)
 311            (type (or null character) search)
 312            (type fixnum start end)
 313            (type boolean blocking)
 314            #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
 315   (with-stream-class (dual-channel-simple-stream stream)
 316     ;; if interactive flag is set, finish-output first
 317     (setf (sm last-char-read-size stream) 0)
 318     ;; Should arrange for the last character to be unreadable
 319     (do ((buffer (sm buffer stream))
 320          (ptr (sm buffpos stream))
 321          (max (sm buffer-ptr stream))
 322          (posn start (1+ posn))
 323          (count 0 (1+ count)))
 324         ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
 325       (declare (type fixnum ptr max posn count))
 326       (let* ((code (if (< ptr max)
 327                        (prog1
 328                            (bref buffer ptr)
 329                          (incf ptr))
 330                        (let ((bytes (refill-buffer stream blocking)))
 331                          (declare (type fixnum bytes))
 332                          (setf ptr (sm buffpos stream)
 333                                max (sm buffer-ptr stream))
 334                          (when (plusp bytes)
 335                            (prog1
 336                                (bref buffer ptr)
 337                              (incf ptr))))))
 338              (char (if code (code-char code) nil))
 339              (ctrl (sm control-in stream)))
 340         (when (and code (< code 32) ctrl (svref ctrl code))
 341           (setq char (funcall (the (or symbol function) (svref ctrl code))
 342                               stream char)))
 343         #|(let ((column (sm charpos stream)))
 344           (declare (type (or null fixnum) column))
 345           (when column
 346             (setf (sm charpos stream) (1+ column))))|#
 347         (cond ((null char)
 348                (setf (sm buffpos stream) ptr)
 349                (return (values count :eof)))
 350               ((and search (char= char search))
 351                (setf (sm buffpos stream) ptr)
 352                (return (values count t)))
 353               (t
 354                (setf (char string posn) char)))))))
 355
 356 (declaim (ftype j-unread-char-fn dc-unread-char))
 357 (defun dc-unread-char (stream relaxed)
 358   (declare (ignore relaxed))
 359   (with-stream-class (dual-channel-simple-stream stream)
 360     (let ((unread (sm last-char-read-size stream)))
 361       (if (>= (sm buffpos stream) unread)
 362           (decf (sm buffpos stream) unread)
 363           (error "Unreading needs work"))
 364       (setf (sm last-char-read-size stream) 0))))
 365
 366 (declaim (ftype j-write-char-fn dc-write-char))
 367 (defun dc-write-char (character stream)
 368   (with-stream-class (dual-channel-simple-stream stream)
 369     (let* ((buffer (sm out-buffer stream))
 370            (ptr (sm outpos stream))
 371            (code (char-code character))
 372            (ctrl (sm control-out stream)))
 373       (when (and (< code 32) ctrl (svref ctrl code)
 374                  (funcall (the (or symbol function) (svref ctrl code))
 375                           stream character))
 376         (return-from dc-write-char character))
 377       (unless (< ptr (sm max-out-pos stream))
 378         (dc-flush-buffer stream t)
 379         (setf ptr (sm outpos stream)))
 380       (progn
 381         (setf (bref buffer ptr) code)
 382         (setf (sm outpos stream) (1+ ptr))
 383         )))
 384   character)
 385
 386 (declaim (ftype j-write-chars-fn dc-write-chars))
 387 (defun dc-write-chars (string stream start end)
 388   (with-stream-class (dual-channel-simple-stream stream)
 389     (do ((buffer (sm out-buffer stream))
 390          (ptr (sm outpos stream))
 391          (max (sm max-out-pos stream))
 392          (ctrl (sm control-out stream))
 393          (posn start (1+ posn))
 394          (count 0 (1+ count)))
 395         ((>= posn end) (setf (sm outpos stream) ptr) count)
 396       (declare (type fixnum ptr max posn count))
 397       (let* ((char (char string posn))
 398              (code (char-code char)))
 399         (unless (and (< code 32) ctrl (svref ctrl code)
 400                      (funcall (the (or symbol function) (svref ctrl code))
 401                               stream char))
 402           (unless (< ptr max)
 403             (setf (sm outpos stream) ptr)
 404             (dc-flush-buffer stream t)
 405             (setf ptr (sm outpos stream)))
 406           (setf (bref buffer ptr) code)
 407           (incf ptr))
 408         ))))
 409
 410 (declaim (ftype j-listen-fn dc-listen))
 411 (defun dc-listen (stream)
 412   (with-stream-class (dual-channel-simple-stream stream)
 413     (or (< (sm buffpos stream) (sm buffer-ptr stream))
 414         (case (device-read stream nil 0 0 nil)
 415           ((0 -2) nil)
 416           (-1 #| latch EOF |# nil)
 417           (-3 t)
 418           (t (error "DEVICE-READ error."))))))
 419
 420 ;;;
 421 ;;; STRING STRATEGY FUNCTIONS
 422 ;;;
 423
 424 (declaim (ftype j-read-char-fn string-read-char))
 425 (defun string-read-char (stream eof-error-p eof-value blocking)
 426   (declare (type string-input-simple-stream stream) (ignore blocking)
 427            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 428   (with-stream-class (string-input-simple-stream stream)
 429     (when (any-stream-instance-flags stream :eof)
 430       (sb-impl::eof-or-lose stream eof-error-p eof-value))
 431     (let* ((ptr (sm buffpos stream))
 432            (char (if (< ptr (sm buffer-ptr stream))
 433                      (schar (sm buffer stream) ptr)
 434                      nil)))
 435       (if (null char)
 436           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 437           (progn
 438             (setf (sm last-char-read-size stream) 1)
 439             ;; do string-streams do control-in processing?
 440             #|(let ((column (sm charpos stream)))
 441               (declare (type (or null fixnum) column))
 442               (when column
 443                 (setf (sm charpos stream) (1+ column))))|#
 444             char)))))
 445
 446
 447 (declaim (ftype j-read-char-fn composing-crlf-read-char))
 448 (defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
 449   ;; TODO: what about the eof-error-p parameter?
 450   (with-stream-class (simple-stream stream)
 451     (let* ((melded-stream (sm melded-stream stream))
 452            (char (funcall-stm-handler j-read-char melded-stream nil stream
 453                                       blocking)))
 454       ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
 455       ;; character was available...
 456       (when (eql char #\Return)
 457         (let ((next (funcall-stm-handler j-read-char melded-stream
 458                                          nil stream blocking)))
 459           ;; if NEXT is STREAM, we hit EOF, so we should just return the
 460           ;; #\Return (and mark the stream :EOF?  At least unread if we
 461           ;; got a soft EOF, from a terminal, etc.
 462           ;; if NEXT is NIL, blocking is NIL and there's a CR but no
 463           ;; LF available on the stream: have to unread the CR and
 464           ;; return NIL, letting the CR be reread later.
 465           ;;
 466           ;; If we did get a linefeed, adjust the last-char-read-size
 467           ;; so that an unread of the resulting newline will unread both
 468           ;; the linefeed _and_ the carriage return.
 469           (if (eql next #\Linefeed)
 470               (setq char #\Newline)
 471               (funcall-stm-handler j-unread-char melded-stream nil))))
 472       ;; do control-in processing on whatever character we've got
 473       char)))
 474
 475 (declaim (ftype j-unread-char-fn composing-crlf-unread-char))
 476 (defun composing-crlf-unread-char (stream relaxed)
 477   (declare (ignore relaxed))
 478   (with-stream-class (simple-stream stream)
 479     (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
 480
 481 ;;;
 482 ;;;
 483 ;;;
 484
 485 (defun install-single-channel-character-strategy (stream external-format
 486                                                          access)
 487   (declare (ignore external-format))
 488   ;; ACCESS is usually NIL
 489   ;; May be "undocumented" values: stream::buffer, stream::mapped
 490   ;;   to install strategies suitable for direct buffer streams
 491   ;;   (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
 492   ;; (Avoids checking "mode" flags by installing special strategy)
 493   (with-stream-class (single-channel-simple-stream stream)
 494     (if (or (eq access 'buffer) (eq access 'mapped))
 495         (setf (sm j-read-char stream) #'sc-read-char--buffer
 496               (sm j-read-chars stream) #'sc-read-chars--buffer
 497               (sm j-unread-char stream) #'sc-unread-char
 498               (sm j-write-char stream) #'sc-write-char
 499               (sm j-write-chars stream) #'sc-write-chars
 500               (sm j-listen stream) #'sc-listen)
 501         (setf (sm j-read-char stream) #'sc-read-char
 502               (sm j-read-chars stream) #'sc-read-chars
 503               (sm j-unread-char stream) #'sc-unread-char
 504               (sm j-write-char stream) #'sc-write-char
 505               (sm j-write-chars stream) #'sc-write-chars
 506               (sm j-listen stream) #'sc-listen)))
 507   stream)
 508
 509 (defun install-dual-channel-character-strategy (stream external-format)
 510   (declare (ignore external-format))
 511   (with-stream-class (dual-channel-simple-stream stream)
 512     (setf (sm j-read-char stream) #'dc-read-char
 513           (sm j-read-chars stream) #'dc-read-chars
 514           (sm j-unread-char stream) #'dc-unread-char
 515           (sm j-write-char stream) #'dc-write-char
 516           (sm j-write-chars stream) #'dc-write-chars
 517           (sm j-listen stream) #'dc-listen))
 518   stream)
 519
 520 (defun install-string-character-strategy (stream)
 521   (with-stream-class (string-simple-stream stream)
 522     (setf (sm j-read-char stream) #'string-read-char))
 523   stream)