X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=d658516140fced218cb6c0959e17c17d05fa97e9;hb=b08e81cd5a06fe5d792f0be1d1c2bf3409a4ae60;hp=b33dfb9b90a4796c5365012fe3c21b913f31f4d4;hpb=cb296ae5a022a5b0f1fd573584301b0d2a9493f9;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index b33dfb9..d658516 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -115,6 +115,9 @@
 (defun stream-element-type (stream)
   (ansi-stream-element-type stream))
 
+(defun stream-external-format (stream)
+  (funcall (ansi-stream-misc stream) stream :external-format))
+
 (defun interactive-stream-p (stream)
   (declare (type stream stream))
   (funcall (ansi-stream-misc stream) stream :interactive-p))
@@ -189,6 +192,7 @@
 	   ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
 	   ;; private predicate function..) is ugly and confusing, but
 	   ;; I can't see any other way. -- WHN 2001-04-14
+	   :datum stream
 	   :expected-type '(satisfies stream-associated-with-file-p)
 	   :format-control
 	   "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
@@ -200,8 +204,18 @@
   ;; cause cross-compiler hangup.
   ;;
   ;; (declare (type (or file-stream synonym-stream) stream))
-  (stream-must-be-associated-with-file stream)
+  ;; 
+  ;; The description for FILE-LENGTH says that an error must be raised
+  ;; for streams not associated with files (which broadcast streams
+  ;; aren't according to the glossary). However, the behaviour of
+  ;; FILE-LENGTH for broadcast streams is explicitly described in the
+  ;; BROADCAST-STREAM entry.
+  (unless (typep stream 'broadcast-stream)	      
+    (stream-must-be-associated-with-file stream))
   (funcall (ansi-stream-misc stream) stream :file-length))
+
+(defun file-string-length (stream object)
+  (funcall (ansi-stream-misc stream) stream :file-string-length object))
 
 ;;;; input functions
 
@@ -298,8 +312,11 @@
 (defun ansi-stream-listen (stream)
   (or (/= (the fixnum (ansi-stream-in-index stream))
           +ansi-stream-in-buffer-length+)
-      ;; Test for T explicitly since misc methods return :EOF sometimes.
-      (eq (funcall (ansi-stream-misc stream) stream :listen) t)))
+      ;; Handle :EOF return from misc methods specially
+      (let ((result (funcall (ansi-stream-misc stream) stream :listen)))
+	(if (eq result :eof)
+	    nil
+	    result))))
 
 (defun listen (&optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
@@ -391,13 +408,23 @@
 	       numbytes
 	       eof-error-p))
      ((<= numbytes num-buffered)
+      #+nil
+      (let ((copy-function (typecase buffer
+                             ((simple-array * (*)) #'ub8-bash-copy)
+                             (system-area-pointer #'copy-ub8-to-system-area))))
+        (funcall copy-function in-buffer index buffer start numbytes))
       (%byte-blt in-buffer index
 		 buffer start (+ start numbytes))
       (setf (ansi-stream-in-index stream) (+ index numbytes))
       numbytes)
      (t
       (let ((end (+ start num-buffered)))
-	(%byte-blt in-buffer index buffer start end)
+	#+nil
+        (let ((copy-function (typecase buffer
+                             ((simple-array * (*)) #'ub8-bash-copy)
+                             (system-area-pointer #'copy-ub8-to-system-area))))
+          (funcall copy-function in-buffer index buffer start num-buffered))
+        (%byte-blt in-buffer index buffer start end)
 	(setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
 	(+ (funcall (ansi-stream-n-bin stream)
 		    stream
@@ -419,30 +446,34 @@
 ;;; and hence must be an N-BIN method.
 (defun fast-read-char-refill (stream eof-error-p eof-value)
   (let* ((ibuf (ansi-stream-cin-buffer stream))
-	 (count (funcall (ansi-stream-n-bin stream)
-			 stream
-			 ibuf
-			 +ansi-stream-in-buffer-extra+
-			 (- +ansi-stream-in-buffer-length+
-			    +ansi-stream-in-buffer-extra+)
-			 nil))
-	 (start (- +ansi-stream-in-buffer-length+ count)))
+         (count (funcall (ansi-stream-n-bin stream)
+                         stream
+                         ibuf
+                         +ansi-stream-in-buffer-extra+
+                         (- +ansi-stream-in-buffer-length+
+                            +ansi-stream-in-buffer-extra+)
+                         nil))
+         (start (- +ansi-stream-in-buffer-length+ count)))
     (declare (type index start count))
     (cond ((zerop count)
-	   (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
-	   (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
-	  (t
-	   (when (/= start +ansi-stream-in-buffer-extra+)
-	     (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+
-				       sb!vm:n-byte-bits)
-				    (* sb!vm:vector-data-offset
-				       sb!vm:n-word-bits))
-			    ibuf (+ (the index (* start sb!vm:n-byte-bits))
-				    (* sb!vm:vector-data-offset
-				       sb!vm:n-word-bits))
-			    (* count sb!vm:n-byte-bits)))
-	   (setf (ansi-stream-in-index stream) (1+ start))
-	   (aref ibuf start)))))
+           (setf (ansi-stream-in-index stream)
+                 +ansi-stream-in-buffer-length+)
+           (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
+          (t
+           (when (/= start +ansi-stream-in-buffer-extra+)
+             (#.(let* ((n-character-array-bits
+                        (sb!vm:saetp-n-bits
+                         (find 'character
+                               sb!vm:*specialized-array-element-type-properties*
+                               :key #'sb!vm:saetp-specifier)))
+                       (bash-function (intern (format nil "UB~D-BASH-COPY" n-character-array-bits)
+                                              (find-package "SB!KERNEL"))))
+                  bash-function)
+                ibuf +ansi-stream-in-buffer-extra+
+                ibuf start
+                count))
+           (setf (ansi-stream-in-index stream) (1+ start))
+           (aref ibuf start)))))
 
 ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
 ;;; leave room for unreading.
@@ -458,11 +489,9 @@
 	   (funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
 	  (t
 	   (unless (zerop start)
-	     (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits)
-			    ibuf (+ (the index (* start sb!vm:n-byte-bits))
-				    (* sb!vm:vector-data-offset
-				       sb!vm:n-word-bits))
-			    (* count sb!vm:n-byte-bits)))
+             (ub8-bash-copy ibuf 0
+                            ibuf start 
+                            count))
 	   (setf (ansi-stream-in-index stream) (1+ start))
 	   (aref ibuf start)))))
 
@@ -602,6 +631,8 @@
      (finish-output stream))
     (:element-type
      (stream-element-type stream))
+    (:stream-external-format
+     (stream-external-format stream))
     (:interactive-p
      (interactive-stream-p stream))
     (:line-length
@@ -610,6 +641,8 @@
      (charpos stream))
     (:file-length
      (file-length stream))
+    (:file-string-length
+     (file-string-length stream arg1))
     (:file-position
      (file-position stream arg1))))
 
@@ -677,6 +710,15 @@
 	     ((null streams) res)
 	   (when (null (cdr streams))
 	     (setq res (stream-element-type (car streams)))))))
+      (:external-format
+       (let ((res :default))
+	 (dolist (stream streams res)
+	   (setq res (stream-external-format stream)))))
+      (:file-length
+       (let ((last (last streams)))
+	 (if last	     
+	     (file-length (car last))
+	     0)))
       (:file-position
        (if arg1
 	   (let ((res (or (eql arg1 :start) (eql arg1 0))))
@@ -685,6 +727,10 @@
 	   (let ((res 0))
 	     (dolist (stream streams res)
 	       (setq res (file-position stream))))))
+      (:file-string-length
+       (let ((res 1))
+	 (dolist (stream streams res)
+	   (setq res (file-string-length stream arg1)))))
       (:close
        (set-closed-flame stream))
       (t
@@ -815,7 +861,7 @@
 	   (or (/= (the fixnum (ansi-stream-in-index in))
 		   +ansi-stream-in-buffer-length+)
 	       (funcall (ansi-stream-misc in) in :listen))
-	   (stream-listen in)))
+	   (listen in)))
       ((:finish-output :force-output :clear-output)
        (if out-ansi-stream-p
 	   (funcall (ansi-stream-misc out) out operation arg1 arg2)
@@ -1008,32 +1054,18 @@
 	 (aver (= numbytes (+ new-start bytes-read)))
 	 numbytes)))))
 
