diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index f01bf3af84b5425cd4dd33f6b0c2e98acfa6e9ba..0033c6e6f70d11dccd9c2f7406204a80dc2f5413 100644
--- a/code/fd-stream.lisp
+++ b/code/fd-stream.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.66 2003/06/06 16:23:45 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.67 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -139,7 +139,7 @@
 ;;; DO-OUTPUT-LATER -- internal
 ;;;
 ;;;   Called by the server when we can write to the given file descriptor.
-;;; Attemt to write the data again. If it worked, remove the data from the
+;;; Attempt to write the data again. If it worked, remove the data from the
 ;;; output-later list. If it didn't work, something is wrong.
 ;;;
 (defun do-output-later (stream)
@@ -161,7 +161,7 @@
 		 (error "Write would have blocked, but SERVER told us to go.")
 		 (error "While writing ~S: ~A"
 			stream (unix:get-unix-error-msg errno))))
-	    ((eql count length) ; Hot damn, it workded.
+	    ((eql count length) ; Hot damn, it worked.
 	     (when reuse-sap
 	       (push base *available-buffers*)))
 	    ((not (null count)) ; Sorta worked.
@@ -175,7 +175,7 @@
 
 ;;; OUTPUT-LATER -- internal
 ;;;
-;;;   Arange to output the string when we can write on the file descriptor.
+;;;   Arrange to output the string when we can write on the file descriptor.
 ;;;
 (defun output-later (stream base start end reuse-sap)
   (cond ((null (fd-stream-output-later stream))
@@ -1232,7 +1232,9 @@
     (multiple-value-bind (name type version)
 	(extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
       (let ((version (if (symbolp version) 1 (1+ version)))
-	    (match (concatenate 'string name "." type ".~")))
+	    (match (if type
+		       (concatenate 'string name "." type ".~")
+		       (concatenate 'string name ".~"))))
 	(when dir
 	  (unwind-protect
 	       (loop
@@ -1515,10 +1517,11 @@
   (declare (ignore external-format input-handle output-handle))
   
   ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
-  (setf direction
+  (setq direction
 	(assure-one-of direction
 		       '(:input :output :io :probe)
 		       :direction))
+  (setf (getf options :direction) direction)
 
   (when (and if-exists-given (member direction '(:output :io)))
     (setq if-exists
@@ -1536,9 +1539,9 @@
 			 :if-does-not-exist))
     (setf (getf options :if-does-not-exist) if-does-not-exist))
 
-  (let ((class (or class 'fd-stream))
+  (let ((filespec (pathname filename))
 	(options (copy-list options))
-	(filespec (pathname filename)))
+	(class (or class 'fd-stream)))
     (cond ((eq class 'fd-stream)
 	   (remf options :class)
            (remf options :mapped)
diff --git a/code/package.lisp b/code/package.lisp
index fbb45fee920af3ac5b1dee4d3f3684f90ba9c9cb..998f797de418dfb99471a274c2e18d8b11e19a56 100644
--- a/code/package.lisp
+++ b/code/package.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.67 2003/06/02 16:00:03 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.68 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -149,7 +149,7 @@
                          "ALIEN-INTERNALS" "UNIX"
                          "CONDITIONS" "DEBUG" "DEBUG-INTERNALS" "SYSTEM"
                          "KERNEL" "EXTENSIONS" #+mp "MULTIPROCESSING"
-                         "WALKER" "XREF")))
+                         "WALKER" "XREF" "STREAM")))
     (dolist (p package-names)
       (let ((p (find-package p)))
         (when p
@@ -1287,7 +1287,7 @@
     (if where
 	(values symbol where)
         (progn
-          #+nil
+          #+(or)
           (when *enable-package-locked-errors*
             (when (ext:package-lock package)
               (restart-case
diff --git a/code/pathname.lisp b/code/pathname.lisp
index 5b3f800f0c0e9b1846c26bb0f2b820fbc8be4f06..6753fc2c66b10cfb642d546cd21f708c22f1a403 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.60 2003/03/21 21:36:34 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.61 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -426,7 +426,8 @@
 		 (etypecase ,var
 		   (pathname ,var)
 		   (string (parse-namestring ,var))
-		   (file-stream (file-name ,var))))))
+		   (file-stream (file-name ,var))
+		   (stream:file-simple-stream (file-name ,var))))))
      ,@body))
 
 ;;; WITH-HOST -- Internal
diff --git a/code/stream.lisp b/code/stream.lisp
index c932cc4e34b2be1ba4a0f92a2b4638562af968b3..773b9fe7f2b44b496b8fa4fdba718ab1c58533df 100644
--- a/code/stream.lisp
+++ b/code/stream.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.61 2003/06/06 16:23:45 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.62 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -698,9 +698,7 @@
   (let ((stream (out-synonym-of stream)))
     (stream-dispatch stream
       ;; simple-stream
-      (progn
-	(stream::%write-char stream character)
-	character)
+      (stream::%write-char stream character)
       ;; lisp-stream
       (funcall (lisp-stream-out stream) stream character)
       ;; fundamental-stream
@@ -746,20 +744,21 @@
   (let ((stream (out-synonym-of stream)))
     (stream-dispatch stream
       ;; simple-stream
-      (progn		     
-        (stream::%write-string stream string start end)
-	string)
+      (if (array-header-p string)
+	  (with-array-data ((data string) (offset-start start)
+			    (offset-end end))
+	    (stream::%write-string stream data offset-start offset-end))
+	  (stream::%write-string stream string start end))
       ;; lisp-stream
-      (progn
-	(if (array-header-p string)
-	    (with-array-data ((data string) (offset-start start)
-			      (offset-end end))
-	      (funcall (lisp-stream-sout stream)
-		       stream data offset-start offset-end))
-	    (funcall (lisp-stream-sout stream) stream string start end))
-	string)
+      (if (array-header-p string)
+	  (with-array-data ((data string) (offset-start start)
+			    (offset-end end))
+	    (funcall (lisp-stream-sout stream)
+		     stream data offset-start offset-end))
+	  (funcall (lisp-stream-sout stream) stream string start end))
       ;; fundamental-stream
-      (stream-write-string stream string start end))))
+      (stream-write-string stream string start end)))
+  string)
 
 (defun write-line (string &optional (stream *standard-output*)
 			  &key (start 0) (end (length string)))
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index c4e87e4e7ed5897b752ccf1000cf5767dcff0efe..7ff63a8d3133137eb140513e61a91a0b30173eb9 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.32 2003/06/06 16:23:46 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.33 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; Some support stuff for compiling and loading PCL.  It would be nice if
 ;;; there was some portable make-system we could all agree to share for a
@@ -66,7 +66,7 @@
 ;;; 
 (defvar *the-pcl-package* (find-package :pcl))
 
-(defvar *pcl-system-date* "$Date: 2003/06/06 16:23:46 $")
+(defvar *pcl-system-date* "$Date: 2003/06/07 17:56:28 $")
 
 (setf (getf ext:*herald-items* :pcl)
       `("    CLOS based on Gerd's PCL " ,(subseq *pcl-system-date* 7 26)))
@@ -500,7 +500,8 @@ and load your system with:
   ;;                                          recompilation
   ;;                                          of this file
   ;;                                          
-  ((iodefs        t           ()               ()               CMU)
+  ((herald        t           ()               ()               CMU)
+   (iodefs        t           ()               ()               CMU)
    (classes       t           (iodefs)         ()               CMU)
    (internal      t           (classes)        ()               CMU)
    (strategy      t           (internal)       ()               CMU)
diff --git a/pcl/simple-streams/classes.lisp b/pcl/simple-streams/classes.lisp
index 7a1b536cc5f448e1a250b0f04070f93fbb7eca59..b12a19ca8649e21155ff4b99b4661c2ff1bc6d1c 100644
--- a/pcl/simple-streams/classes.lisp
+++ b/pcl/simple-streams/classes.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -43,7 +43,7 @@
 	     (values fixnum &optional (member nil t :eof))))
 
 (deftype j-write-char-fn ()
-  '(function (character simple-stream) character))
+  '(function ((or character null) simple-stream) (or character null)))
 
 (deftype j-write-chars-fn ()
   '(function (string simple-stream fixnum fixnum) t)) ; return chars-written?
@@ -57,12 +57,12 @@
   ((%flags :initform 0 :type fixnum)
    (plist :initform nil :type list :accessor stream-plist)
 
-   (j-listen :type j-listen-fn)
-   (j-read-char :type j-read-char-fn)
-   (j-read-chars :type j-read-chars-fn)
-   (j-write-char :type j-write-char-fn)
-   (j-write-chars :type j-write-chars-fn)
-   (j-unread-char :type j-unread-char-fn)
+   (j-listen :initform #'cl::ill-in-any :type j-listen-fn)
+   (j-read-char :initform #'cl::ill-in-any :type j-read-char-fn)
+   (j-read-chars :initform #'cl::ill-in-any :type j-read-chars-fn)
+   (j-unread-char :initform #'cl::ill-in-any :type j-unread-char-fn)
+   (j-write-char :initform #'cl::ill-out-any :type j-write-char-fn) ;@@
+   (j-write-chars :initform #'cl::ill-out-any :type j-write-chars-fn) ;@@
 
    (external-format :initform :default)
 
@@ -101,10 +101,7 @@
    (max-out-pos :initform 0 :type fixnum)))
 
 (def-stream-class string-simple-stream (simple-stream)
-  ((buffer :initform nil :type (or simple-stream-buffer null))
-   (buffpos :initform 0 :type fixnum)
-   (buffer-ptr :initform 0 :type fixnum)
-   (buf-len :initform 0 :type fixnum)))
+  ())
 
 (def-stream-class file-simple-stream (single-channel-simple-stream)
   ((pathname :initform nil :initarg :pathname)
@@ -145,9 +142,6 @@
 (defgeneric device-clear-output (stream)
   (:documentation "Write me"))
 
-(defgeneric device-extend (stream need action)
-  (:documentation "Write me"))
-
 (defgeneric device-finish-record (stream blocking action)
   (:documentation "Write me"))
 
@@ -163,15 +157,19 @@
 
 (defmethod print-object ((object simple-stream) stream)
   (print-unreadable-object (object stream :type nil :identity nil)
-    (unless (any-stream-instance-flags object :input :output)
-      (princ "Closed " stream))
+    (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 nil :identity nil)
     (with-stream-class (file-simple-stream object)
-      (unless (any-stream-instance-flags object :input :output)
-	(princ "Closed " stream))
+      (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)))))
 
@@ -184,7 +182,13 @@
 	    (finish-output stream)))
       (call-next-method)
       (setf (sm input-handle stream) nil
-	    (sm output-handle stream) nil)
+	    (sm output-handle stream) nil
+	    (sm j-listen stream) #'cl::closed-flame
+	    (sm j-read-char stream) #'cl::closed-flame
+	    (sm j-read-chars stream) #'cl::closed-flame
+	    (sm j-unread-char stream) #'cl::closed-flame
+	    (sm j-write-char stream) #'cl::closed-flame	;@@
+	    (sm j-write-chars stream) #'cl::closed-flame) ;@@
       (remove-stream-instance-flags stream :input :output)
       (ext:cancel-finalization stream))))
 
@@ -276,14 +280,3 @@
   (defmethod output-stream-p ((stream stream:simple-stream))
     (any-stream-instance-flags stream :output))
 ) ; WHEN
-
-
-
-(setf (getf ext:*herald-items* :simple-streams)
-      `("    Simple Streams "
-	#+CMU18E
-	,(let ((version "$Revision: 1.1 $"))
-	      (subseq version 11 (- (length version) 2)))))
-
-(pushnew :simple-streams *features*)
-(provide :simple-streams)
diff --git a/pcl/simple-streams/direct.lisp b/pcl/simple-streams/direct.lisp
index d8b3bc3e59c8cd9d10c6c99e42859db4886563fe..35e25fec894f0db49b78118ec037fa5cbdf5a07c 100644
--- a/pcl/simple-streams/direct.lisp
+++ b/pcl/simple-streams/direct.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/direct.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/direct.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -32,10 +32,6 @@
   ;; return buffer length
   )
 
-(defmethod device-extend ((stream direct-simple-stream) need action)
-  (declare (ignore need action))
-  nil)
-
 (defmethod device-open ((stream buffer-input-simple-stream) options)
   #| do something |#
   stream)
diff --git a/pcl/simple-streams/file.lisp b/pcl/simple-streams/file.lisp
index b1854ff0ef034dd8da54f42af922db26e5953cf7..f7aa44868f0c1185a2ca2d4c4b28f5eb9b55d495 100644
--- a/pcl/simple-streams/file.lisp
+++ b/pcl/simple-streams/file.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/file.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/file.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -90,8 +90,9 @@
 		(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))
       stream)))
 
 (defmethod device-close ((stream file-simple-stream) abort)
@@ -183,7 +184,7 @@
       (unix:unix-munmap (sm buffer stream) (sm buf-len stream))
       (setf (sm buffer stream) nil))
     (cond (abort
-	   ;; remove any FD handler
+	   ;; remove any fd handler
 	   ;; if it has an original name (is this possible for mapped files?)
 	   ;;   revert the file
 	   )
@@ -193,7 +194,3 @@
 	   ))
     (unix:unix-close (sm input-handle stream)))
   t)
-
-(defmethod device-extend ((stream mapped-file-simple-stream) need action)
-  (declare (ignore need action))
-  nil)
diff --git a/pcl/simple-streams/herald.lisp b/pcl/simple-streams/herald.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2c2350b0a1d27420b20109bdc3a18b25c0072922
--- /dev/null
+++ b/pcl/simple-streams/herald.lisp
@@ -0,0 +1,20 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;; 
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/herald.lisp,v 1.1 2003/06/07 17:56:28 toy Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;; 
+
+(in-package "STREAM")
+
+(setf (getf ext:*herald-items* :simple-streams)
+      `("    Simple Streams"))
+
+(pushnew :simple-streams *features*)
+(provide :simple-streams)
diff --git a/pcl/simple-streams/impl.lisp b/pcl/simple-streams/impl.lisp
index bcd650175aec97b714e843bf6e23395468ff85d4..4cb99d8312f37de58f18924cba4b099e39ff3ec9 100644
--- a/pcl/simple-streams/impl.lisp
+++ b/pcl/simple-streams/impl.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -136,19 +136,21 @@
 (defun %read-line (stream eof-error-p eof-value recursive-p)
   (declare (type simple-stream stream)
 	   (ignore recursive-p))
-  (with-stream-class (simple-stream)
+  (with-stream-class (simple-stream stream)
     (%check stream :input)
-    (let* ((cbuf (make-string 80))	; current buffer
+    (let* ((encap (sm melded-stream stream)) ; encapsulating stream
+	   (cbuf (make-string 80))	; current buffer
 	   (bufs (list cbuf))		; list of buffers
 	   (tail bufs)			; last cons of bufs list
 	   (index 0)			; current index in current buffer
 	   (total 0))			; total characters
-      (declare (type simple-base-string cbuf)
+      (declare (type simple-stream encap)
+	       (type simple-base-string cbuf)
 	       (type cons bufs tail)
 	       (type fixnum index total))
       (loop
 	(multiple-value-bind (chars done)
-	    (funcall-stm-handler j-read-chars stream cbuf
+	    (funcall-stm-handler j-read-chars encap cbuf
 				 #\Newline index (length cbuf) t)
 	  (declare (type fixnum chars))
 	  (incf index chars)
@@ -192,116 +194,135 @@
 (defun %read-char (stream eof-error-p eof-value recursive-p blocking-p)
   (declare (type simple-stream stream)
 	   (ignore recursive-p))
-  (with-stream-class (simple-stream)
+  (with-stream-class (simple-stream stream)
     (%check stream :input)
-    (funcall-stm-handler j-read-char stream eof-error-p eof-value blocking-p)))
+    (funcall-stm-handler j-read-char (sm melded-stream stream)
+			 eof-error-p eof-value blocking-p)))
 
 (defun %unread-char (stream character)
   (declare (type simple-stream stream) (ignore character))
-  (with-stream-class (simple-stream)
+  (with-stream-class (simple-stream stream)
     (%check stream :input)
     (if (zerop (sm last-char-read-size stream))
 	(error "Nothing to unread.")
-	(funcall-stm-handler j-unread-char stream nil))))
+	(funcall-stm-handler j-unread-char (sm melded-stream stream) nil))))
 
 (defun %peek-char (stream peek-type eof-error-p eof-value recursive-p)
   (declare (type simple-stream stream)
 	   (ignore recursive-p))
-  (with-stream-class (simple-stream)
+  (with-stream-class (simple-stream stream)
     (%check stream :input)
-    (let ((char (funcall-stm-handler j-read-char stream
+    (let* ((encap (sm melded-stream stream))
+	   (char (funcall-stm-handler j-read-char encap
 				     eof-error-p stream t)))
       (cond ((eq char stream) eof-value)
 	    ((characterp peek-type)
-	     (do ((char char (funcall-stm-handler j-read-char stream
+	     (do ((char char (funcall-stm-handler j-read-char encap
 						  eof-error-p
 						  stream t)))
 		 ((or (eq char stream) (char= char peek-type))
 		  (unless (eq char stream)
-		    (funcall-stm-handler j-unread-char stream t))
+		    (funcall-stm-handler j-unread-char encap t))
 		  (if (eq char stream) eof-value char))))
 	    ((eq peek-type t)
-	     (do ((char char (funcall-stm-handler j-read-char stream
+	     (do ((char char (funcall-stm-handler j-read-char encap
 						  eof-error-p
 						  stream t)))
 		 ((or (eq char stream)
 		      (not (cl::whitespace-char-p char)))
 		  (unless (eq char stream)
-		    (funcall-stm-handler j-unread-char stream t))
+		    (funcall-stm-handler j-unread-char encap t))
 		  (if (eq char stream) eof-value char))))
 	    (t
-	     (funcall-stm-handler j-unread-char stream t)
+	     (funcall-stm-handler j-unread-char encap t)
 	     char)))))
 
 (defun %listen (stream width)
   (declare (type simple-stream stream))
   ;; WIDTH is number of octets which must be available; any value
   ;; other than 1 is treated as 'character.
-  (with-stream-class (single-channel-simple-stream stream) ;@@
-    (%check stream :input)
-    (if (not (eql width 1))
-	(funcall-stm-handler j-listen stream)
-	(or (< (sm buffpos stream) (sm buffer-ptr stream))
-	    ;; Note: should try DEVICE-EXTEND for more on buffer streams
-	    (when (>= (sm mode stream) 0) ;; device-connected
-	      (incf (sm last-char-read-size stream))
-	      (let ((ok (sc-refill-buffer stream nil)))
-		(decf (sm last-char-read-size stream))
-		(plusp ok)))))))
+  (%check stream :input)
+  (simple-stream-dispatch stream
+    ;; single-channel-simple-stream
+    (with-stream-class (single-channel-simple-stream stream)
+      (if (not (eql width 1))
+	  (funcall-stm-handler j-listen stream)
+	  (or (< (sm buffpos stream) (sm buffer-ptr stream))
+	      ;; Note: should try DEVICE-EXTEND for more on buffer streams
+	      (when (>= (sm mode stream) 0) ;; device-connected
+		(incf (sm last-char-read-size stream))
+		(let ((ok (sc-refill-buffer stream nil)))
+		  (decf (sm last-char-read-size stream))
+		  (plusp ok))))))
+    ;; dual-channel-simple-stream
+    (error "Implement %LISTEN")
+    ;; string-simple-stream
+    (error "Implement %LISTEN")))
 
 (defun %clear-input (stream buffer-only)
   (declare (type simple-stream stream))
-  (with-stream-class (single-channel-simple-stream stream) ;@@
-    (%check stream :input)
-    (setf (sm buffpos stream) 0
-	  (sm buffer-ptr stream) 0
-	  (sm last-char-read-size stream) 0) ;; ??
-    (device-clear-input stream buffer-only)))
+  (%check stream :input)
+  (simple-stream-dispatch stream
+    ;; single-channel-simple-stream
+    (with-stream-class (single-channel-simple-stream stream)
+      (setf (sm buffpos stream) 0
+	    (sm buffer-ptr stream) 0
+	    (sm last-char-read-size stream) 0))
+    ;; dual-channel-simple-stream
+    (with-stream-class (dual-channel-simple-stream stream)
+      (setf (sm buffpos stream) 0
+	    (sm buffer-ptr stream) 0
+	    (sm last-char-read-size stream) 0))
+    ;; string-simple-stream
+    nil)
+  (device-clear-input stream buffer-only))
 
 (defun %read-byte (stream eof-error-p eof-value)
   (declare (type simple-stream stream))
   (with-stream-class (simple-stream stream)
     (%check stream :input)
-    (cond ((any-stream-instance-flags stream :eof)
-	   (cl::eof-or-lose stream eof-error-p eof-value))
-	  ((any-stream-instance-flags stream :string)
-	   (with-stream-class (string-simple-stream stream)
-	     (let ((encap (sm input-handle stream)))
-	       (unless encap
-		 (error 'simple-type-error
-			:datum stream
-			:expected-type 'stream
-			:format-control "Can't read-byte on string streams"
-			:format-arguments '()))
-	       (prog1
-		   (locally (declare (notinline read-byte))
-		     (read-byte encap eof-error-p eof-value))
-		 (setf (sm last-char-read-size stream) 0
-		       (sm encapsulated-char-read-size stream) 0)))))
-	  ((any-stream-instance-flags stream :dual)
-	   (dc-read-byte stream eof-error-p eof-value t))
-	  (t ;; single-channel-simple-stream
-	   (sc-read-byte stream eof-error-p eof-value t)))))
+    (if (any-stream-instance-flags stream :eof)
+	(cl::eof-or-lose stream eof-error-p eof-value)
+	(simple-stream-dispatch stream
+	  ;; single-channel-simple-stream
+	  (sc-read-byte stream eof-error-p eof-value t)
+	  ;; dual-channel-simple-stream
+	  (dc-read-byte stream eof-error-p eof-value t)
+	  ;; string-simple-stream
+	  (with-stream-class (string-simple-stream stream)
+	    (let ((encap (sm input-handle stream)))
+	      (unless encap
+		(error 'simple-type-error
+		       :datum stream
+		       :expected-type 'stream
+		       :format-control "Can't read-byte on string streams"
+		       :format-arguments '()))
+	      (prog1
+		  (locally (declare (notinline read-byte))
+		    (read-byte encap eof-error-p eof-value))
+		(setf (sm last-char-read-size stream) 0
+		      (sm encapsulated-char-read-size stream) 0))))))))
 
 (defun %write-char (stream character)
   (declare (type simple-stream stream))
   (with-stream-class (simple-stream stream)
     (%check stream :output)
-    (funcall-stm-handler-2 j-write-char character stream)))
+    (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
 
 (defun %fresh-line (stream)
   (declare (type simple-stream stream))
   (with-stream-class (simple-stream stream)
     (%check stream :output)
     (when (/= (or (sm charpos stream) 1) 0)
-      (funcall-stm-handler-2 j-write-char #\Newline stream)
+      (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
       t)))
 
 (defun %write-string (stream string start end)
   (declare (type simple-stream stream))
   (with-stream-class (simple-stream stream)
     (%check stream :output)
-    (funcall-stm-handler-2 j-write-chars string stream start end)))
+    (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
+			   start end)))
 
 (defun %line-length (stream)
   (declare (type simple-stream stream))
@@ -313,23 +334,25 @@
   (declare (type simple-stream stream))
   (with-stream-class (simple-stream stream)
     (%check stream :output)
-    (cond ((any-stream-instance-flags stream :string)
-	   #| nothing to do |#)
-	  ((any-stream-instance-flags stream :dual)
-	   (dc-flush-buffer stream t))
-	  (t
-	   (sc-flush-buffer stream t)))))
+    (simple-stream-dispatch stream
+      ;; single-channel-simple-stream
+      (sc-flush-buffer stream t)
+      ;; dual-channel-simple-stream
+      (dc-flush-buffer stream t)
+      ;; string-simple-stream
+      nil)))
 
 (defun %force-output (stream)
   (declare (type simple-stream stream))
   (with-stream-class (simple-stream stream)
     (%check stream :output)
-    (cond ((any-stream-instance-flags stream :string)
-	   #| nothing to do |#)
-	  ((any-stream-instance-flags stream :dual)
-	   (dc-flush-buffer stream nil))
-	  (t
-	   (sc-flush-buffer stream nil)))))
+    (simple-stream-dispatch stream
+      ;; single-channel-simple-stream
+      (sc-flush-buffer stream nil)
+      ;; dual-channel-simple-stream
+      (dc-flush-buffer stream nil)
+      ;; string-simple-stream
+      nil)))
 
 (defun %clear-output (stream)
   (declare (type simple-stream stream))
@@ -342,28 +365,27 @@
   (declare (type simple-stream stream))
   (with-stream-class (simple-stream stream)
     (%check stream :output)
-    (cond ((any-stream-instance-flags stream :string)
-	   (error 'simple-type-error
-		  :datum stream
-		  :expected-type 'stream
-		  :format-control "Can't write-byte on string streams."
-		  :format-arguments '()))
-	  ((any-stream-instance-flags stream :dual)
-	   (with-stream-class (dual-channel-simple-stream stream)
-	     (let ((ptr (sm outpos stream)))
-	       (when (>= ptr (sm max-out-pos stream))
-		 (dc-flush-buffer stream t)
-		 (setf ptr (1- (sm outpos stream))))
-	       (setf (sm outpos stream) (1+ ptr))
-	       (setf (bref (sm out-buffer stream) ptr) integer))))
-	  (t  ;; single-channel-simple-stream
-	   (with-stream-class (single-channel-simple-stream stream)
-	     (let ((ptr (sm buffpos stream)))
-	       (when (>= ptr (sm buffer-ptr stream))
-		 (sc-flush-buffer stream t)
-		 (setf ptr (sm buffpos stream)))
-	       (setf (sm buffpos stream) (1+ ptr))
-	       (setf (bref (sm buffer stream) ptr) integer)))))))
+    (simple-stream-dispatch stream
+      ;; single-channel-simple-stream
+      (with-stream-class (single-channel-simple-stream stream)
+	(let ((ptr (sm buffpos stream)))
+	  (when (>= ptr (sm buffer-ptr stream))
+	    (setf ptr (sc-flush-buffer stream t)))
+	  (setf (sm buffpos stream) (1+ ptr))
+	  (setf (bref (sm buffer stream) ptr) integer)))
+      ;; dual-channel-simple-stream
+      (with-stream-class (dual-channel-simple-stream stream)
+	(let ((ptr (sm outpos stream)))
+	  (when (>= ptr (sm max-out-pos stream))
+	    (setf ptr (dc-flush-buffer stream t)))
+	  (setf (sm outpos stream) (1+ ptr))
+	  (setf (bref (sm out-buffer stream) ptr) integer)))
+      ;; string-simple-stream
+      (error 'simple-type-error
+	     :datum stream
+	     :expected-type 'stream
+	     :format-control "Can't write-byte on string streams."
+	     :format-arguments '()))))
 
 (defun %read-sequence (stream seq start end partial-fill)
   (declare (type simple-stream stream))
@@ -371,7 +393,7 @@
     (%check stream :input)
     (etypecase seq
       (string
-       (funcall-stm-handler j-read-chars stream seq nil
+       (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
 			    start (or end (length seq))
 			    (if partial-fill :bnb t)))
       ((or (simple-array (unsigned-byte 8) (*))
@@ -386,7 +408,7 @@
     (%check stream :output)
     (etypecase seq
       (string
-       (funcall-stm-handler-2 j-write-chars seq stream
+       (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
 			      start (or end (length seq))))
       ((or (simple-array (unsigned-byte 8) (*))
 	   (simple-array (signed-byte 8) (*)))
diff --git a/pcl/simple-streams/internal.lisp b/pcl/simple-streams/internal.lisp
index b4890d3353552d2e1bf2a4636455935f5b207567..5c9c5be1a7797f770a66d42c1b2f1a7c1b106e5b 100644
--- a/pcl/simple-streams/internal.lisp
+++ b/pcl/simple-streams/internal.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -48,7 +48,7 @@
       (make-array size :element-type '(unsigned-byte 8))))
 
 (defun free-buffer (buffer)
-  (unless (vectorp buffer)
+  (when (sys:system-area-pointer-p buffer)
     (push buffer cl::*available-buffers*))
   t)
 
@@ -88,6 +88,11 @@
 
 
 
+(defun find-external-format (name)
+  nil)
+
+
+
 (defun vector-elt-width (vector)
   ;; Return octet-width of vector elements
   (etypecase vector
diff --git a/pcl/simple-streams/iodefs.lisp b/pcl/simple-streams/iodefs.lisp
index 7af41bf7c651b07218fb3a49a268699ea8d0b4fd..91202891fa12b6a511532a1126c79e7cfbc23e23 100644
--- a/pcl/simple-streams/iodefs.lisp
+++ b/pcl/simple-streams/iodefs.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/iodefs.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/iodefs.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -41,12 +41,19 @@
 
 (defmacro with-stream-class ((class-name &optional stream) &body body)
   (if stream
-    (let ((stm (gensym "STREAM")))
-      `(let ((,stm ,stream))
-	 (declare (type ,class-name ,stm) (ignorable ,stm))
+    (let ((stm (gensym "STREAM"))
+	  (slt (gensym "SV")))
+      `(let* ((,stm ,stream)
+	      (,slt (kernel:%instance-ref ,stm 1)))
+	 (declare (type ,class-name ,stm)
+		  (type simple-vector ,slt)
+		  (ignorable ,slt))
 	 (macrolet ((sm (slot-name stream)
 		      (declare (ignore stream))
-		      `(slot-value ,',stm ',slot-name))
+		      #-count-sm
+		      `(slot-value ,',stm ',slot-name)
+		      #+count-sm
+		      `(%sm ',slot-name ,',stm))
 		    (add-stream-instance-flags (stream &rest flags)
 		      (declare (ignore stream))
 		      `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
@@ -61,7 +68,10 @@
 					   ,(%flags flags))))))
 	   ,@body)))
     `(macrolet ((sm (slot-name stream)
-		  `(slot-value ,stream ',slot-name)))
+		  #-count-sm
+		  `(slot-value ,stream ',slot-name)
+		  #+count-sm
+		  `(%sm ',slot-name ,stream)))
        ,@body)))
 
 (defmacro sm (slot-name stream)
@@ -102,7 +112,16 @@
        (with-stream-class (simple-stream ,s)
 	 (any-stream-instance-flags ,s ,@flags)))))
 
-(defun compose-encapsulating-streams (stream external-format)
-  #| implement me |#)
+(defmacro simple-stream-dispatch (stream single dual string)
+  (let ((s (gensym "STREAM")))
+    `(let ((,s ,stream))
+       (with-stream-class (simple-stream ,s)
+	 (let ((%flags (sm %flags ,s)))
+	   (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
+		  ,single)
+		 ((zerop (logand %flags ,(%flags '(:string))))
+		  ,dual)
+		 (t
+		  ,string)))))))
 
 (provide :iodefs)
diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp
index 12eaf761ba96aba3131f468ea19e5476bae96436..0e780877d525cff231584b09120f4093e4131d0c 100644
--- a/pcl/simple-streams/strategy.lisp
+++ b/pcl/simple-streams/strategy.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -13,6 +13,35 @@
 
 (in-package "STREAM")
 
+;;;;
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ext:define-function-name-syntax sc (name)
+    ;; (sc <name> <external-format> [<access>])
+    (if (and (<= 3 (length name) 4)
+	     (symbolp (second name))
+	     (keywordp (third name)))
+        (values t (second name))
+        (values nil nil)))
+
+  (ext:define-function-name-syntax dc (name)
+    ;; (dc <name> <external-format>)
+    (if (and (= (length name) 3)
+	     (symbolp (second name))
+	     (keywordp (third name)))
+        (values t (second name))
+        (values nil nil)))
+
+  (ext:define-function-name-syntax str (name)
+    ;; (str <name> [<composing-format>])
+    (if (and (<= 2 (length name) 3)
+	     (symbolp (second name))
+	     (or (null (third name))
+	         (keywordp (third name))))
+        (values t (second name))
+        (values nil nil))))
+
+
 ;;;; Helper functions
 (defun sc-refill-buffer (stream blocking)
   (with-stream-class (single-channel-simple-stream stream)
@@ -34,7 +63,7 @@
           (bytes (sm buffpos stream)))
       (declare (type fixnum ptr bytes))
       (loop
-        (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return))
+        (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return 0))
         (let ((bytes-written (device-write stream nil ptr nil blocking)))
           (declare (fixnum bytes-written))
           (when (minusp bytes-written)
@@ -61,7 +90,7 @@
           (bytes (sm outpos stream)))
       (declare (type fixnum ptr bytes))
       (loop
-        (when (>= ptr bytes) (setf (sm outpos stream) 0) (return))
+        (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0))
         (let ((bytes-written (device-write stream nil ptr nil blocking)))
           (declare (fixnum bytes-written))
           (when (minusp bytes-written)
@@ -71,8 +100,18 @@
 
 ;;;; Single-Channel-Simple-Stream strategy functions
 
-(declaim (ftype j-read-char-fn sc-read-char))
-(defun sc-read-char (stream eof-error-p eof-value blocking)
+(declaim (ftype j-listen-fn (sc listen :iso8859-1)))
+(defun (sc listen :iso8859-1) (stream)
+  (with-stream-class (single-channel-simple-stream stream)
+    (or (< (sm buffpos stream) (sm buffer-ptr stream))
+        (case (device-read stream nil 0 0 nil)
+          ((0 -2) nil)
+          (-1 #| latch EOF |# nil)
+          (-3 t)
+          (t (error "DEVICE-READ error."))))))
+
+(declaim (ftype j-read-char-fn (sc read-char :iso8859-1)))
+(defun (sc read-char :iso8859-1) (stream eof-error-p eof-value blocking)
   #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
   (with-stream-class (single-channel-simple-stream stream)
     ;; if stream is open for read-write, may need to flush the buffer
@@ -100,8 +139,8 @@
           (cl::eof-or-lose stream eof-error-p eof-value)
           char))))
 
-(declaim (ftype j-read-char-fn sc-read-char--buffer))
-(defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
+(declaim (ftype j-read-char-fn (sc read-char :iso8859-1 buffer)))
+(defun (sc read-char :iso8859-1 buffer) (stream eof-error-p eof-value blocking)
   (declare (ignore blocking)) ;; everything is already in the buffer
   #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
   (with-stream-class (single-channel-simple-stream stream)
@@ -122,8 +161,8 @@
           (cl::eof-or-lose stream eof-error-p eof-value)
           char))))
 
-(declaim (ftype j-read-chars-fn sc-read-chars))
-(defun sc-read-chars (stream string search start end blocking)
+(declaim (ftype j-read-chars-fn (sc read-chars :iso8859-1)))
+(defun (sc read-chars :iso8859-1) (stream string search start end blocking)
   ;; string is filled from START to END, or until SEARCH is found
   ;; Return two values: count of chars read and
   ;;  NIL if SEARCH was not found
@@ -171,8 +210,9 @@
               (t
                (setf (char string posn) char)))))))
 
-(declaim (ftype j-read-chars-fn sc-read-chars--buffer))
-(defun sc-read-chars--buffer (stream string search start end blocking)
+(declaim (ftype j-read-chars-fn (sc read-chars :iso8859-1 buffer)))
+(defun (sc read-chars :iso8859-1 buffer) (stream string search start end
+						 blocking)
   (declare (type simple-stream stream)
            (type string string)
            (type (or null character) search)
@@ -215,8 +255,8 @@
               (t
                (setf (char string posn) char)))))))
 
-(declaim (ftype j-unread-char-fn sc-unread-char))
-(defun sc-unread-char (stream relaxed)
+(declaim (ftype j-unread-char-fn (sc unread-char :iso8859-1)))
+(defun (sc unread-char :iso8859-1) (stream relaxed)
   (declare (ignore relaxed))
   (with-stream-class (single-channel-simple-stream stream)
     (let ((unread (sm last-char-read-size stream)))
@@ -225,27 +265,26 @@
           (error "Unreading needs work"))
       (setf (sm last-char-read-size stream) 0))))
 
-(declaim (ftype j-write-char-fn sc-write-char))
-(defun sc-write-char (character stream)
-  (with-stream-class (single-channel-simple-stream stream)
-    (let ((code (char-code character))
-          (ctrl (sm control-out stream)))
-      (when (and (< code 32) ctrl (svref ctrl code)
-                 (funcall (the (or symbol function) (svref ctrl code))
-                          stream character))
-        (return-from sc-write-char character))
-      (let ((buffer (sm buffer stream))
-            (ptr (sm buffpos stream)))
-        ;; FIXME: Rudi Schlatte reckons this should be BUF-LEN, not BUFFER-PTR
-        (when (>= ptr (sm buffer-ptr stream))
-          (sc-flush-buffer stream t)
-          (setf ptr (sm buffpos stream)))
-        (setf (bref buffer ptr) code)
-        (setf (sm buffpos stream) (1+ ptr)))))
+(declaim (ftype j-write-char-fn (sc write-char :iso8859-1)))
+(defun (sc write-char :iso8859-1) (character stream)
+  (when character
+    (with-stream-class (single-channel-simple-stream stream)
+      (let ((code (char-code character))
+	    (ctrl (sm control-out stream)))
+	(when (and (< code 32) ctrl (svref ctrl code)
+		   (funcall (the (or symbol function) (svref ctrl code))
+			    stream character))
+	  (return-from write-char character))
+	(let ((buffer (sm buffer stream))
+	      (ptr (sm buffpos stream)))
+	  (when (>= ptr (sm buf-len stream))
+	    (setf ptr (sc-flush-buffer stream t)))
+	  (setf (bref buffer ptr) code)
+	  (setf (sm buffpos stream) (1+ ptr))))))
   character)
 
-(declaim (ftype j-write-chars-fn sc-write-chars))
-(defun sc-write-chars (string stream start end)
+(declaim (ftype j-write-chars-fn (sc write-chars :iso8859-1)))
+(defun (sc write-chars :iso8859-1) (string stream start end)
   (with-stream-class (single-channel-simple-stream stream)
     (do ((buffer (sm buffer stream))
          (ptr (sm buffpos stream))
@@ -262,20 +301,9 @@
                               stream char))
           (when (>= ptr max)
 	    (setf (sm buffpos stream) ptr)
-            (sc-flush-buffer stream t)
-            (setf ptr (sm buffpos stream)))
-          (setf (bref buffer ptr) code)
-          (incf ptr))))))
-
-(declaim (ftype j-listen-fn sc-listen))
-(defun sc-listen (stream)
-  (with-stream-class (single-channel-simple-stream stream)
-    (or (< (sm buffpos stream) (sm buffer-ptr stream))
-        (case (device-read stream nil 0 0 nil)
-          ((0 -2) nil)
-          (-1 #| latch EOF |# nil)
-          (-3 t)
-          (t (error "DEVICE-READ error."))))))
+	    (setf ptr (sc-flush-buffer stream t)))
+	  (setf (bref buffer ptr) code)
+	  (incf ptr))))))
 
 
 ;;; SC-READ-BYTE doesn't actually live in a strategy slot
@@ -296,8 +324,18 @@
 
 ;;;; Dual-Channel-Simple-Stream strategy functions
 
-(declaim (ftype j-read-char-fn dc-read-char))
-(defun dc-read-char (stream eof-error-p eof-value blocking)
+(declaim (ftype j-listen-fn (dc listen :iso8859-1)))
+(defun (dc listen :iso8859-1) (stream)
+  (with-stream-class (dual-channel-simple-stream stream)
+    (or (< (sm buffpos stream) (sm buffer-ptr stream))
+        (case (device-read stream nil 0 0 nil)
+          ((0 -2) nil)
+          (-1 #| latch EOF |# nil)
+          (-3 t)
+          (t (error "DEVICE-READ error."))))))
+
+(declaim (ftype j-read-char-fn (dc read-char :iso8859-1)))
+(defun (dc read-char :iso8859-1) (stream eof-error-p eof-value blocking)
   #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
   (with-stream-class (dual-channel-simple-stream stream)
     (when (and (any-stream-instance-flags stream :interactive)
@@ -327,8 +365,8 @@
           (cl::eof-or-lose stream eof-error-p eof-value)
           char))))
 
-(declaim (ftype j-read-chars-fn dc-read-chars))
-(defun dc-read-chars (stream string search start end blocking)
+(declaim (ftype j-read-chars-fn (dc read-chars :iso8859-1)))
+(defun (dc read-chars :iso8859-1) (stream string search start end blocking)
   (declare (type dual-channel-simple-stream stream)
            (type string string)
            (type (or null character) search)
@@ -376,8 +414,8 @@
               (t
                (setf (char string posn) char)))))))
 
-(declaim (ftype j-unread-char-fn dc-unread-char))
-(defun dc-unread-char (stream relaxed)
+(declaim (ftype j-unread-char-fn (dc unread-char :iso8859-1)))
+(defun (dc unread-char :iso8859-1) (stream relaxed)
   (declare (ignore relaxed))
   (with-stream-class (dual-channel-simple-stream stream)
     (let ((unread (sm last-char-read-size stream)))
@@ -386,26 +424,26 @@
           (error "Unreading needs work"))
       (setf (sm last-char-read-size stream) 0))))
 
-(declaim (ftype j-write-char-fn dc-write-char))
-(defun dc-write-char (character stream)
-  (with-stream-class (dual-channel-simple-stream stream)
-    (let ((code (char-code character))
-          (ctrl (sm control-out stream)))
-      (when (and (< code 32) ctrl (svref ctrl code)
-                 (funcall (the (or symbol function) (svref ctrl code))
-                          stream character))
-        (return-from dc-write-char character))
-      (let ((buffer (sm out-buffer stream))
-            (ptr (sm outpos stream)))
-        (when (>= ptr (sm max-out-pos stream))
-          (dc-flush-buffer stream t)
-          (setf ptr (sm outpos stream)))
-        (setf (bref buffer ptr) code)
-        (setf (sm outpos stream) (1+ ptr)))))
+(declaim (ftype j-write-char-fn (dc write-char :iso8859-1)))
+(defun (dc write-char :iso8859-1) (character stream)
+  (when character
+    (with-stream-class (dual-channel-simple-stream stream)
+      (let ((code (char-code character))
+	    (ctrl (sm control-out stream)))
+	(when (and (< code 32) ctrl (svref ctrl code)
+		   (funcall (the (or symbol function) (svref ctrl code))
+			    stream character))
+	  (return-from write-char character))
+	(let ((buffer (sm out-buffer stream))
+	      (ptr (sm outpos stream)))
+	  (when (>= ptr (sm max-out-pos stream))
+	    (setq ptr (dc-flush-buffer stream t)))
+	  (setf (bref buffer ptr) code)
+	  (setf (sm outpos stream) (1+ ptr))))))
   character)
 
-(declaim (ftype j-write-chars-fn dc-write-chars))
-(defun dc-write-chars (string stream start end)
+(declaim (ftype j-write-chars-fn (dc write-chars :iso8859-1)))
+(defun (dc write-chars :iso8859-1) (string stream start end)
   (with-stream-class (dual-channel-simple-stream stream)
     (do ((buffer (sm out-buffer stream))
          (ptr (sm outpos stream))
@@ -421,21 +459,10 @@
                      (funcall (the (or symbol function) (svref ctrl code))
                               stream char))
           (when (>= ptr max)
-            (dc-flush-buffer stream t)
-            (setf ptr (sm outpos stream)))
-          (setf (bref buffer ptr) code)
-          (incf ptr))))))
-
-
-(declaim (ftype j-listen-fn dc-listen))
-(defun dc-listen (stream)
-  (with-stream-class (dual-channel-simple-stream stream)
-    (or (< (sm buffpos stream) (sm buffer-ptr stream))
-        (case (device-read stream nil 0 0 nil)
-          ((0 -2) nil)
-          (-1 #| latch EOF |# nil)
-          (-3 t)
-          (t (error "DEVICE-READ error."))))))
+	    (setf (sm outpos stream) ptr)
+	    (setf ptr (dc-flush-buffer stream ptr t)))
+	  (setf (bref buffer ptr) code)
+	  (incf ptr))))))
 
 
 ;;; DC-READ-BYTE doesn't actually live in a strategy slot
@@ -456,9 +483,9 @@
 
 ;;;; String-Simple-Stream strategy functions
 
-(declaim (ftype j-read-char-fn string-read-char))
+(declaim (ftype j-read-char-fn (str read-char)))
 #+(or)
-(defun string-read-char (stream eof-error-p eof-value blocking)
+(defun (str read-char) (stream eof-error-p eof-value blocking)
   (declare (type string-input-simple-stream stream) (ignore blocking)
            #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
   (with-stream-class (string-input-simple-stream stream)
@@ -481,9 +508,9 @@
 
 
 
-(declaim (ftype j-read-char-fn composing-crlf-read-char))
-(defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
-  (with-stream-class (simple-stream stream)
+(declaim (ftype j-read-char-fn (str read-char :e-crlf)))
+(defun (str read-char :e-crlf) (stream eof-error-p eof-value blocking)
+  (with-stream-class (composing-stream stream)
     (let* ((melded-stream (sm melded-stream stream))
            (char (funcall-stm-handler j-read-char melded-stream nil stream
                                       blocking)))
@@ -508,51 +535,89 @@
       ;; do control-in processing on whatever character we've got
       char)))
 
-(declaim (ftype j-unread-char-fn composing-crlf-unread-char))
-(defun composing-crlf-unread-char (stream relaxed)
+(declaim (ftype j-unread-char-fn (str unread-char :e-crlf)))
+(defun (str unread-char :e-crlf) (stream relaxed)
   (declare (ignore relaxed))
-  (with-stream-class (simple-stream stream)
+  (with-stream-class (composing-stream stream)
     (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
 
 
 ;;;; Functions to install the strategy functions in the appropriate slots
 
+(defun %find-topmost-stream (stream)
+  ;; N.B.: the topmost stream in the chain of encapsulations is actually
+  ;; the bottommost in the "melding" chain
+  (with-stream-class (simple-stream)
+    (loop
+      (when (eq (sm melded-stream stream) (sm melding-base stream))
+	(return stream))
+      (setq stream (sm melded-stream stream)))))
+
 (defun install-single-channel-character-strategy (stream external-format
                                                          access)
-  (declare (ignore external-format))
-  ;; ACCESS is usually NIL
-  ;; May be "undocumented" values: stream::buffer, stream::mapped
-  ;;   to install strategies suitable for direct buffer streams
-  ;;   (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
-  ;; (Avoids checking "mode" flags by installing special strategy)
-  (with-stream-class (single-channel-simple-stream stream)
-    (if (or (eq access 'buffer) (eq access 'mapped))
-        (setf (sm j-read-char stream) #'sc-read-char--buffer
-              (sm j-read-chars stream) #'sc-read-chars--buffer
-              (sm j-unread-char stream) #'sc-unread-char
-              (sm j-write-char stream) #'sc-write-char
-              (sm j-write-chars stream) #'sc-write-chars
-              (sm j-listen stream) #'sc-listen)
-        (setf (sm j-read-char stream) #'sc-read-char
-              (sm j-read-chars stream) #'sc-read-chars
-              (sm j-unread-char stream) #'sc-unread-char
-              (sm j-write-char stream) #'sc-write-char
-              (sm j-write-chars stream) #'sc-write-chars
-              (sm j-listen stream) #'sc-listen)))
+  (find-external-format external-format)
+  (let ((stream (%find-topmost-stream stream)))
+    ;; ACCESS is usually NIL
+    ;; May be "undocumented" values: stream::buffer, stream::mapped
+    ;;   to install strategies suitable for direct buffer streams
+    ;;   (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
+    ;; (Avoids checking "mode" flags by installing special strategy)
+    (with-stream-class (simple-stream stream)
+      (if (or (eq access 'buffer) (eq access 'mapped))
+	  (setf (sm j-read-char stream) #'(sc read-char :iso8859-1 buffer)
+		(sm j-read-chars stream) #'(sc read-chars :iso8859-1 buffer)
+		(sm j-unread-char stream) #'(sc unread-char :iso8859-1)
+		(sm j-write-char stream) #'(sc write-char :iso8859-1)
+		(sm j-write-chars stream) #'(sc write-chars :iso8859-1)
+		(sm j-listen stream) #'(sc listen :iso8859-1))
+	  (setf (sm j-read-char stream) #'(sc read-char :iso8859-1)
+		(sm j-read-chars stream) #'(sc read-chars :iso8859-1)
+		(sm j-unread-char stream) #'(sc unread-char :iso8859-1)
+		(sm j-write-char stream) #'(sc write-char :iso8859-1)
+		(sm j-write-chars stream) #'(sc write-chars :iso8859-1)
+		(sm j-listen stream) #'(sc listen :iso8859-1)))))
   stream)
 
 (defun install-dual-channel-character-strategy (stream external-format)
-  (declare (ignore external-format))
-  (with-stream-class (dual-channel-simple-stream stream)
-    (setf (sm j-read-char stream) #'dc-read-char
-          (sm j-read-chars stream) #'dc-read-chars
-          (sm j-unread-char stream) #'dc-unread-char
-          (sm j-write-char stream) #'dc-write-char
-          (sm j-write-chars stream) #'dc-write-chars
-          (sm j-listen stream) #'dc-listen))
+  (find-external-format external-format)
+  (let ((stream (%find-topmost-stream stream)))
+    (with-stream-class (simple-stream stream)
+      (setf (sm j-read-char stream) #'(dc read-char :iso8859-1)
+	    (sm j-read-chars stream) #'(dc read-chars :iso8859-1)
+	    (sm j-unread-char stream) #'(dc unread-char :iso8859-1)
+	    (sm j-write-char stream) #'(dc write-char :iso8859-1)
+	    (sm j-write-chars stream) #'(dc write-chars :iso8859-1)
+	    (sm j-listen stream) #'(dc listen :iso8859-1))))
   stream)
 
+;; Deprecated -- use install-string-{input,output}-character-strategy instead!
 (defun install-string-character-strategy (stream)
-  (with-stream-class (string-simple-stream stream)
-    (setf (sm j-read-char stream) #'string-read-char))
+  (install-string-input-character-strategy stream)
+  (when (any-stream-instance-flags stream :output)
+    (install-string-output-character-strategy stream))
   stream)
+
+(defun install-string-input-character-strategy (stream)
+  #| implement me |#
+  (let ((stream (%find-topmost-stream stream)))
+    (with-stream-class (simple-stream stream)
+      (setf (sm j-read-char stream) #'(str read-char))))
+  stream)
+
+(defun install-string-output-character-strategy (stream)
+  #| implement me |#)
+
+(defun compose-encapsulating-streams (stream external-format)
+  (when (consp external-format)
+    (with-stream-class (simple-stream)
+      (dolist (fmt (butlast external-format))
+	(let ((encap (make-instance 'composing-stream :composing-format fmt)))
+	  (setf (sm melding-base encap) stream)
+	  (setf (sm melded-stream encap) (sm melded-stream stream))
+	  (setf (sm melded-stream stream) encap)
+	  (rotatef (sm j-listen encap) (sm j-listen stream))
+	  (rotatef (sm j-read-char encap) (sm j-read-char stream))
+	  (rotatef (sm j-read-chars encap) (sm j-read-chars stream))
+	  (rotatef (sm j-unread-char encap) (sm j-unread-char stream))
+	  (rotatef (sm j-write-char encap) (sm j-write-char stream))
+	  (rotatef (sm j-write-chars encap) (sm j-write-chars stream)))))))
diff --git a/pcl/simple-streams/string.lisp b/pcl/simple-streams/string.lisp
index 095c2ad1baf955d8e5585857050edca9e9d34998..eca0ba5fc64a4b863d28775af2992ed50cdc46f0 100644
--- a/pcl/simple-streams/string.lisp
+++ b/pcl/simple-streams/string.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/string.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/string.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -18,18 +18,25 @@
 	  xp-simple-stream annotation-output-simple-stream))
 
 (def-stream-class string-input-simple-stream (string-simple-stream)
-  ())
+  ((buffer :initform nil :type (or simple-stream-buffer null))
+   (buffpos :initform 0 :type fixnum)
+   (buffer-ptr :initform 0 :type fixnum)
+   (buf-len :initform 0 :type fixnum)))
 
 (def-stream-class string-output-simple-stream (string-simple-stream)
-  ((out-buffer :initform nil :type (or simple-stream-buffer null))
+  ((buffer :initform nil :type (or simple-stream-buffer null))
+   (buffpos :initform 0 :type fixnum)
+   (buffer-ptr :initform 0 :type fixnum)
+   (buf-len :initform 0 :type fixnum)
+   (out-buffer :initform nil :type (or simple-stream-buffer null))
    (outpos :initform 0 :type fixnum)
    (max-out-pos :initform 0 :type fixnum)))
 
-(def-stream-class fill-pointer-output-simple-stream
-    (string-output-simple-stream)
+(def-stream-class composing-stream (string-simple-stream)
   ())
 
-(def-stream-class composing-stream (string-simple-stream)
+(def-stream-class fill-pointer-output-simple-stream
+    (string-output-simple-stream)
   ())
 
 (def-stream-class xp-simple-stream (string-output-simple-stream)
@@ -38,6 +45,33 @@
 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
   ())
 
+(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-file-position ((stream string-simple-stream))
   ;; get string length (of input or output buffer?)
   )
@@ -54,18 +88,10 @@
   #| do something |#
   stream)
 
-(defmethod device-extend ((stream string-input-simple-stream) need action)
-  (declare (ignore need action))
-  nil)
-
 (defmethod device-open ((stream string-output-simple-stream) options)
   #| do something |#
   stream)
 
-(defmethod device-extend ((stream string-output-simple-stream) need action)
-  ;; @@3
-  )
-
 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
   #| do something |#
   stream)
@@ -79,11 +105,6 @@
   ;; set fill pointer (of input or output buffer?)
   )
 
-(defmethod device-extend ((stream fill-pointer-output-simple-stream)
-                          need action)
-  ;; @@4
-  )
-
 (defmethod device-open ((stream xp-simple-stream) options)
   #| do something |#
   stream)
diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp
index 4945780462f61f1333991d5fe08ce63dfa383ea6..b041e8ed4057bce9a4e2d713f0795c41e3a3f7d7 100644
--- a/tools/pclcom.lisp
+++ b/tools/pclcom.lisp
@@ -3,7 +3,7 @@
 ;;; **********************************************************************
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.28 2003/06/06 16:23:46 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.29 2003/06/07 17:56:28 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -117,6 +117,7 @@
 
 (cat-if-anything-changed
  "pcl:simple-streams-library"
+ "pcl:simple-streams/herald"
  "pcl:simple-streams/classes"
  "pcl:simple-streams/internal"
  "pcl:simple-streams/strategy"
@@ -127,3 +128,11 @@
  "pcl:simple-streams/string"
  "pcl:simple-streams/terminal"
  "pcl:simple-streams/socket")
+
+(cat-if-anything-changed
+ "pcl:iodefs-library"
+ "pcl:simple-streams/iodefs")
+
+(cat-if-anything-changed
+ "pcl:gray-compat-library"
+ "pcl:simple-streams/gray-compat")