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
  13 (defun sc-refill-buffer (stream blocking)
  14   (with-stream-class (single-channel-simple-stream stream)
  15     (when (any-stream-instance-flags stream :dirty)
  16       ;; FIXME: Implement flush-buffer failure protocol instead of
  17       ;; blocking here
  18       (sc-flush-buffer stream t))
  19     (let* ((unread (sm last-char-read-size stream))
  20            (buffer (sm buffer stream)))
  21       (unless (zerop unread)
  22         (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
  23       (let ((bytes (device-read stream nil unread nil blocking)))
  24         (declare (type fixnum bytes))
  25         (setf (sm buffpos stream) unread
  26               (sm buffer-ptr stream) (if (plusp bytes)
  27                                          (+ bytes unread)
  28                                          unread))
  29         bytes))))
  30
  31
  32 (defun sc-flush-buffer (stream blocking)
  33   (with-stream-class (single-channel-simple-stream stream)
  34     (let ((ptr 0)
  35           (bytes (sm buffpos stream)))
  36       (declare (type fixnum ptr bytes))
  37       ;; Seek to the left before flushing buffer -- the user could
  38       ;; have set the file-position, and scribbled something in the
  39       ;; data that was read from the file.
  40       (when (> (sm buffer-ptr stream) 0)
  41         (setf (device-file-position stream)
  42               (- (device-file-position stream) (sm buffer-ptr stream))))
  43       (loop
  44         (when (>= ptr bytes)
  45           (setf (sm buffpos stream) 0
  46                 (sm buffer-ptr stream) 0)
  47           (remove-stream-instance-flags stream :dirty)
  48           (return 0))
  49         (let ((bytes-written (device-write stream nil ptr bytes blocking)))
  50           (declare (fixnum bytes-written))
  51           (when (minusp bytes-written)
  52             (error "DEVICE-WRITE error."))
  53           (incf ptr bytes-written))))))
  54
  55 (defun dc-refill-buffer (stream blocking)
  56   (with-stream-class (dual-channel-simple-stream stream)
  57     (let* ((unread (sm last-char-read-size stream))
  58            (buffer (sm buffer stream)))
  59       (unless (zerop unread)
  60         (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
  61       (let ((bytes (device-read stream nil unread nil blocking)))
  62         (declare (type fixnum bytes))
  63         (setf (sm buffpos stream) unread
  64               (sm buffer-ptr stream) (if (plusp bytes)
  65                                          (+ bytes unread)
  66                                          unread))
  67         bytes))))
  68
  69 (defun dc-flush-buffer (stream blocking)
  70   (with-stream-class (dual-channel-simple-stream stream)
  71     (let ((ptr 0)
  72           (bytes (sm outpos stream)))
  73       (declare (type fixnum ptr bytes))
  74       (loop
  75         (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0))
  76         (let ((bytes-written (device-write stream nil ptr bytes blocking)))
  77           (declare (fixnum bytes-written))
  78           (when (minusp bytes-written)
  79             (error "DEVICE-WRITE error."))
  80           (incf ptr bytes-written))))))
  81
  82 ;;;
  83 ;;; SINGLE-CHANNEL STRATEGY FUNCTIONS
  84 ;;;
  85
  86 (declaim (ftype j-read-char-fn sc-read-char))
  87 (defun sc-read-char (stream eof-error-p eof-value blocking)
  88   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
  89   (with-stream-class (single-channel-simple-stream stream)
  90     ;; if stream is open for read-write, may need to flush the buffer
  91     (let* ((buffer (sm buffer stream))
  92            (ptr (sm buffpos stream))
  93            (code (if (< ptr (sm buffer-ptr stream))
  94                      (progn
  95                        (setf (sm buffpos stream) (1+ ptr))
  96                        (bref buffer ptr))
  97                      (let ((bytes (sc-refill-buffer stream blocking)))
  98                        (declare (type fixnum bytes))
  99                        (unless (minusp bytes)
 100                          (let ((ptr (sm buffpos stream)))
 101                            (setf (sm buffpos stream) (1+ ptr))
 102                            (bref buffer ptr))))))
 103            (char (if code (code-char code) nil))
 104            (ctrl (sm control-in stream)))
 105       (when code
 106         (setf (sm last-char-read-size stream) 1)
 107         (when (and (< code 32) ctrl (svref ctrl code))
 108           ;; Does this have to be a function, or can it be a symbol?
 109           (setq char (funcall (the (or symbol function) (svref ctrl code))
 110                               stream char))))
 111       (if (null char)
 112           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 113           char))))
 114
 115 (declaim (ftype j-read-char-fn sc-read-char--buffer))
 116 (defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
 117   (declare (ignore blocking)) ;; everything is already in the buffer
 118   (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 119   (with-stream-class (single-channel-simple-stream stream)
 120     (let* ((buffer (sm buffer stream))
 121            (ptr (sm buffpos stream))
 122            (code (when (< ptr (sm buffer-ptr stream))
 123                    (setf (sm buffpos stream) (1+ ptr))
 124                    (bref buffer ptr)))
 125            (char (if code (code-char code) nil))
 126            (ctrl (sm control-in stream)))
 127       (when code
 128         (setf (sm last-char-read-size stream) 1)
 129         (when (and (< code 32) ctrl (svref ctrl code))
 130           ;; Does this have to be a function, or can it be a symbol?
 131           (setq char (funcall (the (or symbol function) (svref ctrl code))
 132                               stream char))))
 133       (if (null char)
 134           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 135           char))))
 136
 137 (declaim (ftype j-read-chars-fn sc-read-chars))
 138 (defun sc-read-chars (stream string search start end blocking)
 139   ;; string is filled from START to END, or until SEARCH is found
 140   ;; Return two values: count of chars read and
 141   ;;  NIL if SEARCH was not found
 142   ;;  T is SEARCH was found
 143   ;;  :EOF if eof encountered before end
 144   (declare (type simple-stream stream)
 145            (type string string)
 146            (type (or null character) search)
 147            (type fixnum start end)
 148            (type boolean blocking)
 149            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 150   (with-stream-class (single-channel-simple-stream stream)
 151     (setf (sm last-char-read-size stream) 0)
 152     ;; FIXME: Should arrange for the last character to be unreadable
 153     (do ((buffer (sm buffer stream))
 154          (ptr (sm buffpos stream))
 155          (max (sm buffer-ptr stream))
 156          (posn start (1+ posn))
 157          (count 0 (1+ count)))
 158         ((= posn end) (setf (sm buffpos stream) ptr) (values count nil))
 159       (declare (type fixnum ptr max posn count))
 160       (let* ((code (if (< ptr max)
 161                        (prog1
 162                            (bref buffer ptr)
 163                          (incf ptr))
 164                        (let ((bytes (sc-refill-buffer stream blocking)))
 165                          (declare (type fixnum bytes))
 166                          (setf ptr (sm buffpos stream)
 167                                max (sm buffer-ptr stream))
 168                          (when (plusp bytes)
 169                            (prog1
 170                                (bref buffer ptr)
 171                              (incf ptr))))))
 172              (char (if code (code-char code) nil))
 173              (ctrl (sm control-in stream)))
 174         (when (and code (< code 32) ctrl (svref ctrl code))
 175           (setq char (funcall (the (or symbol function) (svref ctrl code))
 176                               stream char)))
 177         (cond ((null char)
 178                (setf (sm buffpos stream) ptr)
 179                (return (values count :eof)))
 180               ((and search (char= char search))
 181                (setf (sm buffpos stream) ptr)
 182                (return (values count t)))
 183               (t
 184                (setf (char string posn) char)))))))
 185
 186 (declaim (ftype j-read-chars-fn sc-read-chars--buffer))
 187 (defun sc-read-chars--buffer (stream string search start end blocking)
 188   (declare (type simple-stream stream)
 189            (type string string)
 190            (type (or null character) search)
 191            (type fixnum start end)
 192            (type boolean blocking)
 193            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 194   (declare (ignore blocking))           ; everything is in the buffer
 195   (with-stream-class (single-channel-simple-stream stream)
 196     (do ((buffer (sm buffer stream))
 197          (ptr (sm buffpos stream))
 198          (max (sm buffer-ptr stream))
 199          (posn start (1+ posn))
 200          (count 0 (1+ count)))
 201         ((= posn end)
 202          (setf (sm buffpos stream) ptr)
 203          (unless (zerop count) (setf (sm last-char-read-size stream) 1))
 204          (values count nil))
 205       (declare (type fixnum ptr max posn count))
 206       (let* ((code (when (< ptr max)
 207                      (prog1
 208                          (bref buffer ptr)
 209                        (incf ptr))))
 210              (char (if code (code-char code) nil))
 211              (ctrl (sm control-in stream)))
 212         (when (and code (< code 32) ctrl (svref ctrl code))
 213           (setq char (funcall (the (or symbol function) (svref ctrl code))
 214                               stream char)))
 215         (cond ((null char)
 216                (setf (sm buffpos stream) ptr)
 217                (unless (zerop count) (setf (sm last-char-read-size stream) 1))
 218                (return (values count :eof)))
 219               ((and search (char= char search))
 220                (setf (sm buffpos stream) ptr)
 221                ;; Unread of last char must unread the search character, too
 222                ;; If no characters were read, just add the length of the
 223                ;; search char to that of the previously read char.
 224                (if (zerop count)
 225                    (incf (sm last-char-read-size stream))
 226                    (setf (sm last-char-read-size stream) 2))
 227                (return (values count t)))
 228               (t
 229                (setf (char string posn) char)))))))
 230
 231 (declaim (ftype j-unread-char-fn sc-unread-char))
 232 (defun sc-unread-char (stream relaxed)
 233   (declare (ignore relaxed))
 234   (with-stream-class (single-channel-simple-stream stream)
 235     (let ((unread (sm last-char-read-size stream)))
 236       (if (>= (sm buffpos stream) unread)
 237           (decf (sm buffpos stream) unread)
 238           (error "Unreading needs work"))
 239       (setf (sm last-char-read-size stream) 0))))
 240
 241 (declaim (ftype j-write-char-fn sc-write-char))
 242 (defun sc-write-char (character stream)
 243   (with-stream-class (single-channel-simple-stream stream)
 244     (let* ((buffer (sm buffer stream))
 245            (ptr (sm buffpos stream))
 246            (code (char-code character))
 247            (ctrl (sm control-out stream)))
 248       (when (and (< code 32) ctrl (svref ctrl code)
 249                  (funcall (the (or symbol function) (svref ctrl code))
 250                           stream character))
 251         (return-from sc-write-char character))
 252       (when (>= ptr (sm buf-len stream))
 253         (setf ptr (sc-flush-buffer stream t)))
 254       (setf (bref buffer ptr) code)
 255       (setf (sm buffpos stream) (1+ ptr))
 256       (add-stream-instance-flags stream :dirty)))
 257   character)
 258
 259 (declaim (ftype j-write-chars-fn sc-write-chars))
 260 (defun sc-write-chars (string stream start end)
 261   (with-stream-class (single-channel-simple-stream stream)
 262     (do ((buffer (sm buffer stream))
 263          (ptr (sm buffpos stream))
 264          (max (sm buf-len stream))
 265          (ctrl (sm control-out stream))
 266          (posn start (1+ posn))
 267          (count 0 (1+ count)))
 268         ((>= posn end)
 269          (setf (sm buffpos stream) ptr)
 270          (add-stream-instance-flags stream :dirty)
 271          count)
 272       (declare (type fixnum ptr max posn count))
 273       (let* ((char (char string posn))
 274              (code (char-code char)))
 275         ;; FIXME: Can functions in the control-out table side-effect
 276         ;; the stream?  Section 9.0 prohibits this only for control-in
 277         ;; functions.  If they can, update (sm buffpos stream) here,
 278         ;; like around the call to sc-flush-buffer below
 279         (unless (and (< code 32) ctrl (svref ctrl code)
 280                      (funcall (the (or symbol function) (svref ctrl code))
 281                               stream char))
 282           (unless (< ptr max)
 283             ;; need to update buffpos before control leaves this
 284             ;; function in any way
 285             (setf (sm buffpos stream) ptr)
 286             (sc-flush-buffer stream t)
 287             (setf ptr (sm buffpos stream)))
 288           (setf (bref buffer ptr) code)
 289           (incf ptr))))))
 290
 291 (declaim (ftype j-listen-fn sc-listen))
 292 (defun sc-listen (stream)
 293   (with-stream-class (single-channel-simple-stream stream)
 294     (or (< (sm buffpos stream) (sm buffer-ptr stream))
 295         (case (device-read stream nil 0 0 nil)
 296           ((0 -2) nil)
 297           (-1 #| latch EOF |# nil)
 298           (-3 t)
 299           (t (error "DEVICE-READ error."))))))
 300
 301 ;;; SC-READ-BYTE doesn't actually live in a strategy slot
 302 (defun sc-read-byte (stream eof-error-p eof-value blocking)
 303   (with-stream-class (single-channel-simple-stream stream)
 304     ;; @@1
 305     (let ((ptr (sm buffpos stream)))
 306       (when (>= ptr (sm buffer-ptr stream))
 307         (let ((bytes (device-read stream nil 0 nil blocking)))
 308           (declare (type fixnum bytes))
 309           (if (plusp bytes)
 310               (setf (sm buffer-ptr stream) bytes
 311                     ptr 0)
 312               (return-from sc-read-byte
 313                 (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
 314       (setf (sm buffpos stream) (1+ ptr))
 315       (setf (sm last-char-read-size stream) 0)
 316       (bref (sm buffer stream) ptr))))
 317
 318 ;;;
 319 ;;; DUAL-CHANNEL STRATEGY FUNCTIONS
 320 ;;;
 321
 322 (declaim (ftype j-read-char-fn dc-read-char))
 323 (defun dc-read-char (stream eof-error-p eof-value blocking)
 324   ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 325   (with-stream-class (dual-channel-simple-stream stream)
 326     ;; if interactive flag is set, finish-output first
 327     (let* ((buffer (sm buffer stream))
 328            (ptr (sm buffpos stream))
 329            (code (if (< ptr (sm buffer-ptr stream))
 330                      (progn
 331                        (setf (sm buffpos stream) (1+ ptr))
 332                        (bref buffer ptr))
 333                      (let ((bytes (dc-refill-buffer stream blocking)))
 334                        (declare (type fixnum bytes))
 335                        (unless (minusp bytes)
 336                          (let ((ptr (sm buffpos stream)))
 337                            (setf (sm buffpos stream) (1+ ptr))
 338                            (bref buffer ptr))))))
 339            (char (if code (code-char code) nil))
 340            (ctrl (sm control-in stream)))
 341       (when code
 342         (setf (sm last-char-read-size stream) 1)
 343         (when (and (< code 32) ctrl (svref ctrl code))
 344           ;; Does this have to be a function, or can it be a symbol?
 345           (setq char (funcall (the (or symbol function) (svref ctrl code))
 346                               stream char)))
 347         #|(let ((column (sm charpos stream)))
 348           (declare (type (or null fixnum) column))
 349           (when column
 350             (setf (sm charpos stream) (1+ column))))|#)
 351       (if (null char)
 352           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 353           char))))
 354
 355 (declaim (ftype j-read-chars-fn dc-read-chars))
 356 (defun dc-read-chars (stream string search start end blocking)
 357   (declare (type dual-channel-simple-stream stream)
 358            (type string string)
 359            (type (or null character) search)
 360            (type fixnum start end)
 361            (type boolean blocking)
 362            #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
 363   (with-stream-class (dual-channel-simple-stream stream)
 364     ;; if interactive flag is set, finish-output first
 365     (setf (sm last-char-read-size stream) 0)
 366     ;; Should arrange for the last character to be unreadable
 367     (do ((buffer (sm buffer stream))
 368          (ptr (sm buffpos stream))
 369          (max (sm buffer-ptr stream))
 370          (posn start (1+ posn))
 371          (count 0 (1+ count)))
 372         ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
 373       (declare (type fixnum ptr max posn count))
 374       (let* ((code (if (< ptr max)
 375                        (prog1
 376                            (bref buffer ptr)
 377                          (incf ptr))
 378                        (let ((bytes (dc-refill-buffer stream blocking)))
 379                          (declare (type fixnum bytes))
 380                          (setf ptr (sm buffpos stream)
 381                                max (sm buffer-ptr stream))
 382                          (when (plusp bytes)
 383                            (prog1
 384                                (bref buffer ptr)
 385                              (incf ptr))))))
 386              (char (if code (code-char code) nil))
 387              (ctrl (sm control-in stream)))
 388         (when (and code (< code 32) ctrl (svref ctrl code))
 389           (setq char (funcall (the (or symbol function) (svref ctrl code))
 390                               stream char)))
 391         #|(let ((column (sm charpos stream)))
 392           (declare (type (or null fixnum) column))
 393           (when column
 394             (setf (sm charpos stream) (1+ column))))|#
 395         (cond ((null char)
 396                (setf (sm buffpos stream) ptr)
 397                (return (values count :eof)))
 398               ((and search (char= char search))
 399                (setf (sm buffpos stream) ptr)
 400                (return (values count t)))
 401               (t
 402                (setf (char string posn) char)))))))
 403
 404 (declaim (ftype j-unread-char-fn dc-unread-char))
 405 (defun dc-unread-char (stream relaxed)
 406   (declare (ignore relaxed))
 407   (with-stream-class (dual-channel-simple-stream stream)
 408     (let ((unread (sm last-char-read-size stream)))
 409       (if (>= (sm buffpos stream) unread)
 410           (decf (sm buffpos stream) unread)
 411           (error "Unreading needs work"))
 412       (setf (sm last-char-read-size stream) 0))))
 413
 414 (declaim (ftype j-write-char-fn dc-write-char))
 415 (defun dc-write-char (character stream)
 416   (when character
 417     (with-stream-class (dual-channel-simple-stream stream)
 418       (let* ((buffer (sm out-buffer stream))
 419              (ptr (sm outpos stream))
 420              (code (char-code character))
 421              (ctrl (sm control-out stream)))
 422         (when (and (< code 32) ctrl (svref ctrl code)
 423                    (funcall (the (or symbol function) (svref ctrl code))
 424                             stream character))
 425           (return-from dc-write-char character))
 426         (when (>= ptr (sm max-out-pos stream))
 427           (setq ptr (dc-flush-buffer stream t)))
 428         (setf (bref buffer ptr) code)
 429         (setf (sm outpos stream) (1+ ptr)))))
 430   character)
 431
 432 (declaim (ftype j-write-chars-fn dc-write-chars))
 433 (defun dc-write-chars (string stream start end)
 434   (with-stream-class (dual-channel-simple-stream stream)
 435     (do ((buffer (sm out-buffer stream))
 436          (ptr (sm outpos stream))
 437          (max (sm max-out-pos stream))
 438          (ctrl (sm control-out stream))
 439          (posn start (1+ posn))
 440          (count 0 (1+ count)))
 441         ((>= posn end) (setf (sm outpos stream) ptr) count)
 442       (declare (type fixnum ptr max posn count))
 443       (let* ((char (char string posn))
 444              (code (char-code char)))
 445         (unless (and (< code 32) ctrl (svref ctrl code)
 446                      (funcall (the (or symbol function) (svref ctrl code))
 447                               stream char))
 448           (unless (< ptr max)
 449             (setf (sm outpos stream) ptr)
 450             (dc-flush-buffer stream t)
 451             (setf ptr (sm outpos stream)))
 452           (setf (bref buffer ptr) code)
 453           (incf ptr))
 454         ))))
 455
 456 (declaim (ftype j-listen-fn dc-listen))
 457 (defun dc-listen (stream)
 458   (with-stream-class (dual-channel-simple-stream stream)
 459     (or (< (sm buffpos stream) (sm buffer-ptr stream))
 460         (case (device-read stream nil 0 0 nil)
 461           ((0 -2) nil)
 462           (-1 #| latch EOF |# nil)
 463           (-3 t)
 464           (t (error "DEVICE-READ error."))))))
 465
 466 ;;; DC-READ-BYTE doesn't actually live in a strategy slot
 467 (defun dc-read-byte (stream eof-error-p eof-value blocking)
 468   (with-stream-class (dual-channel-simple-stream stream)
 469     (let ((ptr (sm buffpos stream)))
 470       (when (>= ptr (sm buffer-ptr stream))
 471         (let ((bytes (device-read stream nil 0 nil blocking)))
 472           (declare (type fixnum bytes))
 473           (if (plusp bytes)
 474               (setf (sm buffer-ptr stream) bytes
 475                     ptr 0)
 476               (return-from dc-read-byte
 477                 (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
 478       (setf (sm buffpos stream) (1+ ptr))
 479       (setf (sm last-char-read-size stream) 0)
 480       (bref (sm buffer stream) ptr))))
 481
 482 ;;;
 483 ;;; STRING STRATEGY FUNCTIONS
 484 ;;;
 485
 486 (declaim (ftype j-read-char-fn string-read-char))
 487 (defun string-read-char (stream eof-error-p eof-value blocking)
 488   (declare (type string-input-simple-stream stream) (ignore blocking)
 489            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 490   (with-stream-class (string-input-simple-stream stream)
 491     (when (any-stream-instance-flags stream :eof)
 492       (sb-impl::eof-or-lose stream eof-error-p eof-value))
 493     (let* ((ptr (sm buffpos stream))
 494            (char (if (< ptr (sm buffer-ptr stream))
 495                      (schar (sm buffer stream) ptr)
 496                      nil)))
 497       (if (null char)
 498           (sb-impl::eof-or-lose stream eof-error-p eof-value)
 499           (progn
 500             (setf (sm last-char-read-size stream) 1)
 501             ;; do string-streams do control-in processing?
 502             #|(let ((column (sm charpos stream)))
 503               (declare (type (or null fixnum) column))
 504               (when column
 505                 (setf (sm charpos stream) (1+ column))))|#
 506             char)))))
 507
 508
 509 (declaim (ftype j-read-char-fn composing-crlf-read-char))
 510 (defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
 511   ;; TODO: what about the eof-error-p parameter?
 512   (declare (ignore eof-error-p eof-value))
 513   (with-stream-class (simple-stream stream)
 514     (let* ((melded-stream (sm melded-stream stream))
 515            (char (funcall-stm-handler j-read-char melded-stream nil stream
 516                                       blocking)))
 517       ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
 518       ;; character was available...
 519       (when (eql char #\Return)
 520         (let ((next (funcall-stm-handler j-read-char melded-stream
 521                                          nil stream blocking)))
 522           ;; if NEXT is STREAM, we hit EOF, so we should just return the
 523           ;; #\Return (and mark the stream :EOF?  At least unread if we
 524           ;; got a soft EOF, from a terminal, etc.
 525           ;; if NEXT is NIL, blocking is NIL and there's a CR but no
 526           ;; LF available on the stream: have to unread the CR and
 527           ;; return NIL, letting the CR be reread later.
 528           ;;
 529           ;; If we did get a linefeed, adjust the last-char-read-size
 530           ;; so that an unread of the resulting newline will unread both
 531           ;; the linefeed _and_ the carriage return.
 532           (if (eql next #\Linefeed)
 533               (setq char #\Newline)
 534               (funcall-stm-handler j-unread-char melded-stream nil))))
 535       ;; do control-in processing on whatever character we've got
 536       char)))
 537
 538 (declaim (ftype j-unread-char-fn composing-crlf-unread-char))
 539 (defun composing-crlf-unread-char (stream relaxed)
 540   (declare (ignore relaxed))
 541   (with-stream-class (simple-stream stream)
 542     (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
 543
 544 ;;;
 545 ;;; Functions to install the strategy functions in the appropriate slots
 546 ;;;
 547
 548 (defun %find-topmost-stream (stream)
 549   ;; N.B.: the topmost stream in the chain of encapsulations is actually
 550   ;; the bottommost in the "melding" chain
 551   (with-stream-class (simple-stream)
 552     (loop
 553       (when (eq (sm melded-stream stream) (sm melding-base stream))
 554         (return stream))
 555       (setq stream (sm melded-stream stream)))))
 556
 557 (defun install-single-channel-character-strategy (stream external-format
 558                                                          access)
 559   (find-external-format external-format)
 560   (let ((stream (%find-topmost-stream stream)))
 561     ;; ACCESS is usually NIL
 562     ;; May be "undocumented" values: stream::buffer, stream::mapped
 563     ;;   to install strategies suitable for direct buffer streams
 564     ;;   (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
 565     ;; (Avoids checking "mode" flags by installing special strategy)
 566     (with-stream-class (single-channel-simple-stream stream)
 567       (if (or (eq access 'buffer) (eq access 'mapped))
 568           (setf (sm j-read-char stream) #'sc-read-char--buffer
 569                 (sm j-read-chars stream) #'sc-read-chars--buffer
 570                 (sm j-unread-char stream) #'sc-unread-char
 571                 (sm j-write-char stream) #'sc-write-char
 572                 (sm j-write-chars stream) #'sc-write-chars
 573                 (sm j-listen stream) #'sc-listen)
 574           (setf (sm j-read-char stream) #'sc-read-char
 575                 (sm j-read-chars stream) #'sc-read-chars
 576                 (sm j-unread-char stream) #'sc-unread-char
 577                 (sm j-write-char stream) #'sc-write-char
 578                 (sm j-write-chars stream) #'sc-write-chars
 579                 (sm j-listen stream) #'sc-listen))))
 580   stream)
 581
 582 (defun install-dual-channel-character-strategy (stream external-format)
 583   (find-external-format external-format)
 584   (let ((stream (%find-topmost-stream stream)))
 585     (with-stream-class (dual-channel-simple-stream stream)
 586       (setf (sm j-read-char stream) #'dc-read-char
 587             (sm j-read-chars stream) #'dc-read-chars
 588             (sm j-unread-char stream) #'dc-unread-char
 589             (sm j-write-char stream) #'dc-write-char
 590             (sm j-write-chars stream) #'dc-write-chars
 591             (sm j-listen stream) #'dc-listen)))
 592   stream)
 593
 594 (defun install-string-input-character-strategy (stream)
 595   #| implement me |#
 596   (let ((stream (%find-topmost-stream stream)))
 597     (with-stream-class (simple-stream stream)
 598       (setf (sm j-read-char stream) #'string-read-char)))
 599   stream)
 600
 601 (defun install-string-output-character-strategy (stream)
 602   #| implement me |#
 603   stream)
 604
 605 (defun compose-encapsulating-streams (stream external-format)
 606   (when (consp external-format)
 607     (with-stream-class (simple-stream)
 608       (dolist (fmt (butlast external-format))
 609         (let ((encap (make-instance 'composing-stream :composing-format fmt)))
 610           (setf (sm melding-base encap) stream)
 611           (setf (sm melded-stream encap) (sm melded-stream stream))
 612           (setf (sm melded-stream stream) encap)
 613           (rotatef (sm j-listen encap) (sm j-listen stream))
 614           (rotatef (sm j-read-char encap) (sm j-read-char stream))
 615           (rotatef (sm j-read-chars encap) (sm j-read-chars stream))
 616           (rotatef (sm j-unread-char encap) (sm j-unread-char stream))
 617           (rotatef (sm j-write-char encap) (sm j-write-char stream))
 618           (rotatef (sm j-write-chars encap) (sm j-write-chars stream)))))))
 619
 620 ;;;
 621 ;;; NULL STRATEGY FUNCTIONS
 622 ;;;
 623
 624 (declaim (ftype j-read-char-fn null-read-char))
 625 (defun null-read-char (stream eof-error-p eof-value blocking)
 626   (declare (ignore blocking))
 627   (sb-impl::eof-or-lose stream eof-error-p eof-value))
 628
 629 (declaim (ftype j-read-chars-fn null-read-chars))
 630 (defun null-read-chars (stream string search start end blocking)
 631   (declare (ignore stream string search start end blocking))
 632   (values 0 :eof))
 633
 634 (declaim (ftype j-unread-char-fn null-unread-char))
 635 (defun null-unread-char (stream relaxed)
 636   (declare (ignore stream relaxed)))
 637
 638 (declaim (ftype j-write-char-fn null-write-char))
 639 (defun null-write-char (character stream)
 640   (declare (ignore stream))
 641   character)
 642
 643 (declaim (ftype j-write-chars-fn null-write-chars))
 644 (defun null-write-chars (string stream start end)
 645   (declare (ignore string stream))
 646   (- end start))
 647
 648 (declaim (ftype j-listen-fn null-listen))
 649 (defun null-listen (stream)
 650   (declare (ignore stream))
 651   nil)