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