source: branches/streams/abcl/src/org/armedbear/lisp/gray-streams.lisp

Last change on this file was 14605, checked in by Mark Evenson, 11 years ago

Fix missing default method for gray-streams:stream-finish-output.

Thanks to Anton Vodonosov. See <http://abcl.org/trac/ticket/342>.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 26.5 KB
Line 
1;;; gray-streams.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves, Andras Simon
4;;; $Id: gray-streams.lisp 14605 2014-01-19 19:13:56Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from:
33;;;; Gray Streams Implementation for Corman Lisp - Version 1.3
34;;;;
35;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
36;;;;
37;;;; License
38;;;; =======
39;;;; This software is provided 'as-is', without any express or implied
40;;;; warranty. In no event will the author be held liable for any damages
41;;;; arising from the use of this software.
42;;;;
43;;;; Permission is granted to anyone to use this software for any purpose,
44;;;; including commercial applications, and to alter it and redistribute
45;;;; it freely, subject to the following restrictions:
46;;;;
47;;;; 1. The origin of this software must not be misrepresented; you must
48;;;;    not claim that you wrote the original software. If you use this
49;;;;    software in a product, an acknowledgment in the product documentation
50;;;;    would be appreciated but is not required.
51;;;;
52;;;; 2. Altered source versions must be plainly marked as such, and must
53;;;;    not be misrepresented as being the original software.
54;;;;
55;;;; 3. This notice may not be removed or altered from any source
56;;;;    distribution.
57;;;;
58;;;; Notes
59;;;; =====
60;;;;
61;;;; NB: The ABCL implementation has been extensively reworked since these
62;;;; notes were included.  Please see the ABCL revision history via
63;;;; the interface at
64;;;;
65;;;; http://trac.common-lisp.net/armedbear/browser/trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp
66;;;;
67;;;; for a more relevant history vis a vis the ABCL implementation.
68;;;;
69;;;; A simple implementation of Gray streams for Corman Lisp 1.42.
70;;;; Gray streams are 'clos' based streams as described at:
71;;;;
72;;;; ftp://parcftp.xerox.com/pub/cl/cleanup/mail/stream-definition-by-user.mail
73;;;;
74;;;; 20110319
75;;;;   The xerox.com ftp URI doesn't resolve.  Instead see Kent Pitman's
76;;;;   archival copy at
77;;;;
78;;;;     http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html
79;;;;
80;;;; Some differences exist between this implementation and the
81;;;; specification above. See notes below for details.
82;;;;
83;;;; More recent versions of this software may be available at:
84;;;;   http://www.double.co.nz/cl
85;;;;
86;;;; Comments, suggestions and bug reports to the author,
87;;;; Christopher Double, at: chris@double.co.nz
88;;;;
89;;;; 03/03/2001 - 1.0
90;;;;              Initial release.
91;;;;
92;;;; 20/08/2001 - 1.1
93;;;;              Small modifications by Frederic Bastenaire (fba@free.fr)
94;;;;              (lines flagged by  ;; # fb 1.01)
95;;;;              - Make it work with the READ function by
96;;;;                defining %read-char, %read-char-with-error
97;;;;               and input-character-stream-p
98;;;;              - Add nickname GS to package "GRAY-STREAMS" for ease of use
99;;;;              - added missing '*' to *old-write-byte* in gray-write-byte
100;;;;
101;;;; 03/01/2002 - 1.2
102;;;;              Fixed bug with GRAY-WRITE-LINE and GRAY-WRITE-STRING
103;;;;              that appeared in Corman Lisp 2.0 due to changes to
104;;;;              WRITE-LINE and WRITE-STRING.
105;;;;
106;;;; 04/01/2002 - 1.3
107;;;;              Added support for STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE.
108;;;;              Fixed STREAM-WRITE-STRING bug.
109;;;;
110;;;; Notes
111;;;; =====
112;;;;
113;;;;
114;;;; Much of the implementation of the Gray streams below is from the
115;;;; document referenced earlier.
116;;;;
117(require "PPRINT")
118
119(defpackage "GRAY-STREAMS"
120  (:use
121   "COMMON-LISP")
122  (:nicknames "GS") ;; # fb 1.01
123  (:export
124   "FUNDAMENTAL-STREAM"
125   "FUNDAMENTAL-OUTPUT-STREAM"
126   "FUNDAMENTAL-INPUT-STREAM"
127   "FUNDAMENTAL-CHARACTER-STREAM"
128   "FUNDAMENTAL-BINARY-STREAM"
129   "STREAM-READ-BYTE"
130   "STREAM-WRITE-BYTE"
131   "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
132   "STREAM-READ-CHAR"
133   "STREAM-UNREAD-CHAR"
134   "STREAM-READ-CHAR-NO-HANG"
135   "STREAM-PEEK-CHAR"
136   "STREAM-LISTEN"
137   "STREAM-READ-LINE"
138   "STREAM-CLEAR-INPUT"
139   "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
140   "STREAM-WRITE-CHAR"
141   "STREAM-LINE-COLUMN"
142   "STREAM-START-LINE-P"
143   "STREAM-WRITE-STRING"
144   "STREAM-TERPRI"
145   "STREAM-FRESH-LINE"
146   "STREAM-FINISH-OUTPUT"
147   "STREAM-FORCE-OUTPUT"
148   "STREAM-CLEAR-OUTPUT"
149   "STREAM-ADVANCE-TO-COLUMN"
150   "STREAM-READ-SEQUENCE"
151   "STREAM-WRITE-SEQUENCE"
152   "STREAM-FILE-POSITION"
153   "FUNDAMENTAL-BINARY-INPUT-STREAM"
154   "FUNDAMENTAL-BINARY-OUTPUT-STREAM"))
155
156(in-package :gray-streams)
157
158(defvar *ansi-read-char* #'read-char)
159(defvar *ansi-peek-char* #'peek-char)
160(defvar *ansi-unread-char* #'unread-char)
161(defvar *ansi-listen* #'listen)
162(defvar *ansi-read-line* #'read-line)
163(defvar *ansi-read-char-no-hang* #'read-char-no-hang)
164(defvar *ansi-write-char* #'write-char)
165(defvar *ansi-fresh-line* #'fresh-line)
166(defvar *ansi-terpri* #'terpri)
167(defvar *ansi-write-string* #'write-string)
168(defvar *ansi-write-line* #'write-line)
169(defvar *sys-%force-output* #'sys::%force-output)
170(defvar *sys-%finish-output* #'sys::%finish-output)
171(defvar *sys-%clear-output* #'sys::%clear-output)
172(defvar *sys-%output-object* #'sys::%output-object)
173(defvar *ansi-clear-input* #'clear-input)
174(defvar *ansi-read-byte* #'read-byte)
175(defvar *ansi-write-byte* #'write-byte)
176(defvar *ansi-stream-element-type* #'cl::stream-element-type)
177(defvar *ansi-close* #'cl::close)
178(defvar *ansi-input-character-stream-p*
179  #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character))))
180(defvar *ansi-input-stream-p* #'cl::input-stream-p)
181(defvar *ansi-output-stream-p* #'cl::output-stream-p)
182(defvar *ansi-open-stream-p* #'cl::open-stream-p)
183(defvar *ansi-streamp* #'cl::streamp)
184(defvar *ansi-read-sequence* #'cl::read-sequence)
185(defvar *ansi-write-sequence* #'cl::write-sequence)
186(defvar *ansi-make-two-way-stream* #'cl:make-two-way-stream)
187(defvar *ansi-two-way-stream-input-stream* #'cl:two-way-stream-input-stream)
188(defvar *ansi-two-way-stream-output-stream* #'cl:two-way-stream-output-stream)
189(defvar *ansi-file-position* #'cl:file-position)
190
191(defun ansi-streamp (stream)
192  (or (xp::xp-structure-p stream)
193      (funcall *ansi-streamp* stream)))
194
195(defclass fundamental-stream (standard-object stream)
196  ((open-p :initform t
197           :accessor stream-open-p))
198  (:documentation "The base class of all Gray streams"))
199
200(defgeneric gray-close (stream &key abort))
201(defgeneric gray-open-stream-p (stream))
202(defgeneric gray-streamp (stream))
203(defgeneric gray-input-stream-p (stream))
204(defgeneric gray-input-character-stream-p (stream)) ;; # fb 1.01
205(defgeneric gray-output-stream-p (stream))
206(defgeneric gray-stream-element-type (stream))
207
208(defmethod gray-close ((stream fundamental-stream) &key abort)
209  (declare (ignore abort))
210  (setf (stream-open-p stream) nil)
211  t)
212
213(defmethod gray-open-stream-p ((stream fundamental-stream))
214  (stream-open-p stream))
215
216(defmethod gray-streamp ((s fundamental-stream))
217  s)
218
219(defclass fundamental-input-stream (fundamental-stream))
220
221(defmethod gray-input-character-stream-p (s)  ;; # fb 1.01
222  (and (gray-input-stream-p s)
223       (eq (gray-stream-element-type s) 'character)))
224
225(defmethod gray-input-stream-p ((s fundamental-input-stream))
226  (declare (ignore s))
227  t)
228
229(defclass fundamental-output-stream (fundamental-stream))
230
231(defmethod gray-input-stream-p ((s fundamental-output-stream))
232  (typep s 'fundamental-input-stream))
233
234(defmethod gray-output-stream-p ((s fundamental-output-stream))
235  (declare (ignore s))
236  t)
237
238(defmethod gray-output-stream-p ((s fundamental-input-stream))
239  (typep s 'fundamental-output-stream))
240
241(defclass fundamental-character-stream (fundamental-stream))
242
243(defmethod gray-stream-element-type ((s fundamental-character-stream))
244  (declare (ignore s))
245  'character)
246
247(defclass fundamental-binary-stream (fundamental-stream))
248
249(defgeneric stream-read-byte (stream))
250(defgeneric stream-write-byte (stream integer))
251
252(defclass fundamental-character-input-stream
253  (fundamental-input-stream fundamental-character-stream))
254
255(defgeneric stream-read-char (stream))
256(defgeneric stream-unread-char (stream character))
257(defgeneric stream-read-char-no-hang (stream))
258(defgeneric stream-peek-char (stream))
259(defgeneric stream-listen (stream))
260(defgeneric stream-read-line (stream))
261(defgeneric stream-clear-input (stream))
262
263(defmethod stream-peek-char ((stream fundamental-character-input-stream))
264  (let ((character (stream-read-char stream)))
265    (unless (eq character :eof)
266      (stream-unread-char stream character))
267    character))
268
269(defmethod stream-listen ((stream  fundamental-character-input-stream))
270  (let ((char (stream-read-char-no-hang stream)))
271    (and (not (null char))
272         (not (eq char :eof))
273         (progn
274           (stream-unread-char stream char)
275           t))))
276
277(defmethod stream-read-line ((stream  fundamental-character-input-stream))
278  (let ((line (make-array 64
279                          :element-type 'character
280                          :fill-pointer 0
281                          :adjustable t)))
282    (loop
283      (let ((character (stream-read-char stream)))
284        (if (eq character :eof)
285            (return (values line t))
286            (if (eql character #\Newline)
287                (return (values line nil))
288                (vector-push-extend character line)))))))
289
290(defmethod stream-clear-input (stream)
291  (declare (ignore stream))
292  nil)
293
294(defclass fundamental-character-output-stream
295  (fundamental-output-stream fundamental-character-stream))
296
297(defgeneric stream-write-char (stream character))
298(defgeneric stream-line-column (stream))
299(defgeneric stream-start-line-p (stream))
300(defgeneric stream-write-string (stream string &optional start end))
301(defgeneric stream-terpri (stream))
302(defmethod stream-terpri (stream)
303  (stream-write-char stream #\Newline))
304
305(defgeneric stream-fresh-line (stream))
306(defgeneric stream-finish-output (stream))
307(defgeneric stream-force-output (stream))
308(defgeneric stream-clear-output (stream))
309(defgeneric stream-advance-to-column (stream column))
310(defgeneric stream-read-sequence (stream sequence &optional start end))
311(defgeneric stream-write-sequence (stream sequence &optional start end))
312
313(defmethod stream-force-output (stream)
314  (declare (ignore stream))
315  nil)
316
317(defmethod stream-finish-output (stream)
318  (declare (ignore stream))
319  nil)
320
321(defmethod stream-clear-output (stream)
322  (declare (ignore stream))
323  nil)
324
325(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
326  (equal (stream-line-column stream) 0))
327
328(defmethod stream-write-string ((stream fundamental-character-output-stream)
329                                string
330                                &optional (start 0) end)
331  (let ((end (or end (length string))))
332    (do ((i start (1+ i)))
333        ((>= i end) string)
334      (stream-write-char stream (char string i)))))
335
336(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
337  (if (stream-start-line-p stream)
338      nil
339      (progn
340        (stream-terpri stream)
341        t)))
342
343(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
344                                     column)
345  (let ((current (stream-line-column stream)))
346    (unless (null current)
347      (dotimes (i (- current column) t)
348        (stream-write-char stream #\Space)))))
349
350(defun basic-read-sequence (stream sequence start end
351                            expected-element-type read-fun)
352  (let ((element-type (stream-element-type stream)))
353    (if (subtypep element-type expected-element-type)
354        (dotimes (count (- end start)
355                  ;; If (< end start), skip the dotimes body but
356                  ;; return start
357                  (max start end))
358          (let ((el (funcall read-fun stream)))
359            (when (eq el :eof)
360              (return (+ count start)))
361            (setf (elt sequence (+ count start)) el)))
362        (error "Cannot READ-SEQUENCE on stream of :ELEMENT-TYPE ~A"
363               element-type))))
364
365(defun basic-write-sequence (stream sequence start end
366                             expected-element-type write-fun)
367  (let ((element-type (stream-element-type stream)))
368    (if (subtypep element-type expected-element-type)
369        ;; Avoid LOOP because it isn't loaded yet
370        (do ((n start (+ n 1)))
371            ((= n end))
372          (funcall write-fun stream (elt sequence n)))
373        (error "Cannot WRITE-SEQUENCE on stream of :ELEMENT-TYPE ~A"
374               element-type)))
375  (stream-force-output stream)
376  sequence)
377
378(defmethod stream-read-sequence ((stream  fundamental-character-input-stream)
379                                 sequence &optional (start 0) end)
380  (basic-read-sequence stream sequence start (or end (length sequence))
381                       'character #'stream-read-char))
382
383(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
384                                  sequence &optional (start 0) end)
385  (basic-write-sequence stream sequence start (or end (length sequence))
386                        'character #'stream-write-char))
387
388(defclass fundamental-binary-input-stream
389  (fundamental-input-stream fundamental-binary-stream))
390
391(defclass fundamental-binary-output-stream
392  (fundamental-output-stream fundamental-binary-stream))
393
394(defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
395                                 sequence &optional (start 0) end)
396  (basic-read-sequence stream sequence start (or end (length sequence))
397                       'signed-byte #'stream-read-byte))
398
399(defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
400                                  sequence &optional (start 0) end)
401  (basic-write-sequence stream sequence start (or end (length sequence))
402                        'signed-byte #'stream-write-byte))
403
404(defun decode-read-arg (arg)
405  (cond ((null arg) *standard-input*)
406        ((eq arg t) *terminal-io*)
407        (t arg)))
408
409(defun decode-print-arg (arg)
410  (cond ((null arg) *standard-output*)
411        ((eq arg t) *terminal-io*)
412        (t arg)))
413
414(defun report-eof (stream eof-errorp eof-value)
415  (if eof-errorp
416      (error 'end-of-file :stream stream)
417      eof-value))
418
419(defun check-for-eof (value stream eof-errorp eof-value)
420  (if (eq value :eof)
421      (report-eof stream eof-errorp eof-value)
422      value))
423
424(defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p)
425  (let ((stream (decode-read-arg input-stream)))
426    (if (ansi-streamp stream)
427        (funcall *ansi-read-char* stream eof-errorp eof-value recursive-p)
428        (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))))
429
430(defun gray-peek-char (&optional peek-type input-stream (eof-errorp t)
431                                 eof-value recursive-p)
432  (let ((stream (decode-read-arg input-stream)))
433    (if (ansi-streamp stream)
434        (funcall *ansi-peek-char* peek-type stream eof-errorp eof-value recursive-p)
435        (if (null peek-type)
436            (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value)
437            (loop
438              (let ((value (stream-peek-char stream)))
439                (if (eq value :eof)
440                    (return (report-eof stream eof-errorp eof-value))
441                    (if (if (eq peek-type t)
442                            (not (member value
443                                         '(#\space #\tab #\newline #\return)))
444                            (char= peek-type value))
445                        (return value)
446                        (stream-read-char stream)))))))))
447
448(defun gray-unread-char (character &optional input-stream)
449  (let ((stream (decode-read-arg input-stream)))
450    (if (ansi-streamp stream)
451        (funcall *ansi-unread-char* character stream)
452        (stream-unread-char stream character))))
453
454(defun gray-listen (&optional input-stream)
455  (let ((stream (decode-read-arg input-stream)))
456    (if (ansi-streamp stream)
457        (funcall *ansi-listen* stream)
458        (stream-listen stream))))
459
460(defun gray-read-line (&optional input-stream (eof-error-p t)
461                                 eof-value recursive-p)
462  (let ((stream (decode-read-arg input-stream)))
463    (if (ansi-streamp stream)
464        (funcall *ansi-read-line* stream eof-error-p eof-value recursive-p)
465        (multiple-value-bind (string eofp)
466          (stream-read-line stream)
467          (if eofp
468              (if (= (length string) 0)
469                  (report-eof stream eof-error-p eof-value)
470                  (values string t))
471              (values string nil))))))
472
473(defun gray-clear-input (&optional input-stream)
474  (let ((stream (decode-read-arg input-stream)))
475    (if (ansi-streamp stream)
476        (funcall *ansi-clear-input* stream)
477        (stream-clear-input stream))))
478
479(defun gray-output-object (object stream)
480  (if (ansi-streamp stream)
481      (funcall *sys-%output-object* object stream)
482      (stream-write-string stream 
483                           (with-output-to-string (s)
484                             (funcall *sys-%output-object* object s)))))
485
486(defun gray-read-char-no-hang (&optional input-stream (eof-errorp t)
487                                         eof-value recursive-p)
488  (let ((stream (decode-read-arg input-stream)))
489    (if (ansi-streamp stream)
490        (funcall *ansi-read-char-no-hang* stream eof-errorp eof-value recursive-p)
491        (check-for-eof (stream-read-char-no-hang stream)
492                       stream eof-errorp eof-value))))
493
494(defun gray-write-char (character &optional output-stream)
495  (let ((stream (decode-print-arg output-stream)))
496    (if (ansi-streamp stream)
497        (funcall *ansi-write-char* character stream)
498        (stream-write-char stream character))))
499
500(defun gray-fresh-line (&optional output-stream)
501  (let ((stream (decode-print-arg output-stream)))
502    (if (ansi-streamp stream)
503        (funcall *ansi-fresh-line* stream)
504        (stream-fresh-line stream))))
505
506(defun gray-terpri (&optional output-stream)
507  (let ((stream (decode-print-arg output-stream)))
508    (if (ansi-streamp stream)
509        (funcall *ansi-terpri* stream)
510        (stream-terpri stream))))
511
512(defun gray-write-string (string &optional output-stream &key (start 0) end)
513  (let ((stream (decode-print-arg output-stream)))
514    (if (ansi-streamp stream)
515        (funcall *ansi-write-string* string stream :start start :end end)
516        (stream-write-string stream string start end))))
517
518(defun gray-write-line (string &optional output-stream &key (start 0) end)
519  (let ((stream (decode-print-arg output-stream)))
520    (if (ansi-streamp stream)
521        (funcall *ansi-write-line* string stream :start start :end end)
522        (progn
523          (stream-write-string stream string start end)
524          (stream-terpri stream)
525          string))))
526
527(defun gray-force-output (&optional output-stream)
528  (let ((stream (decode-print-arg output-stream)))
529    (if (ansi-streamp stream)
530        (funcall *sys-%force-output* stream)
531        (stream-force-output stream))))
532
533(defun gray-finish-output (&optional output-stream)
534  (let ((stream (decode-print-arg output-stream)))
535    (if (ansi-streamp stream)
536        (funcall *sys-%finish-output* stream)
537        (stream-finish-output stream))))
538
539(defun gray-clear-output (&optional output-stream)
540  (let ((stream (decode-print-arg output-stream)))
541    (if (ansi-streamp stream)
542        (funcall *sys-%clear-output* stream)
543        (stream-clear-output stream))))
544
545(defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value)
546  (if (ansi-streamp binary-input-stream)
547      (funcall *ansi-read-byte* binary-input-stream eof-errorp eof-value)
548      (check-for-eof (stream-read-byte binary-input-stream)
549                     binary-input-stream eof-errorp eof-value)))
550
551(defun gray-write-byte (integer binary-output-stream)
552  (if (ansi-streamp binary-output-stream)
553      (funcall *ansi-write-byte* integer binary-output-stream)
554      (stream-write-byte binary-output-stream integer)))
555
556(defmethod stream-line-column ((stream stream))
557  nil)
558
559(defun gray-stream-column (&optional input-stream)
560  (let ((stream (decode-read-arg input-stream)))
561    (if (ansi-streamp stream)
562        nil ;(funcall *ansi-stream-column* stream)
563        (stream-line-column stream))))
564
565(defmethod gray-stream-element-type (stream)
566  (funcall *ansi-stream-element-type* stream))
567
568(defmethod gray-close (stream &key abort)
569  (funcall *ansi-close* stream :abort abort))
570
571(defmethod gray-input-stream-p (stream)
572  (funcall *ansi-input-stream-p* stream))
573
574(defmethod gray-input-character-stream-p (stream)
575  (funcall *ansi-input-character-stream-p* stream))
576
577(defmethod gray-output-stream-p (stream)
578  (funcall *ansi-output-stream-p* stream))
579
580(defmethod gray-open-stream-p (stream)
581  (funcall *ansi-open-stream-p* stream))
582
583(defmethod gray-streamp (stream)
584  (funcall *ansi-streamp* stream))
585
586(defun gray-write-sequence (sequence stream &key (start 0) end)
587  (if (ansi-streamp stream)
588      (funcall *ansi-write-sequence* sequence stream :start start :end end)
589      (stream-write-sequence stream sequence start end)))
590
591(defun gray-read-sequence (sequence stream &key (start 0) end)
592  (if (ansi-streamp stream)
593      (funcall *ansi-read-sequence* sequence stream :start start :end end)
594      (stream-read-sequence stream sequence start end)))
595
596(defgeneric stream-file-position (stream &optional position-spec))
597
598(defun gray-file-position (stream &optional position-spec)
599  (if position-spec
600      (if (ansi-streamp stream)
601          (funcall *ansi-file-position* stream position-spec)
602          (stream-file-position stream position-spec))
603      (if (ansi-streamp stream)
604          (funcall *ansi-file-position* stream)
605          (stream-file-position stream))))
606 
607#|
608(defstruct (two-way-stream-g (:include stream))
609  input-stream output-stream)
610
611(defun gray-make-two-way-stream (in out)
612  (if (and (ansi-streamp in) (ansi-streamp out))
613      (funcall *ansi-make-two-way-stream* in out)
614      (make-two-way-stream-g :input-stream in :output-stream out)))
615
616(defun gray-two-way-stream-input-stream (stream)
617  (if (ansi-streamp stream)
618      (funcall *ansi-two-way-stream-input-stream* stream)
619      (two-way-stream-g-input-stream stream)))
620
621(defun gray-two-way-stream-output-stream (stream)
622  (if (ansi-streamp stream)
623      (funcall *ansi-two-way-stream-output-stream* stream)
624      (two-way-stream-g-output-stream stream)))
625
626|#
627
628(setf (symbol-function 'common-lisp::read-char) #'gray-read-char)
629(setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char)
630(setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char)
631(setf (symbol-function 'common-lisp::read-line) #'gray-read-line)
632(setf (symbol-function 'common-lisp::clear-input) #'gray-clear-input)
633(setf (symbol-function 'common-lisp::read-char-no-hang) #'gray-read-char-no-hang)
634(setf (symbol-function 'common-lisp::write-char) #'gray-write-char)
635(setf (symbol-function 'common-lisp::fresh-line) #'gray-fresh-line)
636(setf (symbol-function 'common-lisp::terpri) #'gray-terpri)
637(setf (symbol-function 'common-lisp::write-string) #'gray-write-string)
638(setf (symbol-function 'common-lisp::write-line) #'gray-write-line)
639(setf (symbol-function 'sys::%force-output) #'gray-force-output)
640(setf (symbol-function 'sys::%finish-output) #'gray-finish-output)
641(setf (symbol-function 'sys::%clear-output) #'gray-clear-output)
642(setf (symbol-function 'sys::%output-object) #'gray-output-object)
643(setf (symbol-function 'common-lisp::read-byte) #'gray-read-byte)
644(setf (symbol-function 'common-lisp::write-byte) #'gray-write-byte)
645(setf (symbol-function 'common-lisp::stream-column) #'gray-stream-column)
646(setf (symbol-function 'common-lisp::stream-element-type) #'gray-stream-element-type)
647(setf (symbol-function 'common-lisp::close) #'gray-close)
648(setf (symbol-function 'common-lisp::input-stream-p) #'gray-input-stream-p)
649(setf (symbol-function 'common-lisp::input-character-stream-p) #'gray-input-character-stream-p)  ;; # fb 1.01
650(setf (symbol-function 'common-lisp::output-stream-p) #'gray-output-stream-p)
651(setf (symbol-function 'common-lisp::open-stream-p) #'gray-open-stream-p)
652(setf (symbol-function 'common-lisp::streamp) #'gray-streamp)
653(setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence)
654(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence)
655(setf (symbol-function 'common-lisp::file-position) #'gray-file-position)
656(setf (symbol-function 'common-lisp::listen) #'gray-listen)
657#|
658(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream)
659(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream)
660(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream)
661|#
662
663(eval-when (:load-toplevel)
664  (mapcar (lambda (o) (mop:finalize-inheritance (find-class o)))
665          '(fundamental-stream 
666            fundamental-input-stream fundamental-output-stream
667            fundamental-character-stream 
668            fundamental-character-input-stream fundamental-character-output-stream
669            fundamental-binary-stream
670            fundamental-binary-input-stream fundamental-binary-output-stream)))
671 
672(provide 'gray-streams)
673
674;;; Fixup Gray/ANSI stream relations
675
676(defparameter *sys--stream-charpos* #'sys::stream-charpos)
677(defun sys::stream-charpos (stream)
678  (cond         
679    ((subtypep (type-of stream) 'gray-streams:fundamental-stream)
680     (stream-line-column stream))
681    ((streamp stream)
682     (funcall *sys--stream-charpos* stream))))
683
684(defparameter *sys--stream-%set-charpos* #'sys::stream-%set-charpos)
685(defun sys::stream-%set-charpos (new-value stream)
686  (cond 
687    ((subtypep (type-of stream) 'gray-streams:fundamental-stream)
688     (setf (stream-line-column stream) new-value))
689    ((streamp stream)
690     (funcall *sys--stream-%set-charpos* stream new-value))))
Note: See TracBrowser for help on using the repository browser.