Changeset 15175 for trunk/source/level-1
- Timestamp:
- Jan 24, 2012, 2:22:19 PM (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-1/l1-streams.lisp
r15165 r15175 100 100 ;;; For input streams: 101 101 102 ;; From Shannon Spires, slightly modified.102 ;;; From Shannon Spires, slightly modified. 103 103 (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 117 133 118 134 (defun generic-character-read-list (stream list count) … … 2298 2314 (io-buffer-idx buf) 0))) 2299 2315 2316 2300 2317 (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)) 2303 2321 (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)) 2309 2324 (let* ((ch (ioblock-untyi-char ioblock))) 2310 2325 (when ch … … 2312 2327 (if (eql ch #\newline) 2313 2328 (return-from %ioblock-unencoded-read-line 2314 (values stringnil))2329 (values "" nil)) 2315 2330 (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 2380 2376 2381 2377 ;;; There are lots of ways of doing better here, but in the most general … … 2383 2379 ;;; whether there's a 1:1 mapping between code units and characters. 2384 2380 (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)))))) 2398 2412 2399 2413 (defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
Note: See TracChangeset
for help on using the changeset viewer.