Author: eweitz Date: Tue May 20 21:18:58 2008 New Revision: 41
Modified: branches/edi/CHANGELOG branches/edi/doc/index.html branches/edi/output.lisp Log: write-sequence
Modified: branches/edi/CHANGELOG ============================================================================== --- branches/edi/CHANGELOG (original) +++ branches/edi/CHANGELOG Tue May 20 21:18:58 2008 @@ -1,3 +1,5 @@ +Complete redesign, various additions, bugfixes, performance improvements (with the help of Hans H�bner) + Version 0.14.0 2007-12-30 Some fixes for LispWorks (when the underlying stream is a character stream)
Modified: branches/edi/doc/index.html ============================================================================== --- branches/edi/doc/index.html (original) +++ branches/edi/doc/index.html Tue May 20 21:18:58 2008 @@ -1037,10 +1037,12 @@
Thanks to David Lichteblau for numerous portability patches. Thanks to Igor Plekhov for the KOI8-R code. Thanks to Anton Vodonosov for -numerous patches and additions. +numerous patches and additions. Thanks +to <a href="http://netzhansa.blogspot.com/">Hans Hübner</a> for +his work on making FLEXI-STREAMS faster.
<p> -$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.105 2008/05/20 23:44:47 edi Exp $ +$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.106 2008/05/21 01:06:45 edi Exp $ <p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
</body>
Modified: branches/edi/output.lisp ============================================================================== --- branches/edi/output.lisp (original) +++ branches/edi/output.lisp Tue May 20 21:18:58 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.57 2008/05/21 00:04:58 edi Exp $ +;;; $Header: /usr/local/cvsrep/flexi-streams/output.lisp,v 1.59 2008/05/21 01:17:45 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
@@ -129,66 +129,71 @@ ;; needed for AllegroCL - grrr... (stream-write-char stream #\Newline))
-(defmethod stream-write-sequence ((flexi-output-stream flexi-output-stream) sequence start end &key) - "Writes all elements of the sequence SEQUENCE from START to END -to the underlying stream. The elements can be either octets or -characters. Characters are output according to the current -encoding (external format) of the FLEXI-OUTPUT-STREAM object -STREAM." - (declare #.*standard-optimize-settings*) +(defmethod stream-write-sequence ((stream flexi-output-stream) sequence start end &key) +; (declare #.*standard-optimize-settings*) (declare (fixnum start end)) - (with-accessors ((stream flexi-stream-stream) - (column flexi-stream-column)) - flexi-output-stream - (cond ((and (arrayp sequence) - (subtypep (array-element-type sequence) 'octet)) - ;; set column to NIL because we don't know how to handle binary - ;; output mixed with character output - (setq column nil) - (write-sequence sequence stream :start start :end end)) - (t (loop for index from start below end - for element = (elt sequence index) - when (characterp element) do - (stream-write-char flexi-output-stream element) - else do - (stream-write-byte flexi-output-stream element)) - sequence)))) - -(defmethod stream-write-sequence ((stream flexi-output-stream) (sequence string) start end &key) - "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 #.*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 - (unless (typep stream 'flexi-binary-output-stream) - (return-from stream-write-sequence - (call-next-method))) - (let ((buffer (make-array (+ +buffer-size+ 20) - :element-type 'octet - :fill-pointer 0)) - (last-newline-pos (position #\Newline sequence - :test #'char= - :start start - :end end - :from-end t))) - (loop with format = (flexi-stream-external-format stream) - for index from start below end - do (char-to-octets format - (aref sequence index) - (lambda (octet) - (vector-push octet buffer))) - when (>= (fill-pointer buffer) +buffer-size+) do - (write-sequence buffer (flexi-stream-stream stream)) - (setf (fill-pointer buffer) 0) - finally (when (>= (fill-pointer buffer) 0) - (write-sequence buffer (flexi-stream-stream stream)))) - (setf (flexi-stream-column stream) - (cond (last-newline-pos (- end last-newline-pos 1)) - ((flexi-stream-column stream) - (+ (flexi-stream-column stream) (- end start)))))) + (with-accessors ((column flexi-stream-column) + (external-format flexi-stream-external-format) + (stream flexi-stream-stream)) + stream + (let* ((octet-seen-p nil) + (buffer-pos 0) + ;; whether we might receive characters and thus the number + ;; of octets to output might not be equal to the number of + ;; sequence elements to write + (chars-p (or (listp sequence) + (and (vectorp sequence) + (not (subtypep (array-element-type sequence) 'integer))))) + (factor (if chars-p (encoding-factor external-format) 1)) + (buffer-size (min +buffer-size+ (ceiling (* factor (- end start))))) + (buffer (make-octet-buffer buffer-size))) + (declare (fixnum buffer-pos buffer-size) + (boolean octet-seen-p) + (type (array octet *) buffer)) + (labels ((flush-buffer () + (write-sequence buffer stream :end buffer-pos) + (setq buffer-pos 0)) + (write-octet (octet) + (declare (octet octet)) + (when (>= buffer-pos buffer-size) + (flush-buffer)) + (setf (aref buffer buffer-pos) octet) + (incf buffer-pos)) + (write-character (char) + (char-to-octets external-format char #'write-octet)) + (write-object (object) + (etypecase object + (octet (setq octet-seen-p t) + (write-octet object)) + (character (write-character object))))) + (declare (dynamic-extent (function write-octet))) + (macrolet ((iterate (octets-p output-form) + `(progn + ,@(if octets-p '((setq octet-seen-p t))) + (loop for index of-type fixnum from start below end + do ,output-form + finally (when (plusp buffer-pos) + (flush-buffer)))))) + (etypecase sequence + (string (iterate nil (write-character (char sequence index)))) + (array + (let ((array-element-type (array-element-type sequence))) + (cond ((type-equal array-element-type 'octet) + (iterate t (write-octet (aref (the (array octet *) sequence) index)))) + ((subtypep array-element-type 'integer) + (iterate t (write-octet (aref sequence index)))) + (t (iterate nil (write-object (aref sequence index))))))) + (list (iterate nil (write-object (nth index sequence))))) + (setq column + (cond (octet-seen-p nil) + (t (let ((last-newline-pos (position #\Newline sequence + :test #'char= + :start start + :end end + :from-end t))) + (cond (last-newline-pos (- end last-newline-pos 1)) + (column (+ column (- end start)))))))))))) + sequence)
(defmethod stream-write-string ((stream flexi-output-stream) string