From: Christophe Rhodes Date: Sun, 27 Jul 2003 13:52:35 +0000 (+0000) Subject: 0.8.2.1: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=acb7e69e6029efd8127b3c4288f750c2d0cb7a42;p=sbcl.git 0.8.2.1: As reported by Edi Weitz on sbcl-help 2003-07-17, WITH-OUTPUT-TO-STRING should accept an :ELEMENT-TYPE keyword argument: ... make it so; ... make it so for MAKE-STRING-OUTPUT-STREAM too; (implementation of such while preserving efficiency in our (vector nil) world is slightly contorted; we accumulate arbitrary characters, then convert to the requested type when the stream's string is requested) ... add tests for reasonable behaviour. --- diff --git a/NEWS b/NEWS index f57ee08..c833b23 100644 --- a/NEWS +++ b/NEWS @@ -1937,6 +1937,11 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1: ** condition slot accessors are methods. ** (VECTOR NIL) is a subtype of STRING. +changes in sbcl-0.8.3 relative to sbcl-0.8.2: + * bug fix: WITH-OUTPUT-TO-STRING (and MAKE-STRING-OUTPUT-STREAM) now + accept and act upon their :ELEMENT-TYPE keyword argument. + (reported by Edi Weitz) + planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles down, it might impact TRACE. They both encapsulate functions, and diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 9159bfb..1091114 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -363,8 +363,9 @@ ,@(when index `((setf ,index (string-input-stream-current ,var))))))))) -(defmacro-mundanely with-output-to-string ((var &optional string) - &body forms-decls) +(defmacro-mundanely with-output-to-string + ((var &optional string &key (element-type ''character)) + &body forms-decls) (multiple-value-bind (forms decls) (parse-body forms-decls nil) (if string `(let ((,var (make-fill-pointer-output-stream ,string))) @@ -372,7 +373,7 @@ (unwind-protect (progn ,@forms) (close ,var))) - `(let ((,var (make-string-output-stream))) + `(let ((,var (make-string-output-stream :element-type ,element-type))) ,@decls (unwind-protect (progn ,@forms) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index c35f45f..db2865d 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1182,12 +1182,16 @@ (sout #'string-sout) (misc #'string-out-misc) ;; The string we throw stuff in. - (string (make-string 40) + (string (missing-arg) :type (simple-array character (*)))) - (:constructor make-string-output-stream ()) + (:constructor make-string-output-stream + (&key (element-type 'character) + &aux (string (make-string 40)))) (:copier nil)) ;; Index of the next location to use. - (index 0 :type fixnum)) + (index 0 :type fixnum) + ;; Requested element type + (element-type 'character)) #!+sb-doc (setf (fdocumentation 'make-string-output-stream 'function) @@ -1254,8 +1258,19 @@ (defun get-output-stream-string (stream) (declare (type string-output-stream stream)) (let* ((length (string-output-stream-index stream)) - (result (make-string length))) - (replace result (string-output-stream-string stream)) + (element-type (string-output-stream-element-type stream)) + (result + (case element-type + ;; Overwhelmingly common case; can be inlined. + ((character) (make-string length)) + (t (make-string length :element-type element-type))))) + ;; For the benefit of the REPLACE transform, let's do this, so + ;; that the common case isn't ludicrously expensive. + (etypecase result + ((simple-array character (*)) + (replace result (string-output-stream-string stream))) + ((simple-array nil (*)) + (replace result (string-output-stream-string stream)))) (setf (string-output-stream-index stream) 0) result)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 6b80f4d..3043940 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -919,7 +919,10 @@ (defknown make-echo-stream (stream stream) stream (flushable)) (defknown make-string-input-stream (string &optional index index) stream (flushable unsafe)) -(defknown make-string-output-stream () stream (flushable)) +(defknown make-string-output-stream + (&key (:element-type type-specifier)) + stream + (flushable)) (defknown get-output-stream-string (stream) simple-string ()) (defknown streamp (t) boolean (movable foldable flushable)) (defknown stream-element-type (stream) type-specifier diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index 016b31c..4bf264c 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -102,3 +102,23 @@ (assert (char= (read-char stream) #\a)) (assert (file-position stream :end)) (assert (eq (read-char stream nil 'foo) 'foo))) + +;;; MAKE-STRING-OUTPUT-STREAM and WITH-OUTPUT-TO-STRING take an +;;; :ELEMENT-TYPE keyword argument +(macrolet ((frob (element-type-form) + `(progn + (let ((s (with-output-to-string + (s nil ,@(when element-type-form + `(:element-type ,element-type-form)))))) + (assert (typep s '(simple-array ,(if element-type-form + (eval element-type-form) + 'character) + (0))))) + (get-output-stream-string + (make-string-output-stream + ,@(when element-type-form + `(:element-type ,element-type-form))))))) + (frob nil) + (frob 'character) + (frob 'base-char) + (frob 'nil)) diff --git a/version.lisp-expr b/version.lisp-expr index 90a6b18..2668ff9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.2" +"0.8.2.1"