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 ;;; SETUP
  13 ;;;
  14
  15 (defmethod shared-initialize :after ((instance simple-stream) slot-names
  16                                      &rest initargs &key &allow-other-keys)
  17   (declare (ignore slot-names))
  18   (unless (slot-boundp instance 'melded-stream)
  19     (setf (slot-value instance 'melded-stream) instance)
  20     (setf (slot-value instance 'melding-base) instance))
  21   (unless (device-open instance initargs)
  22     (device-close instance t)))
  23
  24 ;;; From the simple-streams documentation: "A generic function implies
  25 ;;; a specialization capability that does not exist for
  26 ;;; simple-streams; simple-stream specializations should be on
  27 ;;; device-close."  So don't do it.
  28 (defmethod close ((stream simple-stream) &key abort)
  29   (device-close stream abort))
  30
  31
  32 ;;; This takes care of the things all device-close methods have to do,
  33 ;;; regardless of the type of simple-stream
  34 (defmethod device-close :around ((stream simple-stream) abort)
  35   (with-stream-class (simple-stream stream)
  36     (when (any-stream-instance-flags stream :input :output)
  37       (when (any-stream-instance-flags stream :output)
  38         (if abort
  39             (clear-output stream)
  40             (force-output stream)))
  41       (call-next-method)
  42       (setf (sm input-handle stream) nil
  43             (sm output-handle stream) nil
  44             (sm j-listen stream) #'sb-kernel::closed-flame
  45             (sm j-read-char stream) #'sb-kernel::closed-flame
  46             (sm j-read-chars stream) #'sb-kernel::closed-flame
  47             (sm j-unread-char stream) #'sb-kernel::closed-flame
  48             (sm j-write-char stream) #'sb-kernel::closed-flame  ;@@
  49             (sm j-write-chars stream) #'sb-kernel::closed-flame) ;@@
  50       (remove-stream-instance-flags stream :input :output)
  51       (sb-ext:cancel-finalization stream))))
  52
  53 ;;;
  54 ;;; Stream printing
  55 ;;;
  56
  57 (defmethod print-object ((object simple-stream) stream)
  58   (print-unreadable-object (object stream :type nil :identity nil)
  59     (cond ((not (any-stream-instance-flags object :simple))
  60            (princ "Invalid " stream))
  61           ((not (any-stream-instance-flags object :input :output))
  62            (princ "Closed " stream)))
  63     (format stream "~:(~A~)" (type-of object))))
  64
  65 (defmethod print-object ((object file-simple-stream) stream)
  66   (print-unreadable-object (object stream :type nil :identity nil)
  67     (with-stream-class (file-simple-stream object)
  68       (cond ((not (any-stream-instance-flags object :simple))
  69              (princ "Invalid " stream))
  70             ((not (any-stream-instance-flags object :input :output))
  71              (princ "Closed " stream)))
  72       (format stream "~:(~A~) for ~S"
  73               (type-of object) (sm filename object)))))
  74
  75 (defun make-control-table (&rest inits)
  76   (let ((table (make-array 32 :initial-element nil)))
  77     (do* ((char (pop inits) (pop inits))
  78           (func (pop inits) (pop inits)))
  79          ((null char))
  80       (when (< (char-code char) 32)
  81         (setf (aref table (char-code char)) func)))
  82     table))
  83
  84 (defun std-newline-out-handler (stream character)
  85   (declare (ignore character))
  86   (with-stream-class (simple-stream stream)
  87     (setf (sm charpos stream) -1)
  88     nil))
  89
  90 (defun std-tab-out-handler (stream character)
  91   (declare (ignore character))
  92   (with-stream-class (simple-stream stream)
  93     (let ((col (sm charpos stream)))
  94       (when col
  95         (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
  96     nil))
  97
  98 (defun std-dc-newline-in-handler (stream character)
  99   (with-stream-class (dual-channel-simple-stream stream)
 100     (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
 101     character))
 102
 103 (defvar *std-control-out-table*
 104   (make-control-table #\Newline #'std-newline-out-handler
 105                       #\Tab     #'std-tab-out-handler))
 106
 107 (defvar *terminal-control-in-table*
 108   (make-control-table #\Newline #'std-dc-newline-in-handler))
 109
 110 (defun find-external-format (name)
 111   nil)
 112
 113 ;;;
 114 ;;; LOW LEVEL STUFF
 115 ;;;
 116
 117 (defun vector-elt-width (vector)
 118   ;; Return octet-width of vector elements
 119   (etypecase vector
 120     ;; (simple-array fixnum (*)) not supported
 121     ;; (simple-array base-char (*)) treated specially; don't call this
 122     ((simple-array bit (*)) 1)
 123     ((simple-array (unsigned-byte 2) (*)) 1)
 124     ((simple-array (unsigned-byte 4) (*)) 1)
 125     ((simple-array (signed-byte 8) (*)) 1)
 126     ((simple-array (unsigned-byte 8) (*)) 1)
 127     ((simple-array (signed-byte 16) (*)) 2)
 128     ((simple-array (unsigned-byte 16) (*)) 2)
 129     ((simple-array (signed-byte 32) (*)) 4)
 130     ((simple-array (unsigned-byte 32) (*)) 4)
 131     ((simple-array single-float (*)) 4)
 132     ((simple-array double-float (*)) 8)
 133     ((simple-array (complex single-float) (*)) 8)
 134     ((simple-array (complex double-float) (*)) 16)))
 135
 136 (defun endian-swap-value (vector endian-swap)
 137   (case endian-swap
 138     (:network-order (1- (vector-elt-width vector)))
 139     (:byte-8 0)
 140     (:byte-16 1)
 141     (:byte-32 3)
 142     (:byte-64 7)
 143     (:byte-128 15)
 144     (otherwise endian-swap)))
 145
 146
 147 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
 148   (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
 149            (type stream stream))
 150   ;; START and END are octet offsets, not vector indices!  [Except for strings]
 151   ;; Return value is index of next octet to be read into (i.e., start+count)
 152   (etypecase stream
 153     (simple-stream
 154      (with-stream-class (simple-stream stream)
 155        (if (stringp vector)
 156            (let* ((start (or start 0))
 157                   (end (or end (length vector)))
 158                   (char (funcall-stm-handler j-read-char stream nil nil t)))
 159              (when char
 160                (setf (schar vector start) char)
 161                (incf start)
 162                (+ start (funcall-stm-handler j-read-chars stream vector nil
 163                                              start end nil))))
 164            (do* ((j-read-byte
 165                   (cond ((any-stream-instance-flags stream :string)
 166                          (error "Can't READ-BYTE on string streams."))
 167                         ((any-stream-instance-flags stream :dual)
 168                          #'dc-read-byte)
 169                         (t
 170                          #'sc-read-byte)))
 171                  (index (or start 0) (1+ index))
 172                  (end (or end (* (length vector) (vector-elt-width vector))))
 173                  (endian-swap (endian-swap-value vector endian-swap))
 174                  (byte (funcall j-read-byte stream nil nil t)
 175                        (funcall j-read-byte stream nil nil nil)))
 176                 ((or (null byte) (>= index end)) index)
 177              (setf (bref vector (logxor index endian-swap)) byte)))))
 178     ((or ansi-stream fundamental-stream)
 179      (unless (typep vector '(or string
 180                              (simple-array (signed-byte 8) (*))
 181                              (simple-array (unsigned-byte 8) (*))))
 182        (error "Wrong vector type for read-vector on stream not of type simple-stream."))
 183      ;; FIXME: implement blocking/non-blocking semantics here as well
 184      (read-sequence vector stream :start (or start 0) :end end))))
 185
 186 #|(defun write-vector ...)|#
 187
 188 (defun read-octets (stream buffer start end blocking)
 189   (declare (type simple-stream stream)
 190            (type (or null simple-stream-buffer) buffer)
 191            (type fixnum start)
 192            (type (or null fixnum) end)
 193            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 194   (with-stream-class (simple-stream stream)
 195     (let ((fd (sm input-handle stream))
 196           (end (or end (sm buf-len stream)))
 197           (buffer (or buffer (sm buffer stream))))
 198       (declare (fixnum end))
 199       (typecase fd
 200         (fixnum
 201          (let ((flag (sb-sys:wait-until-fd-usable fd :input
 202                                                   (if blocking nil 0))))
 203            (cond
 204              ((and (not blocking) (= start end)) (if flag -3 0))
 205              ((and (not blocking) (not flag)) 0)
 206              (t (block nil
 207                   (let ((count 0))
 208                     (declare (type fixnum count))
 209                     (tagbody
 210                      again
 211                        ;; Avoid CMUCL gengc write barrier
 212                        (do ((i start (+ i (the fixnum (sb-posix:getpagesize)))))
 213                            ((>= i end))
 214                          (declare (type fixnum i))
 215                          (setf (bref buffer i) 0))
 216                        (setf (bref buffer (1- end)) 0)
 217                        (multiple-value-bind (bytes errno)
 218                            (sb-unix:unix-read fd (buffer-sap buffer start)
 219                                               (the fixnum (- end start)))
 220                          (declare (type (or null fixnum) bytes)
 221                                   (type (integer 0 100) errno))
 222                          (when bytes
 223                            (incf count bytes)
 224                            (incf start bytes))
 225                          (cond ((null bytes)
 226                                 (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
 227                                 (cond ((= errno sb-unix:eintr) (go again))
 228                                       ((and blocking
 229                                             (or (= errno ;;sb-unix:eagain
 230                                                    ;; FIXME: move
 231                                                    ;; eagain into
 232                                                    ;; sb-unix
 233                                                    11)
 234                                                 (= errno sb-unix:ewouldblock)))
 235                                        (sb-sys:wait-until-fd-usable fd :input nil)
 236                                        (go again))
 237                                       (t (return (- -10 errno)))))
 238                                ((zerop count) (return -1))
 239                                (t (return count)))))))))))
 240         ;; Handle encapsulated stream.  FIXME: perhaps handle
 241         ;; sbcl-vintage ansi-stream type in read-octets too?
 242         (stream (read-octets fd buffer start end blocking))
 243         (t (error "Don't know how to handle input handle ~S" fd))))))
 244
 245 (defun write-octets (stream buffer start end blocking)
 246   (declare (type simple-stream stream)
 247            (type (or null simple-stream-buffer) buffer)
 248            (type fixnum start)
 249            (type (or null fixnum) end))
 250   (with-stream-class (simple-stream stream)
 251     (let ((fd (sm output-handle stream))
 252           (end (or end (error "WRITE-OCTETS: end=NIL")))
 253           (buffer (or buffer (error "WRITE-OCTETS: buffer=NIL"))))
 254       (typecase fd
 255         (fixnum
 256          (let ((flag (sb-sys:wait-until-fd-usable fd :output
 257                                                   (if blocking nil 0))))
 258            (cond
 259              ((and (not blocking) (= start end)) (if flag -3 0))
 260              ((and (not blocking) (not flag)) 0)
 261              (t
 262               (block nil
 263                 (let ((count 0))
 264                   (tagbody again
 265                      (multiple-value-bind (bytes errno)
 266                          (sb-unix:unix-write fd (buffer-sap buffer) start
 267                                              (- end start))
 268                        (when bytes
 269                          (incf count bytes)
 270                          (incf start bytes))
 271                        (cond ((null bytes)
 272                               (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%"
 273                                       errno)
 274                               (cond ((= errno sb-unix:eintr) (go again))
 275                                     ;; don't block for subsequent chars
 276                                     (t (return (- -10 errno)))))
 277                              (t (return count)))))))))))
 278         ;; Handle encapsulated stream.  FIXME: perhaps handle
 279         ;; sbcl-vintage ansi-stream type in write-octets too?
 280         (stream (write-octets fd buffer start end blocking))
 281         (t (error "Don't know how to handle output handle ~A" fd))))))
 282
 283
 284 ;;;
 285 ;;; IMPLEMENTATIONS
 286 ;;;
 287
 288
 289 ;;; simple-stream, dual-channel-simple-stream,
 290 ;;; single-channel-simple-stream
 291
 292 (defmethod device-buffer-length ((stream simple-stream))
 293   4096)
 294
 295 (defmethod device-file-position ((stream simple-stream))
 296   (with-stream-class (simple-stream stream)
 297     (cond ((any-stream-instance-flags stream :dual)
 298            (with-stream-class (dual-channel-simple-stream stream)
 299              (sm buffpos stream)))
 300           ((any-stream-instance-flags stream :string)
 301            (with-stream-class (string-simple-stream stream)
 302              (sm buffpos stream)))
 303           (t
 304            (with-stream-class (single-channel-simple-stream stream)
 305              (sm buffpos stream))))))
 306
 307
 308 (defmethod (setf device-file-position) (value (stream simple-stream))
 309   (with-stream-class (simple-stream stream)
 310     (cond ((any-stream-instance-flags stream :dual)
 311            (with-stream-class (dual-channel-simple-stream stream)
 312              (setf (sm buffpos stream) value)))
 313           ((any-stream-instance-flags stream :string)
 314            (with-stream-class (string-simple-stream stream)
 315              (setf (sm buffpos stream) value)))
 316           (t
 317            (with-stream-class (single-channel-simple-stream stream)
 318              (setf (sm buffpos stream) value))))))
 319
 320 (defmethod device-file-length ((stream simple-stream))
 321   nil)
 322
 323 (defmethod device-read ((stream single-channel-simple-stream) buffer
 324                         start end blocking)
 325   ;; rudi (2003-06-07): this block commented out in Paul Foley's code
 326 ;;   (when (and (null buffer) (not (eql start end)))
 327 ;;     (with-stream-class (single-channel-simple-stream stream)
 328 ;;       (setq buffer (sm buffer stream))
 329 ;;       (setq end (sm buf-len stream))))
 330   (read-octets stream buffer start end blocking))
 331
 332 (defmethod device-read ((stream dual-channel-simple-stream) buffer
 333                         start end blocking)
 334   (when (null buffer)
 335     (with-stream-class (dual-channel-simple-stream stream)
 336       (setq buffer (sm buffer stream))
 337       (setq end (- (sm buf-len stream) start))))
 338   (read-octets stream buffer start end blocking))
 339
 340 (defmethod device-clear-input ((stream simple-stream) buffer-only)
 341   (declare (ignore buffer-only))
 342   nil)
 343
 344 (defmethod device-write ((stream single-channel-simple-stream) buffer
 345                          start end blocking)
 346   (when (and (null buffer) (not (eql start end)))
 347     (with-stream-class (single-channel-simple-stream stream)
 348       (setf buffer (sm buffer stream))))
 349   (write-octets stream buffer start end blocking))
 350
 351 (defmethod device-write ((stream dual-channel-simple-stream) buffer
 352                          start end blocking)
 353   (when (and (null buffer) (not (eql start end)))
 354     (with-stream-class (dual-channel-simple-stream stream)
 355       (setf buffer (sm out-buffer stream))))
 356   (write-octets stream buffer start end blocking))
 357
 358 (defmethod device-clear-output ((stream simple-stream))
 359   nil)
 360
 361
 362 ;;; Direct-Simple-Stream and Buffer-(Input|Output)-Simple-Stream
 363
 364 (defmethod device-file-length ((stream direct-simple-stream))
 365   ;; return buffer length
 366   )
 367
 368 (defmethod device-open ((stream buffer-input-simple-stream) options)
 369   #| do something |#
 370   stream)
 371
 372 (defmethod device-open ((stream buffer-output-simple-stream) options)
 373   #| do something |#
 374   stream)
 375
 376
 377 ;;; Definition of File-Simple-Stream and relations
 378
 379 (defun open-file-stream (stream options)
 380   (let ((filename (pathname (getf options :filename)))
 381         (direction (getf options :direction :input))
 382         (if-exists (getf options :if-exists))
 383         (if-exists-given (not (eql (getf options :if-exists t) t)))
 384         (if-does-not-exist (getf options :if-does-not-exist))
 385         (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
 386     (with-stream-class (file-simple-stream stream)
 387       (ecase direction
 388         (:input (add-stream-instance-flags stream :input))
 389         (:output (add-stream-instance-flags stream :output))
 390         (:io (add-stream-instance-flags stream :input :output)))
 391       (cond ((and (sm input-handle stream) (sm output-handle stream)
 392                   (not (eql (sm input-handle stream)
 393                             (sm output-handle stream))))
 394              (error "Input-Handle and Output-Handle can't be different."))
 395             ((or (sm input-handle stream) (sm output-handle stream))
 396              (add-stream-instance-flags stream :simple)
 397              ;; get namestring, etc. from handle, if possible (it's a stream)
 398              ;; set up buffers
 399              stream)
 400             (t
 401              (multiple-value-bind (fd namestring original delete-original)
 402                  (%fd-open filename direction if-exists if-exists-given
 403                            if-does-not-exist if-does-not-exist-given)
 404                (when fd
 405                  (add-stream-instance-flags stream :simple)
 406                  (setf (sm pathname stream) filename
 407                        (sm filename stream) namestring
 408                        (sm original stream) original
 409                        (sm delete-original stream) delete-original)
 410                  (when (any-stream-instance-flags stream :input)
 411                    (setf (sm input-handle stream) fd))
 412                  (when (any-stream-instance-flags stream :output)
 413                    (setf (sm output-handle stream) fd))
 414                  (sb-ext:finalize stream
 415                    (lambda ()
 416                      (sb-unix:unix-close fd)
 417                      (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
 418                              namestring fd)))
 419                  stream)))))))
 420
 421 (defmethod device-open ((stream file-simple-stream) options)
 422   (with-stream-class (file-simple-stream stream)
 423     (when (open-file-stream stream options)
 424       ;; Franz says:
 425       ;;  "The device-open method must be prepared to recognize resource
 426       ;;   and change-class situations. If no filename is specified in
 427       ;;   the options list, and if no input-handle or output-handle is
 428       ;;   given, then the input-handle and output-handle slots should
 429       ;;   be examined; if non-nil, that means the stream is still open,
 430       ;;   and thus the operation being requested of device-open is a
 431       ;;   change-class. Also, a device-open method need not allocate a
 432       ;;   buffer every time it is called, but may instead reuse a
 433       ;;   buffer it finds in a stream, if it does not become a security
 434       ;;   issue."
 435       (unless (sm buffer stream)
 436         (let ((length (device-buffer-length stream)))
 437           ;; Buffer should be array of (unsigned-byte 8), in general
 438           ;; use strings for now so it's easy to read the content...
 439           (setf (sm buffer stream) (make-string length)
 440                 (sm buffpos stream) 0
 441                 (sm buffer-ptr stream) 0
 442                 (sm buf-len stream) length)))
 443       (when (any-stream-instance-flags stream :output)
 444         (setf (sm control-out stream) *std-control-out-table*))
 445       (let ((efmt (getf options :external-format :default)))
 446         (compose-encapsulating-streams stream efmt)
 447         (install-single-channel-character-strategy stream efmt nil)))))
 448
 449 (defmethod device-close ((stream file-simple-stream) abort)
 450   (with-stream-class (file-simple-stream stream)
 451     (cond (abort
 452            ;; TODO:
 453            ;; Remove any fd-handler
 454            ;; If it's an output stream and has an original name,
 455            ;; revert the file
 456            )
 457           (t
 458            ;; TODO:
 459            ;; If there's an original name and delete-original is set
 460            ;; kill the original
 461            ))
 462     (if (sm input-handle stream)
 463         (sb-unix:unix-close (sm input-handle stream))
 464         (sb-unix:unix-close (sm output-handle stream)))
 465     (setf (sm buffer stream) nil))
 466   t)
 467
 468 (defmethod device-file-position ((stream file-simple-stream))
 469   (with-stream-class (file-simple-stream stream)
 470     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 471                                     (sm output-handle stream))
 472                                 0
 473                                 sb-unix:l_incr))))
 474
 475 (defmethod (setf device-file-position) (value (stream file-simple-stream))
 476   (declare (type fixnum value))
 477   (with-stream-class (file-simple-stream stream)
 478     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 479                                     (sm output-handle stream))
 480                                 value
 481                                 (if (minusp value)
 482                                     sb-unix:l_xtnd
 483                                     sb-unix:l_set)))))
 484
 485 (defmethod device-file-length ((stream file-simple-stream))
 486   (with-stream-class (file-simple-stream stream)
 487     (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 488         (sb-unix:unix-fstat (sm input-handle stream))
 489       (declare (ignore dev ino mode nlink uid gid rdev))
 490       (if okay size nil))))
 491
 492 (defmethod device-open ((stream mapped-file-simple-stream) options)
 493   (with-stream-class (mapped-file-simple-stream stream)
 494     (when (open-file-stream stream options)
 495       (let* ((input (any-stream-instance-flags stream :input))
 496              (output (any-stream-instance-flags stream :output))
 497              (prot (logior (if input sb-posix::PROT-READ 0)
 498                            (if output sb-posix::PROT-WRITE 0)))
 499              (fd (or (sm input-handle stream) (sm output-handle stream))))
 500         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 501             (sb-unix:unix-fstat fd)
 502           (declare (ignore ino mode nlink uid gid rdev))
 503           (unless okay
 504             (sb-unix:unix-close fd)
 505             (sb-ext:cancel-finalization stream)
 506             (error "Error fstating ~S: ~A" stream
 507                    (sb-int:strerror dev)))
 508           (when (> size most-positive-fixnum)
 509             ;; Or else BUF-LEN has to be a general integer, or
 510             ;; maybe (unsigned-byte 32).  In any case, this means
 511             ;; BUF-MAX and BUF-PTR have to be the same, which means
 512             ;; number-consing every time BUF-PTR moves...
 513             ;; Probably don't have the address space available to map
 514             ;; bigger files, anyway.
 515             (warn "Unable to memory-map entire file.")
 516             (setf size most-positive-fixnum))
 517           (let ((buffer
 518                  (handler-case
 519                   (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
 520                   (sb-posix:syscall-error nil))))
 521             (when (null buffer)
 522               (sb-unix:unix-close fd)
 523               (sb-ext:cancel-finalization stream)
 524               (error "Unable to map file."))
 525             (setf (sm buffer stream) buffer
 526                   (sm buffpos stream) 0
 527                   (sm buffer-ptr stream) size
 528                   (sm buf-len stream) size)
 529             (install-single-channel-character-strategy
 530              stream (getf options :external-format :default) 'mapped)
 531             (sb-ext:finalize stream
 532               (lambda ()
 533                 (sb-posix:munmap buffer size)
 534                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
 535     stream))
 536
 537 (defmethod device-close ((stream mapped-file-simple-stream) abort)
 538   (with-stream-class (mapped-file-simple-stream stream)
 539     (when (sm buffer stream)
 540       (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
 541       (setf (sm buffer stream) nil))
 542     (cond (abort
 543            ;; remove any FD handler
 544            ;; if it has an original name (is this possible for mapped files?)
 545            ;;   revert the file
 546            )
 547           (t
 548            ;; if there's an original name and delete-original is set (again,
 549            ;;   is this even possible?), kill the original
 550            ))
 551     (sb-unix:unix-close (sm input-handle stream)))
 552   t)
 553
 554
 555 ;;; Definition of Null-Simple-Stream
 556
 557
 558 (defmethod device-open ((stream null-simple-stream) options)
 559   (with-stream-class (null-simple-stream stream)
 560     (add-stream-instance-flags stream :simple :input :output)
 561     ;;(install-single-channel-character-strategy
 562     ;; stream (getf options :external-format :default) nil)
 563     (setf (sm j-read-char stream) #'null-read-char
 564           (sm j-read-chars stream) #'null-read-chars
 565           (sm j-unread-char stream) #'null-unread-char
 566           (sm j-write-char stream) #'null-write-char
 567           (sm j-write-chars stream) #'null-write-chars
 568           (sm j-listen stream) #'null-listen))
 569   stream)
 570
 571
 572 (defmethod device-buffer-length ((stream null-simple-stream))
 573   256)
 574
 575 (defmethod device-read ((stream null-simple-stream) buffer
 576                         start end blocking)
 577   (declare (ignore buffer start end blocking))
 578   -1)
 579
 580 (defmethod device-write ((stream null-simple-stream) buffer
 581                          start end blocking)
 582   (declare (ignore buffer blocking))
 583   (- end start))
 584
 585
 586 ;;; Socket-Simple-Stream and relatives
 587
 588
 589 (defmethod device-open ((stream socket-base-simple-stream) options)
 590   #| do something |#
 591   stream)
 592
 593 (defmethod device-open ((stream socket-simple-stream) options)
 594   (with-stream-class (socket-simple-stream stream)
 595      (let* ((remote-host (getf options :remote-host))
 596             (remote-port (getf options :remote-port))
 597             (socket (make-instance 'sb-bsd-sockets:inet-socket
 598                                    :type :stream :protocol :tcp)))
 599        (setf (sm socket stream) socket)
 600        (sb-bsd-sockets:socket-connect socket remote-host remote-port)
 601        (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
 602          ;; Connect stream to socket, ...
 603          (setf (sm input-handle stream) fd)
 604          (setf (sm output-handle stream) fd)
 605          ;; ... and socket to stream.
 606          (setf (slot-value socket 'stream) stream)
 607          (sb-ext:cancel-finalization socket)
 608          (sb-ext:finalize stream
 609                           (lambda ()
 610                             (sb-unix:unix-close fd)
 611                             (format *terminal-io*
 612                                     "~&;;; ** closed socket (fd ~D)~%" fd))))
 613        ;; Now frob the stream slots.  FIXME: should we handle a
 614        ;; :direction arg from output, defaulting to :input only?
 615        (add-stream-instance-flags stream :simple :input :output :dual)
 616        (unless (sm buffer stream)
 617          (let ((length (device-buffer-length stream)))
 618            ;; Buffer should be array of (unsigned-byte 8), in general
 619            ;; use strings for now so it's easy to read the content...
 620            (setf (sm buffer stream) (make-string length)
 621                  (sm buffpos stream) 0
 622                  (sm buffer-ptr stream) 0
 623                  (sm buf-len stream) length)))
 624        (unless (sm out-buffer stream)
 625         (let ((length (device-buffer-length stream)))
 626           (setf (sm out-buffer stream) (make-string length)
 627                 (sm max-out-pos stream) length)))
 628        (setf (sm control-in stream) *terminal-control-in-table*)
 629        (setf (sm control-out stream) *std-control-out-table*)
 630        (install-dual-channel-character-strategy
 631         stream (getf options :external-format :default)))
 632      stream))
 633
 634 (defmethod device-close ((stream socket-simple-stream) abort)
 635   ;; Abort argument is handled by :around method on base class
 636   (declare (ignore abort))
 637   (with-stream-class (socket-simple-stream stream)
 638     (sb-unix:unix-close (sm input-handle stream))
 639     (setf (sm buffer stream) nil)
 640     (setf (sm out-buffer stream) nil))
 641   (sb-ext:cancel-finalization stream)
 642   t)
 643
 644
 645 ;;; String-Simple-Stream and relatives
 646
 647
 648 (defmethod device-file-position ((stream string-simple-stream))
 649   ;; get string length (of input or output buffer?)
 650   )
 651
 652 (defmethod (setf device-file-position) (value (stream string-simple-stream))
 653   ;; set string length (of input or output buffer?)
 654   )
 655
 656 (defmethod device-file-length ((stream string-simple-stream))
 657   ;; return string length
 658   )
 659
 660 (defmethod device-open :before ((stream string-input-simple-stream) options)
 661   (with-stream-class (string-input-simple-stream stream)
 662     (let ((string (getf options :string)))
 663       (when (and string (null (sm buffer stream)))
 664         (let ((start (getf options :start))
 665               (end (or (getf options :end) (length string))))
 666           (setf (sm buffer stream) string
 667                 (sm buffpos stream) start
 668                 (sm buffer-ptr stream) end))))
 669     (install-string-input-character-strategy stream)
 670     (add-stream-instance-flags stream :string :input :simple)))
 671
 672 (defmethod device-open :before ((stream string-output-simple-stream) options)
 673   (with-stream-class (string-output-simple-stream stream)
 674     (unless (sm out-buffer stream)
 675       (let ((string (getf options :string)))
 676         (if string
 677             (setf (sm out-buffer stream) string
 678                   (sm max-out-pos stream) (length string))
 679             (let ((buflen (max (device-buffer-length stream) 16)))
 680               (setf (sm out-buffer stream) (make-string buflen)
 681                     (sm max-out-pos stream) buflen)))))
 682     (unless (sm control-out stream)
 683       (setf (sm control-out stream) *std-control-out-table*))
 684     (install-string-output-character-strategy stream)
 685     (add-stream-instance-flags stream :string :output :simple)))
 686
 687
 688 (defmethod device-open ((stream string-input-simple-stream) options)
 689   #| do something |#
 690   stream)
 691
 692
 693 (defmethod device-open ((stream string-output-simple-stream) options)
 694   #| do something |#
 695   stream)
 696
 697
 698 (defmethod device-open ((stream xp-simple-stream) options)
 699   #| do something |#
 700   stream)
 701
 702 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
 703   #| do something |#
 704   stream)
 705
 706 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
 707   ;; get fill pointer (of input or output buffer?)
 708   )
 709
 710 (defmethod (setf device-file-position)
 711     (value (stream fill-pointer-output-simple-stream))
 712   ;; set fill pointer (of input or output buffer?)
 713   )
 714
 715
 716 ;;; Terminal-Simple-Stream
 717
 718 (defmethod device-open ((stream terminal-simple-stream) options)
 719   (with-stream-class (terminal-simple-stream stream)
 720     (when (getf options :input-handle)
 721       (setf (sm input-handle stream) (getf options :input-handle))
 722       (add-stream-instance-flags stream :simple :interactive :dual :input)
 723       (unless (sm buffer stream)
 724         (let ((length (device-buffer-length stream)))
 725           (setf (sm buffer stream) (make-string length)
 726                 (sm buf-len stream) length)))
 727       (setf (sm control-in stream) *terminal-control-in-table*))
 728     (when (getf options :output-handle)
 729       (setf (sm output-handle stream) (getf options :output-handle))
 730       (add-stream-instance-flags stream :simple :interactive :dual :output)
 731       (unless (sm out-buffer stream)
 732         (let ((length (device-buffer-length stream)))
 733           (setf (sm out-buffer stream) (make-string length)
 734                 (sm max-out-pos stream) length)))
 735       (setf (sm control-out stream) *std-control-out-table*))
 736     (install-dual-channel-character-strategy
 737      stream (getf options :external-format :default)))
 738   ;; TODO (rudi 2003-06-08): when neither input-handle nor
 739   ;; output-handle are given, close the stream again.
 740   #| do something |#
 741   stream)
 742
 743 (defmethod device-read ((stream terminal-simple-stream) buffer
 744                         start end blocking)
 745   (let ((result (call-next-method)))
 746     (if (= result -1) -2 result)))
 747
 748 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
 749   )
 750
 751 (defmethod device-close ((stream simple-stream) abort)
 752   (declare (ignore abort))
 753   t)
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765 (defmethod device-read ((stream terminal-simple-stream) buffer
 766                         start end blocking)
 767   (let ((result (call-next-method)))
 768     (if (= result -1) -2 result)))
 769
 770
 771
 772 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
 773   )
 774
 775
 776
 777 (defmethod device-write ((stream socket-base-simple-stream) buffer
 778                          start end blocking)
 779   ;; @@2
 780   (call-next-method))
 781
 782
 783
 784
 785
 786
 787
 788
 789 ;; device-finish-record apparently has no methods defined
 790
 791
 792 ;;;
 793 ;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
 794 ;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
 795 ;;;
 796
 797
 798 ;;;
 799 ;;; CREATION OF STANDARD STREAMS
 800 ;;;
 801