diff --git a/bootfiles/20a/boot-2009-10-01.lisp b/bootfiles/20a/boot-2009-10-01.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3de9921f36f29ec9cb7459cd047fced5da10caaf --- /dev/null +++ b/bootfiles/20a/boot-2009-10-01.lisp @@ -0,0 +1,22 @@ +;; Bootstrap for non-unicode build. Just updating the +ef-foo+ values. + +(in-package "STREAM") + +(handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::continue)))) +(vm::defenum (:prefix "+EF-" :suffix "+" :start 1) + str ; string length + cin ; input a character + cout ; output a character + sin ; input string + sout ; output string + os ; octets to string + so ; string to octets + en ; encode + de ; decode + flush ; flush state + copy-state ; copy state + max) +) + diff --git a/bootfiles/20a/boot-2009-10-1-cross.lisp b/bootfiles/20a/boot-2009-10-1-cross.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5a61674ea56c13dc5184bf95dd57ac3e2a1cad81 --- /dev/null +++ b/bootfiles/20a/boot-2009-10-1-cross.lisp @@ -0,0 +1,8 @@ +;;; Cross-compile script to add new slots to lisp-stream so we can +;;; have faster external formats. + +;; Nothing special needed; use standard scripts + +(load #+x86 "target:tools/cross-scripts/cross-x86-x86" + #+sparc "target:tools/cross-scripts/cross-sparc-sparc" + #+ppc "target:tools/cross-scripts/cross-ppc-ppc-darwin") diff --git a/code/extfmts.lisp b/code/extfmts.lisp index e6df7197cf7c5ee266209e71ab08639e323dfe70..ef7012b07b5e37efa7528533be2821bc7e19e3d4 100644 --- a/code/extfmts.lisp +++ b/code/extfmts.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.19 2009/10/02 20:15:04 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.20 2009/10/18 14:21:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -33,6 +33,7 @@ en ; encode de ; decode flush ; flush state + copy-state ; copy state max) ;; Unicode replacement character U+FFFD @@ -567,18 +568,18 @@ `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx)))) (funcall (or (aref (ef-cache ,tmp1) ,tmp2) (setf (aref (ef-cache ,tmp1) ,tmp2) - (let ((*compile-print* nil) - ;; Set default format when we compile so we - ;; can see compiler messages. If we don't, - ;; we run into a problem that we might be - ;; changing the default format while we're - ;; compiling, and we don't know how to output - ;; the compiler messages. - #|(*default-external-format* :iso8859-1)|#) - (compile nil `(lambda (%slots%) - (declare (ignorable %slots%)) - (block ,',blknm - ,,body)))))) + (let ((*compile-print* nil) + ;; Set default format when we compile so we + ;; can see compiler messages. If we don't, + ;; we run into a problem that we might be + ;; changing the default format while we're + ;; compiling, and we don't know how to output + ;; the compiler messages. + #|(*default-external-format* :iso8859-1)|#) + (compile nil `(lambda (%slots%) + (declare (ignorable %slots%)) + (block ,',blknm + ,,body)))))) (ef-slots ,tmp1)))) (declaim (inline ,name)) (defun ,name (,tmp1) @@ -694,46 +695,59 @@ (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr)))) (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+) - `(lambda (octets ptr end string &aux (pos 0) (count 0) (state nil) (last-octet 0)) - (declare (optimize (speed 3) #|(safety 0) (space 0) (debug 0)|#) + `(lambda (octets ptr end state string s-start s-end &aux (pos s-start) (count 0) (last-octet 0)) + (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#) (type (simple-array (unsigned-byte 8) (*)) octets) - (type kernel:index pos end count last-octet) + (type kernel:index pos end count last-octet s-start s-end) (type (integer -1 (#.array-dimension-limit)) ptr) (type simple-string string) (ignorable state)) (catch 'end-of-octets - (loop - (when (= pos (length string)) - (setq string (adjust-array string (* 2 pos)))) - (setf (schar string pos) - (octets-to-char ,extfmt state count - (if (>= ptr end) - (throw 'end-of-octets nil) - (aref octets (incf ptr))) - (lambda (n) (decf ptr n)))) + (loop while (< pos s-end) + do (setf (schar string pos) + (octets-to-char ,extfmt state count + (if (>= ptr end) + (throw 'end-of-octets nil) + (aref octets (incf ptr))) + (lambda (n) (decf ptr n)))) (incf pos) (incf last-octet count))) - (values string pos last-octet))) + (values string pos last-octet state))) (defun octets-to-string (octets &key (start 0) end (external-format :default) - (string nil stringp)) + (string nil stringp) + (s-start 0) (s-end nil s-end-p) + (state nil)) "Octets-to-string converts an array of octets in Octets to a string according to the specified External-format. The array of octets is bounded by Start (defaulting ot 0) and End (defaulting to the end of - the array. If String is given, the string is stored there. If - String is too short to hold all of the characters, it will be - adjusted (via adjust-array). If String is not given, a new string - is created. Three values are returned: the string, the number of - characters read, and the number of octets consumed." + the array. If String is not given, a new string is created. If + String is given, the converted octets are stored in String, starting + at S-Start (defaulting to the 0) and ending at S-End (defaulting to + the length of String). If the string is not large enough to hold + all of characters, then some octets will not be converted. A State + may also be specified; this is used as the state of the external + format. + + Four values are returned: the string, the number of characters read, + the number of octets actually consumed and the new state of the + external format." (declare (type (simple-array (unsigned-byte 8) (*)) octets) - (type kernel:index start) + (type kernel:index start s-start) (type (or kernel:index null) end) (type (or simple-string null) string)) - (multiple-value-bind (string pos last-octet) - (funcall (ef-octets-to-string external-format) - octets (1- start) (1- (or end (length octets))) - (or string (make-string (length octets)))) - (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet))) + (let ((s-end (if s-end-p + s-end + (if stringp + (length string) + (length octets))))) + (multiple-value-bind (string pos last-octet new-state) + (funcall (ef-octets-to-string external-format) + octets (1- start) (1- (or end (length octets))) + state + (or string (make-string (length octets))) + s-start s-end) + (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state)))) diff --git a/code/fd-stream-extfmt.lisp b/code/fd-stream-extfmt.lisp index eda598f171d2a03dcaa5edfe774a8297321d9974..0fb270798f2a1237442fa962f8742e705e2aba43 100644 --- a/code/fd-stream-extfmt.lisp +++ b/code/fd-stream-extfmt.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream-extfmt.lisp,v 1.3 2009/08/10 16:47:41 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream-extfmt.lisp,v 1.4 2009/10/18 14:21:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -66,7 +66,10 @@ (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-cin+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-cout+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-sout+) +(stream::precompile-ef-slot :iso8859-1 #.stream::+ef-os+) ;(set-terminal-coding-system :iso8859-1) + +(setf lisp::*enable-stream-buffer-p* t) diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index 36177639c66d587bdca097a5ad72e9cc6bac8f57..6e547ab5adfc986c1823ee7a84f2f0b2b018dbd4 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.91 2009/09/09 15:51:27 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.92 2009/10/18 14:21:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -41,6 +41,8 @@ "List of available buffers. Each buffer is an sap pointing to bytes-per-buffer of memory.") +(defvar lisp::*enable-stream-buffer-p* nil) + (defconstant bytes-per-buffer (* 4 1024) "Number of bytes per buffer.") @@ -250,7 +252,17 @@ #+unicode (co-state nil) #+unicode - (last-char-read-size 0 :type index)) + (last-char-read-size 0 :type index) + ;; Saved state needed for (setf stream-external-format) when the + ;; fast string-buffer is used. + #+unicode + (saved-oc-state nil) + ;; + ;; The number of octets in in-buffer. Normally equal to + ;; in-buffer-length, but could be less if we reached the + ;; end-of-file. + #+unicode + (in-length 0 :type index)) (defun %print-fd-stream (fd-stream stream depth) (declare (ignore depth) (stream stream)) @@ -1378,18 +1390,32 @@ ;; since we already have size = 1. (or (eq 'unsigned-byte (and (consp type) (car type))) (eq type :default)) - ;; Character streams with :iso8859-1 - (and (eq type 'character) - #+unicode - (eql :iso8859-1 (fd-stream-external-format stream))))) + (eq type 'character))) ;; We only create this buffer for streams of type ;; (unsigned-byte 8) or character streams with an external ;; format of :iso8859-1. Because there's no buffer, the ;; other element-types will dispatch to the appropriate ;; input (output) routine in fast-read-byte/fast-read-char. - (setf (lisp-stream-in-buffer stream) - (make-array in-buffer-length - :element-type '(unsigned-byte 8))))) + (when *enable-stream-buffer-p* + (setf (lisp-stream-in-buffer stream) + (make-array in-buffer-length + :element-type '(unsigned-byte 8))) + #+unicode + (when (and (eq type 'character) + (not (eq :iso8859-1 (fd-stream-external-format stream)))) + ;; For character streams, we create the string-buffer so + ;; we can convert all available octets at once instead + ;; of for each character. The string is one element + ;; longer than in-buffer-length to leave room for + ;; unreading. + ;; + ;; For ISO8859-1, we don't want this because it's very + ;; easy and quick to convert octets to iso8859-1. (See + ;; FAST-READ-CHAR.) + (setf (lisp-stream-string-buffer stream) + (make-string (1+ in-buffer-length))) + (setf (lisp-stream-string-buffer-len stream) 0) + (setf (lisp-stream-string-index stream) 0))))) (setf input-size size) (setf input-type type))) @@ -1496,10 +1522,15 @@ #-unicode (setf (fd-stream-unread stream) arg1) #+unicode - (if (zerop (fd-stream-last-char-read-size stream)) - (setf (fd-stream-unread stream) arg1) - (decf (fd-stream-ibuf-head stream) - (fd-stream-last-char-read-size stream))) + (cond ((lisp-stream-string-buffer stream) + (if (zerop (lisp-stream-string-index stream)) + (setf (fd-stream-unread stream) arg1) + (decf (lisp-stream-string-index stream)))) + (t + (if (zerop (fd-stream-last-char-read-size stream)) + (setf (fd-stream-unread stream) arg1) + (decf (fd-stream-ibuf-head stream) + (fd-stream-last-char-read-size stream))))) ;; Paul says: ;; ;; Not needed for unicode when unreading is implemented by backing up in @@ -1753,11 +1784,13 @@ ;; ;;#-unicode-bootstrap ; fails in stream-reinit otherwise #+(and unicode (not unicode-bootstrap)) - (setf (stream-external-format stream) external-format) + (when lisp::*enable-stream-buffer-p* + (%set-fd-stream-external-format stream external-format nil)) (set-routines stream element-type input output input-buffer-p :binary-stream-p binary-stream-p) #+(and unicode (not unicode-bootstrap)) - (setf (stream-external-format stream) external-format) + (when lisp::*enable-stream-buffer-p* + (%set-fd-stream-external-format stream external-format nil)) (when (and auto-close (fboundp 'finalize)) (finalize stream #'(lambda () @@ -2290,3 +2323,10 @@ (t (etypecase object (character 1) (string (length object)))))) + +#+unicode +(stream::def-ef-macro ef-copy-state (extfmt lisp stream::+ef-max+ stream::+ef-copy-state+) + ;; Return a copy of the state of an external format. + `(lambda (state) + (declare (ignorable state)) + (stream::copy-state ,extfmt state))) diff --git a/code/stream.lisp b/code/stream.lisp index 76bec897fad9da3e4a79b6a8ea117bd320d53ada..8e5877c79ffe54b167df7c206749ad438bd31116 100644 --- a/code/stream.lisp +++ b/code/stream.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.87 2009/08/10 16:47:41 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.88 2009/10/18 14:21:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -298,19 +298,59 @@ ;; fundamental-stream :default)) -(defun %set-fd-stream-external-format (stream extfmt) +#+unicode +(defun %set-fd-stream-external-format (stream extfmt &optional (updatep t)) (declare (type fd-stream stream)) - (setf (fd-stream-external-format stream) - (stream::ef-name (stream::find-external-format extfmt)) - (fd-stream-oc-state stream) nil - (fd-stream-co-state stream) nil) - (when (fd-stream-ibuf-sap stream) ; input stream - (setf (fd-stream-in stream) (ef-cin extfmt))) - (when (fd-stream-obuf-sap stream) ; output stream - (setf (fd-stream-out stream) (ef-cout extfmt) - ;;@@ (fd-stream-sout stream) (ef-sout extfmt) - )) - extfmt) + (let ((old-format (fd-stream-external-format stream))) + (setf (fd-stream-external-format stream) + (stream::ef-name (stream::find-external-format extfmt)) + (fd-stream-oc-state stream) nil + (fd-stream-co-state stream) nil) + (when (fd-stream-ibuf-sap stream) ; input stream + (setf (fd-stream-in stream) (ef-cin extfmt))) + (when (fd-stream-obuf-sap stream) ; output stream + (setf (fd-stream-out stream) (ef-cout extfmt) + ;;@@ (fd-stream-sout stream) (ef-sout extfmt) + )) + (when (and lisp::*enable-stream-buffer-p* updatep + (lisp-stream-string-buffer stream)) + ;; We want to reconvert any octets that haven't been converted + ;; yet. So, we need to figure out which octet to start with. + ;; This is done by converting (the previously converted) octets + ;; until we've converted the right number of characters. + (let ((ibuf (lisp-stream-in-buffer stream)) + (sindex (1- (lisp-stream-string-index stream))) + (index 0) + (state (fd-stream-saved-oc-state stream))) + ;; Reconvert all the octets we've already converted and read. + ;; We don't know how many octets that is, but do know how many + ;; characters there are. + (multiple-value-bind (s pos count new-state) + (octets-to-string ibuf + :start 0 + :external-format old-format + :string (make-string sindex) + :state state) + (declare (ignore s pos)) + (setf state new-state) + (setf index count)) + + ;; We now know the last octet that was used. Now convert the + ;; rest of the octets using the new format. + (multiple-value-bind (s pos count new-state) + (octets-to-string ibuf + :start index + :end (fd-stream-in-length stream) + :external-format (fd-stream-external-format stream) + :string (lisp-stream-string-buffer stream) + :s-start 1 + :state state) + (declare (ignore s)) + (setf (lisp-stream-string-index stream) 1) + (setf (lisp-stream-string-buffer-len stream) pos) + (setf (lisp-stream-in-index stream) (+ index count)) + (setf (fd-stream-oc-state stream) new-state)))) + extfmt)) ;; This is only used while building; it's reimplemented in ;; fd-stream-extfmt.lisp @@ -459,6 +499,7 @@ ;; simple-stream (stream::%unread-char stream character) ;; lisp-stream + #-unicode (let ((index (1- (lisp-stream-in-index stream))) (buffer (lisp-stream-in-buffer stream))) (declare (fixnum index)) @@ -469,6 +510,25 @@ (t (funcall (lisp-stream-misc stream) stream :unread character)))) + #+unicode + (let ((sbuf (lisp-stream-string-buffer stream)) + (ibuf (lisp-stream-in-buffer stream))) + (cond (sbuf + (let ((index (1- (lisp-stream-string-index stream)))) + (when (minusp index) + (error "Nothing to unread.")) + (setf (aref sbuf index) character) + (setf (lisp-stream-string-index stream) index))) + (ibuf + (let ((index (1- (lisp-stream-in-index stream)))) + (when (minusp index) + (error "Nothing to unread.")) + ;; This only works for iso8859-1! + (setf (aref ibuf index) (char-code character)) + (setf (lisp-stream-in-index stream) index))) + (t + (funcall (lisp-stream-misc stream) stream + :unread character)))) ;; fundamental-stream (stream-unread-char stream character))) nil) @@ -703,6 +763,76 @@ (setf (lisp-stream-in-index stream) (1+ start)) (code-char (aref ibuf start)))))) +#+unicode +(defun fast-read-char-string-refill (stream eof-errorp eof-value) + ;; Like fast-read-char-refill, but we don't need or want the + ;; in-buffer-extra. + (let* ((ibuf (lisp-stream-in-buffer stream)) + (index (lisp-stream-in-index stream))) + (declare (type (integer 0 #.in-buffer-length) index)) + + ;; Copy the stuff we haven't read from in-buffer to the beginning + ;; of the buffer. + (replace ibuf ibuf + :start1 0 + :start2 index :end2 in-buffer-length) + + (let ((count (funcall (lisp-stream-n-bin stream) stream + ibuf (- in-buffer-length index) + index + nil))) + (declare (type (integer 0 #.in-buffer-length) count)) + + (cond ((zerop count) + ;; Nothing left in the stream, so update our pointers to + ;; indicate we've read everything and call the stream-in + ;; function so that we do the right thing for eof. + (setf (lisp-stream-in-index stream) in-buffer-length) + (setf (lisp-stream-string-index stream) + (lisp-stream-string-buffer-len stream)) + (funcall (lisp-stream-in stream) stream eof-errorp eof-value)) + (t + (let ((sbuf (lisp-stream-string-buffer stream)) + (slen (lisp-stream-string-buffer-len stream))) + (declare (simple-string sbuf) + (type (integer 0 #.(1+ in-buffer-length)) slen) + (optimize (speed 3))) + + ;; Update in-length and saved-oc-state. These are + ;; needed if we change the external-format of the + ;; stream because we need to know how many octets are + ;; valid (in case end-of-file was reached), and what + ;; the state was when originally converting the octets + ;; to characters. + (setf (fd-stream-in-length stream) (+ count (- in-buffer-length index))) + (let ((state (fd-stream-oc-state stream))) + (setf (fd-stream-saved-oc-state stream) + (cons (car state) + (funcall (ef-copy-state (fd-stream-external-format stream)) + (cdr state))))) + + ;; Copy the last read character to the beginning of the + ;; buffer to support unreading. + (when (plusp slen) + (setf (schar sbuf 0) (schar sbuf (1- slen)))) + + + ;; Convert all the octets, including the ones that we + ;; haven't processed yet and the ones we just read in. + (multiple-value-bind (s char-count octet-count new-state) + (octets-to-string ibuf + :start 0 + :end (+ count (- in-buffer-length index)) + :state (fd-stream-oc-state stream) + :string sbuf + :s-start 1 + :external-format (fd-stream-external-format stream)) + (declare (ignore s)) + (setf (fd-stream-oc-state stream) new-state) + (setf (lisp-stream-string-buffer-len stream) char-count) + (setf (lisp-stream-string-index stream) 2) + (setf (lisp-stream-in-index stream) octet-count) + (schar sbuf 1)))))))) ;;; FAST-READ-BYTE-REFILL -- Interface ;;; diff --git a/code/string.lisp b/code/string.lisp index a084bb134435d544d186bb51e85965cb8ef6c6ae..5205278195338b3e9f54a5ce89e716110e8d763e 100644 --- a/code/string.lisp +++ b/code/string.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.20 2009/09/15 15:52:43 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.21 2009/10/18 14:21:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -44,14 +44,14 @@ char-or-code))) (ecase surrogate-type ((:high :leading) - ;; Test for high surrogate - (<= #xD800 code #xDBFF)) + ;; Test for high surrogate (#xD800 to #xDBFF) + (= #b110110 (ash code -10))) ((:low :trailing) - ;; Test for low surrogate - (<= #xDC00 code #xDFFF)) + ;; Test for low surrogate (#xDC00 to #xDFFF) + (= #b110111 (ash code -10))) ((:any nil) - ;; Test for any surrogate - (<= #xD800 code #xDFFF))))) + ;; Test for any surrogate (#xD800 to #xDFFF) + (= #b11011 (ash code -11)))))) (defun surrogates-to-codepoint (hi-surrogate-char lo-surrogate-char) "Convert the given Hi and Lo surrogate characters to the diff --git a/code/struct.lisp b/code/struct.lisp index 73e1711da2d455abf67b08c2835b1992e5ec1a7f..c77f7b2ca48e2c2039e7c0a965ec033a806ca86c 100644 --- a/code/struct.lisp +++ b/code/struct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/struct.lisp,v 1.21 2002/02/04 17:22:15 toy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/struct.lisp,v 1.22 2009/10/18 14:21:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -37,7 +37,22 @@ (out #'ill-out :type function) ; Write-Char function (bout #'ill-bout :type function) ; Byte output function (sout #'ill-out :type function) ; String output function - (misc #'do-nothing :type function)) ; Less used methods + (misc #'do-nothing :type function) ; Less used methods + ;; + ;; A string to hold characters that have been converted from + ;; in-buffer. + #+unicode + (string-buffer nil :type (or null simple-string)) + ;; + ;; Index into string-buffer where the next character should be read from + #+unicode + (string-index 0 :type index) + ;; + ;; Number of characters in string-buffer. (This isn't the length of + ;; string-buffer, but the number of characters in the buffer, since + ;; many octets may be consumed to produce one character.) + #+unicode + (string-buffer-len 0 :type index)) (declaim (inline streamp)) (defun streamp (stream) diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp index 4f9fc0a61a61e52cb126ee7ad33de8f4eb03c988..13b7a8cd4714ff051a489948d75663bfeae455cb 100644 --- a/code/sysmacs.lisp +++ b/code/sysmacs.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.30 2006/02/03 13:51:28 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.31 2009/10/18 14:21:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -150,8 +150,17 @@ and also the CMUCL C runtime." `(let* ((%frc-stream% ,stream) (%frc-method% (lisp-stream-in %frc-stream%)) (%frc-buffer% (lisp-stream-in-buffer %frc-stream%)) - (%frc-index% (lisp-stream-in-index %frc-stream%))) - (declare (type index %frc-index%) + (%frc-index% (lisp-stream-in-index %frc-stream%)) + #+unicode + (%frc-string-buffer% (lisp-stream-string-buffer %frc-stream%)) + #+unicode + (%frc-string-index% (lisp-stream-string-index %frc-stream%)) + #+unicode + (%frc-string-length% (lisp-stream-string-buffer-len %frc-stream%))) + (declare #+unicode + (type index %frc-string-index% %frc-string-length%) + #+unicode + (type (or null simple-string) %frc-string-buffer%) (type lisp-stream %frc-stream%)) ,@forms)) @@ -161,7 +170,10 @@ and also the CMUCL C runtime." ;;; inside it's scope to decache the lisp-stream-in-index. ;;; (defmacro done-with-fast-read-char () - `(setf (lisp-stream-in-index %frc-stream%) %frc-index%)) + `(progn + (setf (lisp-stream-in-index %frc-stream%) %frc-index%) + #+unicode + (setf (lisp-stream-string-index %frc-stream%) %frc-string-index%))) ;;; Fast-Read-Char -- Internal ;;; @@ -170,14 +182,25 @@ and also the CMUCL C runtime." ;;; (defmacro fast-read-char (&optional (eof-errorp t) (eof-value ())) `(cond - ((not %frc-buffer%) - (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value)) - ((= %frc-index% in-buffer-length) - (prog1 (fast-read-char-refill %frc-stream% ,eof-errorp ,eof-value) - (setq %frc-index% (lisp-stream-in-index %frc-stream%)))) - (t - (prog1 (code-char (aref %frc-buffer% %frc-index%)) - (incf %frc-index%))))) + #+unicode + (%frc-string-buffer% + (cond ((>= %frc-string-index% %frc-string-length%) + (prog1 (fast-read-char-string-refill %frc-stream% ,eof-errorp ,eof-value) + (setf %frc-string-index% (lisp-stream-string-index %frc-stream%)) + (setf %frc-string-length% (lisp-stream-string-buffer-len %frc-stream%)))) + (t + (prog1 (aref %frc-string-buffer% %frc-string-index%) + (incf %frc-string-index%))))) + (%frc-buffer% + (cond ((= %frc-index% in-buffer-length) + (prog1 (fast-read-char-refill %frc-stream% ,eof-errorp ,eof-value) + (setq %frc-index% (lisp-stream-in-index %frc-stream%)))) + (t + ;; This only works correctly for :iso8859-1! + (prog1 (code-char (aref %frc-buffer% %frc-index%)) + (incf %frc-index%))))) + (t + (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value)))) ;;;; And these for the fasloader... @@ -215,4 +238,5 @@ and also the CMUCL C runtime." (incf %frc-index%)))))) ;;; (defmacro done-with-fast-read-byte () - `(done-with-fast-read-char)) + `(progn + (setf (lisp-stream-in-index %frc-stream%) %frc-index%))) diff --git a/general-info/release-20b.txt b/general-info/release-20b.txt index 22c11362612491154d2e59d3a9f18a076f63c3c0..9701b12bb8bf005211fc605474580b4f725d8799 100644 --- a/general-info/release-20b.txt +++ b/general-info/release-20b.txt @@ -21,12 +21,19 @@ New in this release: * Known issues: * Feature enhancements: + - Read operations using an external format of utf8 are now much + faster. Some simple tests on Linux shows that read-line now + only takes 40% as much time. Sparc shows 60% as much time. * ANSI compliance fixes: * Bugfixes: - + - On Unicode builds, printing of '|\|| and '|`| was incorrect + because no escapes were printed. This is fixed now. * Trac Tickets: + #33: get-dispatch-macro-character doesn't signal errors in + compiled code + Fixed. * Other changes: diff --git a/pcl/simple-streams/external-formats/utf-16-be.lisp b/pcl/simple-streams/external-formats/utf-16-be.lisp index 07da197cde238d02059047b20cfe5742690b5596..987abd4f6556f5f94b9e71394ee891c18a2dc9bf 100644 --- a/pcl/simple-streams/external-formats/utf-16-be.lisp +++ b/pcl/simple-streams/external-formats/utf-16-be.lisp @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-be.lisp,v 1.3 2009/09/30 16:12:41 rtoy Exp $") +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-be.lisp,v 1.4 2009/10/18 14:21:24 rtoy Exp $") (in-package "STREAM") @@ -19,11 +19,23 @@ (,code (+ (* 256 ,c1) ,c2))) (declare (type lisp:codepoint ,code)) (cond ((lisp::surrogatep ,code :low) - (setf ,code +replacement-character-code+)) + ;; Got low surrogate. Combine with the state (high + ;; surrogate), if we have it. Otherwise, use the + ;; replacement code. + (if ,state + (setf ,code (+ (ash (- (the (integer #xd800 #xdbff) ,state) #xD800) 10) + ,code #x2400) + ,state nil) + (setf ,code +replacement-character-code+))) ((lisp::surrogatep ,code :high) + ;; Remember the high surrogate in case we bail out + ;; reading the low surrogate (for octets-to-string.) + (setf ,state ,code) (let* ((,c1 ,input) (,c2 ,input) (,next (+ (* 256 ,c1) ,c2))) + ;; We read the trailing code, so clear the state. + (setf ,state nil) ;; If we don't have a high and low surrogate, ;; replace with REPLACEMENT CHARACTER. Possibly ;; unput 2 so it'll be read as another character @@ -33,7 +45,8 @@ (setf ,code +replacement-character-code+)))) ((= ,code #xFFFE) ;; Replace with REPLACEMENT CHARACTER. - (setf ,code +replacement-character-code+))) + (setf ,code +replacement-character-code+)) + (t (setf ,state nil))) (values ,code 2))) (code-to-octets (code state output c c1 c2) `(flet ((output (code) @@ -48,4 +61,9 @@ (output (logior ,c1 #xD800)) (output (logior ,c2 #xDC00)))) (t - (output +replacement-character-code+)))))) + (output +replacement-character-code+))))) + nil + (copy-state (state) + ;; The state is either NIL or a codepoint, so nothing really + ;; special is needed to copy it. + `(progn ,state))) diff --git a/pcl/simple-streams/external-formats/utf-16-le.lisp b/pcl/simple-streams/external-formats/utf-16-le.lisp index 24d0ca958586c6e435be6e94a5a5b694e1282c48..979e45e440d50cf3cace73b7c6a32826be943c0c 100644 --- a/pcl/simple-streams/external-formats/utf-16-le.lisp +++ b/pcl/simple-streams/external-formats/utf-16-le.lisp @@ -4,11 +4,13 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-le.lisp,v 1.3 2009/09/30 16:12:41 rtoy Exp $") +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-le.lisp,v 1.4 2009/10/18 14:21:24 rtoy Exp $") (in-package "STREAM") ;; UTF-16LE. BOM is not recognized, and is never output. +;; +;; The state is either NIL or a codepoint. (define-external-format :utf-16-le (:size 2) () @@ -18,12 +20,24 @@ (,code (+ (* 256 ,c2) ,c1))) (declare (type lisp:codepoint ,code)) (cond ((lisp::surrogatep ,code :low) - ;; Replace with REPLACEMENT CHARACTER. - (setf ,code +replacement-character-code+)) + ;; If possible combine this low surrogate with the + ;; high surrogate in the state. Otherwise, we have + ;; a bare low surrogate so return the replacement + ;; character. + (if ,state + (setf ,code (+ (ash (- (the (integer #xd800 #xdbff) ,state) #xD800) 10) + ,code #x2400) + ,state nil) + (setf ,code +replacement-character-code+))) ((lisp::surrogatep ,code :high) + ;; Remember the high surrogate in case we bail out + ;; reading the low surrogate (for octets-to-string.) + (setf ,state ,code) (let* ((,c1 ,input) (,c2 ,input) (,next (+ (* 256 ,c2) ,c1))) + ;; We read the trailing code, so clear the state. + (setf ,state nil) ;; Replace with REPLACEMENT CHARACTER. Possibly ;; unput 2 so it'll be read as another character ;; next time around? @@ -32,7 +46,8 @@ (setq ,code +replacement-character-code+)))) ((= ,code #xFFFE) ;; replace with REPLACEMENT CHARACTER ? - (error "Illegal character U+FFFE in UTF-16 sequence."))) + (error "Illegal character U+FFFE in UTF-16 sequence.")) + (t (setf ,state nil))) (values ,code 2))) (code-to-octets (code state output c c1 c2) `(flet ((output (code) @@ -47,4 +62,9 @@ (output (logior ,c1 #xD800)) (output (logior ,c2 #xDC00)))) (t - (output +replacement-character-code+)))))) + (output +replacement-character-code+))))) + nil + (copy-state (state) + ;; The state is either NIL or a codepoint, so nothing really + ;; special is needed. + `(progn ,state))) diff --git a/pcl/simple-streams/external-formats/utf-16.lisp b/pcl/simple-streams/external-formats/utf-16.lisp index fcdce8f6e3e566c4badece12960cd0d8f87ffb55..d71c75b8686914ddeac9ff5dd9c0f6fc24ddf476 100644 --- a/pcl/simple-streams/external-formats/utf-16.lisp +++ b/pcl/simple-streams/external-formats/utf-16.lisp @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*- ;;; ;;; ********************************************************************** -(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16.lisp,v 1.4 2009/09/30 16:12:41 rtoy Exp $") +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16.lisp,v 1.5 2009/10/18 14:21:24 rtoy Exp $") (in-package "STREAM") @@ -11,15 +11,14 @@ ;; UTF-16BE, the input stream shouldn't have a BOM. But we allow for ;; one here, anyway. This should be compatible with the Unicode spec. -;; make state an integer: -;; or (or state 0) to cope with NIL case +;; The state is a cons. The car is an integer: ;; 0 = initial state, nothing has been read yet ;; 1 = BOM has been read, little-endian ;; 2 = BOM has been read, big-endian, or non-BOM char has been read ;; -;; (oddp state) = little-endian -;; (evenp state) = big-endian -;; (zerop state) = #xFEFF/#xFFFE is BOM (to be skipped) +;; The cdr is either NIL or a codepoint which is used for converting +;; surrogate pairs into codepoints. If the cdr is non-NIL, then it is +;; the leading (high) surrogate of a surrogate pair. ;; ;; When writing, never output a BOM. @@ -28,10 +27,10 @@ (octets-to-code (state input unput c1 c2 code wd next st) `(block nil - (when (null ,state) (setf ,state 0)) + (when (null ,state) (setf ,state (cons 0 nil))) (tagbody :again - (let* ((,st ,state) + (let* ((,st (car ,state)) (,c1 ,input) (,c2 ,input) (,code (if (oddp ,st) @@ -47,14 +46,29 @@ ;; indicates that BOM has been seen, so that would result in ;; the BOM being reread as a character (cond ((lisp::surrogatep ,code :low) - ;; replace with REPLACEMENT CHARACTER ? - (setf ,code +replacement-character-code+)) + ;; If possible combine this low surrogate with the + ;; high surrogate in the state. Otherwise, we have + ;; a bare low surrogate so return the replacement + ;; character. + (if (cdr ,state) + (setf ,code (+ (ash (- (the (integer #xd800 #xdbff) (cdr ,state)) #xD800) + 10) + ,code #x2400) + ,state nil) + (setf ,code +replacement-character-code+))) ((lisp::surrogatep ,code :high) + ;; Save the high (leading) code in the state, in + ;; case we fail to read the low (trailing) + ;; surrogate. (This should only happen when we're + ;; doing octets-to-string.) + (setf (cdr ,state) ,code) (let* ((,c1 ,input) (,c2 ,input) (,next (if (oddp ,st) (+ (* 256 ,c2) ,c1) (+ (* 256 ,c1) ,c2)))) + ;; We read the trailing surrogate, so clear the state. + (setf (cdr ,state) nil) ;; If we don't have a high and low surrogate, ;; replace with REPLACEMENT CHARACTER. Possibly ;; unput 2 so it'll be read as another character @@ -91,5 +105,5 @@ (output +replacement-character-code+))))) nil (copy-state (state) - ;; The state is either NIL or T, so we can just return that. - state)) + ;; The state is list. Copy it + `(copy-list ,state))) diff --git a/pcl/simple-streams/external-formats/utf-32.lisp b/pcl/simple-streams/external-formats/utf-32.lisp index 94883d785229707d5f004d83c7f6bcf8a26ad8cd..8ce1b3e5af588b67b4b95ed8dc6559c8bea65279 100644 --- a/pcl/simple-streams/external-formats/utf-32.lisp +++ b/pcl/simple-streams/external-formats/utf-32.lisp @@ -4,7 +4,7 @@ ;;; This code was written by Raymond Toy and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-32.lisp,v 1.4 2009/09/28 18:12:59 rtoy Exp $") +(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-32.lisp,v 1.5 2009/10/18 14:21:24 rtoy Exp $") (in-package "STREAM") @@ -83,4 +83,4 @@ nil (copy-state (state) ;; The state is either NIL or T, so we can just return that. - state)) + `(progn ,state)))