Changeset 15177 for trunk/source/level-1


Ignore:
Timestamp:
Jan 24, 2012, 3:21:21 PM (7 years ago)
Author:
gb
Message:

New! Improved! Properly parenthesized!

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-streams.lisp

    r15176 r15177  
    100100;;; For input streams:
    101101
    102 ;; From Shannon Spires, slightly modified.
     102;;; From Shannon Spires, slightly modified.
    103103(defun generic-read-line (s)
    104   (let* ((len 20)
    105          (pos 0)
    106          (str (make-array len :element-type 'base-char))
    107          (eof nil))
    108     (declare (fixnum pos len) (simple-string str))
    109     (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
    110          ((or (eq ch #\newline) (setq eof (eq ch :eof)))
    111           (values (subseq str 0 pos) eof))
    112       (when (= pos len)
    113         (setq len (* len 2)
    114               str (%extend-vector 0 str len)))
    115       (setf (schar str pos) ch
    116             pos (1+ pos)))))
     104  (collect ((chunks))
     105    (let* ((pos 0)
     106           (len 0)
     107           (chunksize 8192)
     108           (str (make-string chunksize))
     109           (eof nil))
     110      (declare (fixnum pos len chunksize)
     111               (simple-string str)
     112               (dynamic-extent str))
     113      (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
     114           ((or (eq ch #\newline) (setq eof (eq ch :eof)))
     115            (if (zerop len)
     116              (values (subseq str 0 pos) eof)
     117              (let* ((outpos 0))
     118                (setq len (+ len pos))
     119                (let* ((out (make-string len)))
     120                  (dolist (s (chunks))
     121                    (%uvector-replace out outpos s 0 chunksize target::subtag-simple-base-string)
     122                    (incf outpos chunksize))
     123                  (%uvector-replace out outpos str 0 pos target::subtag-simple-base-string)
     124                  (values out eof)))))
     125        (when (= pos chunksize)
     126          (chunks str)
     127          (setq str (make-string chunksize)
     128                len (+ len pos)
     129                pos 0))
     130        (setf (schar str pos) ch
     131              pos (1+ pos))))))
     132
    117133
    118134(defun generic-character-read-list (stream list count)
     
    22982314            (io-buffer-idx buf) 0)))
    22992315
     2316
    23002317(defun %ioblock-unencoded-read-line (ioblock)
    2301   (let* ((inbuf (ioblock-inbuf ioblock)))
    2302     (let* ((string "")
     2318  (declare (optimize (speed 3) (safety 0)))
     2319  (collect ((octet-vectors))
     2320    (let* ((inbuf (ioblock-inbuf ioblock))
    23032321           (len 0)
    2304            (eof nil)
    2305            (filled-buf 0)
    2306            (buf (io-buffer-buffer inbuf))
    2307            (newline (char-code #\newline)))
    2308       (declare (fixnum filled-buf))
     2322           (buf (io-buffer-buffer inbuf)))
     2323      (declare (fixnum len) (type (simple-array (unsigned-byte 8)(*)) buf))
    23092324      (let* ((ch (ioblock-untyi-char ioblock)))
    23102325        (when ch
     
    23122327          (if (eql ch #\newline)
    23132328            (return-from %ioblock-unencoded-read-line
    2314               (values string nil))
     2329              (values "" nil))
    23152330            (progn
    2316               (setq string (make-string 1)
    2317                     len 1)
    2318               (setf (schar string 0) ch)))))
    2319       (loop
    2320         (let* ((more 0)
    2321                (idx (io-buffer-idx inbuf))
    2322                (count (io-buffer-count inbuf)))
    2323           (declare (fixnum idx count more filled-buf))
    2324           (if (= idx count)
    2325             (if eof
    2326               (return (values string t))
    2327               (progn
    2328                 (setq eof t)
    2329                 (incf filled-buf)
    2330                 (%ioblock-advance ioblock t)))
    2331             (progn
    2332               (setq eof nil)
    2333               (let* ((pos (position newline buf :start idx :end count)))
    2334                 (when pos
    2335                   (locally (declare (fixnum pos))
    2336                     (setf (io-buffer-idx inbuf) (the fixnum (1+ pos)))
    2337                     (setq more (- pos idx))
    2338                     (unless (zerop more)
    2339                       (setq string
    2340                             (%extend-vector
    2341                              0 string (the fixnum (+ len more)))))
    2342                     (%copy-u8-to-string
    2343                      buf idx string len more)
    2344                     (return (values string nil))))
    2345                 ;; No #\newline in the buffer.  Read everything that's
    2346                 ;; there into the string, and fill the buffer again.
    2347                 (setf (io-buffer-idx inbuf) count)
    2348                 (setq more (- count idx)
    2349                       string (%extend-vector
    2350                               0 string (the fixnum (+ len more))))
    2351                 (%copy-u8-to-string
    2352                  buf idx string len more)
    2353                 (incf len more))
    2354               (when (> filled-buf 1)
    2355                 (let* ((pos len))
    2356                   (loop
    2357                     (%ioblock-advance ioblock t)
    2358                     (setq count (io-buffer-count inbuf))
    2359                     (when (zerop count)                       
    2360                       (return-from %ioblock-unencoded-read-line
    2361                         (values (if (= pos len)
    2362                                   string
    2363                                   (subseq string 0 pos))
    2364                                 t)))
    2365                     (let* ((p (position newline buf :end count))
    2366                            (n (or p count))
    2367                            (room (- len pos)))
    2368                       (declare (fixnum n room))
    2369                       (when (< room n)
    2370                         (setq len (+ len (the fixnum (or p len)))
    2371                               string (%extend-vector 0 string len)))
    2372                       (%copy-u8-to-string buf 0 string pos n)
    2373                       (incf pos n)
    2374                       (when p
    2375                         (return-from %ioblock-unencoded-read-line
    2376                           (values (if (= pos len)
    2377                                     string
    2378                                     (subseq string 0 pos)) nil)))
    2379                       (setf (io-buffer-idx inbuf) count))))))))))))
     2331              (octet-vectors (make-array 1 :element-type '(unsigned-byte 8)
     2332                                         :initial-element (char-code ch)))
     2333              (setq len 1)))))
     2334      (do* ((done nil)
     2335            (idx (io-buffer-idx inbuf))
     2336            (count (io-buffer-count inbuf)))
     2337           (done (let* ((string (make-string len))
     2338                        (outpos 0))
     2339                   (declare (simple-string string) (fixnum outpos))
     2340                   (dolist (v (octet-vectors) (values string (eq done :eof)))
     2341                     (let* ((vlen (length v)))
     2342                       (declare (fixnum vlen))
     2343                       (%copy-u8-to-string v 0 string outpos vlen)
     2344                       (incf outpos vlen)))))
     2345        (declare (fixnum idx count))
     2346        (when (= idx count)
     2347          (%ioblock-advance ioblock t)
     2348          (setq idx (io-buffer-idx inbuf)
     2349                count (io-buffer-count inbuf)
     2350                done (if (= idx count) :eof)))
     2351        (unless done
     2352          (let* ((p (do* ((i idx (1+ i)))
     2353                         ((= i count)
     2354                          (setf (io-buffer-idx inbuf) count)
     2355                          nil)
     2356                      (declare (fixnum i))
     2357                      (when (eql (aref buf i) (char-code #\newline))
     2358                        (setf (io-buffer-idx inbuf) (the fixnum (1+ i)))
     2359                        (setq done t)
     2360                        (return i))))
     2361                 (end (or p count))
     2362                 (n (- end idx)))
     2363            (declare (fixnum p end n))
     2364            (if (and p (eql len 0))
     2365              ;; Likely a fairly common case
     2366              (let* ((string (make-string n)))
     2367                (%copy-u8-to-string buf idx string 0 n)
     2368                (return-from %ioblock-unencoded-read-line
     2369                  (values string nil)))
     2370              (let* ((v (make-array n :element-type '(unsigned-byte 8))))
     2371                (%copy-ivector-to-ivector buf idx v 0 n)
     2372                (incf len n)
     2373                (octet-vectors v)
     2374                (setq idx count)))))))))
     2375
    23802376
    23812377;;; There are lots of ways of doing better here, but in the most general
     
    23832379;;; whether there's a 1:1 mapping between code units and characters.
    23842380(defun %ioblock-encoded-read-line (ioblock)
    2385   (let* ((pos 0)
    2386          (len 20)
    2387          (str (make-string len))
    2388          (rcf (ioblock-read-char-when-locked-function ioblock))
    2389          (eof nil))
    2390     (declare (fixnum pos len) (simple-string str))
    2391     (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
    2392          ((or (eq ch #\newline) (setq eof (eq ch :eof)))
    2393           (values (subseq str 0 pos) eof))
    2394       (when (= pos len)
    2395         (setq len (* len 2) str (%extend-vector 0 str len)))
    2396       (setf (schar str pos) ch
    2397             pos (1+ pos)))))
     2381  (declare (optimize (speed 3) (safety 0)))
     2382  (collect ((chunks))
     2383    (let* ((pos 0)
     2384           (len 0)
     2385           (chunksize 8192)
     2386           (str (make-string chunksize))
     2387           (rcf (ioblock-read-char-when-locked-function ioblock))
     2388           (eof nil))
     2389      (declare (fixnum pos len chunksize)
     2390               (simple-string str)
     2391               (dynamic-extent str))
     2392      (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
     2393           ((or (eq ch #\newline) (setq eof (eq ch :eof)))
     2394            (if (zerop len)
     2395              (values (subseq str 0 pos) eof)
     2396              (let* ((outpos 0))
     2397                (declare (fixnum outpos))
     2398                (setq len (+ len pos))
     2399                (let* ((out (make-string len)))
     2400                  (dolist (s (chunks))
     2401                    (%copy-ivector-to-ivector s 0 out outpos (the fixnum (ash chunksize 2)))
     2402                    (incf outpos (ash chunksize 2)))
     2403                  (%copy-ivector-to-ivector str 0 out outpos (the fixnum (ash pos 2)))
     2404                  (values out eof)))))
     2405        (when (= pos chunksize)
     2406          (chunks str)
     2407          (setq str (make-string chunksize)
     2408                len (+ len pos)
     2409                pos 0))
     2410        (setf (schar str pos) ch
     2411              pos (1+ pos))))))
    23982412         
    23992413(defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
Note: See TracChangeset for help on using the changeset viewer.