+
+
+(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)))
+
+
+(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))))
+
+;;; 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)
+ (ignore-errors (if abort
+ (clear-output stream)
+ (finish-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)
+ ;; This sets all readers and writers to error-raising functions
+ (setf (stream-external-format stream) :void))))
+
+(defmethod device-close ((stream simple-stream) abort)
+ (declare (ignore abort))
+ t)
+
+(defmethod device-buffer-length ((stream simple-stream))
+ 4096)
+
+(defmethod device-file-position ((stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (sm buffpos stream)))
+
+(defmethod (setf device-file-position) (value (stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (setf (sm buffpos stream) value)))
+
+(defmethod device-file-length ((stream simple-stream))
+ nil)
+
+(defgeneric (setf stream-external-format) (value stream))
+
+(defmethod (setf stream-external-format) :before (value (stream simple-stream))
+ ;; (unless (eq value (sm external-format stream))
+ ;; flush out the existing external-format
+ )
+
+(defmethod (setf stream-external-format) :after
+ (ef (stream single-channel-simple-stream))
+ (compose-encapsulating-streams stream ef)
+ (install-single-channel-character-strategy (melding-stream stream) ef nil))
+
+(defmethod (setf stream-external-format) :after
+ (ef (stream dual-channel-simple-stream))
+ (compose-encapsulating-streams stream ef)
+ (install-dual-channel-character-strategy (melding-stream stream) ef))
+
+
+(defmethod device-read ((stream single-channel-simple-stream) buffer
+ start end blocking)
+ (read-octets stream buffer start end blocking))
+
+(defmethod device-read ((stream dual-channel-simple-stream) buffer
+ start end blocking)
+ (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)
+ ;; buffer may be :flush to force/finish-output
+ (when (or (and (null buffer) (not (eql start end)))
+ (eq buffer :flush))
+ (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)
+ ;; buffer may be :flush to force/finish-output
+ (when (or (and (null buffer) (not (eql start end)))
+ (eq buffer :flush))
+ (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-clear-output ((stream simple-stream))
+ nil)