X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fpcl%2Fgray-streams.lisp;h=7498eea0417a1923ed5deb02277f508d92f01396;hb=d7eeed8e500932c38cd2c7d22ea1ff9630d2f7c8;hp=3ad52a1d9ad0b97aea55b614bf05c0de6491aced;hpb=9afb0bc650cd36dc093be6958a224e86d59d3893;p=sbcl.git
diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp
index 3ad52a1..7498eea 100644
--- a/src/pcl/gray-streams.lisp
+++ b/src/pcl/gray-streams.lisp
@@ -15,13 +15,19 @@
;;; user is responsible for some of the protocol implementation, it's
;;; not necessarily a bug in SBCL itself if we fall through to one of
;;; these default methods.
+;;;
+;;; FIXME: there's a lot of similarity in these Gray stream
+;;; implementation generic functions. All of them could (maybe
+;;; should?) have two default methods: one on STREAM calling
+;;; BUG-OR-ERROR, and one on T signalling a TYPE-ERROR.
(defmacro bug-or-error (stream fun)
- `(error "~@).~@:>"
- ,stream ,fun))
-
+ `(error
+ "~@).~@:>"
+ ,stream ,fun))
(fmakunbound 'stream-element-type)
@@ -90,20 +96,42 @@
(defgeneric input-stream-p (stream)
#+sb-doc
(:documentation "Can STREAM perform input operations?"))
-
+
(defmethod input-stream-p ((stream ansi-stream))
(ansi-stream-input-stream-p stream))
-
+
+ (defmethod input-stream-p ((stream fundamental-stream))
+ nil)
+
(defmethod input-stream-p ((stream fundamental-input-stream))
t)
(defmethod input-stream-p ((stream stream))
(bug-or-error stream 'input-stream-p))
-
+
(defmethod input-stream-p ((non-stream t))
(error 'type-error :datum non-stream :expected-type 'stream)))
(let ()
+ (fmakunbound 'interactive-stream-p)
+
+ (defgeneric interactive-stream-p (stream)
+ #+sb-doc
+ (:documentation "Is STREAM an interactive stream?"))
+
+ (defmethod interactive-stream-p ((stream ansi-stream))
+ (funcall (ansi-stream-misc stream) stream :interactive-p))
+
+ (defmethod interactive-stream-p ((stream fundamental-stream))
+ nil)
+
+ (defmethod interactive-stream-p ((stream stream))
+ (bug-or-error stream 'interactive-stream-p))
+
+ (defmethod interactive-stream-p ((non-stream t))
+ (error 'type-error :datum non-stream :expected-type 'stream)))
+
+(let ()
(fmakunbound 'output-stream-p)
(defgeneric output-stream-p (stream)
@@ -113,6 +141,9 @@
(defmethod output-stream-p ((stream ansi-stream))
(ansi-stream-output-stream-p stream))
+ (defmethod output-stream-p ((stream fundamental-stream))
+ nil)
+
(defmethod output-stream-p ((stream fundamental-output-stream))
t)
@@ -193,22 +224,22 @@
(defmethod stream-read-line ((stream fundamental-character-input-stream))
(let ((res (make-string 80))
- (len 80)
- (index 0))
+ (len 80)
+ (index 0))
(loop
(let ((ch (stream-read-char stream)))
(cond ((eq ch :eof)
- (return (values (shrink-vector res index) t)))
- (t
- (when (char= ch #\newline)
- (return (values (shrink-vector res index) nil)))
- (when (= index len)
- (setq len (* len 2))
- (let ((new (make-string len)))
- (replace new res)
- (setq res new)))
- (setf (schar res index) ch)
- (incf index)))))))
+ (return (values (%shrink-vector res index) t)))
+ (t
+ (when (char= ch #\newline)
+ (return (values (%shrink-vector res index) nil)))
+ (when (= index len)
+ (setq len (* len 2))
+ (let ((new (make-string len)))
+ (replace new res)
+ (setq res new)))
+ (setf (schar res index) ch)
+ (incf index)))))))
(defgeneric stream-clear-input (stream)
#+sb-doc
@@ -218,8 +249,13 @@
(defmethod stream-clear-input ((stream fundamental-character-input-stream))
nil)
+(defmethod stream-clear-input ((stream stream))
+ (bug-or-error stream 'stream-clear-input))
+(defmethod stream-clear-input ((non-stream t))
+ (error 'type-error :datum non-stream :expected-type 'stream))
(defgeneric stream-read-sequence (stream seq &optional start end)
+ #+sb-doc
(:documentation
"This is like CL:READ-SEQUENCE, but for Gray streams."))
@@ -231,11 +267,11 @@
;;; not updated, and the index of the next element is returned.
(defun basic-io-type-stream-read-sequence (stream seq start end read-fun)
(declare (type sequence seq)
- (type stream stream)
- (type index start)
- (type sequence-end end)
+ (type stream stream)
+ (type index start)
+ (type sequence-end end)
(type function read-fun)
- (values index))
+ (values index))
(let ((end (or end (length seq))))
(declare (type index end))
(etypecase seq
@@ -337,13 +373,13 @@
STREAM-WRITE-CHAR."))
(defmethod stream-write-string ((stream fundamental-character-output-stream)
- string &optional (start 0) end)
+ string &optional (start 0) end)
(declare (string string)
- (fixnum start))
+ (fixnum start))
(let ((end (or end (length string))))
(declare (fixnum end))
(do ((pos start (1+ pos)))
- ((>= pos end))
+ ((>= pos end))
(declare (type index pos))
(stream-write-char stream (aref string pos))))
string)
@@ -379,6 +415,10 @@
(defmethod stream-finish-output ((stream fundamental-output-stream))
nil)
+(defmethod stream-finish-output ((stream stream))
+ (bug-or-error stream 'stream-finish-output))
+(defmethod stream-finish-output ((non-stream t))
+ (error 'type-error :datum non-stream :expected-type 'stream))
(defgeneric stream-force-output (stream)
#+sb-doc
@@ -388,6 +428,10 @@
(defmethod stream-force-output ((stream fundamental-output-stream))
nil)
+(defmethod stream-force-output ((stream stream))
+ (bug-or-error stream 'stream-force-output))
+(defmethod stream-force-output ((non-stream t))
+ (error 'type-error :datum non-stream :expected-type 'stream))
(defgeneric stream-clear-output (stream)
#+sb-doc
@@ -397,6 +441,10 @@
(defmethod stream-clear-output ((stream fundamental-output-stream))
nil)
+(defmethod stream-clear-output ((stream stream))
+ (bug-or-error stream 'stream-clear-output))
+(defmethod stream-clear-output ((non-stream t))
+ (error 'type-error :datum non-stream :expected-type 'stream))
(defgeneric stream-advance-to-column (stream column)
#+sb-doc
@@ -409,26 +457,27 @@
#\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
- column)
+ column)
(let ((current-column (stream-line-column stream)))
(when current-column
(let ((fill (- column current-column)))
- (dotimes (i fill)
- (stream-write-char stream #\Space)))
+ (dotimes (i fill)
+ (stream-write-char stream #\Space)))
T)))
(defgeneric stream-write-sequence (stream seq &optional start end)
+ #+sb-doc
(:documentation
"This is like CL:WRITE-SEQUENCE, but for Gray streams."))
;;; Write the elements of SEQ bounded by START and END to STREAM.
(defun basic-io-type-stream-write-sequence (stream seq start end write-fun)
(declare (type sequence seq)
- (type stream stream)
- (type index start)
- (type sequence-end end)
+ (type stream stream)
+ (type index start)
+ (type sequence-end end)
(type function write-fun)
- (values sequence))
+ (values sequence))
(let ((end (or end (length seq))))
(declare (type index start end))
(etypecase seq
@@ -470,12 +519,22 @@
"Used by READ-BYTE; returns either an integer, or the symbol :EOF
if the stream is at end-of-file."))
+(defmethod stream-read-byte ((stream stream))
+ (bug-or-error stream 'stream-read-byte))
+(defmethod stream-read-byte ((non-stream t))
+ (error 'type-error :datum non-stream :expected-type 'stream))
+
(defgeneric stream-write-byte (stream integer)
#+sb-doc
(:documentation
"Implements WRITE-BYTE; writes the integer to the stream and
returns the integer as the result."))
+(defmethod stream-write-byte ((stream stream) integer)
+ (bug-or-error stream 'stream-write-byte))
+(defmethod stream-write-byte ((non-stream t) integer)
+ (error 'type-error :datum non-stream :expected-type 'stream))
+
;; Provide a reasonable default for binary Gray streams. We might be
;; able to do better by specializing on the sequence type, but at
;; least the behaviour is reasonable. --tony 2003/05/08.
@@ -485,6 +544,18 @@
(basic-io-type-stream-write-sequence stream seq start end
#'stream-write-byte))
+(defgeneric stream-file-position (stream &optional position-spec)
+ #+sb-doc
+ (:documentation
+ "Used by FILE-POSITION. Returns or changes the current position within STREAM."))
+
+(defmethod stream-file-position ((stream ansi-stream) &optional position-spec)
+ (ansi-stream-file-position stream position-spec))
+
+(defmethod stream-file-position ((stream t) &optional position-spec)
+ (declare (ignore stream position-spec))
+ nil)
+
;;; This is not in the Gray stream proposal, so it is left here
;;; as example code.