[flexi-streams-cvs] r33 - branches/edi
eweitz at common-lisp.net
eweitz at common-lisp.net
Mon May 19 22:59:14 UTC 2008
Author: eweitz
Date: Mon May 19 18:59:07 2008
New Revision: 33
Modified:
branches/edi/decode.lisp
branches/edi/encode.lisp
branches/edi/external-format.lisp
branches/edi/flexi-streams.asd
branches/edi/input.lisp
branches/edi/mapping.lisp
branches/edi/output.lisp
branches/edi/stream.lisp
branches/edi/strings.lisp
branches/edi/util.lisp
Log:
Better read-sequence implementation
Modified: branches/edi/decode.lisp
==============================================================================
--- branches/edi/decode.lisp (original)
+++ branches/edi/decode.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/decode.lisp,v 1.9 2008/05/19 07:57:07 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/decode.lisp,v 1.12 2008/05/19 22:32:56 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -52,24 +52,23 @@
(defgeneric octets-to-char-code (format reader)
(declare #.*standard-optimize-settings*)
(:documentation "Converts a sequence of octets to a character code
-\(which is returned) using the external format FORMAT. The sequence
-is obtained by calling the function \(which must be a functional
-object) READER with no arguments which should return one octet per
-call.
+\(which is returned, or NIL in case of EOF) using the external format
+FORMAT. The sequence is obtained by calling the function \(which must
+be a functional object) READER with no arguments which should return
+one octet per call. In the case of EOF, READER should return NIL.
-The special variables *CURRENT-STREAM* and *CURRENT-UNREADER* must be
-bound correctly whenever this function is called."))
+The special variable *CURRENT-UNREADER* must be bound correctly
+whenever this function is called."))
(defmethod octets-to-char-code ((format flexi-latin-1-format) reader)
(declare #.*standard-optimize-settings*)
(declare (function reader))
- (or (funcall reader) :eof))
+ (funcall reader))
(defmethod octets-to-char-code ((format flexi-ascii-format) reader)
(declare #.*standard-optimize-settings*)
(declare (function reader))
- (let ((octet (or (funcall reader)
- (return-from octets-to-char-code :eof))))
+ (when-let (octet (funcall reader))
(declare (type octet octet))
(if (> octet 127)
(recover-from-encoding-error format
@@ -81,15 +80,14 @@
(declare (function reader))
(with-accessors ((decoding-table external-format-decoding-table))
format
- (let* ((octet (or (funcall reader)
- (return-from octets-to-char-code :eof)))
- (char-code (aref (the (simple-array char-code-integer *) decoding-table) octet)))
+ (when-let (octet (funcall reader))
(declare (type octet octet))
- (if (or (null char-code)
- (= (the char-code-integer char-code) 65533))
- (recover-from-encoding-error format
- "No character which corresponds to octet #x~X." octet)
- char-code))))
+ (let ((char-code (aref (the (simple-array char-code-integer *) decoding-table) octet)))
+ (if (or (null char-code)
+ (= (the char-code-integer char-code) 65533))
+ (recover-from-encoding-error format
+ "No character which corresponds to octet #x~X." octet)
+ char-code)))))
(defmethod octets-to-char-code ((format flexi-utf-8-format) reader)
(declare #.*standard-optimize-settings*)
@@ -103,7 +101,7 @@
(return-from octets-to-char-code
(recover-from-encoding-error format
"End of data while in UTF-8 sequence.")))
- (t (return-from octets-to-char-code :eof))))
+ (t (return-from octets-to-char-code nil))))
(setq first-octet-seen t))))
(let ((octet (read-next-byte)))
(declare (type octet octet))
@@ -150,11 +148,12 @@
(return-from octets-to-char-code
(recover-from-encoding-error format
"End of data while in UTF-16 sequence.")))
- (t (return-from octets-to-char-code :eof))))
+ (t (return-from octets-to-char-code nil))))
(setq first-octet-seen t))))
(flet ((read-next-word ()
(+ (the octet (read-next-byte))
(ash (the octet (read-next-byte)) 8))))
+ (declare (inline read-next-word))
(let ((word (read-next-word)))
(declare (type (unsigned-byte 16) word))
(cond ((<= #xd800 word #xdfff)
@@ -182,11 +181,12 @@
(return-from octets-to-char-code
(recover-from-encoding-error format
"End of data while in UTF-16 sequence.")))
- (t (return-from octets-to-char-code :eof))))
+ (t (return-from octets-to-char-code nil))))
(setq first-octet-seen t))))
(flet ((read-next-word ()
(+ (ash (the octet (read-next-byte)) 8)
(the octet (read-next-byte)))))
+ (declare (inline read-next-word))
(let ((word (read-next-word)))
(declare (type (unsigned-byte 16) word))
(cond ((<= #xd800 word #xdfff)
@@ -214,7 +214,7 @@
(return-from octets-to-char-code
(recover-from-encoding-error format
"End of data while in UTF-32 sequence.")))
- (t (return-from octets-to-char-code :eof))))
+ (t (return-from octets-to-char-code nil))))
(setq first-octet-seen t))))
(loop for count of-type fixnum from 0 to 24 by 8
for octet of-type octet = (read-next-byte)
@@ -232,7 +232,7 @@
(return-from octets-to-char-code
(recover-from-encoding-error format
"End of data while in UTF-32 sequence.")))
- (t (return-from octets-to-char-code :eof))))
+ (t (return-from octets-to-char-code nil))))
(setq first-octet-seen t))))
(loop for count of-type fixnum from 24 downto 0 by 8
for octet of-type octet = (read-next-byte)
@@ -243,7 +243,6 @@
(let ((char-code (call-next-method)))
(case char-code
(#.(char-code #\Return) #.(char-code #\Newline))
- (:eof :eof)
(otherwise char-code))))
(defmethod octets-to-char-code ((format flexi-crlf-mixin) reader)
@@ -255,11 +254,12 @@
(let ((next-char-code (call-next-method)))
(case next-char-code
(#.(char-code #\Linefeed) #.(char-code #\Newline))
- (:eof char-code)
+ ;; we saw a CR but no LF afterwards, but then the data
+ ;; ended, so we just return #\Return
+ ((nil) #.(char-code #\Return))
;; if the character we peeked at wasn't a
;; linefeed character we unread its constituents
(otherwise (funcall *current-unreader* (code-char next-char-code))
char-code))))
- (:eof :eof)
- (t char-code))))
+ (otherwise char-code))))
Modified: branches/edi/encode.lisp
==============================================================================
--- branches/edi/encode.lisp (original)
+++ branches/edi/encode.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/encode.lisp,v 1.8 2008/05/19 07:57:07 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/encode.lisp,v 1.10 2008/05/19 22:32:56 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -35,10 +35,7 @@
using the external format FORMAT. The conversion is performed by
calling the unary function \(which must be a functional object) WRITER
repeatedly each octet. The return value of this function is
-unspecified.
-
-The special variable *CURRENT-STREAM* must be bound correctly whenever
-this function is called."))
+unspecified."))
(defmethod char-to-octets ((format flexi-latin-1-format) char writer)
(declare #.*standard-optimize-settings*)
@@ -104,6 +101,7 @@
(flet ((write-word (word)
(funcall writer (ldb (byte 8 0) word))
(funcall writer (ldb (byte 8 8) word))))
+ (declare (inline read-next-word))
(let ((char-code (char-code char)))
(declare (type char-code-integer char-code))
(cond ((< char-code #x10000)
@@ -118,6 +116,7 @@
(flet ((write-word (word)
(funcall writer (ldb (byte 8 8) word))
(funcall writer (ldb (byte 8 0) word))))
+ (declare (inline read-next-word))
(let ((char-code (char-code char)))
(declare (type char-code-integer char-code))
(cond ((< char-code #x10000)
Modified: branches/edi/external-format.lisp
==============================================================================
--- branches/edi/external-format.lisp (original)
+++ branches/edi/external-format.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/external-format.lisp,v 1.18 2008/05/18 15:54:34 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/external-format.lisp,v 1.19 2008/05/19 11:20:11 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -390,8 +390,8 @@
(:documentation "Given an external format FORMAT, returns a factor
which denotes the octets to characters ratio to expect when
encoding/decoding. If the returned value is an integer, the factor is
-assumed to be exact. If it is a float, the factor is supposed to be
-based on heuristics and usually not exact.
+assumed to be exact. If it is a \(double) float, the factor is
+supposed to be based on heuristics and usually not exact.
This factor is used in string.lisp.")
(declare #.*standard-optimize-settings*))
@@ -407,7 +407,7 @@
;; UTF-8 characters can be anything from one to six octets, but we
;; assume that the "overhead" is only about 5 percent - this
;; estimate is obviously very much dependant on the content
- 1.05)
+ 1.05d0)
(defmethod encoding-factor ((format flexi-utf-16-format))
(declare #.*standard-optimize-settings*)
@@ -415,7 +415,7 @@
;; code points above #x10000 map to four octets - we assume that we
;; usually don't see these characters but of course have to return a
;; float
- 2.0)
+ 2.0d0)
(defmethod encoding-factor ((format flexi-utf-32-format))
(declare #.*standard-optimize-settings*)
@@ -427,4 +427,4 @@
;; if the sequence #\Return #\Linefeed is the line-end marker, this
;; obviously makes encodings potentially longer and definitely makes
;; the estimate unexact
- (* 1.02 (call-next-method)))
\ No newline at end of file
+ (* 1.02d0 (call-next-method)))
Modified: branches/edi/flexi-streams.asd
==============================================================================
--- branches/edi/flexi-streams.asd (original)
+++ branches/edi/flexi-streams.asd Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/flexi-streams.asd,v 1.62 2008/05/18 20:34:52 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/flexi-streams.asd,v 1.63 2008/05/18 23:13:59 edi Exp $
;;; Copyright (c) 2005-2007, Dr. Edmund Weitz. All rights reserved.
@@ -39,8 +39,8 @@
:serial t
:components ((:file "packages")
(:file "mapping")
- (:file "ascii")
- (:file "koi8-r")
+ (:file "ascii")
+ (:file "koi8-r")
(:file "iso-8859")
(:file "code-pages")
(:file "specials")
Modified: branches/edi/input.lisp
==============================================================================
--- branches/edi/input.lisp (original)
+++ branches/edi/input.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/input.lisp,v 1.60 2008/05/19 07:57:07 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/input.lisp,v 1.65 2008/05/19 22:54:10 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -34,7 +34,7 @@
"Reads one byte \(octet) from the underlying stream of
FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not
empty)."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; we're using S instead of STREAM here because of an
;; issue with SBCL:
;; <http://article.gmane.org/gmane.lisp.steel-bank.general/1386>
@@ -58,7 +58,7 @@
"Reads one byte \(octet) from the underlying stream of
FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not
empty)."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((position flexi-stream-position)
(bound flexi-stream-bound)
(octet-stack flexi-stream-octet-stack)
@@ -85,7 +85,7 @@
FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not empty).
Optimized version \(only needed for LispWorks) in case the underlying
stream is binary."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((position flexi-stream-position)
(bound flexi-stream-bound)
(octet-stack flexi-stream-octet-stack)
@@ -104,7 +104,7 @@
(defmethod stream-clear-input ((flexi-input-stream flexi-input-stream))
"Calls the corresponding method for the underlying input stream
and also clears the value of the OCTET-STACK slot."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; note that we don't reset the POSITION slot
(with-accessors ((octet-stack flexi-stream-octet-stack)
(stream flexi-stream-stream))
@@ -116,12 +116,14 @@
"Calls the corresponding method for the underlying input stream
but first checks if \(old) input is available in the OCTET-STACK
slot."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((position flexi-stream-position)
(bound flexi-stream-bound)
(octet-stack flexi-stream-octet-stack)
(stream flexi-stream-stream))
flexi-input-stream
+ (declare (integer position)
+ (type (or null integer) bound))
(when (and bound
(>= position bound))
(return-from stream-listen nil))
@@ -129,7 +131,7 @@
(defmethod stream-read-byte ((stream flexi-input-stream))
"Reads one byte \(octet) from the underlying stream."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; set LAST-CHAR-CODE slot to NIL because we can't UNREAD-CHAR after
;; this operation
(with-accessors ((last-char-code flexi-stream-last-char-code)
@@ -144,6 +146,7 @@
"Used internally to put a character CHAR which was already read back
on the stream. Uses the OCTET-STACK slot and decrements the POSITION
slot accordingly."
+ (declare #.*standard-optimize-settings*)
(with-accessors ((position flexi-stream-position)
(octet-stack flexi-stream-octet-stack)
(external-format flexi-stream-external-format))
@@ -151,16 +154,16 @@
(let ((counter 0) octets-reversed)
(declare (integer position)
(fixnum counter))
- (char-to-octets external-format
- char
- (lambda (octet)
- (incf counter)
- (push octet octets-reversed)))
- (decf position counter)
- (setq octet-stack (nreconc octets-reversed octet-stack)))))
+ (flet ((writer (octet)
+ (incf counter)
+ (push octet octets-reversed)))
+ (declare (dynamic-extent (function writer)))
+ (char-to-octets external-format char #'writer)
+ (decf position counter)
+ (setq octet-stack (nreconc octets-reversed octet-stack))))))
(defmethod stream-read-char ((stream flexi-input-stream))
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; note that we do nothing for the :LF EOL style because we assume
;; that #\Newline is the same as #\Linefeed in all Lisps which will
;; use this library
@@ -171,67 +174,148 @@
;; set LAST-OCTET slot to NIL because we can't UNREAD-BYTE after
;; this operation
(setq last-octet nil)
- (let* ((*current-unreader* (lambda (char)
- (unread-char% char stream)))
- (char-code (octets-to-char-code external-format
- (lambda ()
- (read-byte* stream)))))
- ;; remember this character and its char code for UNREAD-CHAR
- (setq last-char-code char-code)
- (or (code-char char-code) char-code))))
+ (flet ((reader ()
+ (read-byte* stream))
+ (unreader (char)
+ (unread-char% char stream)))
+ (declare (dynamic-extent (function reader) (function unreader)))
+ (let* ((*current-unreader* #'unreader)
+ (char-code (or (octets-to-char-code external-format #'reader)
+ (return-from stream-read-char :eof))))
+ ;; remember this character and its char code for UNREAD-CHAR
+ (setq last-char-code char-code)
+ (or (code-char char-code) char-code)))))
(defmethod stream-read-char-no-hang ((stream flexi-input-stream))
"Reads one character if the underlying stream has at least one
octet available."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; note that this may block for non-8-bit encodings - I think
;; there's no easy way to handle this correctly
(and (stream-listen stream)
(stream-read-char stream)))
(defmethod stream-read-sequence ((flexi-input-stream flexi-input-stream) sequence start end &key)
- "Reads enough input from STREAM to fill SEQUENCE from START to END.
-If SEQUENCE is an array which can store octets we use READ-SEQUENCE to
-fill it in one fell swoop, otherwise we iterate using
-STREAM-READ-CHAR."
- (declare (optimize speed)
- (type (integer 0 *) start end))
- (with-accessors ((last-char-code flexi-stream-last-char-code)
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (with-accessors ((position flexi-stream-position)
+ (bound flexi-stream-bound)
+ (octet-stack flexi-stream-octet-stack)
+ (external-format flexi-stream-external-format)
(last-octet flexi-stream-last-octet)
- (stream flexi-stream-stream)
- (position flexi-stream-position)
- (octet-stack flexi-stream-octet-stack))
+ (last-char-code flexi-stream-last-char-code)
+ (element-type flexi-stream-element-type)
+ (stream flexi-stream-stream))
flexi-input-stream
- (declare (integer position))
- (cond ((and (arrayp sequence)
- (subtypep 'octet (array-element-type sequence)))
- (setf last-char-code nil)
- (let ((cursor start))
- (loop with stack = octet-stack
- for continuep = (< cursor end)
- for octet = (and continuep (pop stack))
- while octet
- do (setf (aref sequence cursor) (the octet octet))
- (incf cursor))
- (let ((index
- (read-sequence sequence stream :start cursor :end end)))
- (incf position (- index start))
- (when (> index start)
- (setq last-octet (aref sequence (1- index))))
- index)))
- (t
- (loop for index from start below end
- for element = (stream-read-char flexi-input-stream)
- until (eq element :eof)
- do (setf (elt sequence index) element)
- finally (return index))))))
+ (let ((buffer (make-octet-buffer))
+ (buffer-pos 0)
+ (buffer-end 0)
+ (index start))
+ (declare (fixnum buffer-pos buffer-end index)
+ (type (array octet *) buffer))
+ (flet ((compute-minimum ()
+ "Computes the minimum amount of octets we can savely
+read into the buffer without violating the stream's bound \(if there
+is one) and without potentially reading more than we need."
+ ;; this has to be done conservatively, unfortunately -
+ ;; it is possible that we only fill the buffer in very
+ ;; small chunks once we're near END (but this is only
+ ;; relevant for multi-byte encodings, of course)
+ (let ((minimum (min (the fixnum (- end index)) +buffer-size+)))
+ (cond (bound (min minimum (- bound position)))
+ (t minimum))))
+ (fill-buffer (end)
+ "Tries to fill the buffer from BUFFER-POS to END and
+returns NIL if the buffer doesn't contain any new data."
+ (setq buffer-end (read-sequence buffer stream
+ :start buffer-pos
+ :end end))
+ ;; BUFFER-POS is only greater than zero if the buffer
+ ;; already contains unread data from the octet stack
+ ;; (see below), so we test for ZEROP here and do /not/
+ ;; compare with BUFFER-POS
+ (unless (zerop buffer-end)
+ (incf position buffer-end))))
+ (let ((minimum (compute-minimum)))
+ (declare (fixnum minimum))
+ ;; put data from octet stack into buffer if there is any
+ (loop
+ (when (>= buffer-pos minimum)
+ (return))
+ (let ((next-octet (pop octet-stack)))
+ (cond (next-octet
+ (setf (aref buffer buffer-pos) (the octet next-octet))
+ (incf buffer-pos))
+ (t (return)))))
+ ;; fill buffer for the first time or return immediately if
+ ;; we don't succeed
+ (unless (fill-buffer minimum)
+ (return-from stream-read-sequence start)))
+ (setq buffer-pos 0)
+ (flet ((next-octet ()
+ "Returns the next octet from the buffer and fills it
+if it is exhausted. Returns NIL if there's no more data on the
+stream."
+ (when (>= buffer-pos buffer-end)
+ (setq buffer-pos 0)
+ (unless (fill-buffer (compute-minimum))
+ (return-from next-octet)))
+ (prog1
+ (aref buffer buffer-pos)
+ (incf buffer-pos)))
+ (unreader (char)
+ (unread-char% char flexi-input-stream)))
+ (declare (dynamic-extent (function next-octet) (function unreader)))
+ (let ((*current-unreader* #'unreader))
+ (macrolet ((iterate (octetp set-place)
+ "A very unhygienic macro to implement the
+actual iteration through the sequence including housekeeping for the
+flexi stream. If OCTETP is true, we put octets into the stream,
+otherwise characters. SET-PLACE is the place \(using the index INDEX)
+used to access the sequence."
+ `(flet ((leave ()
+ "This is the function used to abort
+the LOOP iteration below."
+ (when (> index start)
+ ;; if something was read at all,
+ ;; update LAST-OCTET and
+ ;; LAST-CHAR-CODE accordingly
+ (setq ,(if octetp 'last-char-code 'last-octet)
+ nil
+ ,(if octetp 'last-octet 'last-char-code)
+ ,(sublis '((index . (1- index))) set-place)))
+ (return-from stream-read-sequence index)))
+ (loop
+ (when (>= index end) (leave))
+ (let ((next-thing ,(if octetp
+ '(next-octet)
+ '(octets-to-char-code external-format #'next-octet))))
+ (unless next-thing (leave))
+ (setf ,set-place ,(if octetp 'next-thing '(code-char next-thing)))
+ (incf index))))))
+ (etypecase sequence
+ (string (iterate nil (char sequence index)))
+ (array
+ (let ((array-element-type (array-element-type sequence)))
+ (cond ((type-equal array-element-type 'octet)
+ (iterate t (aref (the (array octet *) sequence) index)))
+ ((or (subtypep array-element-type 'integer)
+ (type-equal element-type 'octet))
+ (iterate t (aref sequence index)))
+ (t
+ (iterate nil (aref sequence index))))))
+ (list
+ (cond ((type-equal element-type 'octet)
+ (iterate t (nth index sequence)))
+ (t
+ (iterate nil (nth index sequence)))))))))))))
(defmethod stream-unread-char ((stream flexi-input-stream) char)
"Implements UNREAD-CHAR for streams of type FLEXI-INPUT-STREAM.
Makes sure CHAR will only be unread if it was the last character
read and if it was read with the same encoding that's currently
being used by the stream."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((last-char-code flexi-stream-last-char-code))
stream
(unless last-char-code
@@ -249,7 +333,7 @@
"Similar to UNREAD-CHAR in that it `unreads' the last octet from
STREAM. Note that you can only call UNREAD-BYTE after a corresponding
READ-BYTE."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((last-octet flexi-stream-last-octet)
(octet-stack flexi-stream-octet-stack)
(position flexi-stream-position))
@@ -274,7 +358,7 @@
not 0 is returned, if PEEK-TYPE is an octet, the next octet which
equals PEEK-TYPE is returned. EOF-ERROR-P and EOF-VALUE are
interpreted as usual."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(loop for octet = (read-byte flexi-input-stream eof-error-p eof-value)
until (cond ((null peek-type))
((eql octet eof-value))
Modified: branches/edi/mapping.lisp
==============================================================================
--- branches/edi/mapping.lisp (original)
+++ branches/edi/mapping.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/util.lisp,v 1.15 2008/05/18 15:54:34 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/mapping.lisp,v 1.1 2008/05/19 09:09:15 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
Modified: branches/edi/output.lisp
==============================================================================
--- branches/edi/output.lisp (original)
+++ branches/edi/output.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/output.lisp,v 1.50 2008/05/19 07:57:07 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/output.lisp,v 1.52 2008/05/19 22:32:56 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -36,14 +36,14 @@
#-:lispworks
(defmethod write-byte* (byte (sink flexi-output-stream))
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((stream flexi-stream-stream))
sink
(write-byte byte stream)))
#+:lispworks
(defmethod write-byte* (byte (sink flexi-output-stream))
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; we use WRITE-SEQUENCE because WRITE-BYTE doesn't work with all
;; bivalent streams in LispWorks (4.4.6)
(with-accessors ((stream flexi-stream-stream))
@@ -57,22 +57,22 @@
(defmethod write-byte* (byte (sink flexi-binary-output-stream))
"Optimized version \(only needed for LispWorks) in case the
underlying stream is binary."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((stream flexi-stream-stream))
sink
(write-byte byte stream)))
(defmethod stream-write-char ((stream flexi-output-stream) char)
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((external-format flexi-stream-external-format))
stream
- (char-to-octets external-format
- char
- (lambda (octet)
- (write-byte* octet stream)))))
+ (flet ((writer (octet)
+ (write-byte* octet stream)))
+ (declare (dynamic-extent (function writer)))
+ (char-to-octets external-format char #'writer))))
(defmethod stream-write-char :after ((stream flexi-output-stream) char)
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; update the column unless we're in the middle of the line and
;; the current value is NIL
(with-accessors ((column flexi-stream-column))
@@ -83,7 +83,7 @@
(defmethod stream-clear-output ((flexi-output-stream flexi-output-stream))
"Simply calls the corresponding method for the underlying
output stream."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((stream flexi-stream-stream))
flexi-output-stream
(clear-output stream)))
@@ -91,7 +91,7 @@
(defmethod stream-finish-output ((flexi-output-stream flexi-output-stream))
"Simply calls the corresponding method for the underlying
output stream."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((stream flexi-stream-stream))
flexi-output-stream
(finish-output stream)))
@@ -99,7 +99,7 @@
(defmethod stream-force-output ((flexi-output-stream flexi-output-stream))
"Simply calls the corresponding method for the underlying
output stream."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((stream flexi-stream-stream))
flexi-output-stream
(force-output stream)))
@@ -107,14 +107,14 @@
(defmethod stream-line-column ((flexi-output-stream flexi-output-stream))
"Returns the column stored in the COLUMN slot of the
FLEXI-OUTPUT-STREAM object STREAM."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((column flexi-stream-column))
flexi-output-stream
column))
(defmethod stream-write-byte ((flexi-output-stream flexi-output-stream) byte)
"Writes a byte \(octet) to the underlying stream."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
(with-accessors ((column flexi-stream-column))
flexi-output-stream
;; set column to NIL because we don't know how to handle binary
@@ -125,7 +125,7 @@
#+:allegro
(defmethod stream-terpri ((stream flexi-output-stream))
"Writes a #\Newline character to the underlying stream."
- (declare (optimize speed))
+ (declare #.*standard-optimize-settings*)
;; needed for AllegroCL - grrr...
(stream-write-char stream #\Newline))
@@ -135,8 +135,8 @@
characters. Characters are output according to the current
encoding \(external format) of the FLEXI-OUTPUT-STREAM object
STREAM."
- (declare (optimize speed)
- (type (integer 0 *) start end))
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
(with-accessors ((stream flexi-stream-stream)
(column flexi-stream-column))
flexi-output-stream
@@ -158,8 +158,8 @@
"Optimized method for the cases where SEQUENCE is a string. Fills
an internal buffer and uses repeated calls to WRITE-SEQUENCE to write
to the underlying stream."
- (declare (optimize speed)
- (type (integer 0 *) start end))
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
;; don't use this optimized method for bivalent character streams on
;; LispWorks, as it currently gets confused by the fill pointer
#+:lispworks
@@ -194,4 +194,5 @@
(defmethod stream-write-string ((stream flexi-output-stream) string
&optional (start 0) (end (length string)))
"Simply hands over to the optimized method for STREAM-WRITE-SEQUENCE."
+ (declare #.*standard-optimize-settings*)
(stream-write-sequence stream string start (or end (length string))))
Modified: branches/edi/stream.lisp
==============================================================================
--- branches/edi/stream.lisp (original)
+++ branches/edi/stream.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/stream.lisp,v 1.60 2008/05/18 23:14:00 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/stream.lisp,v 1.61 2008/05/19 22:32:56 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -74,7 +74,7 @@
"Checks whether the new value makes sense before it is set."
(declare #.*standard-optimize-settings*)
(unless (or (subtypep new-value 'character)
- (subtypep new-value 'octet))
+ (type-equal new-value 'octet))
(error 'flexi-stream-element-type-error
:element-type new-value
:stream flexi-stream)))
Modified: branches/edi/strings.lisp
==============================================================================
--- branches/edi/strings.lisp (original)
+++ branches/edi/strings.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/strings.lisp,v 1.14 2008/05/19 07:57:08 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/strings.lisp,v 1.19 2008/05/19 22:32:56 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -39,32 +39,52 @@
(setq external-format (maybe-convert-external-format external-format))
(let ((factor (encoding-factor external-format))
(length (- end start)))
+ (declare (fixnum length))
(etypecase factor
- (float
- (let ((octets (make-array (round (* factor length))
- :element-type 'octet
- :fill-pointer 0
- :adjustable t)))
- (flet ((writer (octet)
- ;; TODO: do this manually
- (vector-push-extend octet octets)))
- (loop for i of-type fixnum from start below end
- do (char-to-octets external-format
- (char string i)
- #'writer)))
- octets))
(integer
(let ((octets (make-array (* factor length) :element-type 'octet))
(j 0))
(declare (fixnum j))
(flet ((writer (octet)
+ (declare (octet octet))
(setf (aref (the (array octet *) octets) j) octet)
(incf j)))
+ (declare (dynamic-extent (function writer)))
(loop for i of-type fixnum from start below end do
(char-to-octets external-format
(char string i)
#'writer)))
- octets)))))
+ octets))
+ (double-float
+ ;; this is a bit clunky but hopefully a bit more efficient than
+ ;; using VECTOR-PUSH-EXTEND
+ (let* ((octets-length (ceiling (* factor length)))
+ (octets (make-array octets-length
+ :element-type 'octet
+ :fill-pointer t
+ :adjustable t))
+ (i start)
+ (j 0))
+ (declare (fixnum i j octets-length)
+ (double-float factor))
+ (flet ((writer (octet)
+ (declare (octet octet))
+ (when (>= j octets-length)
+ (setq factor (* factor 2.0d0))
+ (incf octets-length (the fixnum (ceiling (* factor (- end i)))))
+ (adjust-array octets octets-length :fill-pointer t))
+ (setf (aref (the (array octet *) octets) j) octet)
+ (incf j)))
+ (declare (dynamic-extent (function writer)))
+ (loop
+ (when (>= i end)
+ (return))
+ (char-to-octets external-format
+ (char string i)
+ #'writer)
+ (incf i))
+ (setf (fill-pointer octets) j)
+ octets))))))
(defun octets-to-string (sequence &key
(external-format (make-external-format :latin1))
@@ -80,51 +100,61 @@
(reader (etypecase sequence
((array octet *)
(lambda ()
- (when (>= i end)
- ;; TODO... -> NIL?
- (error "End of data."))
- (prog1
- (aref (the (array octet *) sequence) i)
- (incf i))))
+ (and (< i end)
+ (prog1
+ (aref (the (array octet *) sequence) i)
+ (incf i)))))
((array * *)
(lambda ()
- (when (>= i end)
- ;; TODO...
- (error "End of data."))
- (prog1
- (aref sequence i)
- (incf i))))
+ (and (< i end)
+ (prog1
+ (aref sequence i)
+ (incf i)))))
(list
(lambda ()
- (when (>= i end)
- ;; TODO...
- (error "End of data."))
- (prog1
- (nth i sequence)
- (incf i))))))
- (*current-unreader* (flet ((pseudo-writer (octet)
- (declare (ignore octet))
- (decf i)))
- (lambda (char)
- (char-to-octets external-format char #'pseudo-writer)))))
- (declare (fixnum i))
- (flet ((next-char ()
- (code-char (octets-to-char-code external-format reader))))
- (etypecase factor
- (float
- (let ((string (make-array (round (/ length factor))
- :element-type 'char*
- :fill-pointer 0
- :adjustable t)))
- (loop while (< i end)
- ;; TODO: do this manually
- do (vector-push-extend (next-char) string)
- finally (return string))))
- (integer
- (let* ((string-length (/ length factor))
- (string (make-array string-length
- :element-type 'char*)))
- (declare (fixnum string-length))
- (loop for j of-type fixnum from 0 below string-length
- do (setf (schar string j) (next-char))
- finally (return string))))))))
+ (and (< i end)
+ (prog1
+ (nth i sequence)
+ (incf i))))))))
+ (declare (fixnum i length) (dynamic-extent reader))
+ (labels ((pseudo-writer (octet)
+ (declare (ignore octet))
+ (decf i))
+ (unreader (char)
+ (char-to-octets external-format char #'pseudo-writer)))
+ (declare (dynamic-extent (function pseudo-writer) (function unreader)))
+ (let ((*current-unreader* #'unreader))
+ (flet ((next-char ()
+ (code-char (octets-to-char-code external-format reader))))
+ (declare (inline next-char))
+ (etypecase factor
+ (integer
+ (let* ((string-length (/ length factor))
+ (string (make-array string-length
+ :element-type 'char*)))
+ (declare (fixnum string-length))
+ (loop for j of-type fixnum from 0 below string-length
+ do (setf (schar string j) (next-char))
+ finally (return string))))
+ (double-float
+ ;; this is a bit clunky but hopefully a bit more efficient than
+ ;; using VECTOR-PUSH-EXTEND
+ (let* ((string-length (ceiling length (the double-float factor)))
+ (string (make-array string-length
+ :element-type 'char*
+ :fill-pointer t
+ :adjustable t))
+ (j 0))
+ (declare (fixnum j string-length)
+ (double-float factor))
+ (loop
+ (when (>= i end)
+ (return))
+ (when (>= j string-length)
+ (setq factor (/ factor 2.0d0))
+ (incf string-length (the fixnum (ceiling (- end i) factor)))
+ (adjust-array string string-length :fill-pointer t))
+ (setf (char string j) (next-char))
+ (incf j))
+ (setf (fill-pointer string) j)
+ string))))))))
Modified: branches/edi/util.lisp
==============================================================================
--- branches/edi/util.lisp (original)
+++ branches/edi/util.lisp Mon May 19 18:59:07 2008
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/flexi-streams/util.lisp,v 1.17 2008/05/19 07:57:08 edi Exp $
+;;; $Header: /usr/local/cvsrep/flexi-streams/util.lisp,v 1.19 2008/05/19 22:32:57 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -31,7 +31,14 @@
#+:lispworks
(eval-when (:compile-toplevel :load-toplevel :execute)
- (import 'lw:with-unique-names))
+ (import '(lw:with-unique-names lw:when-let)))
+
+#-:lispworks
+(defmacro when-let ((var form) &body body)
+ "Evaluates FORM and binds VAR to the result, then executes BODY
+if VAR has a true value."
+ `(let ((,var ,form))
+ (when ,var , at body)))
#-:lispworks
(defmacro with-unique-names ((&rest bindings) &body body)
@@ -167,4 +174,14 @@
;; slots
`(with-slots ,(mapcar #'car slot-entries)
,instance
- , at body))
\ No newline at end of file
+ , at body))
+
+(defun make-octet-buffer ()
+ "Creates and returns a fresh buffer \(a specialized array) of size
++BUFFER-SIZE+ to hold octets."
+ (make-array +buffer-size+ :element-type 'octet))
+
+(defun type-equal (type1 type2)
+ "Whether TYPE1 and TYPE2 denote the same type."
+ (and (subtypep type1 type2)
+ (subtypep type2 type1)))
\ No newline at end of file
More information about the Flexi-streams-cvs
mailing list