-;;;; base STRING-STREAM stuff
-
-(defstruct (string-stream
-             (:include ansi-stream)
-             (:constructor nil)
-             (:copier nil))
-  ;; 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
 
 (defstruct (string-input-stream
-	     (:include string-stream
+	     (:include ansi-stream
 		       (in #'string-inch)
 		       (bin #'ill-bin)
 		       (n-bin #'ill-bin)
-		       (misc #'string-in-misc)
-                       (string (missing-arg) :type simple-string))
+		       (misc #'string-in-misc))
 	     (:constructor internal-make-string-input-stream
 			   (string current end))
 	     (:copier nil))
+  (string (missing-arg) :type simple-string)
   (current (missing-arg) :type index)
   (end (missing-arg) :type index))
 
@@ -1068,14 +1100,16 @@
     (when (plusp copy)
       (setf (string-input-stream-current stream)
 	    (truly-the index (+ index copy)))
+      ;; FIXME: why are we VECTOR-SAP'ing things here?  what's the point?
+      ;; and are there SB-UNICODE issues here as well?  --njf, 2005-03-24
       (sb!sys:without-gcing
-       (system-area-copy (vector-sap string)
-			 (* index sb!vm:n-byte-bits)
-			 (if (typep buffer 'system-area-pointer)
-			     buffer
-			     (vector-sap buffer))
-			 (* start sb!vm:n-byte-bits)
-			 (* copy sb!vm:n-byte-bits))))
+       (system-area-ub8-copy (vector-sap string)
+                             index
+                             (if (typep buffer 'system-area-pointer)
+                                 buffer
+                                 (vector-sap buffer))
+                             start
+                             copy)))
     (if (and (> requested copy) eof-error-p)
 	(error 'end-of-file :stream stream)
 	copy)))
@@ -1124,17 +1158,16 @@
 ;;;; STRING-OUTPUT-STREAM stuff
 
 (defstruct (string-output-stream
-	    (:include string-stream
+	    (:include ansi-stream
 		      (out #'string-ouch)
 		      (sout #'string-sout)
-		      (misc #'string-out-misc)
-                      ;; The string we throw stuff in.
-                      (string (missing-arg)
-			      :type (simple-array character (*))))
+		      (misc #'string-out-misc))
 	    (:constructor make-string-output-stream 
 			  (&key (element-type 'character)
 			   &aux (string (make-string 40))))
 	    (:copier nil))
+  ;; The string we throw stuff in.
+  (string (missing-arg) :type (simple-array character (*)))
   ;; Index of the next location to use.
   (index 0 :type fixnum)
   ;; Index cache for string-output-stream-last-index
@@ -1275,17 +1308,14 @@
 	(satisfies array-has-fill-pointer-p)))
 
 (defstruct (fill-pointer-output-stream
- 	    (:include string-stream
+ 	    (:include ansi-stream
 		      (out #'fill-pointer-ouch)
 		      (sout #'fill-pointer-sout)
-		      (misc #'fill-pointer-misc)
-                      ;; a string with a fill pointer where we stuff
-                      ;; the stuff we write
-                      (string (missing-arg)
-                              :type string-with-fill-pointer
-                              :read-only t))
+		      (misc #'fill-pointer-misc))
 	    (:constructor make-fill-pointer-output-stream (string))
-	    (:copier nil)))
+	    (:copier nil))
+  ;; a string with a fill pointer where we stuff the stuff we write
+  (string (missing-arg) :type string-with-fill-pointer :read-only t))
 
 (defun fill-pointer-ouch (stream character)
   (let* ((buffer (fill-pointer-output-stream-string stream))
@@ -1518,7 +1548,7 @@
 
 (defun case-frob-upcase-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream))
 	(char (char-upcase char)))
     (if (ansi-stream-p target)
@@ -1543,7 +1573,7 @@
 
 (defun case-frob-downcase-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream))
 	(char (char-downcase char)))
     (if (ansi-stream-p target)
@@ -1568,7 +1598,7 @@
 
 (defun case-frob-capitalize-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream)))
     (cond ((alphanumericp char)
 	   (let ((char (char-upcase char)))
@@ -1612,7 +1642,7 @@
 
 (defun case-frob-capitalize-aux-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream)))
     (cond ((alphanumericp char)
 	   (let ((char (char-downcase char)))
@@ -1657,7 +1687,7 @@
 
 (defun case-frob-capitalize-first-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream)))
     (cond ((alphanumericp char)
 	   (let ((char (char-upcase char)))
@@ -1791,30 +1821,36 @@
       (list
        (let ((write-function
 	      (if (subtypep (stream-element-type stream) 'character)
-                  ;; FIXME (rudi 2004-08-09): since we know we're an
-                  ;; ansi stream here, we could replace these
-                  ;; functions with ansi-stream-specific constructs
-		  #'write-char
-		  #'write-byte)))
+		  (ansi-stream-out stream)
+		  (ansi-stream-bout stream))))
 	 (do ((rem (nthcdr start seq) (rest rem))
 	      (i start (1+ i)))
-	     ((or (endp rem) (>= i end)) seq)
+	     ((or (endp rem) (>= i end)))
 	   (declare (type list rem)
 		    (type index i))
-	   (funcall write-function (first rem) stream))))
+	   (funcall write-function stream (first rem)))))
       (string
        (%write-string seq stream start end))
       (vector
-       (let ((write-function
-	      (if (subtypep (stream-element-type stream) 'character)
-                  ;; FIXME (rudi 2004-08-09): since we know we're an
-                  ;; ansi stream here, we could replace these
-                  ;; functions with ansi-specific constructs
-		  #'write-char
-		  #'write-byte)))
-	 (do ((i start (1+ i)))
-	     ((>= i end) seq)
-	   (declare (type index i))
-	   (funcall write-function (aref seq i) stream)))))))
+       (with-array-data ((data seq) (offset-start start) (offset-end end))
+	 (labels
+	     ((output-seq-in-loop ()
+		(let ((write-function
+		       (if (subtypep (stream-element-type stream) 'character)
+			   (ansi-stream-out stream)
+			   (ansi-stream-bout stream))))
+		  (do ((i offset-start (1+ i)))
+		      ((>= i offset-end))
+		    (declare (type index i))
+		    (funcall write-function stream (aref data i))))))
+	   (typecase data
+	     ((or (simple-array (unsigned-byte 8) (*))
+		  (simple-array (signed-byte 8) (*)))
+	      (if (fd-stream-p stream)
+		  (output-raw-bytes stream data offset-start offset-end)
+		  (output-seq-in-loop)))
+	     (t
+	      (output-seq-in-loop))))))))
+  seq)
 
 ;;;; etc.