Changeset 441

Timestamp:

Jan 30, 2004, 3:56:26 PM (21 years ago)

Author:

Gary Byers

Message:

Lots of nit-picking; BROADCAST-STREAM methods (at least partly) fixed to
return value from last stream in list.

File:

• trunk/ccl/level-1/l1-streams.lisp (modified) (12 diffs)

trunk/ccl/level-1/l1-streams.lisp

@@ -24 +24 @@
 ;;;
 
-
 (defclass stream ()
   ((direction :initarg :direction :initform nil :reader stream-direction)
@@ -39 +38 @@
 
 ;;; Some generic stream functions:
+(defmethod stream-length ((x t) &optional new)
+  (declare (ignore new))
+  (report-bad-arg x 'stream))
+
+(defmethod stream-position ((x t) &optional new)
+  (declare (ignore new))
+  (report-bad-arg x 'stream))
+
+(defmethod stream-element-type ((x t))
+  (report-bad-arg x 'stream))
 
 ;;; For input streams:
@@ -244 +253 @@
 (defmethod stream-finish-output ((stream output-stream)) nil)
 
+
+
 (defmethod stream-clear-output ((stream output-stream)) nil)
 
@@ -274 +285 @@
 (defmethod interactive-stream-p ((stream stream)) nil)
 
+(defmethod stream-clear-input ((x t))
+  (report-bad-arg x 'stream))
 (defmethod stream-clear-input ((stream input-stream)) nil)
 
@@ -1174 +1187 @@
 
 (defun make-synonym-stream (symbol)
-  (make-instance 'synonym-stream :symbol symbol))
+  (make-instance 'synonym-stream :symbol (require-type symbol 'symbol)))
 
 
@@ -1238 +1251 @@
 
 (defun make-two-way-stream (in out)
+  (unless (input-stream-p in)
+    (require-type in 'input-stream))
+  (unless (output-stream-p out)
+    (require-type out 'output-stream))
   (make-instance 'two-way-stream :input-stream in :output-stream out))
 
@@ -1389 +1406 @@
              (broadcast-method stream-advance-to-column (s new))
              (broadcast-method stream-start-line-p (s))
-             (broadcast-method stream-fresh-line (s))
              (broadcast-method stream-terpri (s))
              (broadcast-method stream-force-output (s))
@@ -1396 +1412 @@
              (broadcast-method stream-write-vector (s v start end)))
 
+(defun last-broadcast-stream (s)
+  (car (last (broadcast-stream-streams s))))
+
+(defmethod stream-fresh-line ((s broadcast-stream))
+  (let* ((did-output-newline nil))
+    (dolist (sub (broadcast-stream-streams s) did-output-newline)
+      (setq did-output-newline (stream-fresh-line sub)))))
+
+(defmethod stream-element-type ((s broadcast-stream))
+  (let* ((last (last-broadcast-stream s)))
+    (if last
+      (stream-element-type last)
+      t)))
+
+(defmethod stream-length ((s broadcast-stream) &optional new)
+  (unless new
+    (let* ((last (last-broadcast-stream s)))
+      (if last
+        (stream-length last)
+        0))))
+
+(defmethod stream-position ((s broadcast-stream) &optional new)
+  (unless new
+    (let* ((last (last-broadcast-stream s)))
+      (if last
+        (stream-position last)
+        0))))
+
+(defmethod file-stream-external-format ((s broadcast-stream))
+  (let* ((last (last-broadcast-stream s)))
+    (if last
+      (file-stream-external-format last)
+      :default)))
 
 (defun make-broadcast-stream (&rest streams)
@@ -2195 +2244 @@
            (io-buffer (ioblock-outbuf ioblock))
            (buf (%null-ptr))
-           (octets (ioblock-elements-to-octets ioblock count)))
+           (octets-to-write (ioblock-elements-to-octets ioblock count))
+           (octets octets-to-write))
       (declare (fixnum octets))
       (declare (dynamic-extent buf))
@@ -2206 +2256 @@
               (case (%unix-fd-kind fd)
                 (:file (fd-fsync fd))))
-            count)
+            octets-to-write)
         (let* ((written (with-eagain fd :output
                           (fd-write fd buf octets))))
@@ -2249 +2299 @@
                       (element-type 'base-char)
                       (if-exists :error)
-                      (if-does-not-exist (if (or (eq direction :input)
-                                                 ;(eq if-exists :overwrite)
-                                                 (eq if-exists :append))
-                                           :error
-                                           :create))
+                      (if-does-not-exist (cond ((eq direction :probe)
+                                                nil)
+                                               ((or (eq direction :input)
+                                                    (eq if-exists :overwrite)
+                                                    (eq if-exists :append))
+                                                :error)
+                                               (t :create)))
                       (external-format :default)
                       (class *default-file-stream-class*)
@@ -2287 +2339 @@
 
 (defun file-length (stream)
-  (stream-length stream))
+  (etypecase stream
+    ;; Don't use an OR type here
+    (file-stream (stream-length stream))
+    (broadcast-stream (stream-length stream))))
   
 (defun file-position (stream &optional position)