Changeset 13255
- Timestamp:
- 03/20/11 20:26:04 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp
r12373 r13255 58 58 ;;;; Notes 59 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 ;;;; 60 69 ;;;; A simple implementation of Gray streams for Corman Lisp 1.42. 61 70 ;;;; Gray streams are 'clos' based streams as described at: 62 71 ;;;; 63 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 64 79 ;;;; 65 80 ;;;; Some differences exist between this implementation and the … … 106 121 (:export 107 122 "FUNDAMENTAL-STREAM" 108 "STREAM-OPEN-STREAM-P"109 "STREAM-STREAMP"110 "STREAM-INPUT-STREAM-P"111 "STREAM-OUTPUT-STREAM-P"112 "STREAM-STREAM-ELEMENT-TYPE"113 "STREAM-CLOSE"114 123 "FUNDAMENTAL-OUTPUT-STREAM" 115 124 "FUNDAMENTAL-INPUT-STREAM" … … 139 148 "STREAM-READ-SEQUENCE" 140 149 "STREAM-WRITE-SEQUENCE" 150 "STREAM-FILE-POSITION" 141 151 "FUNDAMENTAL-BINARY-INPUT-STREAM" 142 152 "FUNDAMENTAL-BINARY-OUTPUT-STREAM")) … … 144 154 (in-package :gray-streams) 145 155 146 (defvar * old-read-char* #'read-char)147 (defvar * old-peek-char* #'peek-char)148 (defvar * old-unread-char* #'unread-char)149 (defvar * old-listen* nil)150 (defvar * old-read-line* #'read-line)151 (defvar * old-read-char-no-hang* #'read-char-no-hang)152 (defvar * old-write-char* #'write-char)153 (defvar * old-fresh-line* #'fresh-line)154 (defvar * old-terpri* #'terpri)155 (defvar * old-write-string* #'write-string)156 (defvar * old-write-line* #'write-line)157 (defvar * old-force-output* #'sys::%force-output)158 (defvar * old-finish-output* #'sys::%finish-output)159 (defvar * old-clear-output* #'sys::%clear-output)160 (defvar * old-clear-input* #'clear-input)161 (defvar * old-read-byte* #'read-byte)162 (defvar * old-write-byte* #'write-byte)163 (defvar * old-stream-element-type* #'cl::stream-element-type)164 (defvar * old-close* #'cl::close)165 (defvar * old-input-character-stream-p*156 (defvar *ansi-read-char* #'read-char) 157 (defvar *ansi-peek-char* #'peek-char) 158 (defvar *ansi-unread-char* #'unread-char) 159 (defvar *ansi-listen* nil) 160 (defvar *ansi-read-line* #'read-line) 161 (defvar *ansi-read-char-no-hang* #'read-char-no-hang) 162 (defvar *ansi-write-char* #'write-char) 163 (defvar *ansi-fresh-line* #'fresh-line) 164 (defvar *ansi-terpri* #'terpri) 165 (defvar *ansi-write-string* #'write-string) 166 (defvar *ansi-write-line* #'write-line) 167 (defvar *ansi-force-output* #'sys::%force-output) 168 (defvar *ansi-finish-output* #'sys::%finish-output) 169 (defvar *ansi-clear-output* #'sys::%clear-output) 170 (defvar *ansi-clear-input* #'clear-input) 171 (defvar *ansi-read-byte* #'read-byte) 172 (defvar *ansi-write-byte* #'write-byte) 173 (defvar *ansi-stream-element-type* #'cl::stream-element-type) 174 (defvar *ansi-close* #'cl::close) 175 (defvar *ansi-input-character-stream-p* 166 176 #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character)))) 167 (defvar * old-input-stream-p* #'cl::input-stream-p)168 (defvar * old-output-stream-p* #'cl::output-stream-p)169 (defvar * old-open-stream-p* #'cl::open-stream-p)170 (defvar * old-streamp* #'cl::streamp)171 (defvar * old-read-sequence* #'cl::read-sequence)172 (defvar * old-write-sequence* #'cl::write-sequence)173 (defvar * old-make-two-way-stream* #'cl:make-two-way-stream)174 (defvar * old-two-way-stream-input-stream* #'cl:two-way-stream-input-stream)175 (defvar * old-two-way-stream-output-stream* #'cl:two-way-stream-output-stream)176 177 178 (defun old-streamp (stream)177 (defvar *ansi-input-stream-p* #'cl::input-stream-p) 178 (defvar *ansi-output-stream-p* #'cl::output-stream-p) 179 (defvar *ansi-open-stream-p* #'cl::open-stream-p) 180 (defvar *ansi-streamp* #'cl::streamp) 181 (defvar *ansi-read-sequence* #'cl::read-sequence) 182 (defvar *ansi-write-sequence* #'cl::write-sequence) 183 (defvar *ansi-make-two-way-stream* #'cl:make-two-way-stream) 184 (defvar *ansi-two-way-stream-input-stream* #'cl:two-way-stream-input-stream) 185 (defvar *ansi-two-way-stream-output-stream* #'cl:two-way-stream-output-stream) 186 (defvar *ansi-file-position* #'cl:file-position) 187 188 (defun ansi-streamp (stream) 179 189 (or (xp::xp-structure-p stream) 180 (funcall *old-streamp* stream))) 181 182 (defclass fundamental-stream (standard-object stream)) 190 (funcall *ansi-streamp* stream))) 191 192 (defclass fundamental-stream (standard-object stream) 193 ((open-p :initform t 194 :accessor stream-open-p)) 195 (:documentation "The base class of all Gray streams")) 183 196 184 197 (defgeneric gray-close (stream &key abort)) … … 190 203 (defgeneric gray-stream-element-type (stream)) 191 204 192 193 (defmethod stream-streamp ((s fundamental-stream)) 205 (defmethod gray-close ((stream fundamental-stream) &key abort) 206 (declare (ignore abort)) 207 (setf (stream-open-p stream) nil) 208 t) 209 210 (defmethod gray-open-stream-p ((stream fundamental-stream)) 211 (stream-open-p stream)) 212 213 (defmethod gray-streamp ((s fundamental-stream)) 194 214 s) 195 215 196 216 (defclass fundamental-input-stream (fundamental-stream)) 197 217 198 (defmethod stream-input-character-stream-p (s) ;; # fb 1.01199 (and ( stream-input-stream-p s)200 (eq ( stream-stream-element-type s) 'character)))201 202 (defmethod stream-input-stream-p ((s fundamental-input-stream))218 (defmethod gray-input-character-stream-p (s) ;; # fb 1.01 219 (and (gray-input-stream-p s) 220 (eq (gray-stream-element-type s) 'character))) 221 222 (defmethod gray-input-stream-p ((s fundamental-input-stream)) 203 223 (declare (ignore s)) 204 224 t) … … 206 226 (defclass fundamental-output-stream (fundamental-stream)) 207 227 208 (defmethod stream-output-stream-p ((s fundamental-output-stream)) 228 (defmethod gray-input-stream-p ((s fundamental-output-stream)) 229 (typep s 'fundamental-input-stream)) 230 231 (defmethod gray-output-stream-p ((s fundamental-output-stream)) 209 232 (declare (ignore s)) 210 233 t) 211 234 235 (defmethod gray-output-stream-p ((s fundamental-input-stream)) 236 (typep s 'fundamental-output-stream)) 237 212 238 (defclass fundamental-character-stream (fundamental-stream)) 213 239 214 (defmethod stream-stream-element-type ((s fundamental-character-stream))240 (defmethod gray-stream-element-type ((s fundamental-character-stream)) 215 241 (declare (ignore s)) 216 242 'character) … … 383 409 (defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p) 384 410 (let ((stream (decode-read-arg input-stream))) 385 (if ( old-streamp stream)386 (funcall * old-read-char* stream eof-errorp eof-value recursive-p)411 (if (ansi-streamp stream) 412 (funcall *ansi-read-char* stream eof-errorp eof-value recursive-p) 387 413 (check-for-eof (stream-read-char stream) stream eof-errorp eof-value)))) 388 414 … … 390 416 eof-value recursive-p) 391 417 (let ((stream (decode-read-arg input-stream))) 392 (if ( old-streamp stream)393 (funcall * old-peek-char* peek-type stream eof-errorp eof-value recursive-p)418 (if (ansi-streamp stream) 419 (funcall *ansi-peek-char* peek-type stream eof-errorp eof-value recursive-p) 394 420 (if (null peek-type) 395 421 (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value) … … 407 433 (defun gray-unread-char (character &optional input-stream) 408 434 (let ((stream (decode-read-arg input-stream))) 409 (if ( old-streamp stream)410 (funcall * old-unread-char* character stream)435 (if (ansi-streamp stream) 436 (funcall *ansi-unread-char* character stream) 411 437 (stream-unread-char stream character)))) 412 438 413 439 (defun gray-listen (&optional input-stream) 414 440 (let ((stream (decode-read-arg input-stream))) 415 (if ( old-streamp stream)416 (funcall * old-listen* stream)441 (if (ansi-streamp stream) 442 (funcall *ansi-listen* stream) 417 443 (stream-listen stream)))) 418 444 … … 420 446 eof-value recursive-p) 421 447 (let ((stream (decode-read-arg input-stream))) 422 (if ( old-streamp stream)423 (funcall * old-read-line* stream eof-error-p eof-value recursive-p)448 (if (ansi-streamp stream) 449 (funcall *ansi-read-line* stream eof-error-p eof-value recursive-p) 424 450 (multiple-value-bind (string eofp) 425 451 (stream-read-line stream) … … 432 458 (defun gray-clear-input (&optional input-stream) 433 459 (let ((stream (decode-read-arg input-stream))) 434 (if ( old-streamp stream)435 (funcall * old-clear-input* stream)460 (if (ansi-streamp stream) 461 (funcall *ansi-clear-input* stream) 436 462 (stream-clear-input stream)))) 437 463 … … 439 465 eof-value recursive-p) 440 466 (let ((stream (decode-read-arg input-stream))) 441 (if ( old-streamp stream)442 (funcall * old-read-char-no-hang* stream eof-errorp eof-value recursive-p)467 (if (ansi-streamp stream) 468 (funcall *ansi-read-char-no-hang* stream eof-errorp eof-value recursive-p) 443 469 (check-for-eof (stream-read-char-no-hang stream) 444 470 stream eof-errorp eof-value)))) … … 446 472 (defun gray-write-char (character &optional output-stream) 447 473 (let ((stream (decode-print-arg output-stream))) 448 (if ( old-streamp stream)449 (funcall * old-write-char* character stream)474 (if (ansi-streamp stream) 475 (funcall *ansi-write-char* character stream) 450 476 (stream-write-char stream character)))) 451 477 452 478 (defun gray-fresh-line (&optional output-stream) 453 479 (let ((stream (decode-print-arg output-stream))) 454 (if ( old-streamp stream)455 (funcall * old-fresh-line* stream)480 (if (ansi-streamp stream) 481 (funcall *ansi-fresh-line* stream) 456 482 (stream-fresh-line stream)))) 457 483 458 484 (defun gray-terpri (&optional output-stream) 459 485 (let ((stream (decode-print-arg output-stream))) 460 (if ( old-streamp stream)461 (funcall * old-terpri* stream)486 (if (ansi-streamp stream) 487 (funcall *ansi-terpri* stream) 462 488 (stream-terpri stream)))) 463 489 464 490 (defun gray-write-string (string &optional output-stream &key (start 0) end) 465 491 (let ((stream (decode-print-arg output-stream))) 466 (if ( old-streamp stream)467 (funcall * old-write-string* string stream :start start :end end)492 (if (ansi-streamp stream) 493 (funcall *ansi-write-string* string stream :start start :end end) 468 494 (stream-write-string stream string start end)))) 469 495 470 496 (defun gray-write-line (string &optional output-stream &key (start 0) end) 471 497 (let ((stream (decode-print-arg output-stream))) 472 (if ( old-streamp stream)473 (funcall * old-write-line* string stream :start start :end end)498 (if (ansi-streamp stream) 499 (funcall *ansi-write-line* string stream :start start :end end) 474 500 (progn 475 501 (stream-write-string stream string start end) … … 479 505 (defun gray-force-output (&optional output-stream) 480 506 (let ((stream (decode-print-arg output-stream))) 481 (if ( old-streamp stream)482 (funcall * old-force-output* stream)507 (if (ansi-streamp stream) 508 (funcall *ansi-force-output* stream) 483 509 (stream-force-output stream)))) 484 510 485 511 (defun gray-finish-output (&optional output-stream) 486 512 (let ((stream (decode-print-arg output-stream))) 487 (if ( old-streamp stream)488 (funcall * old-finish-output* stream)513 (if (ansi-streamp stream) 514 (funcall *ansi-finish-output* stream) 489 515 (stream-finish-output stream)))) 490 516 491 517 (defun gray-clear-output (&optional output-stream) 492 518 (let ((stream (decode-print-arg output-stream))) 493 (if ( old-streamp stream)494 (funcall * old-clear-output* stream)519 (if (ansi-streamp stream) 520 (funcall *ansi-clear-output* stream) 495 521 (stream-clear-output stream)))) 496 522 497 523 (defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value) 498 (if ( old-streamp binary-input-stream)499 (funcall * old-read-byte* binary-input-stream eof-errorp eof-value)524 (if (ansi-streamp binary-input-stream) 525 (funcall *ansi-read-byte* binary-input-stream eof-errorp eof-value) 500 526 (check-for-eof (stream-read-byte binary-input-stream) 501 527 binary-input-stream eof-errorp eof-value))) 502 528 503 529 (defun gray-write-byte (integer binary-output-stream) 504 (if ( old-streamp binary-output-stream)505 (funcall * old-write-byte* integer binary-output-stream)530 (if (ansi-streamp binary-output-stream) 531 (funcall *ansi-write-byte* integer binary-output-stream) 506 532 (stream-write-byte binary-output-stream integer))) 507 533 … … 511 537 (defun gray-stream-column (&optional input-stream) 512 538 (let ((stream (decode-read-arg input-stream))) 513 (if ( old-streamp stream)514 nil ;(funcall * old-stream-column* stream)539 (if (ansi-streamp stream) 540 nil ;(funcall *ansi-stream-column* stream) 515 541 (stream-line-column stream)))) 516 542 517 543 (defmethod gray-stream-element-type (stream) 518 (funcall * old-stream-element-type* stream))544 (funcall *ansi-stream-element-type* stream)) 519 545 520 546 (defmethod gray-close (stream &key abort) 521 (funcall * old-close* stream :abort abort))547 (funcall *ansi-close* stream :abort abort)) 522 548 523 549 (defmethod gray-input-stream-p (stream) 524 (funcall * old-input-stream-p* stream))550 (funcall *ansi-input-stream-p* stream)) 525 551 526 552 (defmethod gray-input-character-stream-p (stream) 527 (funcall * old-input-character-stream-p* stream))553 (funcall *ansi-input-character-stream-p* stream)) 528 554 529 555 (defmethod gray-output-stream-p (stream) 530 (funcall * old-output-stream-p* stream))556 (funcall *ansi-output-stream-p* stream)) 531 557 532 558 (defmethod gray-open-stream-p (stream) 533 (funcall * old-open-stream-p* stream))559 (funcall *ansi-open-stream-p* stream)) 534 560 535 561 (defmethod gray-streamp (stream) 536 (funcall * old-streamp* stream))562 (funcall *ansi-streamp* stream)) 537 563 538 564 (defun gray-write-sequence (sequence stream &key (start 0) end) 539 (if ( old-streamp stream)540 (funcall * old-write-sequence* sequence stream :start start :end end)565 (if (ansi-streamp stream) 566 (funcall *ansi-write-sequence* sequence stream :start start :end end) 541 567 (stream-write-sequence stream sequence start end))) 542 568 543 569 (defun gray-read-sequence (sequence stream &key (start 0) end) 544 (if ( old-streamp stream)545 (funcall * old-read-sequence* sequence stream :start start :end end)570 (if (ansi-streamp stream) 571 (funcall *ansi-read-sequence* sequence stream :start start :end end) 546 572 (stream-read-sequence stream sequence start end))) 547 573 574 (defgeneric stream-file-position (stream &optional position-spec)) 575 576 (defun gray-file-position (stream &optional position-spec) 577 (if position-spec 578 (if (ansi-streamp stream) 579 (funcall *ansi-file-position* stream position-spec) 580 (stream-file-position stream position-spec)) 581 (if (ansi-streamp stream) 582 (funcall *ansi-file-position* stream) 583 (stream-file-position stream)))) 584 548 585 #| 549 586 (defstruct (two-way-stream-g (:include stream)) … … 551 588 552 589 (defun gray-make-two-way-stream (in out) 553 (if (and ( old-streamp in) (old-streamp out))554 (funcall * old-make-two-way-stream* in out)590 (if (and (ansi-streamp in) (ansi-streamp out)) 591 (funcall *ansi-make-two-way-stream* in out) 555 592 (make-two-way-stream-g :input-stream in :output-stream out))) 556 593 557 594 (defun gray-two-way-stream-input-stream (stream) 558 (if ( old-streamp stream)559 (funcall * old-two-way-stream-input-stream* stream)595 (if (ansi-streamp stream) 596 (funcall *ansi-two-way-stream-input-stream* stream) 560 597 (two-way-stream-g-input-stream stream))) 561 598 562 599 (defun gray-two-way-stream-output-stream (stream) 563 (if ( old-streamp stream)564 (funcall * old-two-way-stream-output-stream* stream)600 (if (ansi-streamp stream) 601 (funcall *ansi-two-way-stream-output-stream* stream) 565 602 (two-way-stream-g-output-stream stream))) 566 603 … … 593 630 (setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence) 594 631 (setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence) 632 (setf (symbol-function 'common-lisp::file-position) #'gray-file-position) 595 633 596 634 #|
Note: See TracChangeset
for help on using the changeset viewer.