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 ,@body)))
#-:lispworks (defmacro with-unique-names ((&rest bindings) &body body) @@ -167,4 +174,14 @@ ;; slots `(with-slots ,(mapcar #'car slot-entries) ,instance - ,@body)) \ No newline at end of file + ,@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