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

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index ac44a90..e3dbd91 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -59,16 +59,16 @@
 
 ;;; stream manipulation functions
 
-(defun input-stream-p (stream)
-  (declare (type stream stream))
+(declaim (inline ansi-stream-input-stream-p))
+(defun ansi-stream-input-stream-p (stream)
+  (declare (type ansi-stream stream))
 
   #!+high-security
   (when (synonym-stream-p stream)
     (setf stream
 	  (symbol-value (synonym-stream-symbol stream))))
 
-  (and (ansi-stream-p stream)
-       (not (eq (ansi-stream-in stream) #'closed-flame))
+  (and (not (eq (ansi-stream-in stream) #'closed-flame))
        ;;; KLUDGE: It's probably not good to have EQ tests on function
        ;;; values like this. What if someone's redefined the function?
        ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
@@ -76,37 +76,60 @@
        (or (not (eq (ansi-stream-in stream) #'ill-in))
 	   (not (eq (ansi-stream-bin stream) #'ill-bin)))))
 
-(defun output-stream-p (stream)
+(defun input-stream-p (stream)
   (declare (type stream stream))
+  (and (ansi-stream-p stream)
+       (ansi-stream-input-stream-p stream)))
+
+(declaim (inline ansi-stream-output-stream-p))
+(defun ansi-stream-output-stream-p (stream)
+  (declare (type ansi-stream stream))
 
   #!+high-security
   (when (synonym-stream-p stream)
     (setf stream (symbol-value
 		  (synonym-stream-symbol stream))))
 
-  (and (ansi-stream-p stream)
-       (not (eq (ansi-stream-in stream) #'closed-flame))
+  (and (not (eq (ansi-stream-in stream) #'closed-flame))
        (or (not (eq (ansi-stream-out stream) #'ill-out))
 	   (not (eq (ansi-stream-bout stream) #'ill-bout)))))
 
-(defun open-stream-p (stream)
+(defun output-stream-p (stream)
   (declare (type stream stream))
+
+  (and (ansi-stream-p stream)
+       (ansi-stream-output-stream-p stream)))
+
+(declaim (inline ansi-stream-open-stream-p))
+(defun ansi-stream-open-stream-p (stream)
+  (declare (type ansi-stream stream))
   (not (eq (ansi-stream-in stream) #'closed-flame)))
 
-(defun stream-element-type (stream)
-  (declare (type stream stream))
+(defun open-stream-p (stream)
+  (ansi-stream-open-stream-p stream))
+
+(declaim (inline ansi-stream-element-type))
+(defun ansi-stream-element-type (stream)
+  (declare (type ansi-stream stream))
   (funcall (ansi-stream-misc stream) stream :element-type))
 
+(defun stream-element-type (stream)
+  (ansi-stream-element-type stream))
+
 (defun interactive-stream-p (stream)
   (declare (type stream stream))
   (funcall (ansi-stream-misc stream) stream :interactive-p))
 
-(defun close (stream &key abort)
-  (declare (type stream stream))
+(declaim (inline ansi-stream-close))
+(defun ansi-stream-close (stream abort)
+  (declare (type ansi-stream stream))
   (when (open-stream-p stream)
     (funcall (ansi-stream-misc stream) stream :close abort))
   t)
 
+(defun close (stream &key abort)
+  (ansi-stream-close stream abort))
+
 (defun set-closed-flame (stream)
   (setf (ansi-stream-in stream) #'closed-flame)
   (setf (ansi-stream-bin stream) #'closed-flame)
@@ -122,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+)
@@ -162,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))
 
@@ -306,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)))
@@ -515,29 +530,23 @@
 	(stream-fresh-line stream))))
 
 (defun write-string (string &optional (stream *standard-output*)
-			    &key (start 0) (end nil))
-  (%write-string string stream start (or end (length string)))
-  string)
-
-(defun %write-string (string stream start end)
+			    &key (start 0) end)
   (declare (type string string))
-  (declare (type streamlike stream))
-  (declare (type index start end))
-
   ;; Note that even though you might expect, based on the behavior of
   ;; things like AREF, that the correct upper bound here is
   ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
   ;; "bounding index" and "length" indicate that in this case (i.e.
-  ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
-  ;; which are implemented in terms of this function), (LENGTH STRING)
-  ;; is the required upper bound. A foolish consistency is the
-  ;; hobgoblin of lesser languages..
-  (unless (<= 0 start end (length string))
-    (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
-	   start
-	   end
-	   string))
+  ;; for the ANSI-specified functions WRITE-STRING [and WRITE-LINE]),
+  ;; (LENGTH STRING) is the required upper bound. A foolish
+  ;; consistency is the hobgoblin of lesser languages..
+  (%write-string string stream start (%check-vector-sequence-bounds
+				      string start end))
+  string)
 
+(defun %write-string (string stream start end)
+  (declare (type string string))
+  (declare (type streamlike stream))
+  (declare (type index start end))
   (let ((stream (out-synonym-of stream)))
     (cond ((ansi-stream-p stream)
 	   (if (array-header-p string)
@@ -551,10 +560,13 @@
 	   (stream-write-string stream string start end)))))
 
 (defun write-line (string &optional (stream *standard-output*)
-			  &key (start 0) (end nil))
-  (let ((defaulted-stream (out-synonym-of stream))
-	(defaulted-end (or end (length string))))
-    (%write-string string defaulted-stream start defaulted-end)
+			  &key (start 0) end)
+  (declare (type string string))
+  ;; FIXME: Why is there this difference between the treatments of the
+  ;; STREAM argument in WRITE-STRING and WRITE-LINE?
+  (let ((defaulted-stream (out-synonym-of stream)))
+    (%write-string string defaulted-stream start (%check-vector-sequence-bounds
+						  string start end))
     (write-char #\newline defaulted-stream))
   string)
 
@@ -884,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))
 
@@ -1060,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
 
@@ -1070,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))
@@ -1080,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
@@ -1090,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))
@@ -1105,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)
@@ -1127,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)))
@@ -1137,22 +1161,18 @@
     (:element-type 'base-char)))
 
 (defun make-string-input-stream (string &optional
-					(start 0) (end (length string)))
+					(start 0) end)
   #!+sb-doc
   "Return an input stream which will supply the characters of STRING between
   START and END in order."
   (declare (type string string)
 	   (type index start)
 	   (type (or index null) end))
-
-  #!+high-security
-  (when (> end (length string))
-    (cerror "Continue with end changed from ~S to ~S"
-	    "Write-string: end (~S) is larger then the length of the string (~S)"
-	    end (1- (length string))))
-
-  (internal-make-string-input-stream (coerce string 'simple-string)
-				     start end))
+  
+  (internal-make-string-input-stream
+   (coerce string 'simple-string)
+   start
+   (%check-vector-sequence-bounds string start end)))
 
 ;;;; STRING-OUTPUT-STREAM stuff
 
@@ -1162,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)
@@ -1176,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)
@@ -1186,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)
@@ -1217,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)))
@@ -1228,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))
 
@@ -1249,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
@@ -1271,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)
@@ -1290,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)
@@ -1656,40 +1700,9 @@
 	(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 nil))
+(defun read-sequence (seq stream &key (start 0) end)
   #!+sb-doc
   "Destructively modify SEQ by reading elements from STREAM.
   That part of SEQ bounded by START and END is destructively modified by