From 77d1a39f28fe8d240cf441a9a54a80d4bc98ea52 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 3 Mar 2005 17:15:17 +0000 Subject: [PATCH] 0.8.20.6: Make FILE-STREAM and STRING-STREAM potential mixins in CLOS (... and also, hackily, into structures.) ... adjust FD-STREAM, and the various ANSI string streams. ... sb-simple-streams can now make file-simple-stream and string-simple-stream subclasses (and hence subtypep) the relevant mixin. Caveat downloader I: This merge includes David Lichteblau's sb-simple-streams test suite extension, from which seven tests fail. Caveat downloader II: debug.impure.lisp is failing for me on x86/Linux. I'm pretty sure this is not my fault -- I blame the debugger restructuring -- but it could be anyway. Caveat user: Bad Things happen if you try to mix both string-stream and file-stream into the same subclass. Don't Do It. --- NEWS | 3 + contrib/sb-simple-streams/classes.lisp | 2 +- contrib/sb-simple-streams/file.lisp | 2 +- contrib/sb-simple-streams/impl.lisp | 8 +- contrib/sb-simple-streams/simple-stream-tests.lisp | 568 ++++++++++++++++++++ package-data-list.lisp-expr | 2 +- src/code/class.lisp | 12 +- src/code/defstruct.lisp | 45 +- src/code/fd-stream.lisp | 34 +- src/code/stream.lisp | 42 +- src/pcl/defs.lisp | 9 +- src/pcl/early-low.lisp | 3 +- src/pcl/std-class.lisp | 8 +- version.lisp-expr | 2 +- 14 files changed, 660 insertions(+), 80 deletions(-) diff --git a/NEWS b/NEWS index deed90b..36f03f1 100644 --- a/NEWS +++ b/NEWS @@ -15,6 +15,9 @@ changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20: (reported by Lutz Euler) * fixed bug: (TYPEP X '(MEMBER ...)) no longer returns a list in compiled code. (reported by Paul Dietz) + * contrib improvement: the SB-SIMPLE-STREAMS contrib now defines + STRING-SIMPLE-STREAM and FILE-SIMPLE-STREAM as subclasses of + STRING-STREAM and FILE-STREAM, respectively. changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.19: * fixed inspection of specialized arrays. (thanks to Simon Alexander) diff --git a/contrib/sb-simple-streams/classes.lisp b/contrib/sb-simple-streams/classes.lisp index 0bc782d..6007d6e 100644 --- a/contrib/sb-simple-streams/classes.lisp +++ b/contrib/sb-simple-streams/classes.lisp @@ -132,7 +132,7 @@ (max-out-pos :initform 0 :type fixnum))) ;;; A stream with a string as buffer. -(def-stream-class string-simple-stream (simple-stream) +(def-stream-class string-simple-stream (simple-stream string-stream) ()) diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp index 5fd3d70..2e20b2a 100644 --- a/contrib/sb-simple-streams/file.lisp +++ b/contrib/sb-simple-streams/file.lisp @@ -14,7 +14,7 @@ ;;; ;;; Definition of File-Simple-Stream and relations -(def-stream-class file-simple-stream (single-channel-simple-stream) +(def-stream-class file-simple-stream (single-channel-simple-stream file-stream) ((pathname :initform nil :initarg :pathname) (filename :initform nil :initarg :filename) (original :initform nil :initarg :original) diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index 79fe4c4..1e22e1c 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -687,10 +687,10 @@ :output-handle - a stream or Unix file descriptor to write to" (declare (ignore element-type external-format input-handle output-handle if-exists if-does-not-exist)) - (let ((class (or class 'sb-sys::file-stream)) + (let ((class (or class 'sb-sys:fd-stream)) (options (copy-list options)) (filespec (merge-pathnames filename))) - (cond ((eq class 'sb-sys::file-stream) + (cond ((eq class 'sb-sys:fd-stream) (remf options :class) (remf options :mapped) (remf options :input-handle) @@ -1082,7 +1082,7 @@ is supported only on simple-streams." (synonym-stream (wait-for-input-available (symbol-value (synonym-stream-symbol stream)) timeout)) - (sb-sys::file-stream + (sb-sys:fd-stream (or (< (sb-impl::fd-stream-in-index stream) (length (sb-impl::fd-stream-in-buffer stream))) (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout)))))) @@ -1096,7 +1096,7 @@ is supported only on simple-streams." (%file-rename stream new-name)) (t (%file-name stream))))) - (sb-sys::file-stream + (sb-sys:fd-stream (cond (new-name (setf (sb-impl::fd-stream-pathname stream) new-name) (setf (sb-impl::fd-stream-file stream) diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp index 6532994..182b752 100644 --- a/contrib/sb-simple-streams/simple-stream-tests.lisp +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -346,3 +346,571 @@ (equalp uvector result-uvector) (equalp svector result-svector))) T) + +(defparameter *multi-line-string* + "This file was created by simple-stream-tests.lisp. +Nothing to see here, move along.") + +(defmacro with-dc-test-stream ((s &key initial-content) &body body) + `(with-test-file + (.ansi-stream. + *test-file* + :direction :io + :if-exists :overwrite + :initial-content ,(or initial-content '*multi-line-string*)) + (let ((,s (make-instance 'terminal-simple-stream + :input-handle (sb-kernel::fd-stream-fd .ansi-stream.) + :output-handle (sb-kernel::fd-stream-fd .ansi-stream.)))) + ,@body))) + +(defmacro with-sc-test-stream ((s &key initial-content) &body body) + `(with-test-file + (,s + *test-file* + :class 'file-simple-stream + :direction :io + :if-exists :overwrite + :initial-content ,(or initial-content '*multi-line-string*)) + ,@body)) + +;;; 0.8.3.93 tried to fix LISTEN on dual channel streams, but failed to do so: + +(deftest listen-dc-1 + ;; LISTEN with filled buffer + (with-dc-test-stream (s) (read-char s) (listen s)) + T) + +(deftest listen-dc-2 + ;; LISTEN with empty buffer + (with-dc-test-stream (s) (listen s)) + T) + +(deftest listen-dc-3 + ;; LISTEN at EOF + (with-dc-test-stream (s) + (read-line s) + (read-line s) + (listen s)) + NIL) + +;;; the following tests are for problems fixed in SBCL 0.8.6.2: + +(deftest charpos-1 + ;; check for bug involving the -1 vs. 0 oddity in std-dc-newline-in-handler + ;; + ;; Note: It not not clear to me that input should affect the CHARPOS at + ;; all. (Except for a terminal stream perhaps, which our test stream + ;; happens to be. Hmm.) + ;; + ;; But CHARPOS must not be -1, so much is sure, hence this test is right + ;; in any case. + (with-dc-test-stream (s) + (read-line s) + (sb-simple-streams:charpos s)) + 0) + +(deftest charpos-2 + ;; FIXME: It not not clear to me that input should affect the CHARPOS at + ;; all, and indeed it does not. That is, except for newlines?! (see above) + ;; + ;; What this test does is (a) check that the CHARPOS works at all without + ;; erroring and (b) force anyone changing the CHARPOS behaviour to read + ;; this comment and start thinking things through better than I can. + (with-dc-test-stream (s) + (read-char s) + (and (eql (sb-kernel:charpos s) 0) + (eql (sb-simple-streams:charpos s) 0))) + T) + +(deftest reader-1 + ;; does the reader support simple streams? Note that, say, "123" instead + ;; of "(1 2)" does not trigger the bugs present in SBCL 0.8.6. + (with-dc-test-stream (s :initial-content "(1 2)") + (equal (read s) '(1 2))) + T) + +(deftest line-length-dc-1 + ;; does LINE-LENGTH support simple streams? + (with-dc-test-stream (s) + (eql (sb-simple-streams:line-length s) + (sb-kernel:line-length s))) + T) + +(defvar *synonym*) + +;; the biggest change in 0.8.6.2: +;; support composite streams writing to simple streams + +;; first, SYNONYM-STREAM: + +(deftest synonym-stream-1 + ;; READ-CHAR + (with-dc-test-stream (*synonym*) + (read-char (make-synonym-stream '*synonym*))) + #\T) + +(deftest synonym-stream-2 + ;; UNREAD-CHAR (via STREAM-MISC-DISPATCH) + (with-dc-test-stream (*synonym*) + (let ((s (make-synonym-stream '*synonym*))) + (unread-char (read-char s) s) + (read-char s))) + #\T) + +(deftest synonym-stream-3 + ;; READ-BYTE + (with-dc-test-stream (*synonym*) + (read-byte (make-synonym-stream '*synonym*))) + #.(char-code #\T)) + +(deftest synonym-stream-4 + ;; WRITE-CHAR + (with-sc-test-stream (*synonym*) + (let ((s (make-synonym-stream '*synonym*))) + (write-char #\A s) + (file-position s 0) + (read-char s))) + #\A) + +(deftest synonym-stream-5 + ;; WRITE-BYTE + (with-sc-test-stream (*synonym*) + (let ((s (make-synonym-stream '*synonym*))) + (write-byte 65 s) + (file-position s 0) + (read-char s))) + #\A) + +(deftest synonym-stream-6 + ;; WRITE-STRING + (with-sc-test-stream (*synonym*) + (let ((s (make-synonym-stream '*synonym*))) + (write-string "ab" s) + (file-position s 0) + (and (char= (read-char s) #\a) + (char= (read-char s) #\b)))) + T) + +(deftest synonym-stream-7 + ;; LISTEN (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (let ((s (make-synonym-stream '*synonym*))) + (and (listen s) t))) + T) + +(deftest synonym-stream-8 + ;; CLEAR-INPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (let ((s (make-synonym-stream '*synonym*))) + (clear-input s) + (listen s))) + NIL) + +(deftest synonym-stream-9 + ;; FORCE-OUTPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + ;; could test more here + (force-output (make-synonym-stream '*synonym*))) + NIL) + +(deftest synonym-stream-10 + ;; FINISH-OUTPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + ;; could test more here + (finish-output (make-synonym-stream '*synonym*))) + NIL) + +(deftest synonym-stream-11 + ;; STREAM-ELEMENT-TYPE (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (stream-element-type (make-synonym-stream '*synonym*)) + (stream-element-type *synonym*))) + T) + +(deftest synonym-stream-12 + ;; INTERACTIVE-STREAM-P (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (interactive-stream-p (make-synonym-stream '*synonym*)) + (interactive-stream-p *synonym*))) + T) + +(deftest synonym-stream-13 + ;; LINE-LENGTH (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (sb-kernel:line-length (make-synonym-stream '*synonym*)) + (sb-kernel:line-length *synonym*))) + T) + +(deftest synonym-stream-14 + ;; CHARPOS (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (sb-kernel:charpos (make-synonym-stream '*synonym*)) + (sb-kernel:charpos *synonym*))) + T) + +(deftest synonym-stream-15 + ;; FILE-LENGTH (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (file-length (make-synonym-stream '*synonym*)) + (file-length *synonym*))) + T) + +(deftest synonym-stream-16 + ;; FILE-POSITION (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (file-position (make-synonym-stream '*synonym*)) + (file-position *synonym*))) + T) + +;; SYNONYM-STREAM tests repeated for BROADCAST-STREAM, where applicable + +(deftest broadcast-stream-4 + ;; WRITE-CHAR + (with-sc-test-stream (synonym) + (let ((s (make-broadcast-stream synonym))) + (write-char #\A s) + (force-output s)) + (file-position synonym 0) + (read-char synonym)) + #\A) + +(deftest broadcast-stream-5 + ;; WRITE-BYTE + (with-sc-test-stream (synonym) + (let ((s (make-broadcast-stream synonym))) + (write-byte 65 s) + (force-output s)) + (file-position synonym 0) + (read-char synonym)) + #\A) + +(deftest broadcast-stream-6 + ;; WRITE-STRING + (with-sc-test-stream (synonym) + (let ((s (make-broadcast-stream synonym))) + (write-string "ab" s) + (force-output s)) + (file-position synonym 0) + (and (char= (read-char synonym) #\a) + (char= (read-char synonym) #\b))) + T) + +(deftest broadcast-stream-9 + ;; FORCE-OUTPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + ;; could test more here + (force-output (make-broadcast-stream synonym))) + NIL) + +(deftest broadcast-stream-10 + ;; FINISH-OUTPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + ;; could test more here + (finish-output (make-broadcast-stream synonym))) + NIL) + +(deftest broadcast-stream-11 + ;; STREAM-ELEMENT-TYPE (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (stream-element-type (make-broadcast-stream synonym)) + (stream-element-type synonym))) + T) + +(deftest broadcast-stream-12 + ;; INTERACTIVE-STREAM-P (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (interactive-stream-p (make-broadcast-stream synonym)) + (interactive-stream-p synonym))) + T) + +(deftest broadcast-stream-13 + ;; LINE-LENGTH (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (sb-kernel:line-length (make-broadcast-stream synonym)) + (sb-kernel:line-length synonym))) + T) + +(deftest broadcast-stream-14 + ;; CHARPOS (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (sb-kernel:charpos (make-broadcast-stream synonym)) + (sb-kernel:charpos synonym))) + T) + +(deftest broadcast-stream-16 + ;; FILE-POSITION (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (file-position (make-broadcast-stream synonym)) + (file-position synonym))) + T) + +;; SYNONYM-STREAM tests repeated for TWO-WAY-STREAM, where applicable + +(deftest two-way-stream-1 + ;; READ-CHAR + (with-dc-test-stream (synonym) + (read-char (make-two-way-stream synonym synonym))) + #\T) + +(deftest two-way-stream-2 + ;; UNREAD-CHAR (via STREAM-MISC-DISPATCH) + (with-dc-test-stream (synonym) + (let ((s (make-two-way-stream synonym synonym))) + (unread-char (read-char s) s) + (read-char s))) + #\T) + +(deftest two-way-stream-3 + ;; READ-BYTE + (with-dc-test-stream (synonym) + (read-byte (make-two-way-stream synonym synonym))) + #.(char-code #\T)) + +(deftest two-way-stream-4 + ;; WRITE-CHAR + (with-sc-test-stream (synonym) + (let ((s (make-two-way-stream synonym synonym))) + (write-char #\A s) + (force-output s)) + (file-position synonym 0) + (read-char synonym)) + #\A) + +(deftest two-way-stream-5 + ;; WRITE-BYTE + (with-sc-test-stream (synonym) + (let ((s (make-two-way-stream synonym synonym))) + (write-byte 65 s) + (force-output s)) + (file-position synonym 0) + (read-char synonym)) + #\A) + +(deftest two-way-stream-6 + ;; WRITE-STRING + (with-sc-test-stream (synonym) + (let ((s (make-two-way-stream synonym synonym))) + (write-string "ab" s) + (force-output s)) + (file-position synonym 0) + (and (char= (read-char synonym) #\a) + (char= (read-char synonym) #\b))) + T) + +(deftest two-way-stream-7 + ;; LISTEN (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (let ((s (make-two-way-stream synonym synonym))) + (and (listen s) t))) + T) + +(deftest two-way-stream-8 + ;; CLEAR-INPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (let ((s (make-two-way-stream synonym synonym))) + (clear-input s) + (listen s))) + NIL) + +(deftest two-way-stream-9 + ;; FORCE-OUTPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + ;; could test more here + (force-output (make-two-way-stream synonym synonym))) + NIL) + +(deftest two-way-stream-10 + ;; FINISH-OUTPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + ;; could test more here + (finish-output (make-two-way-stream synonym synonym))) + NIL) + +(deftest two-way-stream-11 + ;; STREAM-ELEMENT-TYPE (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (stream-element-type (make-two-way-stream synonym synonym)) + (stream-element-type synonym))) + T) + +(deftest two-way-stream-12 + ;; INTERACTIVE-STREAM-P (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (interactive-stream-p (make-two-way-stream synonym synonym)) + (interactive-stream-p synonym))) + T) + +(deftest two-way-stream-13 + ;; LINE-LENGTH (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (sb-kernel:line-length (make-two-way-stream synonym synonym)) + (sb-kernel:line-length synonym))) + T) + +(deftest two-way-stream-14 + ;; CHARPOS (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (sb-kernel:charpos (make-two-way-stream synonym synonym)) + (sb-kernel:charpos synonym))) + T) + +(deftest two-way-stream-16 + ;; FILE-POSITION (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (synonym) + (eql (file-position (make-two-way-stream synonym synonym)) + (file-position synonym))) + T) + +;; SYNONYM-STREAM tests repeated for ECHO-STREAM, where applicable + +(deftest echo-stream-1 + ;; READ-CHAR + (with-dc-test-stream (*synonym*) + (read-char (make-echo-stream *synonym* *synonym*))) + #\T) + +(deftest echo-stream-2 + ;; UNREAD-CHAR (via STREAM-MISC-DISPATCH) + (with-dc-test-stream (*synonym*) + (let ((s (make-echo-stream *synonym* *synonym*))) + (unread-char (read-char s) s) + (read-char s))) + #\T) + +(deftest echo-stream-3 + ;; READ-BYTE + (with-dc-test-stream (*synonym*) + (read-byte (make-echo-stream *synonym* *synonym*))) + #.(char-code #\T)) + +(deftest echo-stream-7 + ;; LISTEN (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (let ((s (make-echo-stream *synonym* *synonym*))) + (and (listen s) t))) + T) + +(deftest echo-stream-8 + ;; CLEAR-INPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (let ((s (make-echo-stream *synonym* *synonym*))) + (clear-input s) + (listen s))) + NIL) + +(deftest echo-stream-11 + ;; STREAM-ELEMENT-TYPE (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (stream-element-type (make-echo-stream *synonym* *synonym*)) + (stream-element-type *synonym*))) + T) + +(deftest echo-stream-12 + ;; INTERACTIVE-STREAM-P (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (interactive-stream-p (make-echo-stream *synonym* *synonym*)) + (interactive-stream-p *synonym*))) + T) + +(deftest echo-stream-13 + ;; LINE-LENGTH (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (sb-kernel:line-length (make-echo-stream *synonym* *synonym*)) + (sb-kernel:line-length *synonym*))) + T) + +(deftest echo-stream-14 + ;; CHARPOS (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (sb-kernel:charpos (make-echo-stream *synonym* *synonym*)) + (sb-kernel:charpos *synonym*))) + T) + +(deftest echo-stream-16 + ;; FILE-POSITION (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (file-position (make-echo-stream *synonym* *synonym*)) + (file-position *synonym*))) + T) + +;; SYNONYM-STREAM tests repeated for CONCATENATED-STREAM, where applicable + +(deftest concatenated-stream-1 + ;; READ-CHAR + (with-dc-test-stream (*synonym*) + (read-char (make-concatenated-stream *synonym*))) + #\T) + +(deftest concatenated-stream-2 + ;; UNREAD-CHAR (via STREAM-MISC-DISPATCH) + (with-dc-test-stream (*synonym*) + (let ((s (make-concatenated-stream *synonym*))) + (unread-char (read-char s) s) + (read-char s))) + #\T) + +(deftest concatenated-stream-3 + ;; READ-BYTE + (with-dc-test-stream (*synonym*) + (read-byte (make-concatenated-stream *synonym*))) + #.(char-code #\T)) + +(deftest concatenated-stream-7 + ;; LISTEN (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (let ((s (make-concatenated-stream *synonym*))) + (and (listen s) t))) + T) + +(deftest concatenated-stream-8 + ;; CLEAR-INPUT (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (let ((s (make-concatenated-stream *synonym*))) + (clear-input s) + (listen s))) + NIL) + +(deftest concatenated-stream-11 + ;; STREAM-ELEMENT-TYPE (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (stream-element-type (make-concatenated-stream *synonym*)) + (stream-element-type *synonym*))) + T) + +(deftest concatenated-stream-12 + ;; INTERACTIVE-STREAM-P (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (interactive-stream-p (make-concatenated-stream *synonym*)) + (interactive-stream-p *synonym*))) + T) + +(deftest concatenated-stream-13 + ;; LINE-LENGTH (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (sb-kernel:line-length (make-concatenated-stream *synonym*)) + (sb-kernel:line-length *synonym*))) + T) + +(deftest concatenated-stream-14 + ;; CHARPOS (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (sb-kernel:charpos (make-concatenated-stream *synonym*)) + (sb-kernel:charpos *synonym*))) + T) + +(deftest concatenated-stream-16 + ;; FILE-POSITION (via STREAM-MISC-DISPATCH) + (with-sc-test-stream (*synonym*) + (eql (file-position (make-concatenated-stream *synonym*)) + (file-position *synonym*))) + T) + +;; uncovered by synonym-stream-15 + +(deftest file-simple-stream-1 + (values (subtypep 'file-simple-stream 'file-stream)) + T) + +(deftest string-simple-stream-1 + (values (subtypep 'string-simple-stream 'string-stream)) + T) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index bb690af..8d5c316 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1810,7 +1810,7 @@ SB-KERNEL) have been undone, but probably more remain." "DLOPEN-OR-LOSE" "FROB-DO-BODY" "ENABLE-INTERRUPT" "ENUMERATION" - "FD-STREAM-FD" "FD-STREAM-P" + "FD-STREAM" "FD-STREAM-FD" "FD-STREAM-P" "FIND-FOREIGN-SYMBOL-IN-TABLE" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-ADDRESS-AS-INTEGER" diff --git a/src/code/class.lisp b/src/code/class.lisp index 3b0b40d..535914c 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -1271,12 +1271,18 @@ NIL is returned when no such class exists." :inherits (symbol list sequence) :direct-superclasses (symbol list) :prototype-form 'nil) - (stream :state :read-only :depth 3 - :inherits (instance) - :prototype-form (make-broadcast-stream))))) + :inherits (instance)) + (file-stream + :state :read-only + :depth 5 + :inherits (stream)) + (string-stream + :state :read-only + :depth 5 + :inherits (stream))))) ;;; See also src/code/class-init.lisp where we finish setting up the ;;; translations for built-in types. diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 5c3ff13..ef5559c 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -843,15 +843,26 @@ (classoid-layout (find-classoid (or (first superclass-opt) 'structure-object)))))) - (if (eq (dd-name info) 'ansi-stream) - ;; a hack to add the CL:STREAM class as a mixin for ANSI-STREAMs - (concatenate 'simple-vector - (layout-inherits super) - (vector super - (classoid-layout (find-classoid 'stream)))) - (concatenate 'simple-vector - (layout-inherits super) - (vector super))))) + (case (dd-name info) + ((ansi-stream) + (concatenate 'simple-vector + (layout-inherits super) + (vector super (classoid-layout (find-classoid 'stream))))) + ((fd-stream) + (concatenate 'simple-vector + (layout-inherits super) + (vector super + (classoid-layout (find-classoid 'file-stream))))) + ((sb!impl::string-input-stream + sb!impl::string-output-stream + sb!impl::fill-pointer-output-stream) + (concatenate 'simple-vector + (layout-inherits super) + (vector super + (classoid-layout (find-classoid 'string-stream))))) + (t (concatenate 'simple-vector + (layout-inherits super) + (vector super)))))) ;;; Do miscellaneous (LOAD EVAL) time actions for the structure ;;; described by DD. Create the class and LAYOUT, checking for @@ -1168,12 +1179,16 @@ (sb!xc:typep x (find-classoid class)))) (fdefinition constructor))) (setf (classoid-direct-superclasses class) - (if (eq (dd-name info) 'ansi-stream) - ;; a hack to add CL:STREAM as a superclass mixin to ANSI-STREAMs - (list (layout-classoid (svref inherits (1- (length inherits)))) - (layout-classoid (svref inherits (- (length inherits) 2)))) - (list (layout-classoid - (svref inherits (1- (length inherits))))))) + (case (dd-name info) + ((ansi-stream + fd-stream + sb!impl::string-input-stream sb!impl::string-output-stream + sb!impl::fill-pointer-output-stream) + (list (layout-classoid (svref inherits (1- (length inherits)))) + (layout-classoid (svref inherits (- (length inherits) 2))))) + (t + (list (layout-classoid + (svref inherits (1- (length inherits)))))))) (let ((new-layout (make-layout :classoid class :inherits inherits :depthoid (length inherits) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 11a105e..ea3e116 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -31,16 +31,10 @@ (pop *available-buffers*) (allocate-system-memory bytes-per-buffer))) -;;;; the FILE-STREAM structure +;;;; the FD-STREAM structure -(defstruct (file-stream +(defstruct (fd-stream (:constructor %make-fd-stream) - ;; KLUDGE: in an ideal world, maybe we'd rewrite - ;; everything to use FILE-STREAM rather than simply - ;; providing this hack for compatibility with the old - ;; code. However, CVS doesn't deal terribly well with - ;; file renaming, so for now we use this - ;; backward-compatibility feature. (:conc-name fd-stream-) (:predicate fd-stream-p) (:include ansi-stream @@ -89,7 +83,7 @@ (pathname nil :type (or pathname null)) (external-format :default) (output-bytes #'ill-out :type function)) -(def!method print-object ((fd-stream file-stream) stream) +(def!method print-object ((fd-stream fd-stream) stream) (declare (type stream stream)) (print-unreadable-object (fd-stream stream :type t :identity t) (format stream "for ~S" (fd-stream-name fd-stream)))) @@ -182,7 +176,7 @@ ;;; writes. If so, just queue this one. Otherwise, try to write it. If ;;; this would block, queue it. (defun frob-output (stream base start end reuse-sap) - (declare (type file-stream stream) + (declare (type fd-stream stream) (type (or system-area-pointer (simple-array * (*))) base) (type index start end)) (if (not (null (fd-stream-output-later stream))) ; something buffered. @@ -899,7 +893,7 @@ ;;; isn't too problematical. (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p &aux (total-copied 0)) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (let ((unread (fd-stream-unread stream))) (when unread @@ -1030,7 +1024,7 @@ ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p &aux (total-copied 0)) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (let ((unread (fd-stream-unread stream))) (when unread @@ -1134,7 +1128,7 @@ ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p &aux (total-copied 0)) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (let ((unread (fd-stream-unread stream))) (when unread @@ -1595,7 +1589,7 @@ ;; appropriate value for the EXPECTED-TYPE slot.. (error 'simple-type-error :datum fd-stream - :expected-type 'file-stream + :expected-type 'fd-stream :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) (multiple-value-bind (okay dev ino mode nlink uid gid rdev size @@ -1612,7 +1606,7 @@ (fd-stream-file-position fd-stream arg1)))) (defun fd-stream-file-position (stream &optional newpos) - (declare (type file-stream stream) + (declare (type fd-stream stream) (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos)) (if (null newpos) (sb!sys:without-interrupts @@ -2010,7 +2004,7 @@ ;;; ;;; FIXME: misleading name, screwy interface (defun file-name (stream &optional new-name) - (when (typep stream 'file-stream) + (when (typep stream 'fd-stream) (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream) @@ -2027,7 +2021,7 @@ ;;;; COMMON-LISP.) (defun file-string-length (stream object) - (declare (type (or string character) object) (type file-stream stream)) + (declare (type (or string character) object) (type fd-stream stream)) #!+sb-doc "Return the delta in STREAM's FILE-POSITION that would be caused by writing OBJECT to STREAM. Non-trivial only in implementations that support @@ -2038,9 +2032,9 @@ (string (length object)))) (defun stream-external-format (stream) - (declare (type file-stream stream)) + (declare (type fd-stream stream)) #!+sb-doc - "Return the actual external format for file-streams, otherwise :DEFAULT." - (if (typep stream 'file-stream) + "Return the actual external format for fd-streams, otherwise :DEFAULT." + (if (typep stream 'fd-stream) (fd-stream-external-format stream) :default)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index ed87695..48687ad 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1020,32 +1020,18 @@ (aver (= numbytes (+ new-start bytes-read))) numbytes))))) -;;;; base STRING-STREAM stuff - -(defstruct (string-stream - (:include ansi-stream) - (:constructor nil) - (:copier nil)) - ;; FIXME: This type declaration is true, and will probably continue - ;; to be true. However, note well the comments in DEFTRANSFORM - ;; REPLACE, implying that performance of REPLACE is somewhat - ;; critical to performance of string streams. If (VECTOR CHARACTER) - ;; ever becomes different from (VECTOR BASE-CHAR), the transform - ;; probably needs to be extended. - (string (missing-arg) :type (vector character))) - ;;;; STRING-INPUT-STREAM stuff (defstruct (string-input-stream - (:include string-stream + (:include ansi-stream (in #'string-inch) (bin #'ill-bin) (n-bin #'ill-bin) - (misc #'string-in-misc) - (string (missing-arg) :type simple-string)) + (misc #'string-in-misc)) (:constructor internal-make-string-input-stream (string current end)) (:copier nil)) + (string (missing-arg) :type simple-string) (current (missing-arg) :type index) (end (missing-arg) :type index)) @@ -1136,17 +1122,16 @@ ;;;; STRING-OUTPUT-STREAM stuff (defstruct (string-output-stream - (:include string-stream + (:include ansi-stream (out #'string-ouch) (sout #'string-sout) - (misc #'string-out-misc) - ;; The string we throw stuff in. - (string (missing-arg) - :type (simple-array character (*)))) + (misc #'string-out-misc)) (:constructor make-string-output-stream (&key (element-type 'character) &aux (string (make-string 40)))) (:copier nil)) + ;; The string we throw stuff in. + (string (missing-arg) :type (simple-array character (*))) ;; Index of the next location to use. (index 0 :type fixnum) ;; Index cache for string-output-stream-last-index @@ -1287,17 +1272,14 @@ (satisfies array-has-fill-pointer-p))) (defstruct (fill-pointer-output-stream - (:include string-stream + (:include ansi-stream (out #'fill-pointer-ouch) (sout #'fill-pointer-sout) - (misc #'fill-pointer-misc) - ;; a string with a fill pointer where we stuff - ;; the stuff we write - (string (missing-arg) - :type string-with-fill-pointer - :read-only t)) + (misc #'fill-pointer-misc)) (:constructor make-fill-pointer-output-stream (string)) - (:copier nil))) + (:copier nil)) + ;; a string with a fill pointer where we stuff the stuff we write + (string (missing-arg) :type string-with-fill-pointer :read-only t)) (defun fill-pointer-ouch (stream character) (let* ((buffer (fill-pointer-output-stream-string stream)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 2de8e27..534a6c2 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -306,7 +306,8 @@ ;; CMU CL code did. -- WHN 20000715 '(t instance funcallable-instance - function stream))) + function stream + file-stream string-stream))) sb-kernel::*built-in-classes*)))) (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") @@ -327,6 +328,12 @@ (defclass stream (instance) () (:metaclass built-in-class)) +(defclass file-stream (stream) () + (:metaclass built-in-class)) + +(defclass string-stream (stream) () + (:metaclass built-in-class)) + (defclass slot-object (t) () (:metaclass slot-class)) diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index cfad90f..046f3cf 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -83,7 +83,8 @@ *the-class-integer* *the-class-float* *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* *the-class-array* - *the-class-stream* + *the-class-stream* *the-class-file-stream* + *the-class-string-stream* *the-class-slot-object* *the-class-structure-object* diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 261941d..09f820a 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -1497,8 +1497,12 @@ (defmethod class-default-initargs ((class built-in-class)) ()) (defmethod validate-superclass ((c class) (s built-in-class)) - (or (eq s *the-class-t*) - (eq s *the-class-stream*))) + (or (eq s *the-class-t*) (eq s *the-class-stream*) + ;; FIXME: bad things happen if someone tries to mix in both + ;; FILE-STREAM and STRING-STREAM (as they have the same + ;; layout-depthoid). Is there any way we can provide a useful + ;; error message? -- CSR, 2005-05-03 + (eq s *the-class-file-stream*) (eq s *the-class-string-stream*))) ;;; Some necessary methods for FORWARD-REFERENCED-CLASS (defmethod class-direct-slots ((class forward-referenced-class)) ()) diff --git a/version.lisp-expr b/version.lisp-expr index d10810f..ae1b536 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.20.5" +"0.8.20.6" -- 1.7.10.4