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

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 869a0cc..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
 
@@ -394,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
@@ -429,13 +453,7 @@
                          (- +ansi-stream-in-buffer-length+
                             +ansi-stream-in-buffer-extra+)
                          nil))
-         (start (- +ansi-stream-in-buffer-length+ count))
-         (n-character-array-bytes
-          #.(/ (sb!vm:saetp-n-bits
-                (find 'character
-                      sb!vm:*specialized-array-element-type-properties*
-                      :key #'sb!vm:saetp-specifier))
-               sb!vm:n-byte-bits)))
+         (start (- +ansi-stream-in-buffer-length+ count)))
     (declare (type index start count))
     (cond ((zerop count)
            (setf (ansi-stream-in-index stream)
@@ -443,19 +461,17 @@
            (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
-                                       n-character-array-bytes)
-                                    (* sb!vm:vector-data-offset
-                                       sb!vm:n-word-bits))
-                            ibuf (+ (the index (* start
-                                                  sb!vm:n-byte-bits
-                                                  n-character-array-bytes))
-                                    (* sb!vm:vector-data-offset
-                                       sb!vm:n-word-bits))
-                            (* count
-                               sb!vm:n-byte-bits
-                               n-character-array-bytes)))
+             (#.(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)))))
 
@@ -473,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)))))
 
@@ -617,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
@@ -625,6 +641,8 @@
      (charpos stream))
     (:file-length
      (file-length stream))
+    (:file-string-length
+     (file-string-length stream arg1))
     (:file-position
      (file-position stream arg1))))
 
@@ -692,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))))
@@ -700,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
@@ -1069,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)))
@@ -1788,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.