X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=e3dbd91b327f1d8471cb837cfe4bd804e34a3818;hb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;hp=c96d81d78cdd1837f7c34f26c436d0eeadf85067;hpb=562dd7fc01e2756b57439cb4ddfbc52e575728fb;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index c96d81d..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+)
@@ -185,13 +185,16 @@
 	   ;; 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))))
 
 ;;; like FILE-POSITION, only using :FILE-LENGTH
 (defun file-length (stream)
-  (declare (type (or file-stream synonym-stream) stream))
+  ;; FIXME: The following declaration uses yet undefined types, which
+  ;; cause cross-compiler hangup.
+  ;;
+  ;; (declare (type (or file-stream synonym-stream) stream))
   (stream-must-be-associated-with-file stream)
   (funcall (ansi-stream-misc stream) stream :file-length))
 
@@ -329,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)))
@@ -904,7 +896,7 @@
 		  (let* ((stream (car current))
 			 (result (,fun stream nil nil)))
 		    (when result (return result)))
-		  (setf (concatenated-stream-current stream) current)))))
+		  (pop (concatenated-stream-current stream))))))
   (in-fun concatenated-in read-char)
   (in-fun concatenated-bin read-byte))
 
@@ -1080,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
 
@@ -1090,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))
@@ -1100,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
@@ -1110,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))
@@ -1125,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)
@@ -1147,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)))
@@ -1178,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)
@@ -1192,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)
@@ -1202,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)
@@ -1233,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)))
@@ -1244,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))
 
@@ -1265,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
@@ -1287,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)
@@ -1306,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)
@@ -1672,37 +1700,6 @@
 	(funcall (ansi-stream-sout target) target str 0 len)
 	(stream-write-string target str 0 len))))
 
-;;;; stream commands
-
-(defstruct (stream-command (:constructor make-stream-command
-					 (name &optional args))
-			   (:copier nil))
-  (name nil :type symbol)
-  (args nil :type list))
-(def!method print-object ((obj stream-command) str)
-  (print-unreadable-object (obj str :type t :identity t)
-    (prin1 (stream-command-name obj) str)))
-
-;;; Take a stream and wait for text or a command to appear on it. If
-;;; text appears before a command, return NIL, otherwise return a
-;;; command.
-;;;
-;;; We can't simply call the stream's misc method because NIL is an
-;;; ambiguous return value: does it mean text arrived, or does it mean
-;;; the stream's misc method had no :GET-COMMAND implementation? We
-;;; can't return NIL until there is text input. We don't need to loop
-;;; because any stream implementing :GET-COMMAND would wait until it
-;;; had some input. If the LISTEN fails, then we have some stream we
-;;; must wait on.
-(defun get-stream-command (stream)
-  (let ((cmdp (funcall (ansi-stream-misc stream) stream :get-command)))
-    (cond (cmdp)
-	  ((listen stream)
-	   nil)
-	  (t
-	   ;; This waits for input and returns NIL when it arrives.
-	   (unread-char (read-char stream) stream)))))
-
 ;;;; READ-SEQUENCE
 
 (defun read-sequence (seq stream &key (start 0) end)