[Openmcl-cvs-notifications] r15177 - /trunk/source/level-1/l1-streams.lisp
gb at clozure.com
gb at clozure.com
Tue Jan 24 09:21:22 CST 2012
Author: gb
Date: Tue Jan 24 09:21:21 2012
New Revision: 15177
Log:
New! Improved! Properly parenthesized!
Modified:
trunk/source/level-1/l1-streams.lisp
Modified: trunk/source/level-1/l1-streams.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-streams.lisp (original)
+++ trunk/source/level-1/l1-streams.lisp Tue Jan 24 09:21:21 2012
@@ -99,21 +99,37 @@
=
;;; For input streams:
=
-;; From Shannon Spires, slightly modified.
+;;; From Shannon Spires, slightly modified.
(defun generic-read-line (s)
- (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 (subseq str 0 pos) eof))
- (when (=3D pos len)
- (setq len (* len 2)
- str (%extend-vector 0 str len)))
- (setf (schar str pos) ch
- pos (1+ pos)))))
+ (collect ((chunks))
+ (let* ((pos 0)
+ (len 0)
+ (chunksize 8192)
+ (str (make-string chunksize))
+ (eof nil))
+ (declare (fixnum pos len chunksize)
+ (simple-string str)
+ (dynamic-extent str))
+ (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
+ ((or (eq ch #\newline) (setq eof (eq ch :eof)))
+ (if (zerop len)
+ (values (subseq str 0 pos) eof)
+ (let* ((outpos 0))
+ (setq len (+ len pos))
+ (let* ((out (make-string len)))
+ (dolist (s (chunks))
+ (%uvector-replace out outpos s 0 chunksize target::sub=
tag-simple-base-string)
+ (incf outpos chunksize))
+ (%uvector-replace out outpos str 0 pos target::subtag-si=
mple-base-string)
+ (values out eof)))))
+ (when (=3D pos chunksize)
+ (chunks str)
+ (setq str (make-string chunksize)
+ len (+ len pos)
+ pos 0))
+ (setf (schar str pos) ch
+ pos (1+ pos))))))
+
=
(defun generic-character-read-list (stream list count)
(declare (fixnum count))
@@ -2295,104 +2311,102 @@
(setf (io-buffer-count buf) 0
(io-buffer-idx buf) 0)))
=
+
(defun %ioblock-unencoded-read-line (ioblock)
- (let* ((inbuf (ioblock-inbuf ioblock)))
- (let* ((string "")
+ (declare (optimize (speed 3) (safety 0)))
+ (collect ((octet-vectors))
+ (let* ((inbuf (ioblock-inbuf ioblock))
(len 0)
- (eof nil)
- (filled-buf 0)
- (buf (io-buffer-buffer inbuf))
- (newline (char-code #\newline)))
- (declare (fixnum filled-buf))
+ (buf (io-buffer-buffer inbuf)))
+ (declare (fixnum len) (type (simple-array (unsigned-byte 8)(*)) buf))
(let* ((ch (ioblock-untyi-char ioblock)))
(when ch
(setf (ioblock-untyi-char ioblock) nil)
(if (eql ch #\newline)
(return-from %ioblock-unencoded-read-line =
- (values string nil))
+ (values "" nil))
(progn
- (setq string (make-string 1)
- len 1)
- (setf (schar string 0) ch)))))
- (loop
- (let* ((more 0)
- (idx (io-buffer-idx inbuf))
- (count (io-buffer-count inbuf)))
- (declare (fixnum idx count more filled-buf))
- (if (=3D idx count)
- (if eof
- (return (values string t))
- (progn
- (setq eof t)
- (incf filled-buf)
- (%ioblock-advance ioblock t)))
- (progn
- (setq eof nil)
- (let* ((pos (position newline buf :start idx :end count)))
- (when pos
- (locally (declare (fixnum pos))
- (setf (io-buffer-idx inbuf) (the fixnum (1+ pos)))
- (setq more (- pos idx))
- (unless (zerop more)
- (setq string
- (%extend-vector
- 0 string (the fixnum (+ len more)))))
- (%copy-u8-to-string
- buf idx string len more)
- (return (values string nil))))
- ;; No #\newline in the buffer. Read everything that's
- ;; there into the string, and fill the buffer again.
- (setf (io-buffer-idx inbuf) count)
- (setq more (- count idx)
- string (%extend-vector
- 0 string (the fixnum (+ len more))))
- (%copy-u8-to-string
- buf idx string 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 (=3D 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 (=3D pos len)
- string
- (subseq string 0 pos)) nil)))
- (setf (io-buffer-idx inbuf) count))))))))))))
+ (octet-vectors (make-array 1 :element-type '(unsigned-byte 8)
+ :initial-element (char-code ch)))
+ (setq len 1)))))
+ (do* ((done nil)
+ (idx (io-buffer-idx inbuf))
+ (count (io-buffer-count inbuf)))
+ (done (let* ((string (make-string len))
+ (outpos 0))
+ (declare (simple-string string) (fixnum outpos))
+ (dolist (v (octet-vectors) (values string (eq done :eof=
)))
+ (let* ((vlen (length v)))
+ (declare (fixnum vlen))
+ (%copy-u8-to-string v 0 string outpos vlen)
+ (incf outpos vlen)))))
+ (declare (fixnum idx count))
+ (when (=3D idx count)
+ (%ioblock-advance ioblock t)
+ (setq idx (io-buffer-idx inbuf)
+ count (io-buffer-count inbuf)
+ done (if (=3D idx count) :eof)))
+ (unless done
+ (let* ((p (do* ((i idx (1+ i)))
+ ((=3D i count)
+ (setf (io-buffer-idx inbuf) count)
+ nil)
+ (declare (fixnum i))
+ (when (eql (aref buf i) (char-code #\newline))
+ (setf (io-buffer-idx inbuf) (the fixnum (1+ i)))
+ (setq done t)
+ (return i))))
+ (end (or p count))
+ (n (- end idx)))
+ (declare (fixnum p end n))
+ (if (and p (eql len 0))
+ ;; Likely a fairly common case
+ (let* ((string (make-string n)))
+ (%copy-u8-to-string buf idx string 0 n)
+ (return-from %ioblock-unencoded-read-line
+ (values string nil)))
+ (let* ((v (make-array n :element-type '(unsigned-byte 8))))
+ (%copy-ivector-to-ivector buf idx v 0 n)
+ (incf len n)
+ (octet-vectors v)
+ (setq idx count)))))))))
+
=
;;; There are lots of ways of doing better here, but in the most general
;;; case we can't tell (a) what a newline looks like in the buffer or (b)
;;; whether there's a 1:1 mapping between code units and characters.
(defun %ioblock-encoded-read-line (ioblock)
- (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 (subseq str 0 pos) eof))
- (when (=3D pos len)
- (setq len (* len 2) str (%extend-vector 0 str len)))
- (setf (schar str pos) ch
- pos (1+ pos)))))
+ (declare (optimize (speed 3) (safety 0)))
+ (collect ((chunks))
+ (let* ((pos 0)
+ (len 0)
+ (chunksize 8192)
+ (str (make-string chunksize))
+ (rcf (ioblock-read-char-when-locked-function ioblock))
+ (eof nil))
+ (declare (fixnum pos len chunksize)
+ (simple-string str)
+ (dynamic-extent str))
+ (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
+ ((or (eq ch #\newline) (setq eof (eq ch :eof)))
+ (if (zerop len)
+ (values (subseq str 0 pos) eof)
+ (let* ((outpos 0))
+ (declare (fixnum outpos))
+ (setq len (+ len pos))
+ (let* ((out (make-string len)))
+ (dolist (s (chunks))
+ (%copy-ivector-to-ivector s 0 out outpos (the fixnum (=
ash chunksize 2)))
+ (incf outpos (ash chunksize 2)))
+ (%copy-ivector-to-ivector str 0 out outpos (the fixnum (=
ash pos 2)))
+ (values out eof)))))
+ (when (=3D pos chunksize)
+ (chunks str)
+ (setq str (make-string chunksize)
+ len (+ len pos)
+ pos 0))
+ (setf (schar str pos) ch
+ pos (1+ pos))))))
=
(defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
(do* ((i start)
More information about the Openmcl-cvs-notifications
mailing list