Changeset 15165 for trunk/source/level-1

Timestamp:

Jan 19, 2012, 1:47:48 AM (8 years ago)

Author:

gb

Message:

Except on the PPC (which has LAP versions of %EXTEND-VECTOR), define
%EXTEND-VECTOR in terms of %UVECTOR-REPLACE, which can use things like
%COPY-IVECTOR-TO-IVECTOR.

Make %UVECTOR-REPLACE work on non-CL-array uvector types, too.

When creating an fd-based stream (in MAKE-FD-STREAM and MAKE-FILE-STREAM),
if the stream is capable of character I/O it'll be buffered by an octet
vector, so call OPTIMAL-BUFFER-SIZE with the appropriate element type.
On Windows, use the arbitrary buffer size of 4K octets (rather than #$BUFSIZ).

In %IOBLOCK-UNENCODED-READ-LINE, if we haven't seen a newline in the first
few bufferfuls of data, stop expecting to do so (and grow the string in
larger increments less often.)

In the more generic READ-LINE cases, use a SIMPLE-STRING (and track
its length and current position manually) rather than a string with a
fill-pointer.

Location:

trunk/source/level-1

Files:

• l1-streams.lisp (modified) (7 diffs)
• l1-sysio.lisp (modified) (3 diffs)

trunk/source/level-1/l1-streams.lisp

@@ -102 +102 @@
 ;; From Shannon Spires, slightly modified.
 (defun generic-read-line (s)
-  (let* ((str (make-array 20 :element-type 'base-char
-                          :adjustable t :fill-pointer 0))
+  (let* ((len 20)
+         (pos 0)
+         (str (make-array len :element-type 'base-char))
          (eof nil))
+    (declare (fixnum pos len) (simple-string str))
     (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
          ((or (eq ch #\newline) (setq eof (eq ch :eof)))
-          (values (ensure-simple-string str) eof))
-      (vector-push-extend ch str))))
+          (values (subseq str 0 pos) eof))
+      (when (= pos len)
+        (setq len (* len 2)
+              str (%extend-vector 0 str len)))
+      (setf (schar str pos) ch
+            pos (1+ pos)))))
 
 (defun generic-character-read-list (stream list count)
@@ -2297 +2303 @@
            (len 0)
            (eof nil)
+           (filled-buf 0)
            (buf (io-buffer-buffer inbuf))
            (newline (char-code #\newline)))
+      (declare (fixnum filled-buf))
       (let* ((ch (ioblock-untyi-char ioblock)))
         (when ch
@@ -2313 +2321 @@
                (idx (io-buffer-idx inbuf))
                (count (io-buffer-count inbuf)))
-          (declare (fixnum idx count more))
+          (declare (fixnum idx count more filled-buf))
           (if (= idx count)
             (if eof
@@ -2319 +2327 @@
               (progn
                 (setq eof t)
+                (incf filled-buf)
                 (%ioblock-advance ioblock t)))
             (progn
@@ -2342 +2351 @@
                 (%copy-u8-to-string
                  buf idx string len more)
-                (incf len more)))))))))
+                (incf len more))
+              (when (> filled-buf 1)
+                (let* ((pos len))
+                  (loop
+                    (%ioblock-advance ioblock t)
+                    (setq count (io-buffer-count inbuf))
+                    (when (zerop count)                        
+                      (return-from %ioblock-unencoded-read-line
+                        (values (if (= pos len)
+                                  string
+                                  (subseq string 0 pos))
+                                t)))
+                    (let* ((p (position newline buf :end count))
+                           (n (or p count))
+                           (room (- len pos)))
+                      (declare (fixnum n room))
+                      (when (< room n)
+                        (setq len (+ len (the fixnum (or p len)))
+                              string (%extend-vector 0 string len)))
+                      (%copy-u8-to-string buf 0 string pos n)
+                      (incf pos n)
+                      (when p
+                        (return-from %ioblock-unencoded-read-line
+                          (values (if (= pos len)
+                                    string
+                                    (subseq string 0 pos)) nil)))
+                      (setf (io-buffer-idx inbuf) count))))))))))))
 
 ;;; There are lots of ways of doing better here, but in the most general
@@ -2348 +2383 @@
 ;;; whether there's a 1:1 mapping between code units and characters.
 (defun %ioblock-encoded-read-line (ioblock)
-  (let* ((str (make-array 20 :element-type 'base-char
-                          :adjustable t :fill-pointer 0))
+  (let* ((pos 0)
+         (len 20)
+         (str (make-string len))
          (rcf (ioblock-read-char-when-locked-function ioblock))
          (eof nil))
+    (declare (fixnum pos len) (simple-string str))
     (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
          ((or (eq ch #\newline) (setq eof (eq ch :eof)))
-          (values (ensure-simple-string str) eof))
-      (vector-push-extend ch str))))
+          (values (subseq str 0 pos) eof))
+      (when (= pos len)
+        (setq len (* len 2) str (%extend-vector 0 str len)))
+      (setf (schar str pos) ch
+            pos (1+ pos)))))
          
 (defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
@@ -3344 +3384 @@
              (8 (ash octets -3)))))
     #+windows-target
-    (let ((octets #$BUFSIZ))
+    (let ((octets 4096))
       (scale-buffer-size octets))
     #-windows-target

trunk/source/level-1/l1-sysio.lisp

@@ -774 +774 @@
         ((:io :output) nil)
         (t (report-bad-arg direction '(member :input :output :io :probe))))
-      (check-pathname-not-wild filename) ;; probe-file-x misses wild versions....
+      (check-pathname-not-wild filename) ; probe-file-x misses wild versions....
       (multiple-value-bind (native-truename kind) (probe-file-x filename)
         (tagbody retry
@@ -805 +805 @@
                    (when (null if-exists) (return-from open nil))
                    (multiple-value-setq (native-truename kind) (probe-file-x filename))
-                   (unless native-truename ;; huh?  Perhaps it disappeared again?
+                   (unless native-truename ; huh?  Perhaps it disappeared again?
                      (error "Attempt to create ~s failed unexpectedly" filename))
                    (go retry))
@@ -830 +830 @@
                        (char-p (or (eq element-type 'character)
                                    (subtypep element-type 'character)))
-                       (elements-per-buffer (optimal-buffer-size fd element-type))
+                       (elements-per-buffer (optimal-buffer-size fd (if char-p '(unsigned-byte 8) element-type)))
                        (real-external-format
                         (if char-p