contrib/sb-simple-streams/strategy.lisp

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