* Martin Atzmueller pointed out that bug 37 was fixed by his patches
some time ago.
+changes in sbcl-0.6.11 relative to sbcl-0.6.10:
+* The Gray subclassable streams extension now works, thanks to a
+ patch from Martin Atzmueller.
+* The full LOAD-FOREIGN extension (not just the primitive
+ LOAD-FOREIGN-1) now works, thanks to a patch from Martin Atzmueller.
+* The default behavior of RUN-PROGRAM has changed. Now, unlike CMU CL
+ but like most other programs, it defaults to copying the Unix
+ environment from the original process instead of starting the
+ new process in an empty environment.
+* Extensions which manipulate the Unix environment now support
+ an :ENVIRONMENT keyword option which doesn't smash case or
+ do other bad things. The CMU-CL-style :ENV option is retained
+ for porting convenience.
+* DESCRIBE now works on structure objects again.
+* Fasl file format version numbers have increased again, because
+ support for the Gray streams extension changes the format of the
+ system's stream objects.
+
planned incompatible changes in 0.7.x:
* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
as you get deeper into recursive calls to the debugger command loop,
"BIT-INDEX" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR"
"BOOLE-CODE"
"BYTE-SPECIFIER" "CALLABLE" "CASE-BODY-ERROR"
+ "CHARPOS"
"CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR"
+ "CLOSED-FLAME"
"CODE-COMPONENT" "CODE-COMPONENT-P"
"CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
"CODE-INSTRUCTIONS" "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUNCTION"
"FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME"
"FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION"
"FORM" "FUNCALLABLE-INSTANCE-P"
- "FUNCTION-CODE-HEADER" "FUNCTION-TYPE"
+ "FUNCTION-CODE-HEADER" "FUNCTION-DOC"
+ "FUNCTION-TYPE"
"FUNCTION-TYPE-ALLOWP"
"FUNCTION-TYPE-KEYP" "FUNCTION-TYPE-KEYWORDS"
"FUNCTION-TYPE-NARGS" "FUNCTION-TYPE-OPTIONAL"
"HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE"
"HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER"
"HANDLE-CIRCULARITY" "IGNORE-IT"
+ "ILL-BIN" "ILL-BOUT" "ILL-IN" "ILL-OUT"
"INDEX-TOO-LARGE-ERROR" "INTEGER-DECODE-DOUBLE-FLOAT"
"INTEGER-DECODE-LONG-FLOAT" "INTEGER-DECODE-SINGLE-FLOAT"
"INTERNAL-ERROR" "INTERNAL-TIME"
"KEY-INFO-P" "KEY-INFO-TYPE"
"LAYOUT-DEPTHOID"
"LAYOUT-INVALID-ERROR" "LEXENV"
+ "LINE-LENGTH"
+ "LISP-STREAM"
+ "LISP-STREAM-BIN" "LISP-STREAM-BOUT"
+ "LISP-STREAM-IN" "LISP-STREAM-IN-BUFFER"
+ "LISP-STREAM-IN-INDEX"
+ "LISP-STREAM-MISC" "LISP-STREAM-N-BIN"
+ "LISP-STREAM-OUT" "LISP-STREAM-SOUT"
"LIST-TO-SIMPLE-STRING*" "LIST-TO-BIT-VECTOR*"
"LIST-TO-VECTOR*"
"LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS"
"LONG-FLOAT-HIGH-BITS"
"LONG-FLOAT-LOW-BITS" "LONG-FLOAT-MID-BITS" "LONG-FLOAT-P"
+ "LONG-FLOAT-RADIX" "LONG-WORDS"
"LRA" "LRA-CODE-HEADER" "LRA-P"
"MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
"MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-CONS-TYPE"
"OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR"
"ODD-KEYWORD-ARGUMENTS-ERROR"
"OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT"
+ "PACKAGE-DOC-STRING"
+ "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
+ "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"
"PARSE-DEFMACRO" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE"
"PARSE-UNKNOWN-TYPE-SPECIFIER"
"PATHNAME-DESIGNATOR" "PUNT-IF-TOO-LONG"
later versions of SBCL, and the other stuff in here is
definitely not guaranteed to be present in later versions of SBCL."
:use ("CL" "SB!ITERATE" "SB!WALKER")
- :import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "SB!INT" "SB!EXT"))
+ :import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "FUNCTION-DOC"
+ "PACKAGE-DOC-STRING"
+ "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
+ "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"
+ "SB!INT" "SB!EXT"))
:reexport ("ADD-METHOD" "ALLOCATE-INSTANCE"
"COMPUTE-APPLICABLE-METHODS"
"ENSURE-GENERIC-FUNCTION"
"GET-PAGE-SIZE" "GET-SYSTEM-INFO"
"IGNORE-INTERRUPT"
"INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT"
- "LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS"
"MACRO" "MAKE-FD-STREAM" "MAKE-OBJECT-SET" "MAP-PORT"
"NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER"
"NULL-TERMINATED-STRING" "OBJECT-SET-OPERATION"
(in-package "SB!IMPL")
-;;; There seems to be no portable way to mask float traps, but we shouldn't
-;;; encounter any float traps when cross-compiling SBCL itself, anyway, so we
-;;; just make this a no-op.
+;;; There seems to be no portable way to mask float traps, but we
+;;; shouldn't encounter any float traps when cross-compiling SBCL
+;;; itself, anyway, so we just make this a no-op.
(defmacro sb!vm::with-float-traps-masked (traps &body body)
(declare (ignore traps))
;; FIXME: should become STYLE-WARNING?
(logior uresult
(logand -1 (lognot mask))))))
-;;; portable implementations of SINGLE-FLOAT-BITS, DOUBLE-FLOAT-LOW-BITS, and
-;;; DOUBLE-FLOAT-HIGH-BITS
+;;; portable implementations of SINGLE-FLOAT-BITS,
+;;; DOUBLE-FLOAT-LOW-BITS, and DOUBLE-FLOAT-HIGH-BITS
;;;
;;; KLUDGE: These will fail if the target's floating point isn't IEEE, and so
;;; I'd be more comfortable if there were an assertion "target's floating point
(defun describe-vector-parts (object)
(list* (format nil "The object is a ~:[~;displaced ~]vector of length ~D.~%"
- (and (sb-impl::array-header-p object)
- (sb-impl::%array-displaced-p object))
+ (and (array-header-p object)
+ (%array-displaced-p object))
(length object))
nil
(coerce object 'list)))
(push (format nil "The object is ~:[a displaced~;an~] array of ~A.~%~
Its dimensions are ~S.~%"
(array-element-type object)
- (and (sb-impl::array-header-p object)
- (sb-impl::%array-displaced-p object))
+ (and (array-header-p object)
+ (%array-displaced-p object))
dimensions)
parts)
(push t parts)
(defconstant default-line-length 80)
-(defstruct (pretty-stream (:include sb!sys:lisp-stream
+(defstruct (pretty-stream (:include sb!kernel:lisp-stream
(:out #'pretty-out)
(:sout #'pretty-sout)
(:misc #'pretty-misc))
nil)
(defun write-byte (integer stream)
- (with-out-stream stream
- ;; FIXME: CMU CL had
- ;; (stream-write-byte integer)
- ;; which was broken unless Gray streams were installed.
- ;; In order to make this work again, MNA replaced it with
- ;; bare (LISP-STREAM-BOUT). Something more complicated will
- ;; probably be required when Gray stream support is restored,
- ;; in order to make those work too; but I dunno what it will be.
- (lisp-stream-bout integer)))
+ (with-out-stream stream (lisp-stream-bout integer)
+ (stream-write-byte integer))
+ integer)
\f
;;; This is called from lisp-steam routines that encapsulate CLOS
;;; streams to handle the misc routines and dispatch to the
"src/pcl/print-object"
"src/pcl/precom1"
"src/pcl/precom2"
- ;; functionality which depends on CLOS
+
+ ;; miscellaneous functionality which depends on CLOS
"src/code/force-delayed-defbangmethods"
+
+ ;; CLOS-level support for the Gray OO streams
+ ;; extension (which is also supported by various
+ ;; lower-level hooks elsewhere in the code)
+ "src/pcl/gray-streams-class"
+ "src/pcl/gray-streams"
+
;; other functionality not needed for cold init, moved
;; to warm init to reduce peak memory requirement in
;; cold init
"src/code/ntrace"
"src/code/foreign"
"src/code/run-program"
+
;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT
;; facility is still used in our ANSI DESCRIBE
;; facility, and should be compiled and loaded after
;; our DESCRIBE facility is compiled and loaded.
- "src/pcl/describe" ; FIXME: should probably be byte compiled
- ;; FIXME: What about Gray streams? e.g. "gray-streams.lisp"
- ;; and "gray-streams-class.lisp"? For now, we just
- ;; have stubs (installed in cold load).
- ))
+ "src/pcl/describe")) ; FIXME: should probably be byte compiled
+
(let ((fullname (concatenate 'string stem ".lisp")))
(sb-int:/show "about to compile" fullname)
(multiple-value-bind
(setf *backend-fasl-file-type* "x86f")
(setf *backend-fasl-file-implementation* :x86)
-(setf *backend-fasl-file-version* 7)
+(setf *backend-fasl-file-version* 8)
;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC.
;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot.
;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
;;; 6 = sbcl-0.6.9, got rid of non-ANSI %DEFCONSTANT/%%DEFCONSTANT stuff
;;; and deleted a slot from DEBUG-SOURCE structure.
;;; 7 = around sbcl-0.6.9.8, merged SB-CONDITIONS package into SB-KERNEL
+;;; 8 = sbcl-0.6.10.4 revived Gray stream support, changing stream layouts
(setf *backend-register-save-penalty* 3)
(cl:find-class symbol))))
;; a hack to add the STREAM class as a
;; mixin to the LISP-STREAM class.
- ((eq symbol 'sb-sys:lisp-stream)
+ ((eq symbol 'sb-kernel:lisp-stream)
'(structure-object stream))
((structure-type-included-type-name symbol)
(list (structure-type-included-type-name
(format stream
"~@[~&It has nicknames ~{~:_~S~^ ~}~]"
(package-nicknames package))
- (let* ((internal (sb-impl::package-internal-symbols package))
- (internal-count (- (sb-impl::package-hashtable-size internal)
- (sb-impl::package-hashtable-free internal)))
- (external (sb-impl::package-external-symbols package))
- (external-count (- (sb-impl::package-hashtable-size external)
- (sb-impl::package-hashtable-free external))))
+ (let* ((internal (package-internal-symbols package))
+ (internal-count (- (package-hashtable-size internal)
+ (package-hashtable-free internal)))
+ (external (package-external-symbols package))
+ (external-count (- (package-hashtable-size external)
+ (package-hashtable-free external))))
(format stream
"~&It has ~S internal and ~S external symbols."
internal-count external-count))
;;; functions, macros, and special forms
(defmethod documentation ((x function) (doc-type (eql 't)))
- (sb-impl::function-doc x))
+ (function-doc x))
(defmethod documentation ((x function) (doc-type (eql 'function)))
- (sb-impl::function-doc x))
+ (function-doc x))
(defmethod documentation ((x list) (doc-type (eql 'function)))
;; FIXME: could test harder to see whether it's a SETF function name,
;;; packages
(defmethod documentation ((x package) (doc-type (eql 't)))
- (sb-impl::package-doc-string x))
+ (package-doc-string x))
(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
- (setf (sb-impl::package-doc-string x) new-value))
+ (setf (package-doc-string x) new-value))
;;; KLUDGE: It's nasty having things like this accessor floating around
;;; out in this mostly-unrelated source file. Perhaps it would be
;;; better to support WARM-INIT-FORMS by analogy with the existing
;;; Bootstrap the FUNDAMENTAL-STREAM class.
(let ((sb-pcl::*pcl-class-boot* 'fundamental-stream))
(defclass fundamental-stream (standard-object stream)
- ()
+ ((open-p :initform t
+ :accessor stream-open-p))
#+sb-doc
(:documentation "the base class for all CLOS streams")))
(defclass fundamental-binary-output-stream
(fundamental-output-stream fundamental-binary-stream) nil)
\f
+#|
+This is not in the gray-stream proposal, so it is left here
+as example code.
;;; example character input and output streams
(defclass character-output-stream (fundamental-character-output-stream)
(defclass character-input-stream (fundamental-character-input-stream)
((lisp-stream :initarg :lisp-stream
:accessor character-input-stream-lisp-stream)))
+|#
+++ /dev/null
-;;;; stubs for the Gray streams implementation for SBCL
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-
-;;;; This software is in the public domain and is provided with absolutely no
-;;;; warranty. See the COPYING and CREDITS files for more information.
-
-(in-package "SB!GRAY")
-
-;;; The intent here is that when Gray streams support isn't installed
-;;; yet, and someone tries to do a stream operation on something
-;;; which isn't an ordinary CL:STREAM, and the code tries to fall
-;;; through to the Gray stream operation, we signal a type error,
-;;; instead of an undefined function error.
-;;;
-;;; Real Gray stream functions will overwrite these stubs. FIXME: When
-;;; and if Gray stream functions become a stable part of the system,
-;;; we should just delete all this.
-(defun %gray-stream-stub (oughtta-be-stream &rest rest)
- (declare (ignore rest))
- (error 'simple-type-error
- :datum oughtta-be-stream
- :expected-type 'stream
- :format-control "~@<not a ~S: ~2I~_~S~:>"
- :format-arguments (list 'stream oughtta-be-stream)))
-
-(dolist (funname
- '(stream-advance-to-column
- stream-clear-input stream-clear-output
- stream-finish-output stream-force-output
- stream-fresh-line
- stream-line-column
- stream-line-length
- stream-listen stream-peek-char
- stream-read-byte
- stream-read-char stream-read-char-no-hang
- stream-read-line
- stream-start-line-p
- stream-terpri
- stream-unread-char
- stream-write-byte stream-write-char
- stream-write-string))
- (setf (fdefinition funname) #'%gray-stream-stub))
called on the stream."))
(defmethod pcl-open-stream-p ((stream lisp-stream))
- (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame)))
+ (not (eq (lisp-stream-in stream) #'closed-flame)))
(defmethod pcl-open-stream-p ((stream fundamental-stream))
- nil)
+ (stream-open-p stream))
;;; bootstrapping hack
(pcl-open-stream-p (make-string-output-stream))
(funcall (lisp-stream-misc stream) stream :close abort))
t)
+(defmethod pcl-close ((stream fundamental-stream) &key abort)
+ (setf (stream-open-p stream) nil)
+ t)
+
(setf (fdefinition 'close) #'pcl-close)
\f
(fmakunbound 'input-stream-p)
(defgeneric input-stream-p (stream)
#+sb-doc
- (:documentation "Returns non-nil if the given Stream can perform input operations."))
+ (:documentation "Return non-nil if the given Stream can perform input operations."))
(defmethod input-stream-p ((stream lisp-stream))
- (and (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame))
- (or (not (eq (sb-impl::lisp-stream-in stream) #'ill-in))
+ (and (not (eq (lisp-stream-in stream) #'closed-flame))
+ (or (not (eq (lisp-stream-in stream) #'ill-in))
(not (eq (lisp-stream-bin stream) #'ill-bin)))))
(defmethod input-stream-p ((stream fundamental-input-stream))
(defgeneric output-stream-p (stream)
#+sb-doc
- (:documentation "Returns non-nil if the given Stream can perform output operations."))
+ (:documentation "Return non-nil if the given Stream can perform output operations."))
(defmethod output-stream-p ((stream lisp-stream))
- (and (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame))
+ (and (not (eq (lisp-stream-in stream) #'closed-flame))
(or (not (eq (lisp-stream-out stream) #'ill-out))
(not (eq (lisp-stream-bout stream) #'ill-bout)))))
defined for this function, although it is permissible for it to
always return NIL."))
+(defmethod stream-line-column ((stream fundamental-character-output-stream))
+ nil)
+
;;; STREAM-LINE-LENGTH is a CMU CL extension to Gray streams.
;;; FIXME: Should we support it? Probably not..
(defgeneric stream-line-length (stream)
(let ((current-column (stream-line-column stream)))
(when current-column
(let ((fill (- column current-column)))
- (dotimes-fixnum (i fill)
+ (dotimes (i fill)
(stream-write-char stream #\Space)))
T)))
\f
"Implements WRITE-BYTE; writes the integer to the stream and
returns the integer as the result."))
\f
+#|
+This is not in the gray-stream proposal, so it is left here
+as example code.
;;; example character output stream encapsulating a lisp-stream
(defun make-character-output-stream (lisp-stream)
(declare (type lisp-stream lisp-stream))
(defmethod stream-clear-input ((stream character-input-stream))
(clear-input (character-input-stream-lisp-stream stream)))
+|#
char sbuf[128];
strcpy(sbuf,filename);
filename=sbuf;
- /* Get rid of remnant stuff. This is a MUST so that
- * the memory manager can get started correctly when
- * we restart after this save. Purify is going to
- * maybe move the args so we need to consider them volatile,
- * especially if the gcc optimizer is working!!
- */
+ /* Get rid of remnant stuff. This is a MUST so that the memory
+ * manager can get started correctly when we restart after this
+ * save. Purify is going to maybe move the args so we need to
+ * consider them volatile, especially if the gcc optimizer is
+ * working!! */
purify(NIL,NIL);
init_function = *func_ptr;
/* Set dynamic space pointer to base value so we don't write out
- * MBs of just cleared heap.
- */
+ * MBs of just cleared heap. */
if(SymbolValue(X86_CGC_ACTIVE_P) != NIL)
SetSymbolValue(ALLOCATION_POINTER, DYNAMIC_SPACE_START);
#endif
#!+gengc ("code/gengc" :not-host)
("code/stream" :not-host)
- ("pcl/gray-streams-stubs" :not-host)
("code/print" :not-host)
("code/pprint" :not-host) ; maybe should be :BYTE-COMPILE T
("code/early-format")
--- /dev/null
+;;;; This file is for compiler tests which have side effects (e.g.
+;;;; executing DEFUN) but which don't need any special side-effecting
+;;;; environmental stuff (e.g. DECLAIM of particular optimization
+;;;; settings). Similar tests which *do* expect special settings may
+;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(cl:in-package :cl-user)
+\f
+;;;; class precedence tests
+
+(assert (subtypep 'fundamental-stream 'stream))
+(assert (subtypep 'fundamental-stream 'standard-object))
+
+(assert (subtypep 'fundamental-input-stream 'fundamental-stream))
+(assert (subtypep 'fundamental-output-stream 'fundamental-stream))
+(assert (subtypep 'fundamental-character-stream 'fundamental-stream))
+(assert (subtypep 'fundamental-binary-stream 'fundamental-stream))
+
+(assert (subtypep 'fundamental-character-input-stream
+ 'fundamental-input-stream))
+(assert (subtypep 'fundamental-character-input-stream
+ 'fundamental-character-stream))
+(assert (subtypep 'fundamental-character-output-stream
+ 'fundamental-output-stream))
+(assert (subtypep 'fundamental-character-output-stream
+ 'fundamental-character-stream))
+
+(assert (subtypep 'fundamental-binary-input-stream
+ 'fundamental-input-stream))
+(assert (subtypep 'fundamental-binary-input-stream
+ 'fundamental-binary-stream))
+(assert (subtypep 'fundamental-binary-output-stream
+ 'fundamental-output-stream))
+(assert (subtypep 'fundamental-binary-output-stream
+ 'fundamental-binary-stream))
+
+(defvar *fundamental-input-stream-instance*
+ (make-instance 'fundamental-input-stream))
+
+(defvar *fundamental-output-stream-instance*
+ (make-instance 'fundamental-output-stream))
+
+(defvar *fundamental-character-stream-instance*
+ (make-instance 'fundamental-character-stream))
+
+(assert (input-stream-p *fundamental-input-stream-instance*))
+(assert (output-stream-p *fundamental-output-stream-instance*))
+(assert (eql (stream-element-type
+ *fundamental-character-stream-instance*)
+ 'character))
+\f
+;;;; example character input and output streams
+
+(defclass character-output-stream (fundamental-character-output-stream)
+ ((lisp-stream :initarg :lisp-stream
+ :accessor character-output-stream-lisp-stream)))
+
+(defclass character-input-stream (fundamental-character-input-stream)
+ ((lisp-stream :initarg :lisp-stream
+ :accessor character-input-stream-lisp-stream)))
+\f
+;;;; example character output stream encapsulating a lisp-stream
+
+(defun make-character-output-stream (lisp-stream)
+ (declare (type sb-kernel:lisp-stream lisp-stream))
+ (make-instance 'character-output-stream :lisp-stream lisp-stream))
+
+(defmethod open-stream-p ((stream character-output-stream))
+ (open-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod close ((stream character-output-stream) &key abort)
+ (close (character-output-stream-lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream character-output-stream))
+ (input-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod output-stream-p ((stream character-output-stream))
+ (output-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-write-char ((stream character-output-stream) character)
+ (write-char character (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-line-column ((stream character-output-stream))
+ (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-line-length ((stream character-output-stream))
+ (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-finish-output ((stream character-output-stream))
+ (finish-output (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-force-output ((stream character-output-stream))
+ (force-output (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream character-output-stream))
+ (clear-output (character-output-stream-lisp-stream stream)))
+\f
+;;;; example character input stream encapsulating a lisp-stream
+
+(defun make-character-input-stream (lisp-stream)
+ (declare (type sb-kernel:lisp-stream lisp-stream))
+ (make-instance 'character-input-stream :lisp-stream lisp-stream))
+
+(defmethod open-stream-p ((stream character-input-stream))
+ (open-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod close ((stream character-input-stream) &key abort)
+ (close (character-input-stream-lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream character-input-stream))
+ (input-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod output-stream-p ((stream character-input-stream))
+ (output-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-read-char ((stream character-input-stream))
+ (read-char (character-input-stream-lisp-stream stream) nil :eof))
+
+(defmethod stream-unread-char ((stream character-input-stream) character)
+ (unread-char character (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-read-char-no-hang ((stream character-input-stream))
+ (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
+
+#+nil
+(defmethod stream-peek-char ((stream character-input-stream))
+ (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
+
+#+nil
+(defmethod stream-listen ((stream character-input-stream))
+ (listen (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-clear-input ((stream character-input-stream))
+ (clear-input (character-input-stream-lisp-stream stream)))
+\f
+;;;; tests for character i/o, using the above:
+
+(let ((test-string (format nil
+ "~% This is a test.~& This is the second line.~
+ ~% This should be the third and last line.~%")))
+ (with-input-from-string (foo test-string)
+ (assert (equal
+ (with-output-to-string (bar)
+ (let ((our-char-input (make-character-input-stream foo))
+ (our-char-output (make-character-output-stream bar)))
+ (assert (open-stream-p our-char-input))
+ (assert (open-stream-p our-char-output))
+ (assert (input-stream-p our-char-input))
+ (assert (output-stream-p our-char-output))
+ (let ((test-char (read-char our-char-input)))
+ (assert (char-equal test-char (char test-string 0)))
+ (unread-char test-char our-char-input))
+ (do ((line #1=(read-line our-char-input nil nil nil) #1#))
+ ((not (listen our-char-input))
+ (format our-char-output "~A~%" line))
+ (format our-char-output "~A~%" line))
+ (assert (null (peek-char nil our-char-input nil nil nil)))))
+ test-string))))
+\f
+;;;; example classes for binary output
+
+(defclass binary-to-char-output-stream (fundamental-binary-output-stream)
+ ((lisp-stream :initarg :lisp-stream
+ :accessor binary-to-char-output-stream-lisp-stream)))
+
+(defclass binary-to-char-input-stream (fundamental-binary-input-stream)
+ ((lisp-stream :initarg :lisp-stream
+ :accessor binary-to-char-input-stream-lisp-stream)))
+
+(defmethod stream-element-type ((stream binary-to-char-output-stream))
+ '(unsigned-byte 8))
+(defmethod stream-element-type ((stream binary-to-char-input-stream))
+ '(unsigned-byte 8))
+
+(defun make-binary-to-char-input-stream (lisp-stream)
+ (declare (type sb-kernel:lisp-stream lisp-stream))
+ (make-instance 'binary-to-char-input-stream
+ :lisp-stream lisp-stream))
+
+(defun make-binary-to-char-output-stream (lisp-stream)
+ (declare (type sb-kernel:lisp-stream lisp-stream))
+ (make-instance 'binary-to-char-output-stream
+ :lisp-stream lisp-stream))
+
+(defmethod stream-read-byte ((stream binary-to-char-input-stream))
+ (let ((char (read-char
+ (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
+ (if (eq char :eof)
+ char
+ (char-code char))))
+
+(defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
+ (let ((char (code-char integer)))
+ (write-char char
+ (binary-to-char-output-stream-lisp-stream stream))))
+\f
+;;;; tests using binary i/o, using the above
+
+(let ((test-string (format nil
+ "~% This is a test.~& This is the second line.~
+ ~% This should be the third and last line.~%")))
+ (with-input-from-string (foo test-string)
+ (assert (equal
+ (with-output-to-string (bar)
+ (let ((our-bin-to-char-input (make-binary-to-char-input-stream
+ foo))
+ (our-bin-to-char-output (make-binary-to-char-output-stream
+ bar)))
+ (assert (open-stream-p our-bin-to-char-input))
+ (assert (open-stream-p our-bin-to-char-output))
+ (assert (input-stream-p our-bin-to-char-input))
+ (assert (output-stream-p our-bin-to-char-output))
+ (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
+ ((eq byte :eof))
+ (write-byte byte our-bin-to-char-output))))
+ test-string))))
+\f
+;;;; Voila!
+
+(quit :unix-status 104) ; success
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.10.3"
+"0.6.10.4"
projects / sbcl.git / commitdiff