contrib/sb-simple-streams/simple-streams.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 ;;; Stream printing
  13 ;;;
  14
  15 (defmethod print-object ((object file-simple-stream) stream)
  16   (print-unreadable-object (object stream :type t :identity t)
  17     (format stream "for ~S" (slot-value object 'filename))))
  18
  19 (defun make-control-table (&rest inits)
  20   (let ((table (make-array 32 :initial-element nil)))
  21     (do* ((char (pop inits) (pop inits))
  22           (func (pop inits) (pop inits)))
  23          ((null char))
  24       (when (< (char-code char) 32)
  25         (setf (aref table (char-code char)) func)))
  26     table))
  27
  28 (defun std-newline-out-handler (stream character)
  29   (declare (ignore character))
  30   (with-stream-class (simple-stream stream)
  31     (setf (sm charpos stream) -1)
  32     nil))
  33
  34 (defun std-tab-out-handler (stream character)
  35   (declare (ignore character))
  36   (with-stream-class (simple-stream stream)
  37     (let ((col (sm charpos stream)))
  38       (when col
  39         (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
  40     nil))
  41
  42 (defun std-dc-newline-in-handler (stream character)
  43   (with-stream-class (dual-channel-simple-stream stream)
  44     (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
  45     character))
  46
  47 (defvar *std-control-out-table*
  48   (make-control-table #\Newline #'std-newline-out-handler
  49                       #\Tab     #'std-tab-out-handler))
  50
  51 (defvar *terminal-control-in-table*
  52   (make-control-table #\Newline #'std-dc-newline-in-handler))
  53
  54 ;;;
  55 ;;; LOW LEVEL STUFF
  56 ;;;
  57
  58 (defun vector-elt-width (vector)
  59   ;; Return octet-width of vector elements
  60   (etypecase vector
  61     ;; missing are: bit, unsigned-byte 2, unsigned-byte 4, signed-byte 30
  62     ;; [and base-char, which is treated specially]
  63     ((simple-array (signed-byte 8) (*)) 1)
  64     ((simple-array (unsigned-byte 8) (*)) 1)
  65     ((simple-array (signed-byte 16) (*)) 2)
  66     ((simple-array (unsigned-byte 16) (*)) 2)
  67     ((simple-array (signed-byte 32) (*)) 4)
  68     ((simple-array (unsigned-byte 32) (*)) 4)
  69     ((simple-array single-float (*)) 4)
  70     ((simple-array double-float (*)) 8)
  71     ((simple-array (complex single-float) (*)) 8)
  72     ((simple-array (complex double-float) (*)) 16)))
  73
  74 (defun endian-swap-value (vector endian-swap)
  75   (case endian-swap
  76     (:network-order (case (vector-elt-width vector)
  77                       (1 0)
  78                       (2 1)
  79                       (4 3)
  80                       (8 7)
  81                       (16 15)))
  82     (:byte-8 0)
  83     (:byte-16 1)
  84     (:byte-32 3)
  85     (:byte-64 7)
  86     (:byte-128 15)
  87     (otherwise endian-swap)))
  88
  89 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
  90   (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
  91            (type stream stream))
  92   ;; START and END are octet offsets, not vector indices!  [Except for strings]
  93   ;; Return value is index of next octet to be read into (i.e., start+count)
  94   (etypecase stream
  95     (simple-stream
  96      (with-stream-class (simple-stream stream)
  97        (if (stringp vector)
  98            (let* ((start (or start 0))
  99                   (end (or end (length vector)))
 100                   (char (funcall-stm-handler j-read-char stream nil nil t)))
 101              (when char
 102                (setf (schar vector start) char)
 103                (incf start)
 104                (+ start (funcall-stm-handler j-read-chars stream vector nil
 105                                              start end nil))))
 106            (do* ((j-read-byte
 107                   (cond ((any-stream-instance-flags stream :string)
 108                          (error "Can't READ-BYTE on string streams."))
 109                         ((any-stream-instance-flags stream :dual)
 110                          #'dc-read-byte)
 111                         (t
 112                          #'sc-read-byte)))
 113                  (index (or start 0) (1+ index))
 114                  (end (or end (* (length vector) (vector-elt-width vector))))
 115                  (endian-swap (endian-swap-value vector endian-swap))
 116                  (byte (funcall j-read-byte stream nil nil t)
 117                        (funcall j-read-byte stream nil nil nil)))
 118                 ((or (null byte) (>= index end)) index)
 119              (setf (bref vector (logxor index endian-swap)) byte)))))
 120     ((or ansi-stream fundamental-stream)
 121      (unless (typep vector '(or string
 122                              (simple-array (signed-byte 8) (*))
 123                              (simple-array (unsigned-byte 8) (*))))
 124        (error "Wrong vector type for read-vector on stream not of type simple-stream."))
 125      (read-sequence vector stream :start (or start 0) :end end))))
 126
 127 #|(defun write-vector ...)|#
 128
 129 ;;; TODO: move getpagesize into sbcl/unix.lisp, where it belongs
 130 (eval-when (:compile-toplevel :load-toplevel :execute)
 131   (defun getpagesize ()
 132     (sb-unix::int-syscall ("getpagesize"))))
 133
 134 (defun read-octets (stream buffer start end blocking)
 135   (declare (type simple-stream stream)
 136            (type (or null simple-stream-buffer) buffer)
 137            (type fixnum start)
 138            (type (or null fixnum) end)
 139            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 140   (with-stream-class (simple-stream stream)
 141     (let ((fd (sm input-handle stream))
 142           (end (or end (sm buf-len stream)))
 143           (buffer (or buffer (sm buffer stream))))
 144       (declare (fixnum end))
 145       (typecase fd
 146         (fixnum
 147          (let ((flag (sb-sys:wait-until-fd-usable fd :input
 148                                                   (if blocking nil 0))))
 149            (cond
 150              ((and (not blocking) (= start end)) (if flag -3 0))
 151              ((and (not blocking) (not flag)) 0)
 152              (t (block nil
 153                   (let ((count 0))
 154                     (declare (type fixnum count))
 155                     (tagbody
 156                      again
 157                        ;; Avoid CMUCL gengc write barrier
 158                        (do ((i start (+ i ;#.(sb-unix:unix-getpagesize)
 159                                         (the fixnum (getpagesize)))))
 160                            ((>= i end))
 161                          (declare (type fixnum i))
 162                          (setf (bref buffer i) 0))
 163                        (setf (bref buffer (1- end)) 0)
 164                        (multiple-value-bind (bytes errno)
 165                            (sb-unix:unix-read fd (buffer-sap buffer start)
 166                                               (the fixnum (- end start)))
 167                          (declare (type (or null fixnum) bytes)
 168                                   (type (integer 0 100) errno))
 169                          (when bytes
 170                            (incf count bytes)
 171                            (incf start bytes))
 172                          (cond ((null bytes)
 173                                 (format t "~&;; UNIX-READ: errno=~D~%" errno)
 174                                 (cond ((= errno sb-unix:eintr) (go again))
 175                                       ((and blocking
 176                                             (or (= errno ;;sb-unix:eagain
 177                                                    ;; FIXME: move
 178                                                    ;; eagain into
 179                                                    ;; sb-unix
 180                                                    11)
 181                                                 (= errno sb-unix:ewouldblock)))
 182                                        (sb-sys:wait-until-fd-usable fd :input nil)
 183                                        (go again))
 184                                       (t (return (- -10 errno)))))
 185                                ((zerop count) (return -1))
 186                                (t (return count)))))))))))
 187         (t (error "implement me"))))))
 188
 189 (defun write-octets (stream buffer start end blocking)
 190   (declare (type simple-stream stream)
 191            (type (or null simple-stream-buffer) buffer)
 192            (type fixnum start)
 193            (type (or null fixnum) end))
 194   (with-stream-class (simple-stream stream)
 195     (let ((fd (sm output-handle stream))
 196           (end (or end (error "WRITE-OCTETS: end=NIL")))
 197           (buffer (or buffer (error "WRITE-OCTETS: buffer=NIL"))))
 198       (typecase fd
 199         (fixnum
 200          (let ((flag (sb-sys:wait-until-fd-usable fd :output
 201                                                   (if blocking nil 0))))
 202            (cond
 203              ((and (not blocking) (= start end)) (if flag -3 0))
 204              ((and (not blocking) (not flag)) 0)
 205              (t
 206               (block nil
 207                 (let ((count 0))
 208                   (tagbody again
 209                      (multiple-value-bind (bytes errno)
 210                          (sb-unix:unix-write fd (buffer-sap buffer) start
 211                                              (- end start))
 212                        (when bytes
 213                          (incf count bytes)
 214                          (incf start bytes))
 215                        (cond ((null bytes)
 216                               (format t "~&;; UNIX-WRITE: errno=~D~%" errno)
 217                               (cond ((= errno sb-unix:eintr) (go again))
 218                                     ;; don't block for subsequent chars
 219                                     (t (return (- -10 errno)))))
 220                              (t (return count)))))))))))
 221         (t (error "implement me"))))))
 222
 223
 224 ;;;
 225 ;;; IMPLEMENTATIONS
 226 ;;;
 227
 228 (defmethod device-open ((stream null-simple-stream) options)
 229   (add-stream-instance-flags stream :simple :input :output)
 230   stream)
 231
 232 (defmethod device-open ((stream buffer-input-simple-stream) options)
 233   #| do something |#
 234   stream)
 235
 236 (defmethod device-open ((stream buffer-output-simple-stream) options)
 237   #| do something |#
 238   stream)
 239
 240 (defun open-file-stream (stream options)
 241   (let ((filename (getf options :filename))
 242         (direction (getf options :direction :input))
 243         (if-exists (getf options :if-exists))
 244         (if-exists-given (not (getf options :if-exists t)))
 245         (if-does-not-exist (getf options :if-does-not-exist))
 246         (if-does-not-exist-given (not (getf options :if-does-not-exist t))))
 247     (with-stream-class (file-simple-stream stream)
 248       (ecase direction
 249         (:input (add-stream-instance-flags stream :input))
 250         (:output (add-stream-instance-flags stream :output))
 251         (:io (add-stream-instance-flags stream :input :output)))
 252       (cond ((and (sm input-handle stream) (sm output-handle stream)
 253                   (not (eql (sm input-handle stream)
 254                             (sm output-handle stream))))
 255              (error "Input-Handle and Output-Handle can't be different."))
 256             ((or (sm input-handle stream) (sm output-handle stream))
 257              (add-stream-instance-flags stream :simple)
 258              ;; get namestring, etc. from handle, if possible (it's a stream)
 259              ;; set up buffers
 260              stream)
 261             (t
 262              (multiple-value-bind (fd namestring original delete-original)
 263                  (%fd-open filename direction if-exists if-exists-given
 264                            if-does-not-exist if-does-not-exist-given)
 265                (when fd
 266                  (add-stream-instance-flags stream :simple)
 267                  (setf (sm pathname stream) filename
 268                        (sm filename stream) namestring
 269                        (sm original stream) original
 270                        (sm delete-original stream) delete-original)
 271                  (when (any-stream-instance-flags stream :input)
 272                    (setf (sm input-handle stream) fd))
 273                  (when (any-stream-instance-flags stream :output)
 274                    (setf (sm output-handle stream) fd))
 275                  (sb-ext:finalize stream
 276                    (lambda ()
 277                      (sb-unix:unix-close fd)
 278                      (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
 279                              namestring fd)))
 280                  stream)))))))
 281
 282 (defmethod device-open ((stream file-simple-stream) options)
 283   (with-stream-class (file-simple-stream stream)
 284     (when (open-file-stream stream options)
 285       ;; Franz says:
 286       ;;  "The device-open method must be prepared to recognize resource
 287       ;;   and change-class situations. If no filename is specified in
 288       ;;   the options list, and if no input-handle or output-handle is
 289       ;;   given, then the input-handle and output-handle slots should
 290       ;;   be examined; if non-nil, that means the stream is still open,
 291       ;;   and thus the operation being requested of device-open is a
 292       ;;   change-class. Also, a device-open method need not allocate a
 293       ;;   buffer every time it is called, but may instead reuse a
 294       ;;   buffer it finds in a stream, if it does not become a security
 295       ;;   issue."
 296       (unless (sm buffer stream)
 297         (let ((length (device-buffer-length stream)))
 298           ;; Buffer should be array of (unsigned-byte 8), in general
 299           ;; use strings for now so it's easy to read the content...
 300           (setf (sm buffer stream) (make-string length)
 301                 (sm buffpos stream) 0
 302                 (sm buffer-ptr stream) 0
 303                 (sm buf-len stream) length)))
 304       (when (any-stream-instance-flags stream :output)
 305         (setf (sm control-out stream) *std-control-out-table*))
 306       (install-single-channel-character-strategy
 307        stream (getf options :external-format :default) nil))))
 308
 309 (defmethod device-open ((stream mapped-file-simple-stream) options)
 310   (with-stream-class (mapped-file-simple-stream stream)
 311     (when (open-file-stream stream options)
 312       (let* ((input (any-stream-instance-flags stream :input))
 313              (output (any-stream-instance-flags stream :output))
 314              (prot (logior (if input PROT-READ 0)
 315                            (if output PROT-WRITE 0)))
 316              (fd (or (sm input-handle stream) (sm output-handle stream))))
 317         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 318             (sb-unix:unix-fstat fd)
 319           (declare (ignore ino mode nlink uid gid rdev))
 320           (unless okay
 321             (sb-unix:unix-close fd)
 322             (sb-ext:cancel-finalization stream)
 323             (error "Error fstating ~S: ~A" stream
 324                    (sb-int:strerror dev)))
 325           (when (> size most-positive-fixnum)
 326             ;; Or else BUF-LEN has to be a general integer, or
 327             ;; maybe (unsigned-byte 32).  In any case, this means
 328             ;; BUF-MAX and BUF-PTR have to be the same, which means
 329             ;; number-consing every time BUF-PTR moves...
 330             ;; Probably don't have the address space available to map
 331             ;; bigger files, anyway.  Maybe DEVICE-EXTEND can adjust
 332             ;; the mapped portion of the file?
 333             (warn "Unable to memory-map entire file.")
 334             (setf size most-positive-fixnum))
 335           (let ((buffer
 336                  (sb-unix:unix-mmap nil size prot MAP-SHARED fd 0)))
 337             (when (null buffer)
 338               (sb-unix:unix-close fd)
 339               (sb-ext:cancel-finalization stream)
 340               (error "Unable to map file."))
 341             (setf (sm buffer stream) buffer
 342                   (sm buffpos stream) 0
 343                   (sm buffer-ptr stream) size
 344                   (sm buf-len stream) size)
 345             (install-single-channel-character-strategy
 346              stream (getf options :external-format :default) 'mapped)
 347             (sb-ext:finalize stream
 348               (lambda ()
 349                 (sb-unix:unix-munmap buffer size)
 350                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
 351     stream))
 352
 353 (defmethod device-open ((stream string-input-simple-stream) options)
 354   #| do something |#
 355   stream)
 356
 357 (defmethod device-open ((stream string-output-simple-stream) options)
 358   #| do something |#
 359   stream)
 360
 361 (defmethod device-open ((stream xp-simple-stream) options)
 362   #| do something |#
 363   stream)
 364
 365 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
 366   #| do something |#
 367   stream)
 368
 369 (defmethod device-open ((stream socket-base-simple-stream) options)
 370   #| do something |#
 371   stream)
 372
 373 (defmethod device-open ((stream socket-simple-stream) options)
 374   #| do something |#
 375   stream)
 376
 377 (defmethod device-open ((stream terminal-simple-stream) options)
 378   (with-stream-class (terminal-simple-stream stream)
 379     (when (getf options :input-handle)
 380       (setf (sm input-handle stream) (getf options :input-handle))
 381       (add-stream-instance-flags stream :simple :interactive :dual :input)
 382       (unless (sm buffer stream)
 383         (let ((length (device-buffer-length stream)))
 384           (setf (sm buffer stream) (make-string length)
 385                 (sm buf-len stream) length)))
 386       (setf (sm control-in stream) *terminal-control-in-table*))
 387     (when (getf options :output-handle)
 388       (setf (sm output-handle stream) (getf options :output-handle))
 389       (add-stream-instance-flags stream :simple :interactive :dual :output)
 390       (unless (sm out-buffer stream)
 391         (let ((length (device-buffer-length stream)))
 392           (setf (sm out-buffer stream) (make-string length)
 393                 (sm max-out-pos stream) length)))
 394       (setf (sm control-out stream) *std-control-out-table*))
 395     (install-dual-channel-character-strategy
 396      stream (getf options :external-format :default)))
 397   #| do something |#
 398   stream)
 399
 400
 401 (defmethod device-close :around ((stream simple-stream) abort)
 402   (with-stream-class (simple-stream stream)
 403     (when (any-stream-instance-flags stream :input :output)
 404       (when (any-stream-instance-flags stream :output)
 405         (if abort
 406             (clear-output stream)
 407             (force-output stream)))
 408       (call-next-method)
 409       (setf (sm input-handle stream) nil
 410             (sm output-handle stream) nil)
 411       (remove-stream-instance-flags stream :input :output)
 412       (sb-ext:cancel-finalization stream))))
 413
 414 (defmethod device-close ((stream simple-stream) abort)
 415   (declare (ignore abort))
 416   t)
 417
 418 (defmethod device-close ((stream file-simple-stream) abort)
 419   (with-stream-class (file-simple-stream stream)
 420     (cond (abort
 421            ;; Remove any fd-handler
 422            ;; If it's an output stream and has an original name,
 423            ;; revert the file
 424            )
 425           (t
 426            ;; If there's an original name and delete-original is set
 427            ;; kill the original
 428            ))
 429     (if (sm input-handle stream)
 430         (sb-unix:unix-close (sm input-handle stream))
 431         (sb-unix:unix-close (sm output-handle stream)))
 432     (setf (sm buffer stream) nil))
 433   t)
 434
 435 (defmethod device-close ((stream mapped-file-simple-stream) abort)
 436   (with-stream-class (mapped-file-simple-stream stream)
 437     (when (sm buffer stream)
 438       (sb-unix:unix-munmap (sm buffer stream) (sm buf-len stream))
 439       (setf (sm buffer stream) nil))
 440     (cond (abort
 441            ;; remove any FD handler
 442            ;; if it has an original name (is this possible for mapped files?)
 443            ;;   revert the file
 444            )
 445           (t
 446            ;; if there's an original name and delete-original is set (again,
 447            ;;   is this even possible?), kill the original
 448            ))
 449     (sb-unix:unix-close (sm input-handle stream)))
 450   t)
 451
 452
 453 (defmethod device-buffer-length ((stream simple-stream))
 454   4096)
 455
 456 (defmethod device-buffer-length ((stream null-simple-stream))
 457   256)
 458
 459
 460 (defmethod device-file-position ((stream simple-stream))
 461   (with-stream-class (simple-stream stream)
 462     ;; this may be wrong if :DUAL flag is set!
 463     (sm buffpos stream)))
 464
 465 (defmethod (setf device-file-position) (value (stream simple-stream))
 466   (with-stream-class (simple-stream stream)
 467     ;; this may be wrong if :DUAL flag is set!
 468     (setf (sm buffpos stream) value)))
 469
 470 (defmethod device-file-position ((stream string-simple-stream))
 471   ;; get string length (of input or output buffer?)
 472   )
 473
 474 (defmethod (setf device-file-position) (value (stream string-simple-stream))
 475   ;; set string length (of input or output buffer?)
 476   )
 477
 478 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
 479   ;; get fill pointer (of input or output buffer?)
 480   )
 481
 482 (defmethod (setf device-file-position)
 483     (value (stream fill-pointer-output-simple-stream))
 484   ;; set fill pointer (of input or output buffer?)
 485   )
 486
 487 (defmethod device-file-position ((stream file-simple-stream))
 488   (with-stream-class (file-simple-stream stream)
 489     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 490                                     (sm output-handle stream))
 491                                 0
 492                                 sb-unix:l_incr))))
 493
 494 (defmethod (setf device-file-position) (value (stream file-simple-stream))
 495   (declare (type fixnum value))
 496   (with-stream-class (file-simple-stream stream)
 497     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 498                                     (sm output-handle stream))
 499                                 value
 500                                 (if (minusp value)
 501                                     sb-unix:l_xtnd
 502                                     sb-unix:l_set)))))
 503
 504
 505 (defmethod device-file-length ((stream simple-stream))
 506   nil)
 507
 508 (defmethod device-file-length ((stream direct-simple-stream))
 509   ;; return buffer length
 510   )
 511
 512 (defmethod device-file-length ((stream string-simple-stream))
 513   ;; return string length
 514   )
 515
 516 (defmethod device-file-length ((stream file-simple-stream))
 517   (with-stream-class (file-simple-stream stream)
 518     (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 519         (sb-unix:unix-fstat (sm input-handle stream))
 520       (declare (ignore dev ino mode nlink uid gid rdev))
 521       (if okay size nil))))
 522
 523
 524 (defmethod device-read ((stream single-channel-simple-stream) buffer
 525                         start end blocking)
 526 ;;  (when (and (null buffer) (not (eql start end)))
 527 ;;    (with-stream-class (single-channel-simple-stream stream)
 528 ;;      (setq buffer (sm buffer stream))
 529 ;;      (setq end (sm buf-len stream))))
 530   (read-octets stream buffer start end blocking))
 531
 532 (defmethod device-read ((stream dual-channel-simple-stream) buffer
 533                         start end blocking)
 534   (when (null buffer)
 535     (with-stream-class (dual-channel-simple-stream stream)
 536       (setq buffer (sm buffer stream))
 537       (setq end (- (sm buf-len stream) start))))
 538   (read-octets stream buffer start end blocking))
 539
 540 (defmethod device-read ((stream null-simple-stream) buffer
 541                         start end blocking)
 542   (declare (ignore buffer start end blocking))
 543   -1)
 544
 545 (defmethod device-read ((stream terminal-simple-stream) buffer
 546                         start end blocking)
 547   (let ((result (call-next-method)))
 548     (if (= result -1) -2 result)))
 549
 550
 551 (defmethod device-clear-input ((stream simple-stream) buffer-only)
 552   (declare (ignore buffer-only))
 553   nil)
 554
 555 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
 556   )
 557
 558
 559 (defmethod device-write ((stream single-channel-simple-stream) buffer
 560                          start end blocking)
 561   (when (and (null buffer) (not (eql start end)))
 562     (with-stream-class (single-channel-simple-stream stream)
 563       (setf buffer (sm buffer stream))
 564       (setf end (sm buffpos stream))))
 565   (write-octets stream buffer start end blocking))
 566
 567 (defmethod device-write ((stream dual-channel-simple-stream) buffer
 568                          start end blocking)
 569   (when (and (null buffer) (not (eql start end)))
 570     (with-stream-class (dual-channel-simple-stream stream)
 571       (setf buffer (sm out-buffer stream))
 572       (setf end (sm outpos stream))))
 573   (write-octets stream buffer start end blocking))
 574
 575 (defmethod device-write ((stream null-simple-stream) buffer
 576                          start end blocking)
 577   (declare (ignore buffer blocking))
 578   (- end start))
 579
 580 (defmethod device-write ((stream socket-base-simple-stream) buffer
 581                          start end blocking)
 582   ;; @@2
 583   (call-next-method))
 584
 585
 586 (defmethod device-clear-output ((stream simple-stream))
 587   nil)
 588
 589
 590 (defmethod device-extend ((stream direct-simple-stream) need action)
 591   (declare (ignore need action))
 592   nil)
 593
 594 (defmethod device-extend ((stream string-input-simple-stream) need action)
 595   (declare (ignore need action))
 596   nil)
 597
 598 (defmethod device-extend ((stream string-output-simple-stream) need action)
 599   ;; @@3
 600   )
 601
 602 (defmethod device-extend ((stream fill-pointer-output-simple-stream)
 603                           need action)
 604   ;; @@4
 605   )
 606
 607 (defmethod device-extend ((stream mapped-file-simple-stream) need action)
 608   (declare (ignore need action))
 609   nil)
 610
 611
 612 ;; device-finish-record apparently has no methods defined
 613
 614
 615 ;;;
 616 ;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
 617 ;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
 618 ;;;
 619
 620
 621 ;;;
 622 ;;; CREATION OF STANDARD STREAMS
 623 ;;;
 624