source: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp @ 12014

Last change on this file since 12014 was 12014, checked in by ehuelsmann, 12 years ago

Implement sane defaults for STREAM-CLEAR-INPUT, STREAM-CLEAR-OUTPUT and STREAM-TERPRI.

  • 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 12014 2009-06-10 21:00:32Z ehuelsmann $
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;;;; A simple implementation of Gray streams for Corman Lisp 1.42.
61;;;; Gray streams are 'clos' based streams as described at:
62;;;;
63;;;; ftp://parcftp.xerox.com/pub/cl/cleanup/mail/stream-definition-by-user.mail
64;;;;
65;;;; Some differences exist between this implementation and the
66;;;; specification above. See notes below for details.
67;;;;
68;;;; More recent versions of this software may be available at:
69;;;;   http://www.double.co.nz/cl
70;;;;
71;;;; Comments, suggestions and bug reports to the author,
72;;;; Christopher Double, at: chris@double.co.nz
73;;;;
74;;;; 03/03/2001 - 1.0
75;;;;              Initial release.
76;;;;
77;;;; 20/08/2001 - 1.1
78;;;;              Small modifications by Frederic Bastenaire (fba@free.fr)
79;;;;              (lines flagged by  ;; # fb 1.01)
80;;;;              - Make it work with the READ function by
81;;;;                defining %read-char, %read-char-with-error
82;;;;               and input-character-stream-p
83;;;;              - Add nickname GS to package "GRAY-STREAMS" for ease of use
84;;;;              - added missing '*' to *old-write-byte* in gray-write-byte
85;;;;
86;;;; 03/01/2002 - 1.2
87;;;;              Fixed bug with GRAY-WRITE-LINE and GRAY-WRITE-STRING
88;;;;              that appeared in Corman Lisp 2.0 due to changes to
89;;;;              WRITE-LINE and WRITE-STRING.
90;;;;
91;;;; 04/01/2002 - 1.3
92;;;;              Added support for STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE.
93;;;;              Fixed STREAM-WRITE-STRING bug.
94;;;;
95;;;; Notes
96;;;; =====
97;;;; CLOSE is not a generic function in this implementation. Instead,
98;;;; the generic is called STREAM-CLOSE and the function CLOSE calls
99;;;; STREAM-CLOSE. The same goes for STREAMP, INPUT-STREAM-P,
100;;;; OUTPUT-STREAM-P and STREAM-ELEMENT-TYPE. The generic functions for
101;;;; these are STREAM-STREAMP, STREAM-INPUT-STREAM-P,
102;;;; STREAM-OUTPUT-STREAM-P and STREAM-STREAM-ELEMENT-TYPE.
103;;;;
104;;;; The standard Corman Lisp streams are not derived from
105;;;; FUNDAMENTAL-STREAM. All the stream functions check to see if the
106;;;; stream is an original Corman Lisp stream and forward on to the
107;;;; original function implementations.
108;;;;
109;;;; The string streams are implemented in this file as Gray streams
110;;;; but do not replace the Corman Lisp string streams. They are only
111;;;; implemented here to test the Gray stream functionality. These methods
112;;;; are called:
113;;;;    GRAY-MAKE-STRING-OUTPUT-STREAM
114;;;;    GRAY-GET-OUTPUT-STREAM-STRING
115;;;;    GRAY-MAKE-STRING-INPUT-STREAM
116;;;;
117;;;; Much of the implementation of the Gray streams below is from the
118;;;; document referenced earlier.
119;;;;
120(defpackage "GRAY-STREAMS"
121  (:use
122   "COMMON-LISP")
123  (:nicknames "GS") ;; # fb 1.01
124  (:export
125   "FUNDAMENTAL-STREAM"
126   "STREAM-CLOSE"
127   "STREAM-OPEN-STREAM-P"
128   "STREAM-STREAMP"
129   "STREAM-INPUT-STREAM-P"
130   "STREAM-OUTPUT-STREAM-P"
131   "STREAM-STREAM-ELEMENT-TYPE"
132   "STREAM-CLOSE"
133   "FUNDAMENTAL-OUTPUT-STREAM"
134   "FUNDAMENTAL-INPUT-STREAM"
135   "FUNDAMENTAL-CHARACTER-STREAM"
136   "FUNDAMENTAL-BINARY-STREAM"
137   "STREAM-READ-BYTE"
138   "STREAM-WRITE-BYTE"
139   "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
140   "STREAM-READ-CHAR"
141   "STREAM-UNREAD-CHAR"
142   "STREAM-READ-CHAR-NO-HANG"
143   "STREAM-PEEK-CHAR"
144   "STREAM-LISTEN"
145   "STREAM-READ-LINE"
146   "STREAM-CLEAR-INPUT"
147   "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
148   "STREAM-WRITE-CHAR"
149   "STREAM-LINE-COLUMN"
150   "STREAM-START-LINE-P"
151   "STREAM-WRITE-STRING"
152   "STREAM-TERPRI"
153   "STREAM-FRESH-LINE"
154   "STREAM-FINISH-OUTPUT"
155   "STREAM-FORCE-OUTPUT"
156   "STREAM-CLEAR-OUTPUT"
157   "STREAM-ADVANCE-TO-COLUMN"
158   "STREAM-READ-SEQUENCE"
159   "STREAM-WRITE-SEQUENCE"
160   "FUNDAMENTAL-BINARY-INPUT-STREAM"
161   "FUNDAMENTAL-BINARY-OUTPUT-STREAM"))
162
163(in-package :gray-streams)
164
165(defvar *old-read-char* #'read-char)
166(defvar *old-peek-char* #'peek-char)
167(defvar *old-unread-char* #'unread-char)
168(defvar *old-listen* nil)
169(defvar *old-read-line* #'read-line)
170(defvar *old-read-char-no-hang* #'read-char-no-hang)
171(defvar *old-write-char* #'write-char)
172(defvar *old-fresh-line* #'fresh-line)
173(defvar *old-terpri* #'terpri)
174(defvar *old-write-string* #'write-string)
175(defvar *old-write-line* #'write-line)
176(defvar *old-force-output* #'sys::%force-output)
177(defvar *old-finish-output* #'sys::%finish-output)
178(defvar *old-clear-output* #'sys::%clear-output)
179(defvar *old-clear-input* #'clear-input)
180(defvar *old-read-byte* #'read-byte)
181(defvar *old-write-byte* #'write-byte)
182(defvar *old-stream-element-type* #'cl::stream-element-type)
183(defvar *old-close* #'cl::close)
184(defvar *old-input-character-stream-p*
185  #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character))))
186(defvar *old-input-stream-p* #'cl::input-stream-p)
187(defvar *old-output-stream-p* #'cl::output-stream-p)
188(defvar *old-open-stream-p* #'cl::open-stream-p)
189(defvar *old-streamp* #'cl::streamp)
190(defvar *old-read-sequence* #'cl::read-sequence)
191(defvar *old-write-sequence* #'cl::write-sequence)
192(defvar *old-make-two-way-stream* #'cl:make-two-way-stream)
193(defvar *old-two-way-stream-input-stream* #'cl:two-way-stream-input-stream)
194(defvar *old-two-way-stream-output-stream* #'cl:two-way-stream-output-stream)
195
196
197(defun old-streamp (stream)
198  (or (xp::xp-structure-p stream)
199      (funcall *old-streamp* stream)))
200
201(defclass fundamental-stream ())
202
203(defgeneric stream-close (stream &key abort))
204(defgeneric stream-open-stream-p (stream))
205(defgeneric stream-streamp (stream))
206(defgeneric stream-input-stream-p (stream))
207(defgeneric stream-input-character-stream-p (stream)) ;; # fb 1.01
208(defgeneric stream-output-stream-p (stream))
209(defgeneric stream-stream-element-type (stream))
210
211(defmethod stream-close (stream &key abort)
212  (declare (ignore stream abort))
213  nil)
214
215(defmethod stream-streamp (s)
216  (declare (ignore s))
217  nil)
218
219(defmethod stream-streamp ((s fundamental-stream))
220  s)
221
222(defclass fundamental-input-stream (fundamental-stream))
223
224(defmethod stream-input-character-stream-p (s)  ;; # fb 1.01
225  (and (stream-input-stream-p s)
226       (eq (stream-stream-element-type s) 'character)))
227
228(defmethod stream-input-stream-p (s)
229  (declare (ignore s))
230  nil)
231
232(defmethod stream-input-stream-p ((s fundamental-input-stream))
233  (declare (ignore s))
234  t)
235
236(defclass fundamental-output-stream (fundamental-stream))
237
238(defmethod stream-output-stream-p (s)
239  (declare (ignore s))
240  nil)
241
242(defmethod stream-output-stream-p ((s fundamental-output-stream))
243  (declare (ignore s))
244  t)
245
246(defclass fundamental-character-stream (fundamental-stream))
247
248(defmethod stream-stream-element-type ((s fundamental-character-stream))
249  (declare (ignore s))
250  'character)
251
252(defclass fundamental-binary-stream (fundamental-stream))
253
254(defgeneric stream-read-byte (stream))
255(defgeneric stream-write-byte (stream integer))
256
257(defclass fundamental-character-input-stream
258  (fundamental-input-stream fundamental-character-stream))
259
260(defgeneric stream-read-char (stream))
261(defgeneric stream-unread-char (stream character))
262(defgeneric stream-read-char-no-hang (stream))
263(defgeneric stream-peek-char (stream))
264(defgeneric stream-listen (stream))
265(defgeneric stream-read-line (stream))
266(defgeneric stream-clear-input (stream))
267
268(defmethod stream-peek-char ((stream fundamental-character-input-stream))
269  (let ((character (stream-read-char stream)))
270    (unless (eq character :eof)
271      (stream-unread-char stream character))
272    character))
273
274(defmethod stream-listen ((stream  fundamental-character-input-stream))
275  (let ((char (stream-read-char-no-hang stream)))
276    (and (not (null char))
277         (not (eq char :eof))
278         (progn
279           (stream-unread-char stream char)
280           t))))
281
282(defmethod stream-read-line ((stream  fundamental-character-input-stream))
283  (let ((line (make-array 64
284                          :element-type 'character
285                          :fill-pointer 0
286                          :adjustable t)))
287    (loop
288      (let ((character (stream-read-char stream)))
289        (if (eq character :eof)
290            (return (values line t))
291            (if (eql character #\Newline)
292                (return (values line nil))
293                (vector-push-extend character line)))))))
294
295(defmethod stream-clear-input (stream)
296  (declare (ignore stream))
297  nil)
298
299(defclass fundamental-character-output-stream
300  (fundamental-output-stream fundamental-character-stream))
301
302(defgeneric stream-write-char (stream character))
303(defgeneric stream-line-column (stream))
304(defgeneric stream-start-line-p (stream))
305(defgeneric stream-write-string (stream string &optional start end))
306(defgeneric stream-terpri (stream))
307(defmethod stream-terpri (stream)
308  (stream-write-char stream #\Newline))
309
310(defgeneric stream-fresh-line (stream))
311(defgeneric stream-finish-output (stream))
312(defgeneric stream-force-output (stream))
313(defgeneric stream-clear-output (stream))
314(defgeneric stream-advance-to-column (stream column))
315(defgeneric stream-read-sequence (stream sequence &optional start end))
316(defgeneric stream-write-sequence (stream sequence &optional start end))
317
318(defmethod stream-force-output (stream)
319  (declare (ignore stream))
320  nil)
321
322(defmethod stream-clear-output (stream)
323  (declare (ignore stream))
324  nil)
325
326(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
327  (equal (stream-line-column stream) 0))
328
329(defmethod stream-write-string ((stream fundamental-character-output-stream)
330                                string
331                                &optional (start 0) end)
332  (let ((end (or end (length string))))
333    (do ((i start (1+ i)))
334        ((>= i end) string)
335      (stream-write-char stream (char string i)))))
336
337(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
338  (if (stream-start-line-p stream)
339      nil
340      (progn
341        (stream-terpri stream)
342        t)))
343
344(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
345                                     column)
346  (let ((current (stream-line-column stream)))
347    (unless (null current)
348      (dotimes (i (- current column) t)
349        (stream-write-char stream #\Space)))))
350
351(defmethod stream-read-sequence ((stream  fundamental-character-input-stream)
352                                 sequence &optional (start 0) end)
353  (let ((element-type (stream-element-type stream))
354        (end (or end (length sequence)))
355        (eof (cons nil nil)))
356    (cond
357     ((eq element-type 'character)
358      (dotimes (count (- end start) (- end start))
359        (let ((c (stream-read-char stream nil eof)))
360          (if (eq c eof)
361              (return (+ count start)))
362          (setf (elt sequence (+ count start)) c))))
363     ((or (eq element-type 'byte)
364          (eq element-type 'unsigned-byte)
365          (eq element-type 'signed-byte))
366      (dotimes (count (- end start) (- end start))
367        (let ((b (stream-read-byte stream nil eof)))
368          (if (eq b eof)
369              (return (+ count start)))
370          (setf (elt sequence (+ count start)) b))))
371     (t (error "Cannot READ-SEQUENCE on stream of :ELEMENT-TYPE ~A"
372               element-type)))))
373
374(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
375                                  sequence &optional (start 0) end)
376  (let ((element-type (stream-element-type stream))
377        (end (or end (length sequence))))
378    (if (eq element-type 'character)
379        (do ((n start (+ n 1)))
380            ((= n end))
381          (stream-write-char
382           stream
383           (if (typep (elt sequence n) 'number)
384               (#+nil ccl:int-char code-char (elt sequence n))
385               (elt sequence n))))
386        (do ((n start (+ n 1)))
387            ((= n end))
388          (stream-write-byte (elt sequence n) stream))))    ;; recoded to avoid LOOP, because it isn't loaded yet
389  (stream-force-output stream))
390
391(defclass fundamental-binary-input-stream
392  (fundamental-input-stream fundamental-binary-stream))
393
394(defclass fundamental-binary-output-stream
395  (fundamental-output-stream fundamental-binary-stream))
396
397(defun decode-read-arg (arg)
398  (cond ((null arg) *standard-input*)
399        ((eq arg t) *terminal-io*)
400        (t arg)))
401
402(defun decode-print-arg (arg)
403  (cond ((null arg) *standard-output*)
404        ((eq arg t) *terminal-io*)
405        (t arg)))
406
407(defun report-eof (stream eof-errorp eof-value)
408  (if eof-errorp
409      (error 'end-of-file :stream stream)
410      eof-value))
411
412(defun check-for-eof (value stream eof-errorp eof-value)
413  (if (eq value :eof)
414      (report-eof stream eof-errorp eof-value)
415      value))
416
417(defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p)
418  (let ((stream (decode-read-arg input-stream)))
419    (if (old-streamp stream)
420        (funcall *old-read-char* stream eof-errorp eof-value recursive-p)
421        (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))))
422
423(defun gray-peek-char (&optional peek-type input-stream (eof-errorp t)
424                                 eof-value recursive-p)
425  (let ((stream (decode-read-arg input-stream)))
426    (if (old-streamp stream)
427        (funcall *old-peek-char* peek-type stream eof-errorp eof-value recursive-p)
428        (if (null peek-type)
429            (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value)
430            (loop
431              (let ((value (stream-peek-char stream)))
432                (if (eq value :eof)
433                    (return (report-eof stream eof-errorp eof-value))
434                    (if (if (eq peek-type t)
435                            (not (member value
436                                         '(#\space #\tab #\newline #\return)))
437                            (char= peek-type value))
438                        (return value)
439                        (stream-read-char stream)))))))))
440
441(defun gray-unread-char (character &optional input-stream)
442  (let ((stream (decode-read-arg input-stream)))
443    (if (old-streamp stream)
444        (funcall *old-unread-char* character stream)
445        (stream-unread-char stream character))))
446
447(defun gray-listen (&optional input-stream)
448  (let ((stream (decode-read-arg input-stream)))
449    (if (old-streamp stream)
450        (funcall *old-listen* stream)
451        (stream-listen stream))))
452
453(defun gray-read-line (&optional input-stream (eof-error-p t)
454                                 eof-value recursive-p)
455  (let ((stream (decode-read-arg input-stream)))
456    (if (old-streamp stream)
457        (funcall *old-read-line* stream eof-error-p eof-value recursive-p)
458        (multiple-value-bind (string eofp)
459          (stream-read-line stream)
460          (if eofp
461              (if (= (length string) 0)
462                  (report-eof stream eof-error-p eof-value)
463                  (values string t))
464              (values string nil))))))
465
466(defun gray-clear-input (&optional input-stream)
467  (let ((stream (decode-read-arg input-stream)))
468    (if (old-streamp stream)
469        (funcall *old-clear-input* stream)
470        (stream-clear-input stream))))
471
472(defun gray-read-char-no-hang (&optional input-stream (eof-errorp t)
473                                         eof-value recursive-p)
474  (let ((stream (decode-read-arg input-stream)))
475    (if (old-streamp stream)
476        (funcall *old-read-char-no-hang* stream eof-errorp eof-value recursive-p)
477        (check-for-eof (stream-read-char-no-hang stream)
478                       stream eof-errorp eof-value))))
479
480(defun gray-write-char (character &optional output-stream)
481  (let ((stream (decode-print-arg output-stream)))
482    (if (old-streamp stream)
483        (funcall *old-write-char* character stream)
484        (stream-write-char stream character))))
485
486(defun gray-fresh-line (&optional output-stream)
487  (let ((stream (decode-print-arg output-stream)))
488    (if (old-streamp stream)
489        (funcall *old-fresh-line* stream)
490        (stream-fresh-line stream))))
491
492(defun gray-terpri (&optional output-stream)
493  (let ((stream (decode-print-arg output-stream)))
494    (if (old-streamp stream)
495        (funcall *old-terpri* stream)
496        (stream-terpri stream))))
497
498(defun gray-write-string (string &optional output-stream &key (start 0) end)
499  (let ((stream (decode-print-arg output-stream)))
500    (if (old-streamp stream)
501        (funcall *old-write-string* string stream :start start :end end)
502        (stream-write-string stream string start end))))
503
504(defun gray-write-line (string &optional output-stream &key (start 0) end)
505  (let ((stream (decode-print-arg output-stream)))
506    (if (old-streamp stream)
507        (funcall *old-write-line* string stream :start start :end end)
508        (progn
509          (stream-write-string stream string start end)
510          (stream-terpri stream)
511          string))))
512
513(defun gray-force-output (&optional output-stream)
514  (let ((stream (decode-print-arg output-stream)))
515    (if (old-streamp stream)
516        (funcall *old-force-output* stream)
517        (stream-force-output stream))))
518
519(defun gray-finish-output (&optional output-stream)
520  (let ((stream (decode-print-arg output-stream)))
521    (if (old-streamp stream)
522        (funcall *old-finish-output* stream)
523        (stream-finish-output stream))))
524
525(defun gray-clear-output (&optional output-stream)
526  (let ((stream (decode-print-arg output-stream)))
527    (if (old-streamp stream)
528        (funcall *old-clear-output* stream)
529        (stream-clear-output stream))))
530
531(defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value)
532  (if (old-streamp binary-input-stream)
533      (funcall *old-read-byte* binary-input-stream eof-errorp eof-value)
534      (check-for-eof (stream-read-byte binary-input-stream)
535                     binary-input-stream eof-errorp eof-value)))
536
537(defun gray-write-byte (integer binary-output-stream)
538  (if (old-streamp binary-output-stream)
539      (funcall *old-write-byte* integer binary-output-stream)
540      (stream-write-byte binary-output-stream integer)))
541
542(defclass string-input-stream (fundamental-character-input-stream)
543  ((string :initarg :string :type string)
544   (index :initarg :start :type fixnum)
545   (end :initarg :end :type fixnum)))
546
547(defun gray-make-string-input-stream (string &optional (start 0) end)
548  (make-instance 'string-input-stream :string string
549                 :start start :end (or end (length string))))
550
551(defmethod stream-read-char ((stream string-input-stream))
552  (with-slots (index end string) stream
553    (if (>= index end)
554        :eof
555        (prog1
556         (char string index)
557         (incf index)))))
558
559(defmethod stream-unread-char ((stream string-input-stream) character)
560  (with-slots (index end string) stream
561    (decf index)
562    (assert (eql (char string index) character))
563    nil))
564
565(defmethod stream-read-line ((stream string-input-stream))
566  (with-slots (index end string) stream
567    (let* ((endline (position #\newline string :start index :end end))
568           (line (subseq string index endline)))
569      (if endline
570          (progn
571            (setq index (1+ endline))
572            (values line nil))
573          (progn
574            (setq index end)
575            (values line t))))))
576
577(defclass string-output-stream (fundamental-character-output-stream)
578  ((string :initform nil :initarg :string)))
579
580(defun gray-make-string-output-stream ()
581  (make-instance 'string-output-stream))
582
583(defun gray-get-output-stream-string (stream)
584  (with-slots (string) stream
585    (if (null string)
586        ""
587        (prog1
588         (coerce string 'string)
589         (setq string nil)))))
590
591(defmethod stream-write-char ((stream string-output-stream) character)
592  (with-slots (string) stream
593    (when (null string)
594      (setq string (make-array 64 :slement-type 'character
595                               :fill-pointer 0 :adjustable t)))
596    (vector-push-extend character string)
597    character))
598
599(defmethod stream-line-column ((stream string-output-stream))
600  (with-slots (string) stream
601    (if (null string)
602        0
603        (let ((nx (position #\newline string :from-end t)))
604          (if (null nx)
605              (length string)
606              (- (length string) nx 1))))))
607
608(defmethod stream-line-column ((stream stream))
609  nil)
610
611(defun gray-stream-column (&optional input-stream)
612  (let ((stream (decode-read-arg input-stream)))
613    (if (old-streamp stream)
614        nil ;(funcall *old-stream-column* stream)
615        (stream-line-column stream))))
616
617(defun gray-stream-element-type (stream)
618  (if (old-streamp stream)
619      (funcall *old-stream-element-type* stream)
620      (stream-stream-element-type stream)))
621
622(defun gray-close (stream &key abort)
623  (if (old-streamp stream)
624      (funcall *old-close* stream :abort abort)
625      (stream-close stream :abort nil)))
626
627(defun gray-input-stream-p (stream)
628  (if (old-streamp stream)
629      (funcall *old-input-stream-p* stream)
630      (stream-input-stream-p stream)))
631
632(defun gray-input-character-stream-p (stream)
633  (if (old-streamp stream)
634      (funcall *old-input-character-stream-p* stream)
635      (stream-input-character-stream-p stream)))
636
637(defun gray-output-stream-p (stream)
638  (if (old-streamp stream)
639      (funcall *old-output-stream-p* stream)
640      (stream-output-stream-p stream)))
641
642(defun gray-open-stream-p (stream)
643  (if (old-streamp stream)
644      (funcall *old-open-stream-p* stream)
645      (stream-open-stream-p stream)))
646
647(defun gray-streamp (stream)
648  (if (old-streamp stream)
649      (funcall *old-streamp* stream)
650      (stream-streamp stream)))
651
652(defun gray-write-sequence (sequence stream &key (start 0) end)
653  (if (old-streamp stream)
654      (funcall *old-write-sequence* sequence stream :start start :end end)
655      (stream-write-sequence stream sequence start end)))
656
657(defun gray-read-sequence (sequence stream &key (start 0) end)
658  (if (old-streamp stream)
659      (funcall *old-read-sequence* sequence stream :start start :end end)
660      (stream-read-sequence stream sequence start end)))
661
662(defstruct two-way-stream-g
663  input-stream output-stream)
664
665(defun gray-make-two-way-stream (in out)
666  (if (and (old-streamp in) (old-streamp out))
667      (funcall *old-make-two-way-stream* in out)
668      (make-two-way-stream-g :input-stream in :output-stream out)))
669
670(defun gray-two-way-stream-input-stream (stream)
671  (if (old-streamp stream)
672      (funcall *old-two-way-stream-input-stream* stream)
673      (two-way-stream-g-input-stream stream)))
674
675(defun gray-two-way-stream-output-stream (stream)
676  (if (old-streamp stream)
677      (funcall *old-two-way-stream-output-stream* stream)
678      (two-way-stream-g-output-stream stream)))
679
680(setf (symbol-function 'common-lisp::read-char) #'gray-read-char)
681(setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char)
682(setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char)
683(setf (symbol-function 'common-lisp::read-line) #'gray-read-line)
684(setf (symbol-function 'common-lisp::clear-input) #'gray-clear-input)
685(setf (symbol-function 'common-lisp::read-char-no-hang) #'gray-read-char-no-hang)
686(setf (symbol-function 'common-lisp::write-char) #'gray-write-char)
687(setf (symbol-function 'common-lisp::fresh-line) #'gray-fresh-line)
688(setf (symbol-function 'common-lisp::terpri) #'gray-terpri)
689(setf (symbol-function 'common-lisp::write-string) #'gray-write-string)
690(setf (symbol-function 'common-lisp::write-line) #'gray-write-line)
691(setf (symbol-function 'sys::%force-output) #'gray-force-output)
692(setf (symbol-function 'sys::%finish-output) #'gray-finish-output)
693(setf (symbol-function 'sys::%clear-output) #'gray-clear-output)
694(setf (symbol-function 'common-lisp::read-byte) #'gray-read-byte)
695(setf (symbol-function 'common-lisp::write-byte) #'gray-write-byte)
696(setf (symbol-function 'common-lisp::stream-column) #'gray-stream-column)
697(setf (symbol-function 'common-lisp::stream-element-type) #'gray-stream-element-type)
698(setf (symbol-function 'common-lisp::close) #'gray-close)
699(setf (symbol-function 'common-lisp::input-stream-p) #'gray-input-stream-p)
700(setf (symbol-function 'common-lisp::input-character-stream-p) #'gray-input-character-stream-p)  ;; # fb 1.01
701(setf (symbol-function 'common-lisp::output-stream-p) #'gray-output-stream-p)
702(setf (symbol-function 'common-lisp::open-stream-p) #'gray-open-stream-p)
703(setf (symbol-function 'common-lisp::streamp) #'gray-streamp)
704(setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence)
705(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence)
706(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream)
707(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream)
708(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream)
709
710(provide 'gray-streams)
Note: See TracBrowser for help on using the repository browser.