source: trunk/ccl/level-1/l1-streams.lisp @ 686

Last change on this file since 686 was 686, checked in by gb, 17 years ago

Selection-stream stuff, apparently still buggy.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 85.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (C) 2001 Clozure Associates
5;;;   This file is part of OpenMCL. 
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(eval-when (:compile-toplevel)
19  #+linuxppc-target
20  (require "LINUX-SYSCALLS")
21  #+darwinppc-target
22  (require "DARWIN-SYSCALLS"))
23
24;;;
25
26(defclass stream ()
27  ((direction :initarg :direction :initform nil :reader stream-direction)
28   (closed :initform nil)))
29
30(defclass input-stream (stream)
31  ((shared-resource :initform nil :accessor input-stream-shared-resource)))
32
33(defclass output-stream (stream) ())
34
35;;; The "direction" argument only helps us dispatch on two-way streams:
36;;; it's legal to ask for the :output device of a stream that's only open
37;;; for input, and one might get a non-null answer in that case.
38(defmethod stream-device ((s stream) direction)
39  (declare (ignore direction)))
40
41;;; Some generic stream functions:
42(defmethod stream-length ((x t) &optional new)
43  (declare (ignore new))
44  (report-bad-arg x 'stream))
45
46(defmethod stream-position ((x t) &optional new)
47  (declare (ignore new))
48  (report-bad-arg x 'stream))
49
50(defmethod stream-element-type ((x t))
51  (report-bad-arg x 'stream))
52
53;;; For input streams:
54
55;; From Shannon Spires, slightly modified.
56(defun generic-read-line (s)
57  (let* ((str (make-array 20 :element-type 'base-char
58                          :adjustable t :fill-pointer 0))
59         (eof nil))
60    (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
61         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
62          (values (ensure-simple-string str) eof))
63      (vector-push-extend ch str))))
64
65(defun generic-character-read-list (stream list count)
66  (declare (fixnum count))
67  (do* ((tail list (cdr tail))
68        (i 0 (1+ i)))
69       ((= i count) count)
70    (declare (fixnum i))
71    (let* ((ch (read-char stream nil :eof)))
72      (if (eq ch :eof)
73        (return i)
74        (rplaca tail ch)))))
75
76(defun generic-binary-read-list (stream list count)
77  (declare (fixnum count))
78  (do* ((tail list (cdr tail))
79        (i 0 (1+ i)))
80       ((= i count) count)
81    (declare (fixnum i))
82    (let* ((ch (stream-read-byte stream)))
83      (if (eq ch :eof)
84        (return i)
85        (rplaca tail ch)))))
86
87(defun generic-character-read-vector (stream vector start end)
88  (declare (fixnum start end))
89  (do* ((i start (1+ i)))
90       ((= i end) end)
91    (declare (fixnum i))
92    (let* ((ch (stream-read-char stream)))
93      (if (eq ch :eof)
94        (return i)
95        (setf (uvref vector i) ch)))))
96
97(defun generic-binary-read-vector (stream vector start end)
98  (declare (fixnum start end))
99  (do* ((i start (1+ i)))
100       ((= i end) end)
101    (declare (fixnum i))
102    (let* ((byte (stream-read-byte stream)))
103      (if (eq byte :eof)
104        (return i)
105        (setf (uvref vector i) byte)))))
106
107
108;;; For output streams:
109
110(defun generic-advance-to-column (s col)
111  (let* ((current (column s)))
112    (unless (null current)
113      (when (< current col)
114        (do* ((i current (1+ i)))
115             ((= i col))
116          (write-char #\Space s)))
117      t)))
118
119
120
121(defun generic-stream-write-string (stream string start end)
122  (setq end (check-sequence-bounds string start end))
123  (locally (declare (fixnum start end))
124    (multiple-value-bind (vect offset) (array-data-and-offset string)
125      (declare (fixnum offset))
126      (unless (zerop offset)
127        (incf start offset)
128        (incf end offset))
129      (do* ((i start (1+ i)))
130           ((= i end) string)
131        (declare (fixnum i))
132        (write-char (schar vect i) stream)))))
133
134
135
136
137
138
139
140
141
142
143
144
145(defloadvar *heap-ivectors* ())
146
147(defun %make-heap-ivector (subtype size-in-bytes &optional size-in-elts)
148  (if (not (fixnump size-in-elts))
149    (error "Need size in elts = fixnum")) ; not really optional, is smaller than fixnum
150  (with-macptrs ((ptr (malloc (+ size-in-bytes (+ 4 2 7))))) ; 4 for header, 2 for delta, 7 for round up
151    (let ((vect (fudge-heap-pointer ptr subtype size-in-elts))
152          (p (%null-ptr)))
153      (%vect-data-to-macptr vect p)
154      (push vect *heap-ivectors*)
155      (values vect p))))
156
157
158
159  ; tag it, return it
160
161(defun %dispose-heap-ivector (v)
162  (if  (uvectorp v) ;(%heap-ivector-p v)
163    (with-macptrs (p)
164      (setq *heap-ivectors* (delq v *heap-ivectors*))
165      (%%make-disposable p v)
166      (free p))))
167
168(defun make-heap-buffer (element-type element-count)
169  (let* ((subtype ppc32::subtag-simple-base-string)
170         (size-in-octets element-count))
171    (unless (subtypep element-type 'character)
172      (case element-type
173        (unsigned-byte (setq element-type '(unsigned-byte 8)))
174        (signed-byte (setq element-type '(signed-byte 8))))
175      (let* ((signed (list 'signed-byte 0))
176             (unsigned (list 'unsigned-byte 0)))
177        (declare (dynamic-extent signed unsigned))
178        (do* ((i 8 (+ i 8))
179              (octets 1 (1+ octets))
180              (match nil))             
181             ((> i 32) (report-bad-arg element-type '(or character
182                                                      (unsigned-byte 32)
183                                                      (signed-byte 32))))
184          (setf (cadr signed) i)
185          (setf (cadr unsigned) i)
186          (if (subtypep element-type signed)
187            (setq match (copy-list signed))
188            (if (subtypep element-type unsigned)
189              (setq match (copy-list unsigned))))
190          (when match
191            (setq size-in-octets (* octets element-count)
192                  subtype (element-type-subtype match)
193                  element-type match)
194            (return)))))
195    (multiple-value-bind (buf p)
196        (%make-heap-ivector subtype element-count size-in-octets)
197      (values buf p size-in-octets subtype))))
198
199
200
201
202
203
204
205
206
207(defvar *elements-per-buffer* 2048)  ; default buffer size for file io
208
209(defmethod streamp ((x t))
210  nil)
211
212(defmethod streamp ((x stream))
213  t)
214
215(defmethod stream-io-error ((stream stream) error-number context)
216  (error 'simple-stream-error :stream stream
217         :format-control (format nil "~a during ~a"
218                                 (%strerror error-number) context)))
219
220(defmethod instance-initialize :after ((stream input-stream) &key)
221  (let ((direction (slot-value stream 'direction)))
222    (if (null direction)
223      (set-slot-value stream 'direction :input)
224      (if (eq direction :output)
225        (set-slot-value stream 'direction :io)))))
226
227(defmethod instance-initialize :after ((stream output-stream) &key)
228  (let ((direction (slot-value stream 'direction)))
229    (if (null direction)
230      (set-slot-value stream 'direction :output)
231      (if (eq direction :input)
232        (set-slot-value stream 'direction :io)))))
233
234(defmethod stream-write-char ((stream stream) char)
235  (declare (ignore char))
236  (error "stream ~S is not capable of output" stream))
237
238(defun stream-write-entire-string (stream string)
239  (stream-write-string stream string))
240
241
242(defmethod stream-read-char ((x t))
243  (report-bad-arg x 'stream))
244
245(defmethod stream-read-char ((stream stream))
246  (error "~s is not capable of input" stream))
247
248(defmethod stream-unread-char ((x t) char)
249  (declare (ignore char))
250  (report-bad-arg x 'stream))
251
252(defmethod stream-unread-char ((stream stream) char)
253  (declare (ignore char))
254  (error "stream ~S is not capable of input" stream))
255
256
257
258(defmethod stream-force-output ((stream output-stream)) nil)
259(defmethod stream-maybe-force-output ((stream stream))
260  (stream-force-output stream))
261
262(defmethod stream-finish-output ((stream output-stream)) nil)
263
264
265
266(defmethod stream-clear-output ((stream output-stream)) nil)
267
268(defmethod close ((stream stream) &key abort)
269  (declare (ignore abort))
270  (with-slots ((closed closed)) stream
271    (unless closed
272      (setf closed t))))
273
274
275
276(defmethod open-stream-p ((x t))
277  (report-bad-arg x 'stream))
278
279(defmethod open-stream-p ((stream stream))
280  (not (slot-value stream 'closed)))
281
282(defmethod stream-fresh-line ((stream output-stream))
283  (terpri stream)
284  t)
285
286(defmethod stream-line-length ((stream stream))
287  "This is meant to be shadowed by particular kinds of streams,
288   esp those associated with windows."
289  80)
290
291(defmethod interactive-stream-p ((x t))
292  (report-bad-arg x 'stream))
293
294(defmethod interactive-stream-p ((stream stream)) nil)
295
296(defmethod stream-clear-input ((x t))
297  (report-bad-arg x 'stream))
298(defmethod stream-clear-input ((stream input-stream)) nil)
299
300(defmethod stream-listen ((stream input-stream))
301  (not (eofp stream)))
302
303(defmethod stream-filename ((stream stream))
304  (report-bad-arg stream 'file-stream))
305
306
307
308
309;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
310
311;;; For input streams, the IO-BUFFER-COUNT field denotes the number
312;;; of elements read from the underlying input source (e.g., the
313;;; file system.)  For output streams, it's the high-water mark of
314;;; elements output to the buffer.
315
316(defstruct io-buffer
317  (buffer nil :type (or (simple-array * (*)) null))
318  (bufptr nil :type (or macptr null))
319  (size 0 :type fixnum)                 ; size (in octets) of buffer
320  (idx 0 :type fixnum)                  ; index of next element
321  (count 0 :type fixnum)                ; count of active elements
322  (limit 0 :type fixnum)                ; size (in elements) of buffer
323  )
324
325(defmethod print-object ((buf io-buffer) out)
326  (print-unreadable-object (buf out :identity t :type t)
327    (let* ((buffer (io-buffer-buffer buf)))
328      (when buffer (format out " ~s " (array-element-type buffer))))
329    (format out "~d/~d/~d"
330            (io-buffer-idx buf)
331            (io-buffer-count buf)
332            (io-buffer-limit buf))))
333
334(defstruct ioblock
335  stream                                ; the stream being buffered
336  untyi-char                            ; nil or last value passed to
337                                        ;  stream-unread-char
338  (inbuf nil :type (or null io-buffer))
339  (outbuf nil :type (or null io-buffer))
340  (element-type 'character)
341  (element-shift 0 :type fixnum)        ;element shift count
342  (charpos 0 :type (or nil fixnum))     ;position of cursor
343  (device -1 :type fixnum)              ;file descriptor
344  (advance-function 'ioblock-advance)
345  (listen-function 'ioblock-listen)
346  (eofp-function 'ioblock-eofp)
347  (force-output-function 'ioblock-force-output)
348  (close-function 'ioblock-close)
349  (inbuf-lock nil)
350  (eof nil)
351  (interactive nil)
352  (dirty nil)
353  (outbuf-lock nil))
354
355
356;;; Functions on ioblocks.  So far, we aren't saying anything
357;;; about how streams use them.
358
359
360(defun ioblock-octets-to-elements (ioblock octets)
361  (let* ((shift (ioblock-element-shift ioblock)))
362    (declare (fixnum shift))
363    (if (zerop shift)
364      octets
365      (ash octets (- shift)))))
366
367(defun ioblock-elements-to-octets (ioblock elements)
368  (let* ((shift (ioblock-element-shift ioblock)))
369    (declare (fixnum shift))
370    (if (zerop shift)
371      elements
372      (ash elements shift))))
373
374
375
376(defmacro with-ioblock-lock-grabbed ((lock)
377                                       &body body)
378  `(with-lock-grabbed (,lock)
379    ,@body))
380
381(defmacro with-ioblock-lock-grabbed-maybe ((lock)
382                                           &body body)
383  `(with-lock-grabbed-maybe (,lock)
384    ,@body))
385
386; ioblock must really be an ioblock or you will crash
387(defmacro with-ioblock-input-locked ((ioblock) &body body)
388  `(with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0)))
389                                   (ioblock-inbuf-lock ,ioblock)))
390     ,@body))
391(defmacro with-ioblock-output-locked ((ioblock) &body body)
392  `(with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0)))
393                                   (ioblock-outbuf-lock ,ioblock)))
394     ,@body))
395
396(defmacro with-ioblock-output-locked-maybe ((ioblock) &body body)
397  `(with-ioblock-lock-grabbed-maybe ((locally (declare (optimize (speed 3) (safety 0)))
398                                       (ioblock-outbuf-lock ,ioblock)))
399     ,@body))
400
401(defun %ioblock-advance (ioblock read-p)
402  (funcall (ioblock-advance-function ioblock)
403           (ioblock-stream ioblock)
404           ioblock
405           read-p))
406(declaim (inline %ioblock-read-byte))
407
408;;; Should only be called with the ioblock locked
409(defun %ioblock-read-byte (ioblock)
410  (declare (optimize (speed 3) (safety 0)))
411  (if (ioblock-untyi-char ioblock)
412    (prog1 (%char-code (ioblock-untyi-char ioblock))
413      (setf (ioblock-untyi-char ioblock) nil))
414    (let* ((buf (ioblock-inbuf ioblock))
415           (idx (io-buffer-idx buf))
416           (limit (io-buffer-count buf)))
417      (declare (fixnum idx limit))
418      (when (= idx limit)
419        (unless (%ioblock-advance ioblock t)
420          (return-from %ioblock-read-byte :eof))
421        (setq idx (io-buffer-idx buf)
422              limit (io-buffer-count buf)))
423      (let ((byte (uvref (io-buffer-buffer buf) idx)))
424        (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
425        (if (characterp byte) (%char-code byte) byte)))))
426
427(defun %ioblock-tyi (ioblock &optional (hang t))
428  (if (ioblock-untyi-char ioblock)
429    (prog1 (ioblock-untyi-char ioblock)
430      (setf (ioblock-untyi-char ioblock) nil))
431    (let* ((buf (ioblock-inbuf ioblock))
432           (idx (io-buffer-idx buf))
433           (limit (io-buffer-count buf)))
434      (declare (fixnum idx limit))
435      (when (= idx limit)
436        (unless (%ioblock-advance ioblock hang)
437          (return-from %ioblock-tyi (if (ioblock-eof ioblock) :eof)))
438        (setq idx (io-buffer-idx buf)
439              limit (io-buffer-count buf)))
440      (let ((byte (uvref (io-buffer-buffer buf) idx)))
441        (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
442        (if (characterp byte) byte (%code-char byte))))))
443
444(defun %ioblock-peek-char (ioblock)
445  (or (ioblock-untyi-char ioblock)
446      (let* ((buf (ioblock-inbuf ioblock))
447             (idx (io-buffer-idx buf))
448             (limit (io-buffer-count buf)))
449        (declare (fixnum idx limit))
450        (when (= idx limit)
451          (unless (%ioblock-advance ioblock t)
452            (return-from %ioblock-peek-char :eof))
453          (setq idx (io-buffer-idx buf)
454                limit (io-buffer-count buf)))
455        (let ((byte (uvref (io-buffer-buffer buf) idx)))
456          (if (characterp byte) byte (%code-char byte))))))
457
458(defun %ioblock-clear-input (ioblock)   
459    (let* ((buf (ioblock-inbuf ioblock)))
460      (setf (io-buffer-count buf) 0
461            (io-buffer-idx buf) 0
462            (ioblock-untyi-char ioblock) nil)))
463
464(defun %ioblock-untyi (ioblock char)
465  (if (ioblock-untyi-char ioblock)
466    (error "Two UNREAD-CHARs without intervening READ-CHAR on ~s"
467           (ioblock-stream ioblock))
468    (setf (ioblock-untyi-char ioblock) char)))
469
470(declaim (inline ioblock-inpos))
471
472(defun ioblock-inpos (ioblock)
473  (io-buffer-idx (ioblock-inbuf ioblock)))
474
475(declaim (inline ioblock-outpos))
476
477(defun ioblock-outpos (ioblock)
478  (io-buffer-count (ioblock-outbuf ioblock)))
479
480(declaim (inline %ioblock-force-output))
481
482(defun %ioblock-force-output (ioblock finish-p)
483  (funcall (ioblock-force-output-function ioblock)
484           (ioblock-stream ioblock)
485           ioblock
486           (ioblock-outpos ioblock)
487           finish-p))
488
489;;; ivector should be an ivector.  The ioblock should have an
490;;; element-shift of 0; start-octet and num-octets should of course
491;;; be sane.  This is mostly to give the fasdumper a quick way to
492;;; write immediate data.
493(defun %ioblock-out-ivect (ioblock ivector start-octet num-octets)
494  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
495    (error "Can't write vector to stream ~s" (ioblock-stream ioblock)))
496  (let* ((written 0)
497         (out (ioblock-outbuf ioblock))
498         (bufsize (io-buffer-size out))
499         (buffer (io-buffer-buffer out)))
500    (declare (fixnum written bufsize))
501    (do* ((pos start-octet (+ pos written))
502          (left num-octets (- left written)))
503         ((= left 0) num-octets)
504      (declare (fixnum pos left))
505      (setf (ioblock-dirty ioblock) t)
506      (let* ((index (io-buffer-idx out))
507             (count (io-buffer-count out))
508             (avail (- bufsize index)))
509        (declare (fixnum index avail count))
510        (cond
511          ((= (setq written avail) 0)
512           (%ioblock-force-output ioblock nil))
513          (t
514           (if (> written left)
515             (setq written left))
516           (%copy-ivector-to-ivector ivector pos buffer index written)
517           (setf (ioblock-dirty ioblock) t)
518           (incf index written)
519           (if (> index count)
520             (setf (io-buffer-count out) index))
521           (setf (io-buffer-idx out) index)
522           (if (= index  bufsize)
523             (%ioblock-force-output ioblock nil))))))))
524
525(declaim (inline %ioblock-write-simple-string))
526
527(defun %ioblock-write-simple-string (ioblock string start-octet num-octets)
528  (declare (fixnum start-octet num-octets) (simple-string string))
529  (let* ((written 0)
530         (col (ioblock-charpos ioblock))
531         (out (ioblock-outbuf ioblock))
532         (bufsize (io-buffer-size out))
533         (buffer (io-buffer-buffer out)))
534    (declare (fixnum written bufsize col)
535             (simple-string buffer)
536             (optimize (speed 3) (safety 0)))
537    (do* ((pos start-octet (+ pos written))
538          (left num-octets (- left written)))
539         ((= left 0) (setf (ioblock-charpos ioblock) col)  num-octets)
540      (declare (fixnum pos left))
541      (setf (ioblock-dirty ioblock) t)
542      (let* ((index (io-buffer-idx out))
543             (count (io-buffer-count out))
544             (avail (- bufsize index)))
545        (declare (fixnum index avail count))
546        (cond
547          ((= (setq written avail) 0)
548           (%ioblock-force-output ioblock nil))
549          (t
550           (if (> written left)
551             (setq written left))
552           (do* ((p pos (1+ p))
553                 (i index (1+ i))
554                 (j 0 (1+ j)))
555                ((= j written))
556             (declare (fixnum p i j))
557             (let* ((ch (schar string p)))
558               (if (eql ch #\newline)
559                 (setq col 0)
560                 (incf col))
561               (setf (schar buffer i) ch)))
562           (setf (ioblock-dirty ioblock) t)
563           (incf index written)
564           (if (> index count)
565             (setf (io-buffer-count out) index))
566           (setf (io-buffer-idx out) index)
567           (if (= index  bufsize)
568             (%ioblock-force-output ioblock nil))))))))
569
570
571(defun %ioblock-eofp (ioblock)
572  (let* ((buf (ioblock-inbuf ioblock)))
573   (and (eql (io-buffer-idx buf)
574             (io-buffer-count buf))
575         (locally (declare (optimize (speed 3) (safety 0)))
576           (with-ioblock-input-locked (ioblock)
577             (funcall (ioblock-eofp-function ioblock)
578                      (ioblock-stream ioblock)
579                      ioblock))))))
580
581(defun %ioblock-listen (ioblock)
582  (let* ((buf (ioblock-inbuf ioblock)))
583    (or (< (the fixnum (io-buffer-idx buf))
584           (the fixnum (io-buffer-count buf)))
585        (funcall (ioblock-listen-function ioblock)
586                 (ioblock-stream ioblock)
587                 ioblock))))
588
589(declaim (inline %ioblock-write-element))
590
591(defun %ioblock-write-element (ioblock element)
592  (declare (optimize (speed 3) (safety 0)))
593  (let* ((buf (ioblock-outbuf ioblock))
594         (idx (io-buffer-idx buf))
595         (count (io-buffer-count buf))
596         (limit (io-buffer-limit buf)))
597    (declare (fixnum idx limit count))
598    (when (= idx limit)
599      (%ioblock-force-output ioblock nil)
600      (setq idx 0 count 0))
601    (setf (aref (io-buffer-buffer buf) idx) element)
602    (incf idx)
603    (setf (io-buffer-idx buf) idx)
604    (when (> idx count)
605      (setf (io-buffer-count buf) idx))
606    (setf (ioblock-dirty ioblock) t)
607    element))
608
609(defun %ioblock-write-char (ioblock char)
610  (declare (optimize (speed 3) (safety 0)))
611  (if (eq char #\linefeed)
612    (setf (ioblock-charpos ioblock) 0)
613    (incf (ioblock-charpos ioblock)))
614  (unless (eq (typecode (io-buffer-buffer (ioblock-outbuf ioblock)))
615              ppc32::subtag-simple-base-string)
616    (setq char (char-code char)))
617  (%ioblock-write-element ioblock char))
618
619(defun %ioblock-write-byte (ioblock byte)
620  (declare (optimize (speed 3) (safety 0)))
621  (when (eq (typecode (io-buffer-buffer (ioblock-outbuf ioblock)))
622            ppc32::subtag-simple-base-string)
623    (setq byte (code-char byte)))
624  (%ioblock-write-element ioblock byte))
625
626 
627(defun %ioblock-clear-output (ioblock)
628  (let* ((buf (ioblock-outbuf ioblock)))                     
629    (setf (io-buffer-count buf) 0
630            (io-buffer-idx buf) 0)))
631
632(defun %ioblock-read-line (ioblock)
633  (let* ((string "")
634         (len 0)
635         (eof nil)
636         (inbuf (ioblock-inbuf ioblock))
637         (buf (io-buffer-buffer inbuf))
638         (newline (if (eq (typecode buf) ppc32::subtag-simple-base-string)
639                    #\newline
640                    (char-code #\newline))))
641    (let* ((ch (ioblock-untyi-char ioblock)))
642      (when ch
643        (setf (ioblock-untyi-char ioblock) nil)
644        (if (eql ch #\newline)
645          (return-from %ioblock-read-line 
646            (values string nil))
647          (progn
648            (setq string (make-string 1)
649                  len 1)
650            (setf (schar string 0) ch)))))
651    (loop
652        (let* ((more 0)
653               (idx (io-buffer-idx inbuf))
654               (count (io-buffer-count inbuf)))
655          (declare (fixnum idx count more))
656          (if (= idx count)
657            (if eof
658              (return (values string t))
659              (progn
660                (setq eof t)
661                (%ioblock-advance ioblock t)))
662            (progn
663              (setq eof nil)
664              (let* ((pos (position newline buf :start idx :end count)))
665                (when pos
666                  (locally (declare (fixnum pos))
667                    (setf (io-buffer-idx inbuf) (the fixnum (1+ pos)))
668                    (setq more (- pos idx))
669                    (unless (zerop more)
670                      (setq string
671                            (%extend-vector
672                             0 string (the fixnum (+ len more)))))
673                    (%copy-ivector-to-ivector
674                     buf idx string len more)
675                    (return (values string nil))))
676                ;; No #\newline in the buffer.  Read everything that's
677                ;; there into the string, and fill the buffer again.
678                (setf (io-buffer-idx inbuf) count)
679                (setq more (- count idx)
680                      string (%extend-vector
681                              0 string (the fixnum (+ len more))))
682                (%copy-ivector-to-ivector
683                 buf idx string len more)
684                (incf len more))))))))
685         
686(defun %ioblock-character-read-vector (ioblock vector start end)
687  (do* ((i start)
688        (in (ioblock-inbuf ioblock))
689        (inbuf (io-buffer-buffer in))
690        (need (- end start)))
691       ((= i end) end)
692    (declare (fixnum i need))
693    (let* ((ch (%ioblock-tyi ioblock)))
694      (if (eq ch :eof)
695        (return i))
696      (setf (schar vector i) ch)
697      (incf i)
698      (decf need)
699      (let* ((idx (io-buffer-idx in))
700             (count (io-buffer-count in))
701             (avail (- count idx)))
702        (declare (fixnum idx count avail))
703        (unless (zerop avail)
704          (if (> avail need)
705            (setq avail need))
706          (%copy-ivector-to-ivector inbuf idx vector i avail)
707          (setf (io-buffer-idx in) (+ idx avail))
708          (incf i avail)
709          (decf need avail))))))
710
711(defun %ioblock-binary-read-vector (ioblock vector start end)
712  (declare (fixnum start end))
713  (let* ((in (ioblock-inbuf ioblock))
714         (inbuf (io-buffer-buffer in)))
715    (if (not (= (the fixnum (typecode inbuf))
716                (the fixnum (typecode vector))))
717      (do* ((i start (1+ i)))
718           ((= i end) i)
719        (declare (fixnum i))
720        (let* ((b (%ioblock-read-byte ioblock)))
721          (if (eq b :eof)
722            (return i)
723            (setf (uvref vector i) b))))
724      (do* ((i start)
725            (need (- end start)))
726           ((= i end) end)
727        (declare (fixnum i need))
728        (let* ((ch (%ioblock-read-byte ioblock)))
729          (if (eq ch :eof)
730            (return i))
731          (setf (uvref vector i) ch)
732          (incf i)
733          (decf need)
734          (let* ((idx (io-buffer-idx in))
735                 (count (io-buffer-count in))
736                 (avail (- count idx)))
737            (declare (fixnum idx count avail))
738            (unless (zerop avail)
739              (if (> avail need)
740                (setq avail need))
741              (%copy-ivector-to-ivector
742               inbuf
743               (ioblock-elements-to-octets ioblock idx)
744               vector
745               (ioblock-elements-to-octets ioblock i)
746               (ioblock-elements-to-octets ioblock avail))
747              (setf (io-buffer-idx in) (+ idx avail))
748              (incf i avail)
749              (decf need avail))))))))
750
751;;; About the same, only less fussy about ivector's element-type.
752;;; (All fussiness is about the stream's element-type ...).
753;;; Whatever the element-type is, elements must be 1 octet in size.
754(defun %ioblock-character-in-ivect (ioblock vector start nb)
755  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
756           (fixnum start nb)
757           (optimize (speed 3) (safety 0)))
758  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
759    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
760  (do* ((i start)
761        (in (ioblock-inbuf ioblock))
762        (inbuf (io-buffer-buffer in))
763        (need nb)
764        (end (+ start nb)))
765       ((= i end) end)
766    (declare (fixnum i end need))
767    (let* ((ch (%ioblock-tyi ioblock)))
768      (if (eq ch :eof)
769        (return (- i start)))
770      (setf (aref vector i) (char-code ch))
771      (incf i)
772      (decf need)
773      (let* ((idx (io-buffer-idx in))
774             (count (io-buffer-count in))
775             (avail (- count idx)))
776        (declare (fixnum idx count avail))
777        (unless (zerop avail)
778          (if (> avail need)
779            (setq avail need))
780          (%copy-ivector-to-ivector inbuf idx vector i avail)
781          (setf (io-buffer-idx in) (+ idx avail))
782          (incf i avail)
783          (decf need avail))))))
784
785(defun %ioblock-binary-in-ivect (ioblock vector start nb)
786  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
787           (fixnum start nb)
788           (optimize (speed 3) (safety 0)))
789  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
790    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
791  (do* ((i start)
792        (in (ioblock-inbuf ioblock))
793        (inbuf (io-buffer-buffer in))
794        (need nb)
795        (end (+ start nb)))
796       ((= i end) nb)
797    (declare (fixnum i end need))
798    (let* ((b (%ioblock-read-byte ioblock)))
799      (if (eq b :eof)
800        (return (- i start)))
801      (setf (uvref vector i) b)
802      (incf i)
803      (decf need)
804      (let* ((idx (io-buffer-idx in))
805             (count (io-buffer-count in))
806             (avail (- count idx)))
807        (declare (fixnum idx count avail))
808        (unless (zerop avail)
809          (if (> avail need)
810            (setq avail need))
811          (%copy-ivector-to-ivector inbuf idx vector i avail)
812          (setf (io-buffer-idx in) (+ idx avail))
813          (incf i avail)
814          (decf need avail))))))
815
816(defun %ioblock-close (ioblock)
817  (let* ((stream (ioblock-stream ioblock)))
818      (funcall (ioblock-close-function ioblock) stream ioblock)
819      (setf (stream-ioblock stream) nil)
820      (let* ((in-iobuf (ioblock-inbuf ioblock))
821             (out-iobuf (ioblock-outbuf ioblock))
822             (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf)))
823             (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf)))
824             (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf)))
825             (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf))))
826        (if (and in-buffer in-bufptr)
827          (%dispose-heap-ivector in-buffer))
828        (unless (eq in-buffer out-buffer)
829          (if (and out-buffer out-bufptr)
830            (%dispose-heap-ivector out-buffer)))
831        (when in-iobuf
832          (setf (io-buffer-buffer in-iobuf) nil
833                (io-buffer-bufptr in-iobuf) nil
834                (ioblock-inbuf ioblock) nil))
835        (when out-iobuf
836          (setf (io-buffer-buffer out-iobuf) nil
837                (io-buffer-bufptr out-iobuf) nil
838                (ioblock-outbuf ioblock) nil)))))
839
840
841;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
842
843
844
845
846
847(defun init-stream-ioblock (stream
848                            &key
849                            insize ; integer to allocate inbuf here, nil
850                                        ; otherwise
851                            outsize ; integer to allocate outbuf here, nil
852                                        ; otherwise
853                            share-buffers-p ; true if input and output
854                                        ; share a buffer
855                            element-type
856                            device
857                            advance-function
858                            listen-function
859                            eofp-function
860                            force-output-function
861                            close-function
862                            element-shift
863                            interactive
864                            &allow-other-keys)
865  (declare (ignorable element-shift))
866  (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil)))
867                        (when ioblock
868                          (setf (ioblock-stream ioblock) stream)
869                          ioblock))
870                      (stream-create-ioblock stream))))
871    (when insize
872      (unless (ioblock-inbuf ioblock)
873        (multiple-value-bind (buffer ptr in-size-in-octets)
874            (make-heap-buffer element-type insize)
875          (setf (ioblock-inbuf ioblock)
876                (make-io-buffer :buffer buffer
877                                :bufptr ptr
878                                :size in-size-in-octets
879                                :limit insize))
880          (setf (ioblock-inbuf-lock ioblock) (make-lock))
881          (setf (ioblock-element-shift ioblock) (ceiling (log  (/ in-size-in-octets insize) 2)))
882          )))
883    (if share-buffers-p
884        (if insize
885            (progn (setf (ioblock-outbuf ioblock)
886                         (ioblock-inbuf ioblock))
887                   (setf (ioblock-outbuf-lock ioblock)
888                         (ioblock-inbuf-lock ioblock)))
889          (error "Can't share buffers unless insize is non-zero and non-null"))
890     
891      (when outsize
892        (unless (ioblock-outbuf ioblock)
893          (multiple-value-bind (buffer ptr out-size-in-octets)
894              (make-heap-buffer element-type outsize)
895            (setf (ioblock-outbuf ioblock)
896                  (make-io-buffer :buffer buffer
897                                  :bufptr ptr
898                                  :count 0
899                                  :limit outsize
900                                  :size out-size-in-octets))
901            (setf (ioblock-outbuf-lock ioblock) (make-lock))
902            (setf (ioblock-element-shift ioblock) (ceiling (log (/ out-size-in-octets outsize) 2)))
903            ))))
904    (when element-type
905      (setf (ioblock-element-type ioblock) element-type))
906;    (when element-shift
907;      (setf (ioblock-element-shift ioblock) element-shift))
908    (when device
909      (setf (ioblock-device ioblock) device))
910    (when advance-function
911      (setf (ioblock-advance-function ioblock) advance-function))
912    (when listen-function
913      (setf (ioblock-listen-function ioblock) listen-function))
914    (when eofp-function
915      (setf (ioblock-eofp-function ioblock) eofp-function))
916    (when force-output-function
917      (setf (ioblock-force-output-function ioblock) force-output-function))
918    (when close-function
919      (setf (ioblock-close-function ioblock) close-function))
920    (when interactive
921      (setf (ioblock-interactive ioblock) interactive))
922    (setf (stream-ioblock stream) ioblock)))
923
924;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses
925;;; in MCL; of course, calling the structure-class's constructor does
926;;; much the same thing (but note that MCL only keeps track of the
927;;; default, automatically generated constructor.)
928(defun make-ioblock-stream (class-name
929                            &rest initargs
930                            &key 
931                            &allow-other-keys)
932  (declare (dynamic-extent initargs))
933  (let* ((class (find-class class-name))
934         (s   (apply #'make-instance class :allow-other-keys t initargs)))
935    (apply #'init-stream-ioblock s initargs)
936    s))
937   
938
939
940(defmethod select-stream-class ((s symbol) in-p out-p char-p)
941  (select-stream-class (class-prototype (find-class s)) in-p out-p char-p))
942
943(defmethod select-stream-class ((s structure-class) in-p out-p char-p)
944  (select-stream-class (class-prototype s) in-p out-p char-p))
945
946(defmethod select-stream-class ((s standard-class) in-p out-p char-p)
947  (select-stream-class (class-prototype s) in-p out-p char-p))
948
949
950(defun make-fd-stream (fd &key
951                          (direction :input)
952                          (interactive t)
953                          (elements-per-buffer *elements-per-buffer*)
954                          (element-type 'character)
955                          (class 'fd-stream))
956  (let* ((in-p (member direction '(:io :input)))
957         (out-p (member direction '(:io :output)))
958         (char-p (or (eq element-type 'character)
959                     (subtypep element-type 'character)))
960         (class-name (select-stream-class class in-p out-p char-p)))
961    (make-ioblock-stream class-name
962                         :insize (if in-p elements-per-buffer)
963                         :outsize (if out-p elements-per-buffer)
964                         :device fd
965                         :interactive interactive
966                         :element-type element-type
967                         :advance-function (if in-p
968                                             (select-stream-advance-function class))
969                         :listen-function (if in-p 'fd-stream-listen)
970                         :eofp-function (if in-p 'fd-stream-eofp)
971                         :force-output-function (if out-p
972                                                  (select-stream-force-output-function class))
973                         :close-function 'fd-stream-close)))
974 
975;;;  Fundamental streams.
976
977(defclass fundamental-stream (stream)
978    ())
979
980(defclass fundamental-input-stream (fundamental-stream input-stream)
981    ())
982
983(defclass fundamental-output-stream (fundamental-stream output-stream)
984    ())
985
986(defmethod input-stream-p ((x t))
987  (report-bad-arg x 'stream))
988                           
989(defmethod input-stream-p ((s fundamental-input-stream))
990  t)
991
992(defmethod output-stream-p ((x t))
993  (report-bad-arg x 'stream))
994
995(defmethod output-stream-p ((s fundamental-input-stream))
996  (typep s 'fundamental-output-stream))
997
998(defmethod output-stream-p ((s fundamental-output-stream))
999  t)
1000
1001(defmethod input-stream-p ((s fundamental-output-stream))
1002  (typep s 'fundamental-input-stream))
1003
1004(defclass fundamental-character-stream (fundamental-stream)
1005    ())
1006
1007(defmethod stream-element-type ((s fundamental-character-stream))
1008  'character)
1009
1010(defclass fundamental-binary-stream (fundamental-stream)
1011    ())
1012
1013(defclass fundamental-character-input-stream (fundamental-input-stream
1014                                              fundamental-character-stream)
1015    ())
1016
1017(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream))
1018  (stream-read-char s))
1019
1020(defmethod stream-peek-char ((s fundamental-character-input-stream))
1021  (let* ((ch (stream-read-char s)))
1022    (unless (eq ch :eof)
1023      (stream-unread-char s ch))
1024    ch))
1025
1026(defmethod stream-listen ((s fundamental-character-input-stream))
1027  (let* ((ch (stream-read-char-no-hang s)))
1028    (when (and ch (not (eq ch :eof)))
1029      (stream-unread-char s ch))
1030    ch))
1031
1032(defmethod stream-clear-input ((s fundamental-character-input-stream))
1033  )
1034
1035(defmethod stream-read-line ((s fundamental-character-input-stream))
1036  (generic-read-line s))
1037
1038(defclass fundamental-character-output-stream (fundamental-output-stream
1039                                               fundamental-character-stream)
1040    ())
1041
1042(defclass fundamental-binary-input-stream (fundamental-input-stream
1043                                           fundamental-binary-stream)
1044    ())
1045
1046(defclass fundamental-binary-output-stream (fundamental-output-stream
1047                                            fundamental-binary-stream)
1048    ())
1049
1050
1051(defmethod stream-read-byte ((s t))
1052  (report-bad-arg s '(and input-stream fundamental-binary-stream)))
1053
1054(defmethod stream-write-byte ((s t) b)
1055  (declare (ignore b))
1056  (report-bad-arg s '(and output-stream fundamental-binary-stream)))
1057
1058(defmethod stream-length ((s stream) &optional new)
1059  (declare (ignore new)))
1060
1061(defmethod stream-start-line-p ((s fundamental-character-output-stream))
1062  (eql 0 (stream-line-column s)))
1063
1064(defmethod stream-terpri ((s fundamental-character-output-stream))
1065  (stream-write-char s #\Newline))
1066
1067(defmethod stream-fresh-line ((s fundamental-character-output-stream))
1068  (unless (stream-start-line-p s)
1069    (stream-terpri s)
1070    t))
1071
1072;;; The bad news is that this doesn't even bother to do the obvious
1073;;; (calling STREAM-WRITE-STRING with a longish string of spaces.)
1074;;; The good news is that this method is pretty useless to (format "~T" ...)
1075;;; anyhow.
1076(defmethod stream-advance-to-column ((s fundamental-character-output-stream)
1077                                     col)
1078  (generic-advance-to-column s col))
1079
1080(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end)
1081  (generic-stream-write-string stream string start end))
1082
1083(defmethod stream-write-list ((stream fundamental-character-output-stream)
1084                              list count)
1085  (declare (fixnum count))
1086  (dotimes (i count)
1087    (stream-write-char stream (pop list))))
1088
1089(defmethod stream-read-list ((stream fundamental-character-input-stream)
1090                             list count)
1091  (generic-character-read-list stream list count))
1092
1093(defmethod stream-write-list ((stream fundamental-binary-output-stream)
1094                              list count)
1095  (declare (fixnum count))
1096  (dotimes (i count)
1097    (stream-write-byte stream (pop list))))
1098
1099(defmethod stream-read-list ((stream fundamental-binary-input-stream)
1100                             list count)
1101  (declare (fixnum count))
1102  (do* ((tail list (cdr tail))
1103        (i 0 (1+ i)))
1104       ((= i count) count)
1105    (declare (fixnum i))
1106    (let* ((b (stream-read-byte stream)))
1107      (if (eq b :eof)
1108        (return i)
1109        (rplaca tail b)))))
1110
1111;;; The read-/write-vector methods could be specialized for stream classes
1112;;; that expose the underlying buffering mechanism.
1113;;; They can assume that the 'vector' argument is a simple one-dimensional
1114;;; array and that the 'start' and 'end' arguments are sane.
1115
1116(defmethod stream-write-vector ((stream fundamental-character-output-stream)
1117                                vector start end)
1118  (declare (fixnum start end))
1119  (do* ((i start (1+ i)))
1120       ((= i end))
1121    (declare (fixnum i))
1122    (stream-write-char stream (uvref vector i))))
1123
1124(defmethod stream-write-vector ((stream fundamental-binary-output-stream)
1125                                vector start end)
1126  (declare (fixnum start end))
1127  (do* ((i start (1+ i)))
1128       ((= i end))
1129    (declare (fixnum i))
1130    (stream-write-byte stream (uvref vector i))))
1131
1132(defmethod stream-read-vector ((stream fundamental-character-input-stream)
1133                               vector start end)
1134  (generic-character-read-vector stream vector start end))
1135
1136(defmethod stream-read-vector ((stream fundamental-binary-input-stream)
1137                               vector start end)
1138  (declare (fixnum start end))
1139  (do* ((i start (1+ i)))
1140       ((= i end) end)
1141    (declare (fixnum i))
1142    (let* ((b (stream-read-byte stream)))
1143      (if (eq b :eof)
1144        (return i)
1145        (setf (uvref vector i) b)))))
1146
1147;;; Synonym streams.
1148
1149(defclass synonym-stream (fundamental-stream)
1150    ((symbol :initarg :symbol :reader synonym-stream-symbol)))
1151
1152(defmethod print-object ((s synonym-stream) out)
1153  (print-unreadable-object (s out :type t :identity t)
1154    (format out "to ~s" (synonym-stream-symbol s))))
1155
1156(macrolet ((synonym-method (name &rest args)
1157            (let* ((stream (make-symbol "STREAM")))
1158              `(defmethod ,name ((,stream synonym-stream) ,@args)
1159                (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args)))))
1160           (synonym-method stream-read-char)
1161           (synonym-method stream-read-byte)
1162           (synonym-method stream-unread-char c)
1163           (synonym-method stream-read-char-no-hang)
1164           (synonym-method stream-peek-char)
1165           (synonym-method stream-listen)
1166           (synonym-method stream-eofp)
1167           (synonym-method stream-clear-input)
1168           (synonym-method stream-read-line)
1169           (synonym-method stream-read-list l c)
1170           (synonym-method stream-read-vector v start end)
1171           (synonym-method stream-write-char c)
1172           ;(synonym-method stream-write-string str &optional (start 0) end)
1173           (synonym-method stream-write-byte b)
1174           (synonym-method stream-clear-output)
1175           (synonym-method stream-line-column)
1176           (synonym-method stream-set-column new)
1177           (synonym-method stream-advance-to-column new)
1178           (synonym-method stream-start-line-p)
1179           (synonym-method stream-fresh-line)
1180           (synonym-method stream-terpri)
1181           (synonym-method stream-force-output)
1182           (synonym-method stream-finish-output)
1183           (synonym-method stream-write-list l c)
1184           (synonym-method stream-write-vector v start end)
1185           (synonym-method stream-element-type)
1186           (synonym-method input-stream-p)
1187           (synonym-method output-stream-p)
1188           (synonym-method interactive-stream-p)
1189           (synonym-method stream-direction)
1190           (synonym-method stream-device direction))
1191
1192
1193(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end)
1194  (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end))
1195
1196(defmethod stream-length ((s synonym-stream) &optional new)
1197  (stream-length (symbol-value (synonym-stream-symbol s)) new))
1198
1199(defmethod stream-position ((s synonym-stream) &optional new)
1200  (stream-position (symbol-value (synonym-stream-symbol s)) new))
1201
1202(defun make-synonym-stream (symbol)
1203  (make-instance 'synonym-stream :symbol (require-type symbol 'symbol)))
1204
1205
1206;;; Two-way streams.
1207(defclass two-way-stream (fundamental-input-stream fundamental-output-stream)
1208    ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream)
1209     (output-stream :initarg :output-stream :accessor two-way-stream-output-stream)))
1210
1211(defmethod print-object ((s two-way-stream) out)
1212  (print-unreadable-object (s out :type t :identity t)
1213    (format out "input ~s, output ~s" 
1214            (two-way-stream-input-stream s)
1215            (two-way-stream-output-stream s))))
1216
1217(macrolet ((two-way-input-method (name &rest args)
1218             (let* ((stream (make-symbol "STREAM")))
1219               `(defmethod ,name ((,stream two-way-stream) ,@args)
1220                 (,name (two-way-stream-input-stream ,stream) ,@args))))
1221           (two-way-output-method (name &rest args)
1222             (let* ((stream (make-symbol "STREAM")))
1223               `(defmethod ,name ((,stream two-way-stream) ,@args)
1224                 (,name (two-way-stream-output-stream ,stream) ,@args)))))
1225  (two-way-input-method stream-read-char)
1226  (two-way-input-method stream-read-byte)
1227  (two-way-input-method stream-unread-char c)
1228  (two-way-input-method stream-read-char-no-hang)
1229  (two-way-input-method stream-peek-char)
1230  (two-way-input-method stream-listen)
1231  (two-way-input-method stream-eofp)
1232  (two-way-input-method stream-clear-input)
1233  (two-way-input-method stream-read-line)
1234  (two-way-input-method stream-read-list l c)
1235  (two-way-input-method stream-read-vector v start end)
1236  (two-way-output-method stream-write-char c)
1237  (two-way-output-method stream-write-byte b)
1238  (two-way-output-method stream-clear-output)
1239  (two-way-output-method stream-line-column)
1240  (two-way-output-method stream-set-column new)
1241  (two-way-output-method stream-advance-to-column new)
1242  (two-way-output-method stream-start-line-p)
1243  (two-way-output-method stream-fresh-line)
1244  (two-way-output-method stream-terpri)
1245  (two-way-output-method stream-force-output)
1246  (two-way-output-method stream-finish-output)
1247  (two-way-output-method stream-write-list l c)
1248  (two-way-output-method stream-write-vector v start end))
1249
1250(defmethod stream-device ((s two-way-stream) direction)
1251  (case direction
1252    (:input (stream-device (two-way-stream-input-stream s) direction))
1253    (:output (stream-device (two-way-stream-output-stream s) direction))))
1254   
1255(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end)
1256  (stream-write-string (two-way-stream-output-stream s) string start end))
1257
1258(defmethod stream-element-type ((s two-way-stream))
1259  (let* ((in-type (stream-element-type (two-way-stream-input-stream s)))
1260         (out-type (stream-element-type (two-way-stream-output-stream s))))
1261    (if (equal in-type out-type)
1262      in-type
1263      `(and ,in-type ,out-type))))
1264
1265(defun make-two-way-stream (in out)
1266  (unless (input-stream-p in)
1267    (require-type in 'input-stream))
1268  (unless (output-stream-p out)
1269    (require-type out 'output-stream))
1270  (make-instance 'two-way-stream :input-stream in :output-stream out))
1271
1272;;; This is intended for use with things like *TERMINAL-IO*, where the
1273;;; OS echoes interactive input.  Whenever we read a character from
1274;;; the underlying input-stream of such a stream, we need to update
1275;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN.
1276
1277(defclass echoing-two-way-stream (two-way-stream)
1278    ())
1279
1280(defmethod stream-read-char ((s echoing-two-way-stream))
1281  (let* ((out (two-way-stream-output-stream s))
1282         (in (two-way-stream-input-stream s)))
1283    (force-output out)
1284    (let* ((ch (stream-read-char in)))
1285      (unless (eq ch :eof)
1286        (if (eq ch #\newline)
1287          (stream-set-column out 0)
1288          (let* ((cur (stream-line-column out)))
1289            (when cur
1290              (stream-set-column out (1+ (the fixnum cur)))))))
1291      ch)))
1292
1293(defun make-echoing-two-way-stream (in out)
1294  (make-instance 'echoing-two-way-stream :input-stream in :output-stream out))
1295
1296;;;echo streams
1297
1298(defclass echo-stream (two-way-stream)
1299    ((did-untyi :initform nil)))
1300
1301(defmethod echo-stream-input-stream ((s echo-stream))
1302  (two-way-stream-input-stream s))
1303
1304(defmethod echo-stream-output-stream ((s echo-stream))
1305  (two-way-stream-output-stream s))
1306
1307(defmethod stream-read-char ((s echo-stream))
1308  (let* ((char (stream-read-char (echo-stream-input-stream s))))
1309    (unless (eq char :eof)
1310      (if (slot-value s 'did-untyi)
1311        (setf (slot-value s 'did-untyi) nil)
1312        (stream-write-char (echo-stream-output-stream s) char)))
1313    char))
1314
1315(defmethod stream-unread-char ((s echo-stream) c)
1316  (call-next-method s c)
1317  (setf (slot-value s 'did-untyi) c))
1318
1319(defmethod stream-clear-input ((s echo-stream))
1320  (call-next-method)
1321  (setf (slot-value s 'did-untyi) nil))
1322
1323(defun make-echo-stream (input-stream output-stream)
1324  (make-instance 'echo-stream
1325                 :input-stream input-stream
1326                 :output-stream output-stream))
1327
1328;;;concatenated-streams
1329
1330(defclass concatenated-stream (fundamental-input-stream)
1331    ((stream :initarg :streams :accessor concatenated-stream-streams)))
1332
1333(defun concatenated-stream-current-input-stream (s)
1334  (car (concatenated-stream-streams s)))
1335
1336(defun concatenated-stream-next-input-stream (s)
1337  (setf (concatenated-stream-streams s)
1338        (cdr (concatenated-stream-streams s)))
1339  (concatenated-stream-current-input-stream s))
1340
1341(defmethod stream-element-type ((s concatenated-stream))
1342  (let* ((c (concatenated-stream-current-input-stream s)))
1343    (if c
1344      (stream-element-type c)
1345      nil)))
1346
1347
1348
1349(defmethod stream-read-char ((s concatenated-stream))
1350  (do* ((c (concatenated-stream-current-input-stream s)
1351           (concatenated-stream-next-input-stream s)))
1352       ((null c) :eof)
1353    (let* ((ch (stream-read-char c)))
1354      (unless (eq ch :eof)
1355        (return ch)))))
1356
1357(defmethod stream-read-byte ((s concatenated-stream))
1358  (do* ((c (concatenated-stream-current-input-stream s)
1359           (concatenated-stream-next-input-stream s)))
1360       ((null c) :eof)
1361    (let* ((b (stream-read-byte c)))
1362      (unless (eq b :eof)
1363        (return b)))))
1364
1365(defmethod stream-unread-char ((s concatenated-stream) char)
1366  (let* ((c (concatenated-stream-current-input-stream s)))
1367    (if c
1368      (stream-unread-char c char))))
1369
1370(defmethod stream-listen ((s concatenated-stream))
1371  (do* ((c (concatenated-stream-current-input-stream s)
1372           (concatenated-stream-next-input-stream s)))
1373       ((null c))
1374    (when (stream-listen c)
1375      (return t))))
1376
1377(defmethod stream-eofp ((s concatenated-stream))
1378  (do* ((c (concatenated-stream-current-input-stream s)
1379           (concatenated-stream-next-input-stream s)))
1380       ((null c) t)
1381    (when (stream-listen c)
1382      (return nil))))
1383
1384(defmethod stream-clear-input ((s concatenated-stream))
1385  (let* ((c (concatenated-stream-current-input-stream s)))
1386    (when c (stream-clear-input c))))
1387
1388
1389(defun make-concatenated-stream (&rest streams)
1390  (dolist (s streams (make-instance 'concatenated-stream :streams streams))
1391    (unless (input-stream-p s)
1392      (error "~S is not an input stream" s))))
1393
1394;;;broadcast-streams
1395
1396
1397
1398(defclass broadcast-stream (fundamental-output-stream)
1399    ((streams :initarg :streams :reader broadcast-stream-streams)))
1400
1401(macrolet ((broadcast-method
1402               (op (stream &rest others )
1403                   &optional
1404                   (args (cons stream others)))
1405             (let* ((sub (gensym))
1406                    (result (gensym)))
1407               `(defmethod ,op ((,stream broadcast-stream) ,@others)
1408                 (let* ((,result nil))
1409                   (dolist (,sub (broadcast-stream-streams ,stream) ,result)
1410                             (setq ,result (,op ,@(cons sub (cdr args))))))))))
1411             (broadcast-method stream-write-char (s c))
1412             (broadcast-method stream-write-string
1413                                      (s str &optional (start 0) end)
1414                                      (s str start end))
1415             (broadcast-method stream-write-byte (s b))
1416             (broadcast-method stream-clear-output (s))
1417             (broadcast-method stream-line-column (s))
1418             (broadcast-method stream-set-column (s new))
1419             (broadcast-method stream-advance-to-column (s new))
1420             (broadcast-method stream-start-line-p (s))
1421             (broadcast-method stream-terpri (s))
1422             (broadcast-method stream-force-output (s))
1423             (broadcast-method stream-finish-output (s))
1424             (broadcast-method stream-stream-write-list (s l c))
1425             (broadcast-method stream-write-vector (s v start end)))
1426
1427(defun last-broadcast-stream (s)
1428  (car (last (broadcast-stream-streams s))))
1429
1430(defmethod stream-fresh-line ((s broadcast-stream))
1431  (let* ((did-output-newline nil))
1432    (dolist (sub (broadcast-stream-streams s) did-output-newline)
1433      (setq did-output-newline (stream-fresh-line sub)))))
1434
1435(defmethod stream-element-type ((s broadcast-stream))
1436  (let* ((last (last-broadcast-stream s)))
1437    (if last
1438      (stream-element-type last)
1439      t)))
1440
1441(defmethod stream-length ((s broadcast-stream) &optional new)
1442  (unless new
1443    (let* ((last (last-broadcast-stream s)))
1444      (if last
1445        (stream-length last)
1446        0))))
1447
1448(defmethod stream-position ((s broadcast-stream) &optional new)
1449  (unless new
1450    (let* ((last (last-broadcast-stream s)))
1451      (if last
1452        (stream-position last)
1453        0))))
1454
1455(defmethod file-stream-external-format ((s broadcast-stream))
1456  (let* ((last (last-broadcast-stream s)))
1457    (if last
1458      (file-stream-external-format last)
1459      :default)))
1460
1461(defun make-broadcast-stream (&rest streams)
1462  (dolist (s streams (make-instance 'broadcast-stream :streams streams))
1463    (unless (output-stream-p s)
1464      (error "~s is not an output stream." s))))
1465
1466
1467
1468;;; String streams.
1469(defclass string-stream (fundamental-character-stream)
1470    ((string :initarg :string :initform nil :reader %string-stream-string)))
1471
1472(defmethod string-stream-string ((s string-stream))
1473  (or (%string-stream-string s)
1474      (error "~s is closed" s)))
1475
1476(defmethod close  ((s string-stream) &key abort)
1477  (declare (ignore abort))
1478  (when (slot-value s 'string)
1479    (setf (slot-value s 'string) nil)
1480    (call-next-method)
1481    t))
1482
1483(defmethod print-object ((s string-stream) out)
1484  (print-unreadable-object (s out :type t :identity t)
1485    (let* ((closed (slot-value s 'closed)))
1486      (when closed (format out "~s" closed)))))
1487
1488(defclass string-output-stream (string-stream fundamental-character-output-stream)
1489    ((column :initform 0 :accessor %stream-column)))
1490
1491(defmethod stream-write-char ((s string-output-stream) c)
1492  (if (eq c #\newline)
1493    (setf (%stream-column s) 0)
1494    (incf (%stream-column s)))
1495  (vector-push-extend c (string-stream-string s)))
1496
1497(defmethod stream-position ((s string-output-stream) &optional newpos)
1498  (let* ((string (string-stream-string s)))
1499    (if newpos
1500      (setf (fill-pointer string) newpos)
1501      (fill-pointer string))))
1502
1503;;; If the stream's string is adjustable, it doesn't really have a meaningful
1504;;; "maximum size".
1505(defmethod stream-length ((s string-output-stream) &optional newlen)
1506  (unless newlen
1507    (array-total-size (string-stream-string s))))
1508
1509(defmethod stream-line-column ((s string-output-stream))
1510  (%stream-column s))
1511
1512(defmethod stream-set-column ((s string-output-stream) new)
1513  (setf (%stream-column s) new))
1514
1515(defun %make-string-output-stream (string)
1516  (unless (and (typep string 'string)
1517               (array-has-fill-pointer-p string))
1518    (error "~S must be a string with a fill pointer."))
1519  (make-instance 'string-output-stream :string  string))
1520
1521(defun make-string-output-stream (&key (element-type 'character element-type-p))
1522  (when (and element-type-p
1523             (not (member element-type '(base-character character
1524                                         standard-char))))
1525    (unless (subtypep element-type 'character)
1526      (error "~S argument ~S is not a subtype of ~S."
1527             :element-type element-type 'character)))
1528  (make-instance 'string-output-stream
1529                 :string (make-array 10 :element-type 'base-char
1530                                     :fill-pointer 0
1531                                     :adjustable t)))
1532
1533;;;"Bounded" string output streams.
1534(defclass truncating-string-stream (string-output-stream)
1535    ((truncated :initform nil)))
1536
1537(defun make-truncating-string-stream (len)
1538  (make-instance 'truncating-string-stream
1539                 :string (make-array len
1540                                     :element-type 'character
1541                                     :fill-pointer 0
1542                                     :adjustable nil)))
1543
1544(defmethod stream-write-char ((s truncating-string-stream) char)
1545  (or (vector-push char (string-stream-string s))
1546      (setf (slot-value s 'truncated) t))
1547  char)
1548
1549(defmethod stream-write-string ((stream truncating-string-stream)
1550                                string &optional (start 0) end)
1551  (setq end (check-sequence-bounds string start end))
1552  (locally (declare (fixnum start end))
1553    (multiple-value-bind (vect offset) (array-data-and-offset string)
1554      (declare (fixnum offset))
1555      (unless (zerop offset)
1556        (incf start offset)
1557        (incf end offset))
1558      (do* ((v (string-stream-string stream))
1559            (i start (1+ i)))
1560           ((= i end) string)
1561        (declare (fixnum i))
1562        (if (slot-value stream 'truncated)
1563          (return string)
1564          (or (vector-push (schar vect i) v)
1565              (progn
1566                (setf (slot-value stream 'truncated) t)
1567                (return string))))))))
1568
1569;;;One way to indent on newlines:
1570
1571(defclass indenting-string-output-stream (string-output-stream)
1572    ((prefixchar :initform nil :initarg :prefixchar)
1573     (indent :initform nil :initarg :indent :accessor indenting-string-output-stream-indent)))
1574
1575(defun make-indenting-string-output-stream (prefixchar indent)
1576  (make-instance 'indenting-string-output-stream
1577   :string (make-array 10
1578                     :element-type 'character
1579                     :fill-pointer 0
1580                     :adjustable t)
1581   :prefixchar prefixchar
1582   :indent indent))
1583
1584(defmethod stream-write-char ((s indenting-string-output-stream) c)
1585  (call-next-method)
1586  (when (eq c #\newline)
1587    (let* ((indent (slot-value s 'indent))
1588           (prefixchar (slot-value s 'prefixchar))
1589           (prefixlen 0))
1590      (when prefixchar
1591        (if (typep prefixchar 'character)
1592          (progn
1593            (setq prefixlen 1)
1594            (call-next-method s prefixchar))
1595          (dotimes (i (setq prefixlen (length prefixchar)))
1596            (call-next-method s (schar prefixchar i)))))
1597      (when indent
1598        (dotimes (i (the fixnum (- indent prefixlen)))
1599          (call-next-method s #\Space)))))
1600  c)
1601
1602(defun get-output-stream-string (s)
1603  (unless (typep s 'string-output-stream)
1604    (report-bad-arg s 'string-output-stream))
1605  (let* ((string (string-stream-string s)))
1606    (prog1 (coerce string 'simple-string)
1607      (setf (fill-pointer string) 0))))
1608
1609;;; String input streams.
1610(defclass string-input-stream (string-stream fundamental-character-input-stream)
1611    ((start :initform 0 :initarg :start :accessor string-input-stream-start)
1612     (index :initarg :index :accessor string-input-stream-index)
1613     (end :initarg :end :accessor string-input-stream-end)))
1614
1615(defmethod stream-read-char ((s string-input-stream))
1616  (let* ((string (string-stream-string s))
1617         (idx (string-input-stream-index s))
1618         (end (string-input-stream-end s)))
1619    (declare (fixnum idx end))
1620    (if (< idx end)
1621      (prog1 (char string idx) (setf (string-input-stream-index s) (1+ idx)))
1622      :eof)))
1623
1624(defmethod stream-peek-char ((s string-input-stream))
1625  (let* ((string (string-stream-string s))
1626         (idx (string-input-stream-index s))
1627         (end (string-input-stream-end s)))
1628    (declare (fixnum idx end))
1629    (if (< idx end)
1630      (char string idx)
1631      :eof)))
1632
1633(defmethod stream-unread-char ((s string-input-stream) c)
1634  (let* ((data (string-stream-string s))
1635         (idx (string-input-stream-index s))
1636         (start (string-input-stream-start s)))
1637    (declare (fixnum idx start))
1638    (unless (> idx start)
1639      (error "Nothing has been read from ~s yet." s))
1640    (decf idx)
1641    (unless (eq c (char data idx))
1642      (error "~a was not the last character read from ~s" c s))
1643    (setf (string-input-stream-index s) idx)
1644    c))
1645
1646
1647
1648(defmethod stream-eofp ((s string-input-stream))
1649  (let* ((idx (string-input-stream-index s))
1650         (end (string-input-stream-end s)))
1651    (declare (fixnum idx end))
1652    (>= idx end)))
1653
1654(defmethod stream-listen ((s string-input-stream))
1655  (let* ((idx (string-input-stream-index s))
1656         (end (string-input-stream-end s)))
1657    (declare (fixnum idx end))
1658    (< idx end)))
1659
1660(defmethod stream-clear-input ((s string-input-stream))
1661  (setf (string-input-stream-index s)
1662        (string-input-stream-start s))
1663  nil)
1664
1665(defmethod stream-position ((s string-input-stream) &optional newpos)
1666  (let* ((start (string-input-stream-start s))
1667         (end (string-input-stream-end s))
1668         (len (- end start)))
1669    (declare (fixnum start end len))
1670    (if newpos
1671      (if (and (>= newpos 0) (<= newpos len))
1672        (setf (string-input-stream-index s) (+ start newpos)))
1673      (- (string-input-stream-index s) start))))
1674
1675(defmethod stream-length ((s string-input-stream) &optional newlen)
1676  (unless newlen
1677    (- (string-input-stream-end s) (string-input-stream-start s))))
1678
1679(defun make-string-input-stream (string &optional (start 0)
1680                                        (end nil))
1681  (setq end (check-sequence-bounds string start end))
1682  (make-instance 'string-input-stream
1683                 :string string
1684                 :start start
1685                 :index start
1686                 :end end))
1687
1688
1689;;; A mixin to be used with FUNDAMENTAL-STREAMs that want to use ioblocks
1690;;; to buffer I/O.
1691
1692(defclass buffered-stream-mixin ()
1693  ((ioblock :reader %stream-ioblock :writer (setf stream-ioblock) :initform nil)
1694   (element-type :initarg :element-type :reader %buffered-stream-element-type)))
1695
1696(defun stream-ioblock (stream &optional (error-if-nil t))
1697  (or (%stream-ioblock stream)
1698      (when error-if-nil
1699        (error "~s is closed" stream))))
1700
1701(defmethod stream-device ((s buffered-stream-mixin) direction)
1702  (declare (ignore direction))
1703  (let* ((ioblock (stream-ioblock s nil)))
1704    (and ioblock (ioblock-device ioblock))))
1705 
1706(defmethod stream-element-type ((s buffered-stream-mixin))
1707  (%buffered-stream-element-type s))
1708
1709(defmethod stream-create-ioblock ((stream buffered-stream-mixin) &rest args &key)
1710  (declare (dynamic-extent args))
1711  (apply #'make-ioblock :stream stream args))
1712
1713(defclass buffered-input-stream-mixin
1714          (buffered-stream-mixin fundamental-input-stream)
1715  ())
1716
1717(defclass buffered-output-stream-mixin
1718          (buffered-stream-mixin fundamental-output-stream)
1719  ())
1720
1721(defclass buffered-io-stream-mixin
1722          (buffered-input-stream-mixin buffered-output-stream-mixin)
1723  ())
1724
1725(defclass buffered-character-input-stream-mixin
1726          (buffered-input-stream-mixin fundamental-character-input-stream)
1727  ())
1728
1729(defclass buffered-character-output-stream-mixin
1730          (buffered-output-stream-mixin fundamental-character-output-stream)
1731  ())
1732
1733(defclass buffered-character-io-stream-mixin
1734          (buffered-character-input-stream-mixin buffered-character-output-stream-mixin)
1735  ())
1736
1737(defclass buffered-binary-input-stream-mixin
1738          (buffered-input-stream-mixin fundamental-binary-input-stream)
1739  ())
1740
1741(defclass buffered-binary-output-stream-mixin
1742          (buffered-output-stream-mixin fundamental-binary-output-stream)
1743  ())
1744
1745(defclass buffered-binary-io-stream-mixin
1746          (buffered-binary-input-stream-mixin
1747           buffered-binary-output-stream-mixin)
1748  ())
1749
1750(defmethod close :after ((stream buffered-stream-mixin) &key abort)
1751  (declare (ignore abort))
1752  (let* ((ioblock (stream-ioblock stream nil)))
1753    (when ioblock
1754      (%ioblock-close ioblock))))
1755
1756(defmethod close :before ((stream buffered-output-stream-mixin) &key abort)
1757  (unless abort
1758    (when (open-stream-p stream)
1759      (stream-force-output stream))))
1760
1761(defmethod interactive-stream-p ((stream buffered-stream-mixin))
1762  (let* ((ioblock (stream-ioblock stream nil)))
1763    (and ioblock (ioblock-interactive ioblock))))
1764
1765
1766#|
1767(defgeneric ioblock-advance (stream ioblock readp)
1768  (:documentation
1769   "Called when the current input buffer is empty (or non-existent).
1770    readp true means the caller expects to return a byte now.
1771    Return value is meaningless unless readp is true, in which case
1772    it means that there is input ready"))
1773
1774(defgeneric ioblock-listen (stream ioblock)
1775  (:documentation
1776   "Called in response to stream-listen when the current
1777    input buffer is empty.
1778    Returns a boolean"))
1779
1780(defgeneric ioblock-eofp (stream ioblock)
1781  (:documentation
1782   "Called in response to stream-eofp when the input buffer is empty.
1783    Returns a boolean."))
1784
1785(defgeneric ioblock-force-output (stream ioblock count finish-p)
1786  (:documentation
1787   "Called in response to stream-force-output.
1788    Write count bytes from ioblock-outbuf.
1789    Finish the I/O if finish-p is true."))
1790
1791(defgeneric ioblock-close (stream ioblock)
1792  (:documentation
1793   "May free some resources associated with the ioblock."))
1794|#
1795
1796(defmethod ioblock-close ((stream buffered-stream-mixin) ioblock)
1797  (declare (ignore ioblock)))
1798
1799(defmethod ioblock-force-output ((stream buffered-output-stream-mixin)
1800                                   ioblock
1801                                   count
1802                                   finish-p)
1803  (declare (ignore ioblock count finish-p)))
1804
1805
1806
1807(defmacro with-stream-ioblock-input ((ioblock stream &key
1808                                             speedy)
1809                                  &body body)
1810  `(let ((,ioblock (stream-ioblock ,stream)))
1811     ,@(when speedy `((declare (optimize (speed 3) (safety 0)))))
1812     (with-ioblock-input-locked (,ioblock) ,@body)))
1813
1814(defmacro with-stream-ioblock-output ((ioblock stream &key
1815                                             speedy)
1816                                  &body body)
1817  `(let ((,ioblock (stream-ioblock ,stream)))
1818     ,@(when speedy `((declare (optimize (speed 3) (safety 0)))))
1819     (with-ioblock-output-locked (,ioblock) ,@body)))
1820
1821(defmacro with-stream-ioblock-output-maybe ((ioblock stream &key
1822                                                     speedy)
1823                                            &body body)
1824  `(let ((,ioblock (stream-ioblock ,stream)))
1825    ,@(when speedy `((declare (optimize (speed 3) (safety 0)))))
1826    (with-ioblock-output-locked-maybe (,ioblock) ,@body)))
1827
1828(defmethod stream-read-char ((stream buffered-character-input-stream-mixin))
1829  (with-stream-ioblock-input (ioblock stream :speedy t)
1830    (%ioblock-tyi ioblock)))
1831
1832(defmethod stream-read-char-no-hang ((stream buffered-character-input-stream-mixin))
1833  (with-stream-ioblock-input (ioblock stream :speedy t)
1834    (%ioblock-tyi ioblock nil)))
1835
1836(defmethod stream-peek-char ((stream buffered-character-input-stream-mixin))
1837  (with-stream-ioblock-input (ioblock stream :speedy t)
1838    (%ioblock-peek-char ioblock)))
1839
1840(defmethod stream-clear-input ((stream buffered-input-stream-mixin))
1841  (with-stream-ioblock-input (ioblock stream :speedy t)
1842    (%ioblock-clear-input ioblock)))
1843
1844(defmethod stream-unread-char ((stream buffered-character-input-stream-mixin) char)
1845  (with-stream-ioblock-input (ioblock stream :speedy t)
1846    (%ioblock-untyi ioblock char))
1847  char)
1848
1849(defmethod stream-read-byte ((stream buffered-binary-input-stream-mixin))
1850  (with-stream-ioblock-input (ioblock stream :speedy t)
1851    (%ioblock-read-byte ioblock)))
1852
1853(defmethod stream-eofp ((stream buffered-input-stream-mixin))
1854  (with-stream-ioblock-input (ioblock stream :speedy t)
1855    (%ioblock-eofp ioblock)))
1856
1857(defmethod stream-listen ((stream buffered-input-stream-mixin))
1858  (with-stream-ioblock-input (ioblock stream :speedy t)
1859    (%ioblock-listen ioblock)))
1860
1861(defun flush-ioblock (ioblock finish-p)
1862  (with-ioblock-output-locked (ioblock)
1863    (%ioblock-force-output ioblock finish-p)))
1864
1865(defmethod stream-write-byte ((stream buffered-binary-output-stream-mixin)
1866                              byte)
1867  (with-stream-ioblock-output (ioblock stream :speedy t)
1868    (%ioblock-write-byte ioblock byte)))
1869
1870(defmethod stream-write-char ((stream buffered-character-output-stream-mixin) char)
1871  (with-stream-ioblock-output (ioblock stream :speedy t)
1872    (%ioblock-write-char ioblock char)))
1873
1874(defmethod stream-clear-output ((stream buffered-output-stream-mixin))
1875  (with-stream-ioblock-output (ioblock stream :speedy t)
1876    (%ioblock-clear-output ioblock))
1877  nil)
1878
1879(defmethod stream-line-column ((stream buffered-character-output-stream-mixin))
1880  (let* ((ioblock (stream-ioblock stream nil)))
1881    (and ioblock (ioblock-charpos ioblock))))
1882
1883(defmethod stream-set-column ((stream buffered-character-output-stream-mixin)
1884                              new)
1885  (let* ((ioblock (stream-ioblock stream nil)))
1886    (and ioblock (setf (ioblock-charpos ioblock) new))))
1887
1888(defmethod stream-force-output ((stream buffered-output-stream-mixin))
1889  (with-stream-ioblock-output (ioblock stream :speedy t)
1890    (%ioblock-force-output ioblock nil)
1891    nil))
1892
1893(defmethod maybe-stream-force-output ((stream buffered-output-stream-mixin))
1894  (with-stream-ioblock-output-maybe (ioblock stream :speedy t)
1895    (%ioblock-force-output ioblock nil)
1896    nil))
1897
1898(defmethod stream-finish-output ((stream buffered-output-stream-mixin))
1899  (with-stream-ioblock-output (ioblock stream :speedy t)
1900    (%ioblock-force-output ioblock t)
1901    nil))
1902
1903(defmethod stream-write-string ((stream buffered-character-output-stream-mixin)
1904                                string &optional (start 0 start-p) end)
1905                               
1906  (with-stream-ioblock-output (ioblock stream :speedy t)
1907    (if (and (typep string 'simple-string)
1908             (not start-p))
1909      (%ioblock-write-simple-string ioblock string 0 (length string))
1910      (progn
1911        (setq end (check-sequence-bounds string start end))
1912        (locally (declare (fixnum start end))
1913          (multiple-value-bind (arr offset)
1914              (if (typep string 'simple-string)
1915                (values string 0)
1916                (array-data-and-offset (require-type string 'string)))
1917            (unless (eql 0 offset)
1918              (incf start offset)
1919              (incf end offset))
1920            (%ioblock-write-simple-string ioblock arr start (the fixnum (- end start)))))))))
1921
1922
1923(defmethod stream-write-ivector ((s buffered-output-stream-mixin)
1924                                 iv start length)
1925  (with-stream-ioblock-output (ioblock s :speedy t)
1926    (%ioblock-out-ivect ioblock iv start length)))
1927
1928(defmethod stream-read-ivector ((s buffered-character-input-stream-mixin)
1929                                iv start nb)
1930  (with-stream-ioblock-input (ioblock s :speedy t)
1931    (%ioblock-character-in-ivect ioblock iv start nb)))
1932
1933(defmethod stream-read-ivector ((s buffered-binary-input-stream-mixin)
1934                                iv start nb)
1935  (with-stream-ioblock-input (ioblock s :speedy t)
1936    (%ioblock-binary-in-ivect ioblock iv start nb)))
1937
1938(defmethod stream-write-vector ((stream buffered-character-output-stream-mixin)
1939                                vector start end)
1940  (declare (fixnum start end))
1941  (if (not (typep vector 'simple-base-string))
1942    (call-next-method)
1943    (with-stream-ioblock-output (ioblock stream :speedy t)
1944      (let* ((total (- end start)))
1945        (declare (fixnum total))
1946        (%ioblock-out-ivect ioblock vector start total)
1947        (let* ((last-newline (position #\newline vector
1948                                       :start start
1949                                       :end end
1950                                       :from-end t)))
1951          (if last-newline
1952            (setf (ioblock-charpos ioblock)
1953                  (- end last-newline 1))
1954            (incf (ioblock-charpos ioblock) total)))))))
1955
1956(defmethod stream-write-vector ((stream buffered-binary-output-stream-mixin)
1957                                vector start end)
1958  (declare (fixnum start end))
1959  (with-stream-ioblock-output (ioblock stream :speedy t)
1960    (let* ((out (ioblock-outbuf ioblock))
1961           (buf (io-buffer-buffer out))
1962           (written 0)
1963           (limit (io-buffer-limit out))
1964           (total (- end start))
1965           (buftype (typecode buf)))
1966      (declare (fixnum buftype written total limit))
1967      (if (not (= (the fixnum (typecode vector)) buftype))
1968        (do* ((i start (1+ i)))
1969             ((= i end))
1970          (let ((byte (uvref vector i)))
1971            (when (characterp byte)
1972              (setq byte (char-code byte)))
1973            (%ioblock-write-byte ioblock byte)))
1974        (do* ((pos start (+ pos written))
1975              (left total (- left written)))
1976             ((= left 0))
1977          (declare (fixnum pos left))
1978          (setf (ioblock-dirty ioblock) t)
1979          (let* ((index (io-buffer-idx out))
1980                 (count (io-buffer-count out))
1981                 (avail (- limit index)))
1982            (declare (fixnum index avail count))
1983            (cond
1984              ((= (setq written avail) 0)
1985               (%ioblock-force-output ioblock nil))
1986              (t
1987               (if (> written left)
1988                 (setq written left))
1989               (%copy-ivector-to-ivector
1990                vector
1991                (ioblock-elements-to-octets ioblock pos)
1992                buf
1993                (ioblock-elements-to-octets ioblock index)
1994                (ioblock-elements-to-octets ioblock written))
1995               (setf (ioblock-dirty ioblock) t)
1996               (incf index written)
1997               (if (> index count)
1998                 (setf (io-buffer-count out) index))
1999               (setf (io-buffer-idx out) index)
2000               (if (= index  limit)
2001                 (%ioblock-force-output ioblock nil))))))))))
2002
2003(defmethod stream-read-vector ((stream buffered-character-input-stream-mixin)
2004                               vector start end)
2005  (declare (fixnum start end))
2006  (if (not (typep vector 'simple-base-string))
2007    (call-next-method)
2008    (with-stream-ioblock-input (ioblock stream :speedy t)
2009      (%ioblock-character-read-vector ioblock vector start end))))
2010
2011(defmethod stream-read-vector ((stream buffered-binary-input-stream-mixin)
2012                               vector start end)
2013  (declare (fixnum start end))
2014  (if (typep vector 'simple-base-string)
2015    (call-next-method)
2016    (with-stream-ioblock-input (ioblock stream :speedy t)
2017      (%ioblock-binary-read-vector ioblock vector start end))))
2018
2019(defloadvar *fd-set-size*
2020    (ff-call (%kernel-import ppc32::kernel-import-fd-setsize-bytes)
2021             :unsigned-fullword))
2022
2023(defun unread-data-available-p (fd)
2024  (%stack-block ((arg 4))
2025    (setf (%get-long arg) 0)
2026    (when (zerop (syscall os::ioctl fd #$FIONREAD arg))
2027      (let* ((avail (%get-long arg)))
2028        (and (> avail 0) avail)))))
2029
2030;;; Read and discard any available unread input.
2031(defun %fd-drain-input (fd)
2032  (%stack-block ((buf 1024))
2033    (do* ((avail (unread-data-available-p fd) (unread-data-available-p fd)))
2034         ((or (null avail) (eql avail 0)))
2035      (do* ((max (min avail 1024) (min avail 1024)))
2036           ((zerop avail))
2037        (let* ((count (fd-read fd buf max)))
2038          (if (< count 0)
2039            (return)
2040            (decf avail count)))))))
2041
2042(defun fd-zero (fdset)
2043  (ff-call (%kernel-import ppc32::kernel-import-do-fd-zero)
2044           :address fdset
2045           :void))
2046
2047(defun fd-set (fd fdset)
2048  (ff-call (%kernel-import ppc32::kernel-import-do-fd-set)
2049           :unsigned-fullword fd
2050           :address fdset
2051           :void))
2052
2053(defun fd-clr (fd fdset)
2054  (ff-call (%kernel-import ppc32::kernel-import-do-fd-clr)
2055           :unsigned-fullword fd
2056           :address fdset
2057           :void))
2058
2059(defun fd-is-set (fd fdset)
2060  (not (= 0 (the fixnum (ff-call (%kernel-import ppc32::kernel-import-do-fd-is-set)
2061                                 :unsigned-fullword fd
2062                                 :address fdset
2063                                 :unsigned-fullword)))))
2064
2065(defun process-input-wait (fd &optional ticks)
2066  (let* ((wait-end (if ticks (+ (get-tick-count) ticks))))
2067    (loop
2068      (when (fd-input-available-p fd 0)
2069        (return t))
2070      (let* ((now (get-tick-count)))
2071        (if (and wait-end (>= now wait-end))
2072          (return))
2073        (fd-input-available-p fd (if ticks (- wait-end now)))))))
2074
2075
2076
2077(defun process-output-wait (fd)
2078  (loop
2079    (when (fd-ready-for-output-p fd 0)
2080      (return t))
2081    (process-wait "output-wait" #'fd-ready-for-output-p fd *ticks-per-second*)))
2082
2083
2084 
2085;; Use this when it's possible that the fd might be in
2086;; a non-blocking state.  Body must return a negative of
2087;; the os error number on failure.
2088;; The use of READ-FROM-STRING below is certainly ugly, but macros
2089;; that expand into reader-macros don't generally trigger the reader-macro's
2090;; side-effects.  (Besides, the reader-macro might return a different
2091;; value when the macro function is expanded than it did when the macro
2092;; function was defined; this can happen during cross-compilation.)
2093(defmacro with-eagain (fd direction &body body)
2094  (let* ((res (gensym))
2095         (eagain (symbol-value (read-from-string "#$EAGAIN"))))
2096   `(loop
2097      (let ((,res (progn ,@body)))
2098        (if (eql ,res (- ,eagain))
2099          (,(ecase direction
2100             (:input 'process-input-wait)
2101             (:output 'process-output-wait))
2102           ,fd)
2103          (return ,res))))))
2104
2105
2106(defun ticks-to-timeval (ticks tv)
2107  (when ticks
2108    (let* ((total-us (* ticks (/ 1000000 *ticks-per-second*))))
2109      (multiple-value-bind (seconds us) (floor total-us 1000000)
2110        (setf (pref tv :timeval.tv_sec) seconds
2111              (pref tv :timeval.tv_usec) us)))))
2112
2113(defun fd-input-available-p (fd &optional ticks)
2114  (rletZ ((tv :timeval))
2115    (ticks-to-timeval ticks tv)
2116    (%stack-block ((infds *fd-set-size*)
2117                   (errfds *fd-set-size*))
2118      (fd-zero infds)
2119      (fd-zero errfds)
2120      (fd-set fd infds)
2121      (fd-set fd errfds)
2122      (let* ((res (syscall os::select (1+ fd) infds (%null-ptr) errfds
2123                           (if ticks tv (%null-ptr)))))
2124        (> res 0)))))
2125
2126(defun fd-ready-for-output-p (fd &optional ticks)
2127  (rletZ ((tv :timeval))
2128    (ticks-to-timeval ticks tv)
2129    (%stack-block ((outfds *fd-set-size*)
2130                   (errfds *fd-set-size*))
2131      (fd-zero outfds)
2132      (fd-zero errfds)
2133      (fd-set fd outfds)
2134      (fd-set fd errfds)
2135      (let* ((res (#_select (1+ fd) (%null-ptr) outfds errfds
2136                            (if ticks tv (%null-ptr)))))
2137        (> res 0)))))
2138
2139(defun fd-urgent-data-available-p (fd &optional ticks)
2140  (rletZ ((tv :timeval))
2141    (ticks-to-timeval ticks tv)
2142    (%stack-block ((errfds *fd-set-size*))
2143      (fd-zero errfds)
2144      (fd-set fd errfds)
2145      (let* ((res (#_select (1+ fd) (%null-ptr) (%null-ptr)  errfds
2146                            (if ticks tv (%null-ptr)))))
2147        (> res 0)))))
2148
2149;;; FD-streams, built on top of the ioblock mechanism.
2150(defclass fd-stream (buffered-stream-mixin fundamental-stream) ())
2151
2152
2153(defmethod select-stream-advance-function ((s symbol))
2154  (select-stream-advance-function (find-class s)))
2155
2156(defmethod select-stream-advance-function ((c class))
2157  (select-stream-advance-function (class-prototype c)))
2158
2159(defmethod select-stream-advance-function ((s fd-stream))
2160  'fd-stream-advance)
2161
2162(defmethod select-stream-force-output-function ((s symbol))
2163  (select-stream-force-output-function (find-class s)))
2164
2165(defmethod select-stream-force-output-function ((c class))
2166  (select-stream-force-output-function (class-prototype c)))
2167
2168(defmethod select-stream-force-output-function ((f fd-stream))
2169  'fd-stream-force-output)
2170
2171(defmethod print-object ((s fd-stream) out)
2172  (print-unreadable-object (s out :type t :identity t)
2173    (let* ((ioblock (stream-ioblock s nil))
2174           (fd (and ioblock (ioblock-device ioblock))))
2175      (if fd
2176        (format out "(~a/~d)" (%unix-fd-kind fd) fd)
2177        (format out "~s" :closed)))))
2178
2179(defclass fd-input-stream (fd-stream buffered-input-stream-mixin)
2180    ())
2181
2182(defclass fd-output-stream (fd-stream buffered-output-stream-mixin)
2183    ())
2184
2185(defclass fd-io-stream (fd-stream buffered-io-stream-mixin)
2186    ())
2187
2188(defclass fd-character-input-stream (fd-input-stream
2189                                     buffered-character-input-stream-mixin)
2190    ())
2191
2192(defclass fd-character-output-stream (fd-output-stream
2193                                      buffered-character-output-stream-mixin)
2194    ())
2195
2196(defclass fd-character-io-stream (fd-io-stream
2197                                  buffered-character-io-stream-mixin)
2198    ())
2199
2200(defclass fd-binary-input-stream (fd-input-stream
2201                                  buffered-binary-input-stream-mixin)
2202    ())
2203
2204(defclass fd-binary-output-stream (fd-output-stream
2205                                   buffered-binary-output-stream-mixin)
2206    ())
2207
2208(defclass fd-binary-io-stream (fd-io-stream buffered-binary-io-stream-mixin)
2209    ())
2210
2211(defun fd-stream-advance (s ioblock read-p)
2212  (let* ((fd (ioblock-device ioblock))
2213         (buf (ioblock-inbuf ioblock))
2214         (bufptr (io-buffer-bufptr buf))
2215         (size (io-buffer-size buf)))
2216    (setf (io-buffer-idx buf) 0
2217          (io-buffer-count buf) 0
2218          (ioblock-eof ioblock) nil)
2219    (let* ((avail nil))
2220      (when (or read-p (setq avail (stream-listen s)))
2221        (if (and (ioblock-interactive ioblock)
2222                 (not avail))
2223          (process-input-wait fd))
2224        (let* ((n (with-eagain fd :input
2225                    (fd-read fd bufptr size))))
2226          (declare (fixnum n))
2227          (if (< n 0)
2228            (stream-io-error s (- n) "read")
2229            (if (> n 0)
2230              (setf (io-buffer-count buf)
2231                    (ioblock-octets-to-elements ioblock n))
2232              (progn (setf (ioblock-eof ioblock) t)
2233                     nil))))))))
2234
2235(defun fd-stream-eofp (s ioblock)
2236  (declare (ignore s))
2237  (ioblock-eof ioblock))
2238 
2239(defun fd-stream-listen (s ioblock)
2240  (declare (ignore s))
2241  (unread-data-available-p (ioblock-device ioblock)))
2242
2243(defun fd-stream-close (s ioblock)
2244  (when (ioblock-dirty ioblock)
2245    (stream-finish-output s))
2246  (let* ((fd (ioblock-device ioblock)))
2247    (when fd
2248      (setf (ioblock-device ioblock) nil)
2249      (fd-close fd))))
2250
2251(defun fd-stream-force-output (s ioblock count finish-p)
2252  (when (or (ioblock-dirty ioblock) finish-p)
2253    (setf (ioblock-dirty ioblock) nil)
2254    (let* ((fd (ioblock-device ioblock))
2255           (io-buffer (ioblock-outbuf ioblock))
2256           (buf (%null-ptr))
2257           (octets-to-write (ioblock-elements-to-octets ioblock count))
2258           (octets octets-to-write))
2259      (declare (fixnum octets))
2260      (declare (dynamic-extent buf))
2261      (%setf-macptr buf (io-buffer-bufptr io-buffer))
2262      (setf (io-buffer-idx io-buffer) 0
2263            (io-buffer-count io-buffer) 0)
2264      (do* ()
2265           ((= octets 0)
2266            (when finish-p
2267              (case (%unix-fd-kind fd)
2268                (:file (fd-fsync fd))))
2269            octets-to-write)
2270        (let* ((written (with-eagain fd :output
2271                          (fd-write fd buf octets))))
2272          (declare (fixnum written))
2273          (if (< written 0)
2274            (stream-io-error s (- written) "write"))
2275          (decf octets written)
2276          (unless (zerop octets)
2277            (%incf-ptr buf written)))))))
2278
2279(defmethod stream-read-line ((s buffered-stream-mixin))
2280   (with-stream-ioblock-input (ioblock s :speedy t)
2281     (%ioblock-read-line ioblock)))
2282
2283(defmethod stream-clear-input ((s fd-input-stream))
2284  (call-next-method)
2285  (with-stream-ioblock-input (ioblock s :speedy t)
2286    (let* ((fd (ioblock-device ioblock)))
2287      (when fd (%fd-drain-input fd)))))
2288
2289(defmethod select-stream-class ((class (eql 'fd-stream)) in-p out-p char-p)
2290  (if char-p
2291    (if in-p
2292      (if out-p
2293        'fd-character-io-stream
2294        'fd-character-input-stream)
2295      'fd-character-output-stream)
2296    (if in-p
2297      (if out-p
2298        'fd-binary-io-stream
2299        'fd-binary-input-stream)
2300      'fd-character-output-stream)))
2301
2302(defstruct (input-selection (:include dll-node))
2303  (package nil :type (or null string package))
2304  (source-file nil :type (or null string pathname))
2305  (string-stream nil :type (or null string-input-stream)))
2306
2307(defstruct (input-selection-queue (:include locked-dll-header)))
2308
2309(defclass selection-input-stream (fd-character-input-stream)
2310    ((selections :initform (init-dll-header (make-input-selection-queue))
2311                 :reader selection-input-stream-selections)
2312     (current-selection :initform nil
2313                        :accessor selection-input-stream-current-selection)
2314     (peer-fd  :reader selection-input-stream-peer-fd)))
2315
2316(defmethod select-stream-class ((class (eql 'selection-input-stream))
2317                                in-p out-p char-p)
2318  (if (and in-p char-p (not out-p))
2319    'selection-input-stream
2320    (error "Can't create that type of stream.")))
2321
2322(defun make-selection-input-stream (fd &key peer-fd (elements-per-buffer *elements-per-buffer*))
2323  (let* ((s (make-fd-stream fd
2324                            :elements-per-buffer elements-per-buffer
2325                            :class 'selection-input-stream)))
2326    (setf (slot-value s 'peer-fd) peer-fd)
2327    s))
2328
2329(defmethod stream-clear-input ((s selection-input-stream))
2330  (call-next-method)
2331  (let* ((q (selection-input-stream-selections s)))
2332    (with-locked-dll-header (q)
2333      (do* ((first (dll-header-first q) (dll-header-first q)))
2334           ((eq first q))
2335        (remove-dll-node first))))
2336  (setf (selection-input-stream-current-selection s) nil))
2337
2338(defmethod enqueue-input-selection ((stream selection-input-stream)
2339                                    (selection input-selection))
2340  (let* ((q (selection-input-stream-selections stream)))
2341    (with-locked-dll-header (q)
2342      (append-dll-node selection q)
2343      (%stack-block ((buf 1))
2344        (setf (%get-unsigned-byte buf)
2345              (logand (char-code #\d) #x1f))
2346        (fd-write (slot-value stream 'peer-fd)
2347                  buf
2348                  1)))))
2349             
2350
2351
2352(defresource *string-output-stream-pool*
2353  :constructor (make-string-output-stream)
2354  :initializer 'stream-clear-output)
2355
2356;;;File streams.
2357(defparameter *use-new-file-streams* t)
2358
2359(defparameter *default-file-stream-class* 'file-stream)
2360
2361(defun open (filename &key (direction :input)
2362                      (element-type 'base-char)
2363                      (if-exists :error)
2364                      (if-does-not-exist (cond ((eq direction :probe)
2365                                                nil)
2366                                               ((or (eq direction :input)
2367                                                    (eq if-exists :overwrite)
2368                                                    (eq if-exists :append))
2369                                                :error)
2370                                               (t :create)))
2371                      (external-format :default)
2372                      (class *default-file-stream-class*)
2373                      (elements-per-buffer *elements-per-buffer*))
2374  (loop
2375    (restart-case
2376      (return
2377        (make-file-stream filename
2378                          direction
2379                          element-type
2380                          if-exists
2381                          if-does-not-exist
2382                          elements-per-buffer
2383                          class
2384                          external-format))
2385      (retry-open ()
2386                  :report (lambda (stream) (format stream "Retry opening ~s" filename))
2387                  nil))))
2388
2389
2390
2391
2392
2393(defun gen-file-name (path)
2394  (let* ((date (file-write-date path))
2395         (tem-path (merge-pathnames (make-pathname :name (%integer-to-string date) :type "tem" :defaults nil) path)))
2396    (loop
2397      (when (not (probe-file tem-path)) (return tem-path))
2398      (setf (%pathname-name tem-path) (%integer-to-string (setq date (1+ date)))))))
2399
2400(defun probe-file-x (path)
2401  (%probe-file-x (native-translated-namestring path)))
2402
2403(defun file-length (stream)
2404  (etypecase stream
2405    ;; Don't use an OR type here
2406    (file-stream (stream-length stream))
2407    (synonym-stream (file-length
2408                     (symbol-value (synonym-stream-symbol stream))))
2409    (broadcast-stream (let* ((last (last-broadcast-stream stream)))
2410                        (if last
2411                          (file-length last)
2412                          0)))))
2413 
2414(defun file-position (stream &optional position)
2415  (when position
2416    (if (eq position :start)
2417      (setq position 0)
2418      (if (eq position :end)
2419        (setq position (file-length stream))
2420        (unless (typep position 'unsigned-byte)
2421          (report-bad-arg position '(or
2422                                     null
2423                                     (eql :start)
2424                                     (eql :end)
2425                                     unsigned-byte))))))
2426  (stream-position stream position))
2427
2428
2429(defun %request-terminal-input ()
2430  (let* ((shared-resource
2431          (if (typep *terminal-io* 'two-way-stream)
2432            (input-stream-shared-resource
2433             (two-way-stream-input-stream *terminal-io*)))))
2434    (if shared-resource (%acquire-shared-resource shared-resource t))))
2435
2436
2437
2438
2439(defun %%yield-terminal-to (&optional process)
2440  (let* ((shared-resource
2441          (if (typep *terminal-io* 'two-way-stream)
2442            (input-stream-shared-resource
2443             (two-way-stream-input-stream *terminal-io*)))))
2444    (when shared-resource (%yield-shared-resource shared-resource process))))
2445
2446(defun %restore-terminal-input (&optional took-it)
2447  (let* ((shared-resource
2448          (if took-it
2449            (if (typep *terminal-io* 'two-way-stream)
2450              (input-stream-shared-resource
2451               (two-way-stream-input-stream *terminal-io*))))))
2452    (when shared-resource
2453      (%release-shared-resource shared-resource))))
2454
2455;;; Initialize the global streams
2456; These are defparameters because they replace the ones that were in l1-init
2457; while bootstrapping.
2458
2459(defparameter *terminal-io* nil)
2460(defparameter *debug-io* nil)
2461(defparameter *query-io* nil)
2462(defparameter *error-output* nil)
2463(defparameter *standard-input* nil)
2464(defparameter *standard-output* nil)
2465(defparameter *trace-output* nil)
2466
2467(proclaim '(stream 
2468          *query-io* *debug-io* *error-output* *standard-input* 
2469          *standard-output* *trace-output*))
2470
2471;;; Interaction with the REPL.  READ-TOPLEVEL-FORM should return 3
2472;;; values: a form, a (possibly null) pathname, and a boolean that
2473;;; indicates whether or not the result(s) of evaluating the form
2474;;; should be printed.  (The last value has to do with how selections
2475;;; that contain multiple forms are handled; see *VERBOSE-EVAL-SELECTION*
2476;;; and the SELECTION-INPUT-STREAM method below.)
2477(defmethod read-toplevel-form ((stream input-stream)
2478                               eof-value)
2479  (loop
2480    (let* ((*in-read-loop* nil) 
2481           (form (read stream nil eof-value)))
2482      (if (eq form eof-value)
2483        (return (values form nil t))
2484        (progn
2485           (let ((ch))                 ;Trim whitespace
2486            (while (and (listen stream)
2487                        (setq ch (read-char stream nil nil))
2488                        (whitespacep cH))
2489              (setq ch nil))
2490            (when ch (unread-char ch stream)))
2491          (when *listener-indent* 
2492            (write-char #\space stream)
2493            (write-char #\space stream))
2494          (return (values (process-single-selection form) nil t)))))))
2495
2496(defparameter *verbose-eval-selection* nil
2497  "When true, the results of evaluating all forms in an input selection
2498are printed.  When false, only the results of evaluating the last form
2499are printed.")
2500
2501(defmethod read-toplevel-form ((stream selection-input-stream)
2502                               eof-value)
2503  ;; If we don't have a selection, try to get one.  Read from the
2504  ;; underlying input stream; if that yields an EOF, that -usually-
2505  ;; means that a selection's been posted.
2506  (do* ((selection (selection-input-stream-current-selection stream)))
2507       ()
2508    (when (null selection)
2509      (let* ((form (call-next-method)))
2510        (if (eq form eof-value)
2511          (setq selection
2512                (setf (selection-input-stream-current-selection stream)
2513                      (locked-dll-header-dequeue
2514                       (selection-input-stream-selections stream))))
2515          (return (values form nil t)))))
2516    (if (null selection)
2517      (return (values eof-value nil t))
2518      (let* ((*package* *package*)
2519             (string-stream (input-selection-string-stream selection))
2520             (selection-package (input-selection-package selection))
2521             (pkg (if selection-package (pkg-arg selection-package))))
2522        (when pkg (setq *package* pkg))
2523        (let* ((form (read-toplevel-form string-stream eof-value))
2524               (last-form-in-selection (eofp string-stream)))
2525          (when last-form-in-selection
2526            (setf (selection-input-stream-current-selection stream) nil))
2527          (return (values form
2528                          (input-selection-source-file selection)
2529                          (or last-form-in-selection *verbose-eval-selection*))))))))
2530
2531                             
2532       
2533
2534
2535; end of L1-streams.lisp
Note: See TracBrowser for help on using the repository browser.