X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=e3dbd91b327f1d8471cb837cfe4bd804e34a3818;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=aa91999f902618eeffebd680455c0c1bd00e5cf3;hpb=02afc3779a467fd354d40db8b891f2d866f3d49a;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index aa91999..e3dbd91 100644
--- 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+)
@@ -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)))
@@ -1083,7 +1072,13 @@
              (:include ansi-stream)
              (:constructor nil)
              (:copier nil))
-  (string nil :type string))
+  ;; FIXME: This type declaration is true, and will probably continue
+  ;; to be true.  However, note well the comments in DEFTRANSFORM
+  ;; REPLACE, implying that performance of REPLACE is somewhat
+  ;; critical to performance of string streams.  If (VECTOR CHARACTER)
+  ;; ever becomes different from (VECTOR BASE-CHAR), the transform
+  ;; probably needs to be extended.
+  (string (missing-arg) :type (vector character)))
 
 ;;;; STRING-INPUT-STREAM stuff
 
@@ -1093,7 +1088,8 @@
 		       (bin #'string-binch)
 		       (n-bin #'string-stream-read-n-bytes)
 		       (misc #'string-in-misc)
-                       (string nil :type simple-string))
+                       (string (missing-arg)
+			       :type (simple-array character (*))))
 	     (:constructor internal-make-string-input-stream
 			   (string current end))
 	     (:copier nil))
@@ -1103,7 +1099,8 @@
 (defun string-inch (stream eof-error-p eof-value)
   (let ((string (string-input-stream-string stream))
 	(index (string-input-stream-current stream)))
-    (declare (simple-string string) (fixnum index))
+    (declare (type (simple-array character (*)) string)
+	     (type fixnum index))
     (cond ((= index (the index (string-input-stream-end stream)))
 	   (eof-or-lose stream eof-error-p eof-value))
 	  (t
@@ -1113,7 +1110,7 @@
 (defun string-binch (stream eof-error-p eof-value)
   (let ((string (string-input-stream-string stream))
 	(index (string-input-stream-current stream)))
-    (declare (simple-string string)
+    (declare (type (simple-array character (*)) string)
 	     (type index index))
     (cond ((= index (the index (string-input-stream-end stream)))
 	   (eof-or-lose stream eof-error-p eof-value))
@@ -1128,7 +1125,7 @@
 	 (index (string-input-stream-current stream))
 	 (available (- (string-input-stream-end stream) index))
 	 (copy (min available requested)))
-    (declare (simple-string string)
+    (declare (type (simple-array character (*)) string)
 	     (type index index available copy))
     (when (plusp copy)
       (setf (string-input-stream-current stream)
@@ -1150,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)))
@@ -1181,11 +1182,16 @@
 		      (sout #'string-sout)
 		      (misc #'string-out-misc)
                       ;; The string we throw stuff in.
-                      (string (make-string 40) :type simple-string))
-	    (:constructor make-string-output-stream ())
+                      (string (missing-arg)
+			      :type (simple-array character (*))))
+	    (: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)
@@ -1195,7 +1201,8 @@
 (defun string-ouch (stream character)
   (let ((current (string-output-stream-index stream))
 	(workspace (string-output-stream-string stream)))
-    (declare (simple-string workspace) (fixnum current))
+    (declare (type (simple-array character (*)) workspace)
+	     (type fixnum current))
     (if (= current (the fixnum (length workspace)))
 	(let ((new-workspace (make-string (* current 2))))
 	  (replace new-workspace workspace)
@@ -1205,13 +1212,17 @@
     (setf (string-output-stream-index stream) (1+ current))))
 
 (defun string-sout (stream string start end)
-  (declare (simple-string string) (fixnum start end))
-  (let* ((current (string-output-stream-index stream))
+  (declare (type simple-string string)
+	   (type fixnum start end))
+  (let* ((string (if (typep string '(simple-array character (*)))
+		     string
+		     (coerce string '(simple-array character (*)))))
+	 (current (string-output-stream-index stream))
 	 (length (- end start))
 	 (dst-end (+ length current))
 	 (workspace (string-output-stream-string stream)))
-    (declare (simple-string workspace)
-	     (fixnum current length dst-end))
+    (declare (type (simple-array character (*)) workspace string)
+	     (type fixnum current length dst-end))
     (if (> dst-end (the fixnum (length workspace)))
 	(let ((new-workspace (make-string (+ (* current 2) length))))
 	  (replace new-workspace workspace :end2 current)
@@ -1236,8 +1247,8 @@
 	  (count 0 (1+ count))
 	  (string (string-output-stream-string stream)))
 	 ((< index 0) count)
-       (declare (simple-string string)
-		(fixnum index count))
+       (declare (type (simple-array character (*)) string)
+		(type fixnum index count))
        (if (char= (schar string index) #\newline)
 	   (return count))))
     (:element-type 'base-char)))
@@ -1247,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))
 
@@ -1268,7 +1290,7 @@
 ;;; WITH-OUTPUT-TO-STRING.
 
 (deftype string-with-fill-pointer ()
-  '(and string
+  '(and (vector character)
 	(satisfies array-has-fill-pointer-p)))
 
 (defstruct (fill-pointer-output-stream
@@ -1290,7 +1312,7 @@
 	 (current+1 (1+ current)))
     (declare (fixnum current))
     (with-array-data ((workspace buffer) (start) (end))
-      (declare (simple-string workspace))
+      (declare (type (simple-array character (*)) workspace))
       (let ((offset-current (+ start current)))
 	(declare (fixnum offset-current))
 	(if (= offset-current end)
@@ -1309,20 +1331,23 @@
 
 (defun fill-pointer-sout (stream string start end)
   (declare (simple-string string) (fixnum start end))
-  (let* ((buffer (fill-pointer-output-stream-string stream))
+  (let* ((string (if (typep string '(simple-array character (*)))
+		     string
+		     (coerce string '(simple-array character (*)))))
+	 (buffer (fill-pointer-output-stream-string stream))
 	 (current (fill-pointer buffer))
 	 (string-len (- end start))
 	 (dst-end (+ string-len current)))
     (declare (fixnum current dst-end string-len))
     (with-array-data ((workspace buffer) (dst-start) (dst-length))
-      (declare (simple-string workspace))
+      (declare (type (simple-array character (*)) workspace))
       (let ((offset-dst-end (+ dst-start dst-end))
 	    (offset-current (+ dst-start current)))
 	(declare (fixnum offset-dst-end offset-current))
 	(if (> offset-dst-end dst-length)
 	    (let* ((new-length (+ (the fixnum (* current 2)) string-len))
 		   (new-workspace (make-string new-length)))
-	      (declare (simple-string new-workspace))
+	      (declare (type (simple-array character (*)) new-workspace))
 	      (%byte-blt workspace dst-start
 			 new-workspace 0 current)
 	      (setf workspace new-workspace)