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         ;; Handle encapsulated stream.  FIXME: perhaps handle
 188         ;; sbcl-vintage ansi-stream type in read-octets too?
 189         (stream (read-octets fd buffer start end blocking))
 190         (t (error "Don't know how to handle input handle &A" fd))))))
 191
 192 (defun write-octets (stream buffer start end blocking)
 193   (declare (type simple-stream stream)
 194            (type (or null simple-stream-buffer) buffer)
 195            (type fixnum start)
 196            (type (or null fixnum) end))
 197   (with-stream-class (simple-stream stream)
 198     (let ((fd (sm output-handle stream))
 199           (end (or end (error "WRITE-OCTETS: end=NIL")))
 200           (buffer (or buffer (error "WRITE-OCTETS: buffer=NIL"))))
 201       (typecase fd
 202         (fixnum
 203          (let ((flag (sb-sys:wait-until-fd-usable fd :output
 204                                                   (if blocking nil 0))))
 205            (cond
 206              ((and (not blocking) (= start end)) (if flag -3 0))
 207              ((and (not blocking) (not flag)) 0)
 208              (t
 209               (block nil
 210                 (let ((count 0))
 211                   (tagbody again
 212                      (multiple-value-bind (bytes errno)
 213                          (sb-unix:unix-write fd (buffer-sap buffer) start
 214                                              (- end start))
 215                        (when bytes
 216                          (incf count bytes)
 217                          (incf start bytes))
 218                        (cond ((null bytes)
 219                               (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%"
 220                                       errno)
 221                               (cond ((= errno sb-unix:eintr) (go again))
 222                                     ;; don't block for subsequent chars
 223                                     (t (return (- -10 errno)))))
 224                              (t (return count)))))))))))
 225         ;; Handle encapsulated stream.  FIXME: perhaps handle
 226         ;; sbcl-vintage ansi-stream type in write-octets too?
 227         (stream (write-octets fd buffer start end blocking))
 228         (t (error "Don't know how to handle output handle &A" fd))))))
 229
 230
 231 ;;;
 232 ;;; IMPLEMENTATIONS
 233 ;;;
 234
 235 (defmethod device-open ((stream null-simple-stream) options)
 236   (add-stream-instance-flags stream :simple :input :output)
 237   stream)
 238
 239 (defmethod device-open ((stream buffer-input-simple-stream) options)
 240   #| do something |#
 241   stream)
 242
 243 (defmethod device-open ((stream buffer-output-simple-stream) options)
 244   #| do something |#
 245   stream)
 246
 247 (defun open-file-stream (stream options)
 248   (let ((filename (pathname (getf options :filename)))
 249         (direction (getf options :direction :input))
 250         (if-exists (getf options :if-exists))
 251         (if-exists-given (not (getf options :if-exists t)))
 252         (if-does-not-exist (getf options :if-does-not-exist))
 253         (if-does-not-exist-given (not (getf options :if-does-not-exist t))))
 254     (with-stream-class (file-simple-stream stream)
 255       (ecase direction
 256         (:input (add-stream-instance-flags stream :input))
 257         (:output (add-stream-instance-flags stream :output))
 258         (:io (add-stream-instance-flags stream :input :output)))
 259       (cond ((and (sm input-handle stream) (sm output-handle stream)
 260                   (not (eql (sm input-handle stream)
 261                             (sm output-handle stream))))
 262              (error "Input-Handle and Output-Handle can't be different."))
 263             ((or (sm input-handle stream) (sm output-handle stream))
 264              (add-stream-instance-flags stream :simple)
 265              ;; get namestring, etc. from handle, if possible (it's a stream)
 266              ;; set up buffers
 267              stream)
 268             (t
 269              (multiple-value-bind (fd namestring original delete-original)
 270                  (%fd-open filename direction if-exists if-exists-given
 271                            if-does-not-exist if-does-not-exist-given)
 272                (when fd
 273                  (add-stream-instance-flags stream :simple)
 274                  (setf (sm pathname stream) filename
 275                        (sm filename stream) namestring
 276                        (sm original stream) original
 277                        (sm delete-original stream) delete-original)
 278                  (when (any-stream-instance-flags stream :input)
 279                    (setf (sm input-handle stream) fd))
 280                  (when (any-stream-instance-flags stream :output)
 281                    (setf (sm output-handle stream) fd))
 282                  (sb-ext:finalize stream
 283                    (lambda ()
 284                      (sb-unix:unix-close fd)
 285                      (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
 286                              namestring fd)))
 287                  stream)))))))
 288
 289 (defmethod device-open ((stream file-simple-stream) options)
 290   (with-stream-class (file-simple-stream stream)
 291     (when (open-file-stream stream options)
 292       ;; Franz says:
 293       ;;  "The device-open method must be prepared to recognize resource
 294       ;;   and change-class situations. If no filename is specified in
 295       ;;   the options list, and if no input-handle or output-handle is
 296       ;;   given, then the input-handle and output-handle slots should
 297       ;;   be examined; if non-nil, that means the stream is still open,
 298       ;;   and thus the operation being requested of device-open is a
 299       ;;   change-class. Also, a device-open method need not allocate a
 300       ;;   buffer every time it is called, but may instead reuse a
 301       ;;   buffer it finds in a stream, if it does not become a security
 302       ;;   issue."
 303       (unless (sm buffer stream)
 304         (let ((length (device-buffer-length stream)))
 305           ;; Buffer should be array of (unsigned-byte 8), in general
 306           ;; use strings for now so it's easy to read the content...
 307           (setf (sm buffer stream) (make-string length)
 308                 (sm buffpos stream) 0
 309                 (sm buffer-ptr stream) 0
 310                 (sm buf-len stream) length)))
 311       (when (any-stream-instance-flags stream :output)
 312         (setf (sm control-out stream) *std-control-out-table*))
 313       (install-single-channel-character-strategy
 314        stream (getf options :external-format :default) nil))))
 315
 316 (defmethod device-open ((stream mapped-file-simple-stream) options)
 317   (with-stream-class (mapped-file-simple-stream stream)
 318     (when (open-file-stream stream options)
 319       (let* ((input (any-stream-instance-flags stream :input))
 320              (output (any-stream-instance-flags stream :output))
 321              (prot (logior (if input PROT-READ 0)
 322                            (if output PROT-WRITE 0)))
 323              (fd (or (sm input-handle stream) (sm output-handle stream))))
 324         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 325             (sb-unix:unix-fstat fd)
 326           (declare (ignore ino mode nlink uid gid rdev))
 327           (unless okay
 328             (sb-unix:unix-close fd)
 329             (sb-ext:cancel-finalization stream)
 330             (error "Error fstating ~S: ~A" stream
 331                    (sb-int:strerror dev)))
 332           (when (> size most-positive-fixnum)
 333             ;; Or else BUF-LEN has to be a general integer, or
 334             ;; maybe (unsigned-byte 32).  In any case, this means
 335             ;; BUF-MAX and BUF-PTR have to be the same, which means
 336             ;; number-consing every time BUF-PTR moves...
 337             ;; Probably don't have the address space available to map
 338             ;; bigger files, anyway.  Maybe DEVICE-EXTEND can adjust
 339             ;; the mapped portion of the file?
 340             (warn "Unable to memory-map entire file.")
 341             (setf size most-positive-fixnum))
 342           (let ((buffer
 343                  (sb-unix:unix-mmap nil size prot MAP-SHARED fd 0)))
 344             (when (null buffer)
 345               (sb-unix:unix-close fd)
 346               (sb-ext:cancel-finalization stream)
 347               (error "Unable to map file."))
 348             (setf (sm buffer stream) buffer
 349                   (sm buffpos stream) 0
 350                   (sm buffer-ptr stream) size
 351                   (sm buf-len stream) size)
 352             (install-single-channel-character-strategy
 353              stream (getf options :external-format :default) 'mapped)
 354             (sb-ext:finalize stream
 355               (lambda ()
 356                 (sb-unix:unix-munmap buffer size)
 357                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
 358     stream))
 359
 360 (defmethod device-open ((stream string-input-simple-stream) options)
 361   #| do something |#
 362   stream)
 363
 364 (defmethod device-open ((stream string-output-simple-stream) options)
 365   #| do something |#
 366   stream)
 367
 368 (defmethod device-open ((stream xp-simple-stream) options)
 369   #| do something |#
 370   stream)
 371
 372 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
 373   #| do something |#
 374   stream)
 375
 376 (defmethod device-open ((stream socket-base-simple-stream) options)
 377   #| do something |#
 378   stream)
 379
 380 (defmethod device-open ((stream socket-simple-stream) options)
 381   (with-stream-class (socket-simple-stream stream)
 382      (let* ((remote-host (getf options :remote-host))
 383             (remote-port (getf options :remote-port))
 384             (socket (make-instance 'sb-bsd-sockets:inet-socket
 385                                    :type :stream :protocol :tcp)))
 386        (setf (sm socket stream) socket)
 387        (sb-bsd-sockets:socket-connect socket remote-host remote-port)
 388        (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
 389          ;; Connect stream to socket, ...
 390          (setf (sm input-handle stream) fd)
 391          (setf (sm output-handle stream) fd)
 392          ;; ... and socket to stream.
 393          (setf (slot-value socket 'stream) stream)
 394          (sb-ext:cancel-finalization socket)
 395          (sb-ext:finalize stream
 396                           (lambda ()
 397                             (sb-unix:unix-close fd)
 398                             (format *terminal-io*
 399                                     "~&;;; ** closed socket (fd ~D)~%" fd))))
 400        ;; Now frob the stream slots.
 401        (add-stream-instance-flags stream :simple :input :output :dual)
 402        (unless (sm buffer stream)
 403          (let ((length (device-buffer-length stream)))
 404            ;; Buffer should be array of (unsigned-byte 8), in general
 405            ;; use strings for now so it's easy to read the content...
 406            (setf (sm buffer stream) (make-string length)
 407                  (sm buffpos stream) 0
 408                  (sm buffer-ptr stream) 0
 409                  (sm buf-len stream) length)))
 410        (unless (sm out-buffer stream)
 411         (let ((length (device-buffer-length stream)))
 412           (setf (sm out-buffer stream) (make-string length)
 413                 (sm max-out-pos stream) length)))
 414        (setf (sm control-in stream) *terminal-control-in-table*)
 415        (setf (sm control-out stream) *std-control-out-table*)
 416        (install-dual-channel-character-strategy
 417         stream (getf options :external-format :default)))
 418      stream))
 419
 420 (defmethod device-open ((stream terminal-simple-stream) options)
 421   (with-stream-class (terminal-simple-stream stream)
 422     (when (getf options :input-handle)
 423       (setf (sm input-handle stream) (getf options :input-handle))
 424       (add-stream-instance-flags stream :simple :interactive :dual :input)
 425       (unless (sm buffer stream)
 426         (let ((length (device-buffer-length stream)))
 427           (setf (sm buffer stream) (make-string length)
 428                 (sm buf-len stream) length)))
 429       (setf (sm control-in stream) *terminal-control-in-table*))
 430     (when (getf options :output-handle)
 431       (setf (sm output-handle stream) (getf options :output-handle))
 432       (add-stream-instance-flags stream :simple :interactive :dual :output)
 433       (unless (sm out-buffer stream)
 434         (let ((length (device-buffer-length stream)))
 435           (setf (sm out-buffer stream) (make-string length)
 436                 (sm max-out-pos stream) length)))
 437       (setf (sm control-out stream) *std-control-out-table*))
 438     (install-dual-channel-character-strategy
 439      stream (getf options :external-format :default)))
 440   #| do something |#
 441   stream)
 442
 443
 444 (defmethod device-close :around ((stream simple-stream) abort)
 445   (with-stream-class (simple-stream stream)
 446     (when (any-stream-instance-flags stream :input :output)
 447       (when (any-stream-instance-flags stream :output)
 448         (if abort
 449             (clear-output stream)
 450             (force-output stream)))
 451       (call-next-method)
 452       (setf (sm input-handle stream) nil
 453             (sm output-handle stream) nil)
 454       (remove-stream-instance-flags stream :input :output)
 455       (sb-ext:cancel-finalization stream))))
 456
 457 (defmethod device-close ((stream simple-stream) abort)
 458   (declare (ignore abort))
 459   t)
 460
 461 (defmethod device-close ((stream file-simple-stream) abort)
 462   (with-stream-class (file-simple-stream stream)
 463     (cond (abort
 464            ;; Remove any fd-handler
 465            ;; If it's an output stream and has an original name,
 466            ;; revert the file
 467            )
 468           (t
 469            ;; If there's an original name and delete-original is set
 470            ;; kill the original
 471            ))
 472     (if (sm input-handle stream)
 473         (sb-unix:unix-close (sm input-handle stream))
 474       (sb-unix:unix-close (sm output-handle stream)))
 475     (setf (sm buffer stream) nil))
 476   t)
 477
 478 (defmethod device-close ((stream mapped-file-simple-stream) abort)
 479   (with-stream-class (mapped-file-simple-stream stream)
 480     (when (sm buffer stream)
 481       (sb-unix:unix-munmap (sm buffer stream) (sm buf-len stream))
 482       (setf (sm buffer stream) nil))
 483     (cond (abort
 484            ;; remove any FD handler
 485            ;; if it has an original name (is this possible for mapped files?)
 486            ;;   revert the file
 487            )
 488           (t
 489            ;; if there's an original name and delete-original is set (again,
 490            ;;   is this even possible?), kill the original
 491            ))
 492     (sb-unix:unix-close (sm input-handle stream)))
 493   t)
 494
 495 (defmethod device-close ((stream socket-simple-stream) abort)
 496   ;; Abort argument is handled by :around method on base class
 497   (declare (ignore abort))
 498   (with-stream-class (socket-simple-stream stream)
 499     (sb-unix:unix-close (sm input-handle stream))
 500     (setf (sm buffer stream) nil)
 501     (setf (sm out-buffer stream) nil))
 502   (sb-ext:cancel-finalization stream)
 503   t)
 504
 505 (defmethod device-buffer-length ((stream simple-stream))
 506   4096)
 507
 508 (defmethod device-buffer-length ((stream null-simple-stream))
 509   256)
 510
 511
 512 (defmethod device-file-position ((stream simple-stream))
 513   (with-stream-class (simple-stream stream)
 514     ;; this may be wrong if :DUAL flag is set!
 515     (sm buffpos stream)))
 516
 517 (defmethod (setf device-file-position) (value (stream simple-stream))
 518   (with-stream-class (simple-stream stream)
 519     ;; this may be wrong if :DUAL flag is set!
 520     (setf (sm buffpos stream) value)))
 521
 522 (defmethod device-file-position ((stream string-simple-stream))
 523   ;; get string length (of input or output buffer?)
 524   )
 525
 526 (defmethod (setf device-file-position) (value (stream string-simple-stream))
 527   ;; set string length (of input or output buffer?)
 528   )
 529
 530 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
 531   ;; get fill pointer (of input or output buffer?)
 532   )
 533
 534 (defmethod (setf device-file-position)
 535     (value (stream fill-pointer-output-simple-stream))
 536   ;; set fill pointer (of input or output buffer?)
 537   )
 538
 539 (defmethod device-file-position ((stream file-simple-stream))
 540   (with-stream-class (file-simple-stream stream)
 541     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 542                                     (sm output-handle stream))
 543                                 0
 544                                 sb-unix:l_incr))))
 545
 546 (defmethod (setf device-file-position) (value (stream file-simple-stream))
 547   (declare (type fixnum value))
 548   (with-stream-class (file-simple-stream stream)
 549     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 550                                     (sm output-handle stream))
 551                                 value
 552                                 (if (minusp value)
 553                                     sb-unix:l_xtnd
 554                                     sb-unix:l_set)))))
 555
 556
 557 (defmethod device-file-length ((stream simple-stream))
 558   nil)
 559
 560 (defmethod device-file-length ((stream direct-simple-stream))
 561   ;; return buffer length
 562   )
 563
 564 (defmethod device-file-length ((stream string-simple-stream))
 565   ;; return string length
 566   )
 567
 568 (defmethod device-file-length ((stream file-simple-stream))
 569   (with-stream-class (file-simple-stream stream)
 570     (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 571         (sb-unix:unix-fstat (sm input-handle stream))
 572       (declare (ignore dev ino mode nlink uid gid rdev))
 573       (if okay size nil))))
 574
 575
 576 (defmethod device-read ((stream single-channel-simple-stream) buffer
 577                         start end blocking)
 578 ;;  (when (and (null buffer) (not (eql start end)))
 579 ;;    (with-stream-class (single-channel-simple-stream stream)
 580 ;;      (setq buffer (sm buffer stream))
 581 ;;      (setq end (sm buf-len stream))))
 582   (read-octets stream buffer start end blocking))
 583
 584 (defmethod device-read ((stream dual-channel-simple-stream) buffer
 585                         start end blocking)
 586   (when (null buffer)
 587     (with-stream-class (dual-channel-simple-stream stream)
 588       (setq buffer (sm buffer stream))
 589       (setq end (- (sm buf-len stream) start))))
 590   (read-octets stream buffer start end blocking))
 591
 592 (defmethod device-read ((stream null-simple-stream) buffer
 593                         start end blocking)
 594   (declare (ignore buffer start end blocking))
 595   -1)
 596
 597 (defmethod device-read ((stream terminal-simple-stream) buffer
 598                         start end blocking)
 599   (let ((result (call-next-method)))
 600     (if (= result -1) -2 result)))
 601
 602
 603 (defmethod device-clear-input ((stream simple-stream) buffer-only)
 604   (declare (ignore buffer-only))
 605   nil)
 606
 607 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
 608   )
 609
 610
 611 (defmethod device-write ((stream single-channel-simple-stream) buffer
 612                          start end blocking)
 613   (when (and (null buffer) (not (eql start end)))
 614     (with-stream-class (single-channel-simple-stream stream)
 615       (setf buffer (sm buffer stream))
 616       (setf end (sm buffpos stream))))
 617   (write-octets stream buffer start end blocking))
 618
 619 (defmethod device-write ((stream dual-channel-simple-stream) buffer
 620                          start end blocking)
 621   (when (and (null buffer) (not (eql start end)))
 622     (with-stream-class (dual-channel-simple-stream stream)
 623       (setf buffer (sm out-buffer stream))
 624       (setf end (sm outpos stream))))
 625   (write-octets stream buffer start end blocking))
 626
 627 (defmethod device-write ((stream null-simple-stream) buffer
 628                          start end blocking)
 629   (declare (ignore buffer blocking))
 630   (- end start))
 631
 632 (defmethod device-write ((stream socket-base-simple-stream) buffer
 633                          start end blocking)
 634   ;; @@2
 635   (call-next-method))
 636
 637
 638 (defmethod device-clear-output ((stream simple-stream))
 639   nil)
 640
 641
 642 (defmethod device-extend ((stream direct-simple-stream) need action)
 643   (declare (ignore need action))
 644   nil)
 645
 646 (defmethod device-extend ((stream string-input-simple-stream) need action)
 647   (declare (ignore need action))
 648   nil)
 649
 650 (defmethod device-extend ((stream string-output-simple-stream) need action)
 651   ;; @@3
 652   )
 653
 654 (defmethod device-extend ((stream fill-pointer-output-simple-stream)
 655                           need action)
 656   ;; @@4
 657   )
 658
 659 (defmethod device-extend ((stream mapped-file-simple-stream) need action)
 660   (declare (ignore need action))
 661   nil)
 662
 663
 664 ;; device-finish-record apparently has no methods defined
 665
 666
 667 ;;;
 668 ;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
 669 ;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
 670 ;;;
 671
 672
 673 ;;;
 674 ;;; CREATION OF STANDARD STREAMS
 675 ;;;
 676