0.8.3.5:

[sbcl.git] / src / code / stream.lisp

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 5e5b892..e3dbd91 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -145,7 +145,7 @@
 ;;; Call the MISC method with the :FILE-POSITION operation.
 (defun file-position (stream &optional position)
   (declare (type stream stream))
-  (declare (type (or index (member nil :start :end)) position))
+  (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) position))
   (cond
    (position
     (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
@@ -185,7 +185,7 @@
           ;; private predicate function..) is ugly and confusing, but
           ;; I can't see any other way. -- WHN 2001-04-14
           :expected-type '(satisfies stream-associated-with-file-p)
-          :format-string
+          :format-control
           "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
           :format-arguments (list stream))))
 
@@ -332,20 +332,9 @@
                            eof-value
                            recursive-p)
   (declare (ignore recursive-p))
-  ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
-  ;; the compiler doesn't seem to be smart enough to go from there to
-  ;; imposing a type check. Figure out why (because PEEK-TYPE is an
-  ;; &OPTIONAL argument?) and fix it, and then this explicit type
-  ;; check can go away.
-  (unless (typep peek-type '(or character boolean))
-    (error 'simple-type-error
-          :datum peek-type
-          :expected-type '(or character boolean)
-          :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
-          :format-arguments (list peek-type '(or character boolean))))
   (let ((stream (in-synonym-of stream)))
     (cond ((typep stream 'echo-stream)
-          (echo-misc stream 
+          (echo-misc stream
                      :peek-char
                      peek-type
                      (list eof-error-p eof-value)))
@@ -1158,7 +1147,11 @@
   (case operation
     (:file-position
      (if arg1
-        (setf (string-input-stream-current stream) arg1)
+        (setf (string-input-stream-current stream)
+              (case arg1
+                (:start 0)
+                (:end (string-input-stream-end stream))
+                (t arg1)))
         (string-input-stream-current stream)))
     (:file-length (length (string-input-stream-string stream)))
     (:unread (decf (string-input-stream-current stream)))
@@ -1189,12 +1182,16 @@
                      (sout #'string-sout)
                      (misc #'string-out-misc)
                       ;; The string we throw stuff in.
-                      (string (make-string 40)
+                      (string (missing-arg)
                              :type (simple-array character (*))))
-           (:constructor make-string-output-stream ())
+           (:constructor make-string-output-stream 
+                         (&key (element-type 'character)
+                          &aux (string (make-string 40))))
            (:copier nil))
   ;; Index of the next location to use.
-  (index 0 :type fixnum))
+  (index 0 :type fixnum)
+  ;; Requested element type
+  (element-type 'character))
 
 #!+sb-doc
 (setf (fdocumentation 'make-string-output-stream 'function)
@@ -1261,8 +1258,19 @@
 (defun get-output-stream-string (stream)
   (declare (type string-output-stream stream))
   (let* ((length (string-output-stream-index stream))
-        (result (make-string length)))
-    (replace result (string-output-stream-string stream))
+        (element-type (string-output-stream-element-type stream))
+        (result 
+         (case element-type
+           ;; Overwhelmingly common case; can be inlined.
+           ((character) (make-string length))
+           (t (make-string length :element-type element-type)))))
+    ;; For the benefit of the REPLACE transform, let's do this, so
+    ;; that the common case isn't ludicrously expensive.
+    (etypecase result 
+      ((simple-array character (*)) 
+       (replace result (string-output-stream-string stream)))
+      ((simple-array nil (*))
+       (replace result (string-output-stream-string stream))))
     (setf (string-output-stream-index stream) 0)
     result))