Utility predicates for packing: UNBOUNDED-SC-P and UNBOUNDED-TN-P

[sbcl.git] / src / pcl / gray-streams.lisp

diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp
index c09524a..f182d4e 100644 (file)
--- a/src/pcl/gray-streams.lisp
+++ b/src/pcl/gray-streams.lisp
@@ -10,6 +10,24 @@
 ;;;; more information.
 
 (in-package "SB-GRAY")
 ;;;; more information.
 
 (in-package "SB-GRAY")

+
+;;; BUG-OR-ERROR: because we have extensible streams, wherewith the
+;;; 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
+    "~@<The stream ~S has no suitable method for ~S, ~
+     and so has fallen through to this method.  If you think that this is ~
+     a bug, please report it to the applicable authority (bugs in SBCL itself ~
+     should go to the mailing lists referenced from ~
+     <http://www.sbcl.org/>).~@:>"
+    ,stream ,fun))

 \f
 (fmakunbound 'stream-element-type)
 
 \f
 (fmakunbound 'stream-element-type)
 

@@ -21,10 +39,16 @@
   which returns CHARACTER."))
 
 (defmethod stream-element-type ((stream ansi-stream))
   which returns CHARACTER."))
 
 (defmethod stream-element-type ((stream ansi-stream))

-  (funcall (ansi-stream-misc stream) stream :element-type))
+  (ansi-stream-element-type stream))

 
 (defmethod stream-element-type ((stream fundamental-character-stream))
   'character)
 
 (defmethod stream-element-type ((stream fundamental-character-stream))
   'character)

+
+(defmethod stream-element-type ((stream stream))
+  (bug-or-error stream 'stream-element-type))
+
+(defmethod stream-element-type ((non-stream t))
+  (error 'type-error :datum non-stream :expected-type 'stream))

 \f
 (defgeneric pcl-open-stream-p (stream)
   #+sb-doc
 \f
 (defgeneric pcl-open-stream-p (stream)
   #+sb-doc

@@ -34,11 +58,17 @@
   called on the stream."))
 
 (defmethod pcl-open-stream-p ((stream ansi-stream))
   called on the stream."))
 
 (defmethod pcl-open-stream-p ((stream ansi-stream))

-  (not (eq (ansi-stream-in stream) #'closed-flame)))
+  (ansi-stream-open-stream-p stream))

 
 (defmethod pcl-open-stream-p ((stream fundamental-stream))
   (stream-open-p stream))
 
 
 (defmethod pcl-open-stream-p ((stream fundamental-stream))
   (stream-open-p stream))
 

+(defmethod pcl-open-stream-p ((stream stream))
+  (bug-or-error stream 'open-stream-p))
+
+(defmethod pcl-open-stream-p ((non-stream t))
+  (error 'type-error :datum non-stream :expected-type 'stream))
+

 ;;; bootstrapping hack
 (pcl-open-stream-p (make-string-output-stream))
 (setf (fdefinition 'open-stream-p) #'pcl-open-stream-p)
 ;;; bootstrapping hack
 (pcl-open-stream-p (make-string-output-stream))
 (setf (fdefinition 'open-stream-p) #'pcl-open-stream-p)

@@ -51,44 +81,83 @@
   to clean up the side effects of having created the stream."))
 
 (defmethod pcl-close ((stream ansi-stream) &key abort)
   to clean up the side effects of having created the stream."))
 
 (defmethod pcl-close ((stream ansi-stream) &key abort)

-  (when (open-stream-p stream)
-    (funcall (ansi-stream-misc stream) stream :close abort))
-  t)
+  (ansi-stream-close stream abort))

 
 (defmethod pcl-close ((stream fundamental-stream) &key abort)
   (declare (ignore abort))
   (setf (stream-open-p stream) nil)
   t)
 
 
 (defmethod pcl-close ((stream fundamental-stream) &key abort)
   (declare (ignore abort))
   (setf (stream-open-p stream) nil)
   t)
 

-(setf (fdefinition 'close) #'pcl-close)
+(progn
+  ;; KLUDGE: Get in a call to PCL-CLOSE with a string-output-stream before
+  ;; setting it as CLOSE. Otherwise using NAMED-LAMBDAs as DFUNs causes a
+  ;; vicious metacircle from FORMAT NIL somewhere in the compiler. This is
+  ;; enough to get the dispatch settled down before we need it.
+  (pcl-close (make-string-output-stream))
+  (setf (fdefinition 'close) #'pcl-close))

 \f
 \f

-(fmakunbound 'input-stream-p)
+(let ()
+  (fmakunbound 'input-stream-p)

 
 

-(defgeneric input-stream-p (stream)
-  #+sb-doc
-  (:documentation "Can STREAM perform input operations?"))
+  (defgeneric input-stream-p (stream)
+    #+sb-doc
+    (:documentation "Can STREAM perform input operations?"))

 
 

-(defmethod input-stream-p ((stream ansi-stream))
-  (and (not (eq (ansi-stream-in stream) #'closed-flame))
-       (or (not (eq (ansi-stream-in stream) #'ill-in))
-          (not (eq (ansi-stream-bin stream) #'ill-bin)))))
+  (defmethod input-stream-p ((stream ansi-stream))
+    (ansi-stream-input-stream-p stream))

 
 

-(defmethod input-stream-p ((stream fundamental-input-stream))
-  t)
+  (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)))

 \f
 \f

-(fmakunbound 'output-stream-p)
+(let ()
+  (fmakunbound 'interactive-stream-p)

 
 

-(defgeneric output-stream-p (stream)
-  #+sb-doc
-  (:documentation "Can STREAM perform output operations?"))
+  (defgeneric interactive-stream-p (stream)
+    #+sb-doc
+    (:documentation "Is STREAM an interactive stream?"))

 
 

-(defmethod output-stream-p ((stream ansi-stream))
-  (and (not (eq (ansi-stream-in stream) #'closed-flame))
-       (or (not (eq (ansi-stream-out stream) #'ill-out))
-          (not (eq (ansi-stream-bout stream) #'ill-bout)))))
+  (defmethod interactive-stream-p ((stream ansi-stream))
+    (funcall (ansi-stream-misc stream) stream :interactive-p))

 
 

-(defmethod output-stream-p ((stream fundamental-output-stream))
-  t)
+  (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)))
+\f
+(let ()
+  (fmakunbound 'output-stream-p)
+
+  (defgeneric output-stream-p (stream)
+    #+sb-doc
+    (:documentation "Can STREAM perform output operations?"))
+
+  (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)
+
+  (defmethod output-stream-p ((stream stream))
+    (bug-or-error stream 'output-stream-p))
+
+  (defmethod output-stream-p ((non-stream t))
+    (error 'type-error :datum non-stream :expected-type 'stream)))

 \f
 ;;; character input streams
 ;;;
 \f
 ;;; character input streams
 ;;;

@@ -107,7 +176,7 @@
 (defgeneric stream-unread-char (stream character)
   #+sb-doc
   (:documentation
 (defgeneric stream-unread-char (stream character)
   #+sb-doc
   (:documentation

-   "Un-do the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
+   "Undo the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.

   Return NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
   must define a method for this function."))
 
   Return NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
   must define a method for this function."))
 

@@ -161,22 +230,22 @@
 
 (defmethod stream-read-line ((stream fundamental-character-input-stream))
   (let ((res (make-string 80))
 
 (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)
     (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
 
 (defgeneric stream-clear-input (stream)
   #+sb-doc

@@ -186,8 +255,13 @@
 
 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
   nil)
 
 (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)
 
 (defgeneric stream-read-sequence (stream seq &optional start end)

+  #+sb-doc

   (:documentation
    "This is like CL:READ-SEQUENCE, but for Gray streams."))
 
   (:documentation
    "This is like CL:READ-SEQUENCE, but for Gray streams."))
 

@@ -199,11 +273,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)
 ;;; 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)
            (type function read-fun)

-          (values index))
+           (values index))

   (let ((end (or end (length seq))))
     (declare (type index end))
     (etypecase seq
   (let ((end (or end (length seq))))
     (declare (type index end))
     (etypecase seq

@@ -232,6 +306,13 @@
                                  &optional (start 0) (end nil))
   (basic-io-type-stream-read-sequence stream seq start end
                                       #'stream-read-char))
                                  &optional (start 0) (end nil))
   (basic-io-type-stream-read-sequence stream seq start end
                                       #'stream-read-char))

+
+(defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
+                                 (seq sequence)
+                                 &optional (start 0) (end nil))
+  (basic-io-type-stream-read-sequence stream seq start end
+                                      #'stream-read-byte))
+

 \f
 ;;; character output streams
 ;;;
 \f
 ;;; character output streams
 ;;;

@@ -298,13 +379,13 @@
   STREAM-WRITE-CHAR."))
 
 (defmethod stream-write-string ((stream fundamental-character-output-stream)
   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)
   (declare (string string)

-          (fixnum start))
+           (fixnum start))

   (let ((end (or end (length string))))
     (declare (fixnum end))
     (do ((pos start (1+ pos)))
   (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)
       (declare (type index pos))
       (stream-write-char stream (aref string pos))))
   string)

@@ -322,7 +403,7 @@
   #+sb-doc
   (:documentation
    "Outputs a new line to the Stream if it is not positioned at the
   #+sb-doc
   (:documentation
    "Outputs a new line to the Stream if it is not positioned at the

-  begining of a line. Returns T if it output a new line, nil
+  beginning of a line. Returns T if it output a new line, nil

   otherwise. Used by FRESH-LINE. The default method uses
   STREAM-START-LINE-P and STREAM-TERPRI."))
 
   otherwise. Used by FRESH-LINE. The default method uses
   STREAM-START-LINE-P and STREAM-TERPRI."))
 

@@ -340,6 +421,10 @@
 
 (defmethod stream-finish-output ((stream fundamental-output-stream))
   nil)
 
 (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
 
 (defgeneric stream-force-output (stream)
   #+sb-doc

@@ -349,6 +434,10 @@
 
 (defmethod stream-force-output ((stream fundamental-output-stream))
   nil)
 
 (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
 
 (defgeneric stream-clear-output (stream)
   #+sb-doc

@@ -358,6 +447,10 @@
 
 (defmethod stream-clear-output ((stream fundamental-output-stream))
   nil)
 
 (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
 
 (defgeneric stream-advance-to-column (stream column)
   #+sb-doc

@@ -370,26 +463,27 @@
   #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
 
 (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
   #\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)))
   (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)
       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)
   (: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)
            (type function write-fun)

-          (values sequence))
+           (values sequence))

   (let ((end (or end (length seq))))
     (declare (type index start end))
     (etypecase seq
   (let ((end (or end (length seq))))
     (declare (type index start end))
     (etypecase seq

@@ -431,11 +525,43 @@
    "Used by READ-BYTE; returns either an integer, or the symbol :EOF
   if the stream is at end-of-file."))
 
    "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."))
 (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.
+(defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
+                                  (seq sequence)
+                                  &optional (start 0) (end nil))
+  (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)
+

 \f
 ;;; This is not in the Gray stream proposal, so it is left here
 ;;; as example code.
 \f
 ;;; This is not in the Gray stream proposal, so it is left here
 ;;; as example code.