X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Fsimple-streams.lisp;h=31db6dd653e0869f2026df1cd339f52823a78dc4;hb=8dc1241068db5855115a9e25488a8962718a6c79;hp=e762c9ff024e5c73f223baa342fed0e61231c326;hpb=c9078c1bae4ee38d5e1433c12ae3128f1bb9bc78;p=sbcl.git

diff --git a/contrib/sb-simple-streams/simple-streams.lisp b/contrib/sb-simple-streams/simple-streams.lisp
index e762c9f..31db6dd 100644
--- a/contrib/sb-simple-streams/simple-streams.lisp
+++ b/contrib/sb-simple-streams/simple-streams.lisp
@@ -9,12 +9,68 @@
 (in-package "SB-SIMPLE-STREAMS")
 
 ;;;
+;;; SETUP
+;;;
+
+(defmethod shared-initialize :after ((instance simple-stream) slot-names
+				     &rest initargs &key &allow-other-keys)
+  (declare (ignore slot-names))
+  (unless (slot-boundp instance 'melded-stream)
+    (setf (slot-value instance 'melded-stream) instance)
+    (setf (slot-value instance 'melding-base) instance))
+  (unless (device-open instance initargs)
+    (device-close instance t)))
+
+;;; From the simple-streams documentation: "A generic function implies
+;;; a specialization capability that does not exist for
+;;; simple-streams; simple-stream specializations should be on
+;;; device-close."  So don't do it.
+(defmethod close ((stream simple-stream) &key abort)
+  (device-close stream abort))
+
+
+;;; This takes care of the things all device-close methods have to do,
+;;; regardless of the type of simple-stream
+(defmethod device-close :around ((stream simple-stream) abort)
+  (with-stream-class (simple-stream stream)
+    (when (any-stream-instance-flags stream :input :output)
+      (when (any-stream-instance-flags stream :output)
+	(if abort
+	    (clear-output stream)
+	    (force-output stream)))
+      (call-next-method)
+      (setf (sm input-handle stream) nil
+	    (sm output-handle stream) nil
+	    (sm j-listen stream) #'sb-kernel::closed-flame
+	    (sm j-read-char stream) #'sb-kernel::closed-flame
+	    (sm j-read-chars stream) #'sb-kernel::closed-flame
+	    (sm j-unread-char stream) #'sb-kernel::closed-flame
+	    (sm j-write-char stream) #'sb-kernel::closed-flame	;@@
+	    (sm j-write-chars stream) #'sb-kernel::closed-flame) ;@@
+      (remove-stream-instance-flags stream :input :output)
+      (sb-ext:cancel-finalization stream))))
+
+;;;
 ;;; Stream printing
 ;;;
 
+(defmethod print-object ((object simple-stream) stream)
+  (print-unreadable-object (object stream :type nil :identity nil)
+    (cond ((not (any-stream-instance-flags object :simple))
+	   (princ "Invalid " stream))
+	  ((not (any-stream-instance-flags object :input :output))
+	   (princ "Closed " stream)))
+    (format stream "~:(~A~)" (type-of object))))
+
 (defmethod print-object ((object file-simple-stream) stream)
-  (print-unreadable-object (object stream :type t :identity t)
-    (format stream "for ~S" (slot-value object 'filename))))
+  (print-unreadable-object (object stream :type nil :identity nil)
+    (with-stream-class (file-simple-stream object)
+      (cond ((not (any-stream-instance-flags object :simple))
+             (princ "Invalid " stream))
+            ((not (any-stream-instance-flags object :input :output))
+             (princ "Closed " stream)))
+      (format stream "~:(~A~) for ~S"
+	      (type-of object) (sm filename object)))))
 
 (defun make-control-table (&rest inits)
   (let ((table (make-array 32 :initial-element nil)))
@@ -51,6 +107,9 @@
 (defvar *terminal-control-in-table*
   (make-control-table #\Newline #'std-dc-newline-in-handler))
 
+(defun find-external-format (name)
+  nil)
+
 ;;;
 ;;; LOW LEVEL STUFF
 ;;;
@@ -58,8 +117,11 @@
 (defun vector-elt-width (vector)
   ;; Return octet-width of vector elements
   (etypecase vector
-    ;; missing are: bit, unsigned-byte 2, unsigned-byte 4, signed-byte 30
-    ;; [and base-char, which is treated specially]
+    ;; (simple-array fixnum (*)) not supported
+    ;; (simple-array base-char (*)) treated specially; don't call this
+    ((simple-array bit (*)) 1)
+    ((simple-array (unsigned-byte 2) (*)) 1)
+    ((simple-array (unsigned-byte 4) (*)) 1)
     ((simple-array (signed-byte 8) (*)) 1)
     ((simple-array (unsigned-byte 8) (*)) 1)
     ((simple-array (signed-byte 16) (*)) 2)
@@ -73,12 +135,7 @@
 
 (defun endian-swap-value (vector endian-swap)
   (case endian-swap
-    (:network-order (case (vector-elt-width vector)
-		      (1 0)
-		      (2 1)
-		      (4 3)
-		      (8 7)
-		      (16 15)))
+    (:network-order (1- (vector-elt-width vector)))
     (:byte-8 0)
     (:byte-16 1)
     (:byte-32 3)
@@ -86,6 +143,7 @@
     (:byte-128 15)
     (otherwise endian-swap)))
 
+
 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
   (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
 	   (type stream stream))
@@ -122,15 +180,11 @@
 			     (simple-array (signed-byte 8) (*))
 			     (simple-array (unsigned-byte 8) (*))))
        (error "Wrong vector type for read-vector on stream not of type simple-stream."))
+     ;; FIXME: implement blocking/non-blocking semantics here as well
      (read-sequence vector stream :start (or start 0) :end end))))
 
 #|(defun write-vector ...)|#
 
-;;; TODO: move getpagesize into sbcl/unix.lisp, where it belongs
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun getpagesize ()
-    (sb-unix::int-syscall ("getpagesize"))))
-
 (defun read-octets (stream buffer start end blocking)
   (declare (type simple-stream stream)
 	   (type (or null simple-stream-buffer) buffer)
@@ -155,8 +209,7 @@
 		    (tagbody
 		     again
 		       ;; Avoid CMUCL gengc write barrier
-		       (do ((i start (+ i ;#.(sb-unix:unix-getpagesize)
-                                        (the fixnum (getpagesize)))))
+		       (do ((i start (+ i (the fixnum (sb-posix:getpagesize)))))
 			   ((>= i end))
 			 (declare (type fixnum i))
 			 (setf (bref buffer i) 0))
@@ -170,7 +223,7 @@
 			   (incf count bytes)
 			   (incf start bytes))
 			 (cond ((null bytes)
-				(format t "~&;; UNIX-READ: errno=~D~%" errno)
+				(format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
 				(cond ((= errno sb-unix:eintr) (go again))
 				      ((and blocking
 					    (or (= errno ;;sb-unix:eagain
@@ -187,7 +240,7 @@
         ;; Handle encapsulated stream.  FIXME: perhaps handle
         ;; sbcl-vintage ansi-stream type in read-octets too?
         (stream (read-octets fd buffer start end blocking))
-	(t (error "Don't know how to handle input handle &A" fd))))))
+	(t (error "Don't know how to handle input handle ~S" fd))))))
 
 (defun write-octets (stream buffer start end blocking)
   (declare (type simple-stream stream)
@@ -232,9 +285,85 @@
 ;;; IMPLEMENTATIONS
 ;;;
 
-(defmethod device-open ((stream null-simple-stream) options)
-  (add-stream-instance-flags stream :simple :input :output)
-  stream)
+
+;;; simple-stream, dual-channel-simple-stream,
+;;; single-channel-simple-stream
+
+(defmethod device-buffer-length ((stream simple-stream))
+  4096)
+
+(defmethod device-file-position ((stream simple-stream))
+  (with-stream-class (simple-stream stream)
+    (cond ((any-stream-instance-flags stream :dual)
+	   (with-stream-class (dual-channel-simple-stream stream)
+	     (sm buffpos stream)))
+	  ((any-stream-instance-flags stream :string)
+	   (with-stream-class (string-simple-stream stream)
+	     (sm buffpos stream)))
+	  (t
+	   (with-stream-class (single-channel-simple-stream stream)
+	     (sm buffpos stream))))))
+
+
+(defmethod (setf device-file-position) (value (stream simple-stream))
+  (with-stream-class (simple-stream stream)
+    (cond ((any-stream-instance-flags stream :dual)
+	   (with-stream-class (dual-channel-simple-stream stream)
+	     (setf (sm buffpos stream) value)))
+	  ((any-stream-instance-flags stream :string)
+	   (with-stream-class (string-simple-stream stream)
+	     (setf (sm buffpos stream) value)))
+	  (t
+	   (with-stream-class (single-channel-simple-stream stream)
+	     (setf (sm buffpos stream) value))))))
+
+(defmethod device-file-length ((stream simple-stream))
+  nil)
+
+(defmethod device-read ((stream single-channel-simple-stream) buffer
+			start end blocking)
+  ;; rudi (2003-06-07): this block commented out in Paul Foley's code
+;;   (when (and (null buffer) (not (eql start end)))
+;;     (with-stream-class (single-channel-simple-stream stream)
+;;       (setq buffer (sm buffer stream))
+;;       (setq end (sm buf-len stream))))
+  (read-octets stream buffer start end blocking))
+
+(defmethod device-read ((stream dual-channel-simple-stream) buffer
+			start end blocking)
+  (when (null buffer)
+    (with-stream-class (dual-channel-simple-stream stream)
+      (setq buffer (sm buffer stream))
+      (setq end (- (sm buf-len stream) start))))
+  (read-octets stream buffer start end blocking))
+
+(defmethod device-clear-input ((stream simple-stream) buffer-only)
+  (declare (ignore buffer-only))
+  nil)
+
+(defmethod device-write ((stream single-channel-simple-stream) buffer
+			 start end blocking)
+  (when (and (null buffer) (not (eql start end)))
+    (with-stream-class (single-channel-simple-stream stream)
+      (setf buffer (sm buffer stream))))
+  (write-octets stream buffer start end blocking))
+
+(defmethod device-write ((stream dual-channel-simple-stream) buffer
+			 start end blocking)
+  (when (and (null buffer) (not (eql start end)))
+    (with-stream-class (dual-channel-simple-stream stream)
+      (setf buffer (sm out-buffer stream))))
+  (write-octets stream buffer start end blocking))
+
+(defmethod device-clear-output ((stream simple-stream))
+  nil)
+
+
+;;; Direct-Simple-Stream and Buffer-(Input|Output)-Simple-Stream
+
+(defmethod device-file-length ((stream direct-simple-stream))
+  ;; return buffer length
+  )
 
 (defmethod device-open ((stream buffer-input-simple-stream) options)
   #| do something |#
@@ -244,13 +373,16 @@
   #| do something |#
   stream)
 
+
+;;; Definition of File-Simple-Stream and relations
+
 (defun open-file-stream (stream options)
   (let ((filename (pathname (getf options :filename)))
 	(direction (getf options :direction :input))
 	(if-exists (getf options :if-exists))
-	(if-exists-given (not (getf options :if-exists t)))
+	(if-exists-given (not (eql (getf options :if-exists t) t)))
 	(if-does-not-exist (getf options :if-does-not-exist))
-	(if-does-not-exist-given (not (getf options :if-does-not-exist t))))
+	(if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
     (with-stream-class (file-simple-stream stream)
       (ecase direction
 	(:input (add-stream-instance-flags stream :input))
@@ -310,16 +442,60 @@
 		(sm buf-len stream) length)))
       (when (any-stream-instance-flags stream :output)
 	(setf (sm control-out stream) *std-control-out-table*))
-      (install-single-channel-character-strategy
-       stream (getf options :external-format :default) nil))))
+      (let ((efmt (getf options :external-format :default)))
+	(compose-encapsulating-streams stream efmt)
+	(install-single-channel-character-strategy stream efmt nil)))))
+
+(defmethod device-close ((stream file-simple-stream) abort)
+  (with-stream-class (file-simple-stream stream)
+    (cond (abort
+           ;; TODO:
+	   ;; Remove any fd-handler
+	   ;; If it's an output stream and has an original name,
+	   ;; revert the file
+	   )
+	  (t
+           ;; TODO:
+	   ;; If there's an original name and delete-original is set
+	   ;; kill the original
+	   ))
+    (if (sm input-handle stream)
+	(sb-unix:unix-close (sm input-handle stream))
+        (sb-unix:unix-close (sm output-handle stream)))
+    (setf (sm buffer stream) nil))
+  t)
+
+(defmethod device-file-position ((stream file-simple-stream))
+  (with-stream-class (file-simple-stream stream)
+    (values (sb-unix:unix-lseek (or (sm input-handle stream)
+                                    (sm output-handle stream))
+                                0
+                                sb-unix:l_incr))))
+
+(defmethod (setf device-file-position) (value (stream file-simple-stream))
+  (declare (type fixnum value))
+  (with-stream-class (file-simple-stream stream)
+    (values (sb-unix:unix-lseek (or (sm input-handle stream)
+                                    (sm output-handle stream))
+                                value
+                                (if (minusp value)
+                                    sb-unix:l_xtnd
+                                    sb-unix:l_set)))))
+
+(defmethod device-file-length ((stream file-simple-stream))
+  (with-stream-class (file-simple-stream stream)
+    (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
+	(sb-unix:unix-fstat (sm input-handle stream))
+      (declare (ignore dev ino mode nlink uid gid rdev))
+      (if okay size nil))))
 
 (defmethod device-open ((stream mapped-file-simple-stream) options)
   (with-stream-class (mapped-file-simple-stream stream)
     (when (open-file-stream stream options)
       (let* ((input (any-stream-instance-flags stream :input))
 	     (output (any-stream-instance-flags stream :output))
-	     (prot (logior (if input PROT-READ 0)
-			   (if output PROT-WRITE 0)))
+	     (prot (logior (if input sb-posix::PROT-READ 0)
+			   (if output sb-posix::PROT-WRITE 0)))
 	     (fd (or (sm input-handle stream) (sm output-handle stream))))
 	(multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 	    (sb-unix:unix-fstat fd)
@@ -335,12 +511,13 @@
 	    ;; BUF-MAX and BUF-PTR have to be the same, which means
 	    ;; number-consing every time BUF-PTR moves...
 	    ;; Probably don't have the address space available to map
-	    ;; bigger files, anyway.  Maybe DEVICE-EXTEND can adjust
-	    ;; the mapped portion of the file?
+	    ;; bigger files, anyway.
 	    (warn "Unable to memory-map entire file.")
 	    (setf size most-positive-fixnum))
 	  (let ((buffer
-		 (sb-unix:unix-mmap nil size prot MAP-SHARED fd 0)))
+		 (handler-case
+                  (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
+                  (sb-posix:syscall-error nil))))
 	    (when (null buffer)
 	      (sb-unix:unix-close fd)
 	      (sb-ext:cancel-finalization stream)
@@ -353,26 +530,62 @@
 	     stream (getf options :external-format :default) 'mapped)
 	    (sb-ext:finalize stream
 	      (lambda ()
-		(sb-unix:unix-munmap buffer size)
+		(sb-posix:munmap buffer size)
 		(format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
     stream))
 
-(defmethod device-open ((stream string-input-simple-stream) options)
-  #| do something |#
-  stream)
+(defmethod device-close ((stream mapped-file-simple-stream) abort)
+  (with-stream-class (mapped-file-simple-stream stream)
+    (when (sm buffer stream)
+      (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
+      (setf (sm buffer stream) nil))
+    (cond (abort
+	   ;; remove any FD handler
+	   ;; if it has an original name (is this possible for mapped files?)
+	   ;;   revert the file
+	   )
+	  (t
+	   ;; if there's an original name and delete-original is set (again,
+	   ;;   is this even possible?), kill the original
+	   ))
+    (sb-unix:unix-close (sm input-handle stream)))
+  t)
 
-(defmethod device-open ((stream string-output-simple-stream) options)
-  #| do something |#
-  stream)
 
-(defmethod device-open ((stream xp-simple-stream) options)
-  #| do something |#
-  stream)
+;;; Definition of Null-Simple-Stream
 
-(defmethod device-open ((stream fill-pointer-output-simple-stream) options)
-  #| do something |#
+
+(defmethod device-open ((stream null-simple-stream) options)
+  (with-stream-class (null-simple-stream stream)
+    (add-stream-instance-flags stream :simple :input :output)
+    ;;(install-single-channel-character-strategy
+    ;; stream (getf options :external-format :default) nil)
+    (setf (sm j-read-char stream) #'null-read-char
+	  (sm j-read-chars stream) #'null-read-chars
+	  (sm j-unread-char stream) #'null-unread-char
+	  (sm j-write-char stream) #'null-write-char
+	  (sm j-write-chars stream) #'null-write-chars
+	  (sm j-listen stream) #'null-listen))
   stream)
 
+
+(defmethod device-buffer-length ((stream null-simple-stream))
+  256)
+
+(defmethod device-read ((stream null-simple-stream) buffer
+			start end blocking)
+  (declare (ignore buffer start end blocking))
+  -1)
+
+(defmethod device-write ((stream null-simple-stream) buffer
+			 start end blocking)
+  (declare (ignore buffer blocking))
+  (- end start))
+
+
+;;; Socket-Simple-Stream and relatives
+
+
 (defmethod device-open ((stream socket-base-simple-stream) options)
   #| do something |#
   stream)
@@ -397,7 +610,8 @@
                             (sb-unix:unix-close fd)
                             (format *terminal-io*
                                     "~&;;; ** closed socket (fd ~D)~%" fd))))
-       ;; Now frob the stream slots.
+       ;; Now frob the stream slots.  FIXME: should we handle a
+       ;; :direction arg from output, defaulting to :input only?
        (add-stream-instance-flags stream :simple :input :output :dual)
        (unless (sm buffer stream)
          (let ((length (device-buffer-length stream)))
@@ -417,81 +631,6 @@
         stream (getf options :external-format :default)))
      stream))
 
-(defmethod device-open ((stream terminal-simple-stream) options)
-  (with-stream-class (terminal-simple-stream stream)
-    (when (getf options :input-handle)
-      (setf (sm input-handle stream) (getf options :input-handle))
-      (add-stream-instance-flags stream :simple :interactive :dual :input)
-      (unless (sm buffer stream)
-	(let ((length (device-buffer-length stream)))
-	  (setf (sm buffer stream) (make-string length)
-		(sm buf-len stream) length)))
-      (setf (sm control-in stream) *terminal-control-in-table*))
-    (when (getf options :output-handle)
-      (setf (sm output-handle stream) (getf options :output-handle))
-      (add-stream-instance-flags stream :simple :interactive :dual :output)
-      (unless (sm out-buffer stream)
-	(let ((length (device-buffer-length stream)))
-	  (setf (sm out-buffer stream) (make-string length)
-		(sm max-out-pos stream) length)))
-      (setf (sm control-out stream) *std-control-out-table*))
-    (install-dual-channel-character-strategy
-     stream (getf options :external-format :default)))
-  #| do something |#
-  stream)
-
-
-(defmethod device-close :around ((stream simple-stream) abort)
-  (with-stream-class (simple-stream stream)
-    (when (any-stream-instance-flags stream :input :output)
-      (when (any-stream-instance-flags stream :output)
-	(if abort
-	    (clear-output stream)
-	    (force-output stream)))
-      (call-next-method)
-      (setf (sm input-handle stream) nil
-	    (sm output-handle stream) nil)
-      (remove-stream-instance-flags stream :input :output)
-      (sb-ext:cancel-finalization stream))))
-
-(defmethod device-close ((stream simple-stream) abort)
-  (declare (ignore abort))
-  t)
-
-(defmethod device-close ((stream file-simple-stream) abort)
-  (with-stream-class (file-simple-stream stream)
-    (cond (abort
-	   ;; Remove any fd-handler
-	   ;; If it's an output stream and has an original name,
-	   ;; revert the file
-	   )
-	  (t
-	   ;; If there's an original name and delete-original is set
-	   ;; kill the original
-	   ))
-    (if (sm input-handle stream)
-	(sb-unix:unix-close (sm input-handle stream))
-      (sb-unix:unix-close (sm output-handle stream)))
-    (setf (sm buffer stream) nil))
-  t)
-
-(defmethod device-close ((stream mapped-file-simple-stream) abort)
-  (with-stream-class (mapped-file-simple-stream stream)
-    (when (sm buffer stream)
-      (sb-unix:unix-munmap (sm buffer stream) (sm buf-len stream))
-      (setf (sm buffer stream) nil))
-    (cond (abort
-	   ;; remove any FD handler
-	   ;; if it has an original name (is this possible for mapped files?)
-	   ;;   revert the file
-	   )
-	  (t
-	   ;; if there's an original name and delete-original is set (again,
-	   ;;   is this even possible?), kill the original
-	   ))
-    (sb-unix:unix-close (sm input-handle stream)))
-  t)
-
 (defmethod device-close ((stream socket-simple-stream) abort)
   ;; Abort argument is handled by :around method on base class
   (declare (ignore abort))
@@ -502,22 +641,9 @@
   (sb-ext:cancel-finalization stream)
   t)
 
-(defmethod device-buffer-length ((stream simple-stream))
-  4096)
-
-(defmethod device-buffer-length ((stream null-simple-stream))
-  256)
-
 
-(defmethod device-file-position ((stream simple-stream))
-  (with-stream-class (simple-stream stream)
-    ;; this may be wrong if :DUAL flag is set!
-    (sm buffpos stream)))
+;;; String-Simple-Stream and relatives
 
-(defmethod (setf device-file-position) (value (stream simple-stream))
-  (with-stream-class (simple-stream stream)
-    ;; this may be wrong if :DUAL flag is set!
-    (setf (sm buffpos stream) value)))
 
 (defmethod device-file-position ((stream string-simple-stream))
   ;; get string length (of input or output buffer?)
@@ -527,6 +653,56 @@
   ;; set string length (of input or output buffer?)
   )
 
+(defmethod device-file-length ((stream string-simple-stream))
+  ;; return string length
+  )
+
+(defmethod device-open :before ((stream string-input-simple-stream) options)
+  (with-stream-class (string-input-simple-stream stream)
+    (let ((string (getf options :string)))
+      (when (and string (null (sm buffer stream)))
+	(let ((start (getf options :start))
+	      (end (or (getf options :end) (length string))))
+	  (setf (sm buffer stream) string
+		(sm buffpos stream) start
+		(sm buffer-ptr stream) end))))
+    (install-string-input-character-strategy stream)
+    (add-stream-instance-flags stream :string :input :simple)))
+
+(defmethod device-open :before ((stream string-output-simple-stream) options)
+  (with-stream-class (string-output-simple-stream stream)
+    (unless (sm out-buffer stream)
+      (let ((string (getf options :string)))
+	(if string
+	    (setf (sm out-buffer stream) string
+		  (sm max-out-pos stream) (length string))
+	    (let ((buflen (max (device-buffer-length stream) 16)))
+	      (setf (sm out-buffer stream) (make-string buflen)
+		    (sm max-out-pos stream) buflen)))))
+    (unless (sm control-out stream)
+      (setf (sm control-out stream) *std-control-out-table*))
+    (install-string-output-character-strategy stream)
+    (add-stream-instance-flags stream :string :output :simple)))
+
+
+(defmethod device-open ((stream string-input-simple-stream) options)
+  #| do something |#
+  stream)
+
+
+(defmethod device-open ((stream string-output-simple-stream) options)
+  #| do something |#
+  stream)
+
+
+(defmethod device-open ((stream xp-simple-stream) options)
+  #| do something |#
+  stream)
+
+(defmethod device-open ((stream fill-pointer-output-simple-stream) options)
+  #| do something |#
+  stream)
+
 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
   ;; get fill pointer (of input or output buffer?)
   )
@@ -536,63 +712,55 @@
   ;; set fill pointer (of input or output buffer?)
   )
 
-(defmethod device-file-position ((stream file-simple-stream))
-  (with-stream-class (file-simple-stream stream)
-    (values (sb-unix:unix-lseek (or (sm input-handle stream)
-                                    (sm output-handle stream))
-                                0
-                                sb-unix:l_incr))))
 
-(defmethod (setf device-file-position) (value (stream file-simple-stream))
-  (declare (type fixnum value))
-  (with-stream-class (file-simple-stream stream)
-    (values (sb-unix:unix-lseek (or (sm input-handle stream)
-                                    (sm output-handle stream))
-                                value
-                                (if (minusp value)
-                                    sb-unix:l_xtnd
-                                    sb-unix:l_set)))))
+;;; Terminal-Simple-Stream
 
+(defmethod device-open ((stream terminal-simple-stream) options)
+  (with-stream-class (terminal-simple-stream stream)
+    (when (getf options :input-handle)
+      (setf (sm input-handle stream) (getf options :input-handle))
+      (add-stream-instance-flags stream :simple :interactive :dual :input)
+      (unless (sm buffer stream)
+	(let ((length (device-buffer-length stream)))
+	  (setf (sm buffer stream) (make-string length)
+		(sm buf-len stream) length)))
+      (setf (sm control-in stream) *terminal-control-in-table*))
+    (when (getf options :output-handle)
+      (setf (sm output-handle stream) (getf options :output-handle))
+      (add-stream-instance-flags stream :simple :interactive :dual :output)
+      (unless (sm out-buffer stream)
+	(let ((length (device-buffer-length stream)))
+	  (setf (sm out-buffer stream) (make-string length)
+		(sm max-out-pos stream) length)))
+      (setf (sm control-out stream) *std-control-out-table*))
+    (install-dual-channel-character-strategy
+     stream (getf options :external-format :default)))
+  ;; TODO (rudi 2003-06-08): when neither input-handle nor
+  ;; output-handle are given, close the stream again.
+  #| do something |#
+  stream)
 
-(defmethod device-file-length ((stream simple-stream))
-  nil)
+(defmethod device-read ((stream terminal-simple-stream) buffer
+                        start end blocking)
+  (let ((result (call-next-method)))
+    (if (= result -1) -2 result)))
 
-(defmethod device-file-length ((stream direct-simple-stream))
-  ;; return buffer length
+(defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
   )
 
-(defmethod device-file-length ((stream string-simple-stream))
-  ;; return string length
-  )
+(defmethod device-close ((stream simple-stream) abort)
+  (declare (ignore abort))
+  t)
+
+
+
+
+
 
-(defmethod device-file-length ((stream file-simple-stream))
-  (with-stream-class (file-simple-stream stream)
-    (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
-	(sb-unix:unix-fstat (sm input-handle stream))
-      (declare (ignore dev ino mode nlink uid gid rdev))
-      (if okay size nil))))
 
 
-(defmethod device-read ((stream single-channel-simple-stream) buffer
-			start end blocking)
-;;  (when (and (null buffer) (not (eql start end)))
-;;    (with-stream-class (single-channel-simple-stream stream)
-;;      (setq buffer (sm buffer stream))
-;;      (setq end (sm buf-len stream))))
-  (read-octets stream buffer start end blocking))
 
-(defmethod device-read ((stream dual-channel-simple-stream) buffer
-			start end blocking)
-  (when (null buffer)
-    (with-stream-class (dual-channel-simple-stream stream)
-      (setq buffer (sm buffer stream))
-      (setq end (- (sm buf-len stream) start))))
-  (read-octets stream buffer start end blocking))
 
-(defmethod device-read ((stream null-simple-stream) buffer
-			start end blocking)
-  (declare (ignore buffer start end blocking))
-  -1)
 
 (defmethod device-read ((stream terminal-simple-stream) buffer
 			start end blocking)
@@ -600,34 +768,11 @@
     (if (= result -1) -2 result)))
 
 
-(defmethod device-clear-input ((stream simple-stream) buffer-only)
-  (declare (ignore buffer-only))
-  nil)
 
 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
   )
 
 
-(defmethod device-write ((stream single-channel-simple-stream) buffer
-			 start end blocking)
-  (when (and (null buffer) (not (eql start end)))
-    (with-stream-class (single-channel-simple-stream stream)
-      (setf buffer (sm buffer stream))
-      (setf end (sm buffpos stream))))
-  (write-octets stream buffer start end blocking))
-
-(defmethod device-write ((stream dual-channel-simple-stream) buffer
-			 start end blocking)
-  (when (and (null buffer) (not (eql start end)))
-    (with-stream-class (dual-channel-simple-stream stream)
-      (setf buffer (sm out-buffer stream))
-      (setf end (sm outpos stream))))
-  (write-octets stream buffer start end blocking))
-
-(defmethod device-write ((stream null-simple-stream) buffer
-			 start end blocking)
-  (declare (ignore buffer blocking))
-  (- end start))
 
 (defmethod device-write ((stream socket-base-simple-stream) buffer
 			 start end blocking)
@@ -635,30 +780,10 @@
   (call-next-method))
 
 
-(defmethod device-clear-output ((stream simple-stream))
-  nil)
 
 
-(defmethod device-extend ((stream direct-simple-stream) need action)
-  (declare (ignore need action))
-  nil)
 
-(defmethod device-extend ((stream string-input-simple-stream) need action)
-  (declare (ignore need action))
-  nil)
 
-(defmethod device-extend ((stream string-output-simple-stream) need action)
-  ;; @@3
-  )
-
-(defmethod device-extend ((stream fill-pointer-output-simple-stream)
-			  need action)
-  ;; @@4
-  )
-
-(defmethod device-extend ((stream mapped-file-simple-stream) need action)
-  (declare (ignore need action))
-  nil)
 
 
 ;; device-finish-record apparently has no methods defined