[cmucl-cvs] CMUCL commit: src (5 files)
Raymond Toy
rtoy at common-lisp.net
Tue Oct 12 21:52:44 UTC 2010
Date: Tuesday, October 12, 2010 @ 17:52:44
Author: rtoy
Path: /project/cmucl/cvsroot/src
Modified: code/fd-stream-extfmt.lisp code/fd-stream.lisp code/struct.lisp
code/sysmacs.lisp compiler/dump.lisp
Make read-char and read-byte signal errors when given the wrong kind
of streams. This is a change from current 20a and 20b behavior which
didn't signal errors, but matches the behavior for releases 19f and
earlier.
But allow them to work on binary-text-streams. This is the same
behavior as before for binary-text-stream streams.
However, read-sequence no longer allows reading from streams into
arbitrary objects, unless the stream is a binary-text-stream stream.
code/fd-stream-extfmt.lisp:
o In %SET-FD-STREAM-EXTERNAL-FORMAT, only update
fd-stream-in/fd-stream-out if we have a character or
binary-text-stream stream.
o Don't update the fd-stream-string-buffer or lisp-stream-in-buffer if
we have a binary-text-stream because that will mess up how
fast-read-char and fast-read-byte dispatch to do the right thing for
binary-text-stream streams.
code/fd-stream.lisp:
o Set the fd-stream-in and fd-stream-bin slots appropriately depending
on whether we have a character, binary, or binary-text-stream
stream.
o Only create the lisp-stream-in-buffer if we do NOT have a
binary-text-stream. (Binary streams didn't use the
lisp-stream-buffer previously, so no change there. Character
streams use the lisp-stream-buffer and/or lisp-string-buffer.)
o Set the fd-stream-flags appropriately for the kind of stream this
is. Checking a fixnum is faster than checking the type of a stream.
code/struct.lisp:
o Add FLAGS slot to LISP-STREAM so we can tell what kind of stream
(character, binary, binary-text-stream) we have.
code/sysmacs.lisp:
o Change FAST-READ-CHAR so that if we have a have a binary or
binary-text-stream stream, we dispatch to the fast-read-char methods
to do the right thing, including signaling an error for the wrong
kind of stream.
o Change FAST-READ-BYTE so that if we do not have a binary stream, we
dispatch to the fast-read-char method to do the right thing.
compiler/dump.lisp:
o With the above changes, we can no longer write characters to a
binary stream, like a FASL file. Make the fasl file a
binary-text-stream so that we can. (Alternatively, we could create
the FASL header as a string, convert to octets and dump the octest
to the file. This is easier, and should still be fast for writing
fasls.)
----------------------------+
code/fd-stream-extfmt.lisp | 178 ++++++++++++++++++++++---------------------
code/fd-stream.lisp | 61 ++++++++++----
code/struct.lisp | 16 +++
code/sysmacs.lisp | 24 +++--
compiler/dump.lisp | 5 -
5 files changed, 170 insertions(+), 114 deletions(-)
Index: src/code/fd-stream-extfmt.lisp
diff -u src/code/fd-stream-extfmt.lisp:1.13 src/code/fd-stream-extfmt.lisp:1.14
--- src/code/fd-stream-extfmt.lisp:1.13 Thu Sep 23 20:36:03 2010
+++ src/code/fd-stream-extfmt.lisp Tue Oct 12 17:52:44 2010
@@ -5,7 +5,7 @@
;;; domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/fd-stream-extfmt.lisp,v 1.13 2010-09-24 00:36:03 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/fd-stream-extfmt.lisp,v 1.14 2010-10-12 21:52:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -70,101 +70,113 @@
(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
+ ;; Set fd-stream-in only if we have an input stream for a
+ ;; character stream or binary-text-stream.
+ (when (and (fd-stream-ibuf-sap stream)
+ (plusp (logand #b101 (lisp-stream-flags stream))))
(setf (fd-stream-in stream) (ef-cin extfmt)))
- (when (fd-stream-obuf-sap stream) ; output stream
+ ;; Set fd-stream-in only if we have an input stream for a
+ ;; character stream or binary-text-stream.
+ (when (and (fd-stream-obuf-sap stream)
+ (plusp (logand #b101 (lisp-stream-flags stream))))
(setf (fd-stream-out stream) (ef-cout extfmt)
;;@@ (fd-stream-sout stream) (ef-sout extfmt)
))
+
;; The following handles the case of setting the external format
;; for input streams where we need to handle the various buffering
- ;; strategies.
- ;;
- (cond
- ((eq old-format (fd-stream-external-format stream))
- ;; Nothing to do if the new and old formats are the same.
- )
- ((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. Or,
- ;; since we have the octet-count, just sum up them up to figure
- ;; out how many octets we've already consumed.
- (let* ((ibuf (lisp-stream-in-buffer stream))
- (sindex (lisp-stream-string-index stream))
- (octet-count (fd-stream-octet-count stream))
- (oc (make-array in-buffer-length :element-type '(unsigned-byte 8)))
- (index (loop for k of-type fixnum from 0 below (1- sindex)
- summing (aref octet-count k))))
- ;; We now know the last octet that was used. Now convert the
- ;; rest of the octets using the new format. The new
- ;; characters are placed in the string buffer at the point
- ;; just after the last character that we've already read.
- (multiple-value-bind (s pos count new-state)
- (stream::octets-to-string-counted ibuf
- oc
- :start index
- :end (fd-stream-in-length stream)
- :external-format (fd-stream-external-format stream)
- :string (lisp-stream-string-buffer stream)
- :s-start sindex
- :error (fd-stream-octets-to-char-error stream))
- (replace octet-count oc :start1 index :end2 pos)
- (cond ((eq (fd-stream-external-format stream) :iso8859-1)
- ;; ISO8859-1 doesn't use the string-buffer, so we
- ;; need to copy the string to the in-buffer and then
- ;; set the string-buffer to nil to indicate we're not
- ;; using the string buffer anymore.
- (let ((index (- in-buffer-length count)))
- (dotimes (k count)
- (setf (aref ibuf (+ k index))
- (char-code (aref s (+ k sindex)))))
- (setf (lisp-stream-in-index stream) index)
- (setf (lisp-stream-string-buffer stream) nil)
- (setf (lisp-stream-string-buffer-len stream) 0)
- (setf (lisp-stream-string-index stream) 0)))
- (t
- (setf (lisp-stream-string-index stream) sindex)
- (setf (lisp-stream-string-buffer-len stream) pos)
- (setf (lisp-stream-in-index stream) (+ index count))
- (setf (fd-stream-oc-state stream) new-state))))))
- ((and updatep (lisp-stream-in-buffer stream))
- ;; This means the external format was ISO8859-1 and we're
- ;; switching to something else. If so, we need to convert all
- ;; the octets that haven't been processed yet and place them in
- ;; the string buffer. We also need to adjust the in-buffer to
- ;; put those octets in the expected place at the beginning of
- ;; in-buffer.
- (let ((index (lisp-stream-in-index stream))
- (ibuf (lisp-stream-in-buffer stream)))
- (setf (lisp-stream-string-buffer stream)
- (make-string (1+ in-buffer-length)))
- (setf (lisp-stream-string-index stream) 1)
- ;; Set the unread char to be the last read octet.
- (setf (aref (lisp-stream-string-buffer stream) 0)
- (code-char (aref ibuf (1- index))))
-
- (let ((oc (or (fd-stream-octet-count stream)
- (setf (fd-stream-octet-count stream)
- (make-array in-buffer-length :element-type '(unsigned-byte 8))))))
+ ;; strategies. But don't change anything if we have a
+ ;; binary-text-stream. In that case, we don't want to set the
+ ;; lisp-stream-in-buffer or lisp-stream-string-buffer which would
+ ;; cause the FAST-READ-CHAR/FAST-READ-BYTE functions to bypass the
+ ;; methods.
+
+ (unless (typep stream 'binary-text-stream)
+ (cond
+ ((eq old-format (fd-stream-external-format stream))
+ ;; Nothing to do if the new and old formats are the same.
+ )
+ ((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. Or,
+ ;; since we have the octet-count, just sum up them up to figure
+ ;; out how many octets we've already consumed.
+ (let* ((ibuf (lisp-stream-in-buffer stream))
+ (sindex (lisp-stream-string-index stream))
+ (octet-count (fd-stream-octet-count stream))
+ (oc (make-array in-buffer-length :element-type '(unsigned-byte 8)))
+ (index (loop for k of-type fixnum from 0 below (1- sindex)
+ summing (aref octet-count k))))
+ ;; We now know the last octet that was used. Now convert the
+ ;; rest of the octets using the new format. The new
+ ;; characters are placed in the string buffer at the point
+ ;; just after the last character that we've already read.
(multiple-value-bind (s pos count new-state)
(stream::octets-to-string-counted ibuf
oc
:start index
+ :end (fd-stream-in-length stream)
:external-format (fd-stream-external-format stream)
:string (lisp-stream-string-buffer stream)
- :s-start 1
+ :s-start sindex
:error (fd-stream-octets-to-char-error stream))
- (declare (ignore s))
- (setf (lisp-stream-string-buffer-len stream) pos)
- (setf (fd-stream-oc-state stream) new-state)
- ;; Move the octets from the end of the in-buffer to the
- ;; beginning. Set the index to the number of octets we've
- ;; processed.
- (replace ibuf ibuf :start2 index)
- (setf (lisp-stream-in-index stream) count))))))
+ (replace octet-count oc :start1 index :end2 pos)
+ (cond ((eq (fd-stream-external-format stream) :iso8859-1)
+ ;; ISO8859-1 doesn't use the string-buffer, so we
+ ;; need to copy the string to the in-buffer and then
+ ;; set the string-buffer to nil to indicate we're not
+ ;; using the string buffer anymore.
+ (let ((index (- in-buffer-length count)))
+ (dotimes (k count)
+ (setf (aref ibuf (+ k index))
+ (char-code (aref s (+ k sindex)))))
+ (setf (lisp-stream-in-index stream) index)
+ (setf (lisp-stream-string-buffer stream) nil)
+ (setf (lisp-stream-string-buffer-len stream) 0)
+ (setf (lisp-stream-string-index stream) 0)))
+ (t
+ (setf (lisp-stream-string-index stream) sindex)
+ (setf (lisp-stream-string-buffer-len stream) pos)
+ (setf (lisp-stream-in-index stream) (+ index count))
+ (setf (fd-stream-oc-state stream) new-state))))))
+ ((and updatep (lisp-stream-in-buffer stream))
+ ;; This means the external format was ISO8859-1 and we're
+ ;; switching to something else. If so, we need to convert all
+ ;; the octets that haven't been processed yet and place them in
+ ;; the string buffer. We also need to adjust the in-buffer to
+ ;; put those octets in the expected place at the beginning of
+ ;; in-buffer.
+ (let ((index (lisp-stream-in-index stream))
+ (ibuf (lisp-stream-in-buffer stream)))
+ (setf (lisp-stream-string-buffer stream)
+ (make-string (1+ in-buffer-length)))
+ (setf (lisp-stream-string-index stream) 1)
+ ;; Set the unread char to be the last read octet.
+ (setf (aref (lisp-stream-string-buffer stream) 0)
+ (code-char (aref ibuf (1- index))))
+
+ (let ((oc (or (fd-stream-octet-count stream)
+ (setf (fd-stream-octet-count stream)
+ (make-array in-buffer-length :element-type '(unsigned-byte 8))))))
+ (multiple-value-bind (s pos count new-state)
+ (stream::octets-to-string-counted ibuf
+ oc
+ :start index
+ :external-format (fd-stream-external-format stream)
+ :string (lisp-stream-string-buffer stream)
+ :s-start 1
+ :error (fd-stream-octets-to-char-error stream))
+ (declare (ignore s))
+ (setf (lisp-stream-string-buffer-len stream) pos)
+ (setf (fd-stream-oc-state stream) new-state)
+ ;; Move the octets from the end of the in-buffer to the
+ ;; beginning. Set the index to the number of octets we've
+ ;; processed.
+ (replace ibuf ibuf :start2 index)
+ (setf (lisp-stream-in-index stream) count)))))))
extfmt))
Index: src/code/fd-stream.lisp
diff -u src/code/fd-stream.lisp:1.120 src/code/fd-stream.lisp:1.121
--- src/code/fd-stream.lisp:1.120 Wed Sep 15 07:32:49 2010
+++ src/code/fd-stream.lisp Tue Oct 12 17:52:44 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/fd-stream.lisp,v 1.120 2010-09-15 11:32:49 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/fd-stream.lisp,v 1.121 2010-10-12 21:52:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -1402,9 +1402,16 @@
(setf (fd-stream-ibuf-sap stream) (next-available-buffer))
(setf (fd-stream-ibuf-length stream) bytes-per-buffer)
(setf (fd-stream-ibuf-tail stream) 0)
+
+ ;; Set the in and bin methods. Normally put an illegal input
+ ;; function in, but if we have a binary text stream, pick an
+ ;; appropriate input routine.
(if (subtypep type 'character)
(setf (fd-stream-in stream) routine
- (fd-stream-bin stream) #'ill-bin)
+ (fd-stream-bin stream) (if (and binary-stream-p
+ (eql size 1))
+ (pick-input-routine '(unsigned-byte 8))
+ #'ill-bin))
(setf (fd-stream-in stream) (if (and binary-stream-p
(eql size 1))
(pick-input-routine 'character)
@@ -1423,17 +1430,17 @@
(or (eq 'unsigned-byte (and (consp type) (car type)))
(eq type :default))
(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.
(when *enable-stream-buffer-p*
- (setf (lisp-stream-in-buffer stream)
- (make-array in-buffer-length
- :element-type '(unsigned-byte 8)))
+ (when (and (not binary-stream-p)
+ (eq type 'character))
+ ;; Create the in-buffer for any character (only)
+ ;; stream. Don't want one for binary-text-streams!
+ (setf (lisp-stream-in-buffer stream)
+ (make-array in-buffer-length
+ :element-type '(unsigned-byte 8))))
#+unicode
- (when (and (eq type 'character)
+ (when (and (not binary-stream-p)
+ (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
@@ -1444,6 +1451,7 @@
;; 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 (fd-stream-octet-count stream)
@@ -1464,15 +1472,23 @@
(setf (fd-stream-obuf-sap stream) (next-available-buffer))
(setf (fd-stream-obuf-length stream) bytes-per-buffer)
(setf (fd-stream-obuf-tail stream) 0)
+ ;; Normally signal errors for reading from a stream with the
+ ;; wrong element type, but allow binary-text-streams to read
+ ;; from either.
(if (subtypep type 'character)
- (setf (fd-stream-out stream) routine
- (fd-stream-bout stream) #'ill-bout)
- (setf (fd-stream-out stream)
- (or (if (eql size 1)
+ (setf (fd-stream-out stream) routine
+ (fd-stream-bout stream)
+ (if (and binary-stream-p
+ (eql size 1))
+ (pick-output-routine '(unsigned-byte 8)
+ (fd-stream-buffering stream))
+ #'ill-bout))
+ (setf (fd-stream-out stream)
+ (if (and binary-stream-p (eql size 1))
(pick-output-routine 'base-char
- (fd-stream-buffering stream)))
- #'ill-out)
- (fd-stream-bout stream) routine))
+ (fd-stream-buffering stream))
+ #'ill-out)
+ (fd-stream-bout stream) routine))
(setf (fd-stream-sout stream)
(if (eql size 1) #'fd-sout #'ill-out))
(setf (fd-stream-char-pos stream) 0)
@@ -1880,6 +1896,15 @@
:timeout timeout
:char-to-octets-error e
:octets-to-char-error d)))))
+ ;; Set the lisp-stream flags appropriately for the kind of stream
+ ;; we have (character, binary, binary-text-stream).
+ (cond ((typep stream 'binary-text-stream)
+ (setf (fd-stream-flags stream) #b100))
+ ((subtypep element-type 'character)
+ (setf (fd-stream-flags stream) #b001))
+ (t
+ (setf (fd-stream-flags stream) #b010)))
+
;; FIXME: setting the external format here should be better
;; integrated into set-routines. We do it before so that
;; set-routines can create an in-buffer if appropriate. But we
Index: src/code/struct.lisp
diff -u src/code/struct.lisp:1.25 src/code/struct.lisp:1.26
--- src/code/struct.lisp:1.25 Sun Aug 15 08:04:44 2010
+++ src/code/struct.lisp Tue Oct 12 17:52:44 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/struct.lisp,v 1.25 2010-08-15 12:04:44 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/struct.lisp,v 1.26 2010-10-12 21:52:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -61,7 +61,19 @@
;; in string-buffer. This is basically unused, except by
;; FILE-POSITION so that we can get the correct file position.
#+unicode
- (octet-count nil :type (or null (simple-array (unsigned-byte 8) (*)))))
+ (octet-count nil :type (or null (simple-array (unsigned-byte 8) (*))))
+ ;;
+ ;; Flags indicating if the stream is a character stream, binary
+ ;; stream or binary-text-stream. This is somewhat redundant because
+ ;; binary-text-stream is its own type (defstruct). But we can't
+ ;; easily distinguish a character stream from a binary stream.
+ ;;
+ ;; #b001 - character (only) stream
+ ;; #b010 - binary (only) stream
+ ;; #b100 - binary-text-stream (supports character and binary)
+ ;;
+ ;; It is an error if both character and binary bits are set.
+ (flags 0 :type fixnum))
(declaim (inline streamp))
(defun streamp (stream)
Index: src/code/sysmacs.lisp
diff -u src/code/sysmacs.lisp:1.34 src/code/sysmacs.lisp:1.35
--- src/code/sysmacs.lisp:1.34 Sun Jul 4 23:40:02 2010
+++ src/code/sysmacs.lisp Tue Oct 12 17:52:44 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/sysmacs.lisp,v 1.34 2010-07-05 03:40:02 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/sysmacs.lisp,v 1.35 2010-10-12 21:52:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -184,6 +184,9 @@
;;;
(defmacro fast-read-char (&optional (eof-errorp t) (eof-value ()))
`(cond
+ ((/= (lisp-stream-flags %frc-stream%) 1)
+ ;; Call the method if we're doing a read-char on a character stream.
+ (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value))
#+unicode
(%frc-string-buffer%
(cond ((>= %frc-string-index% %frc-string-length%)
@@ -231,14 +234,17 @@
`(truly-the
,(if (and (eq eof-errorp 't) (not any-type)) '(unsigned-byte 8) 't)
(cond
- ((not %frc-buffer%)
- (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value))
- ((= %frc-index% in-buffer-length)
- (prog1 (fast-read-byte-refill %frc-stream% ,eof-errorp ,eof-value)
- (setq %frc-index% (lisp-stream-in-index %frc-stream%))))
- (t
- (prog1 (aref %frc-buffer% %frc-index%)
- (incf %frc-index%))))))
+ ((or (not %frc-buffer%) (/= (lisp-stream-flags %frc-stream%) #b10))
+ ;; Call the method if we're doing a read-byte on a stream that
+ ;; is has no in-buffer (a binary-text-stream) or is not a
+ ;; binary stream (flags /= #b10).
+ (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value))
+ ((= %frc-index% in-buffer-length)
+ (prog1 (fast-read-byte-refill %frc-stream% ,eof-errorp ,eof-value)
+ (setq %frc-index% (lisp-stream-in-index %frc-stream%))))
+ (t
+ (prog1 (aref %frc-buffer% %frc-index%)
+ (incf %frc-index%))))))
;;;
(defmacro done-with-fast-read-byte ()
`(progn
Index: src/compiler/dump.lisp
diff -u src/compiler/dump.lisp:1.87 src/compiler/dump.lisp:1.88
--- src/compiler/dump.lisp:1.87 Tue Jun 1 16:27:09 2010
+++ src/compiler/dump.lisp Tue Oct 12 17:52:44 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/dump.lisp,v 1.87 2010-06-01 20:27:09 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/dump.lisp,v 1.88 2010-10-12 21:52:44 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -383,7 +383,8 @@
(declare (type pathname name))
(let* ((stream (open name :direction :output
:if-exists :rename-and-delete
- :element-type '(unsigned-byte 8)))
+ :element-type '(unsigned-byte 8)
+ :class 'binary-text-stream))
(res (make-fasl-file :stream stream)))
(multiple-value-bind
(version f-vers f-imp)
More information about the cmucl-cvs
mailing list