Changeset 13255


Ignore:
Timestamp:
03/20/11 20:26:04 (11 years ago)
Author:
Mark Evenson
Message:

Enable our GRAY-STREAMS implementation to work with flexi-streams.

With this patch, flexi-streams-1.0.7 now passes its internal tests
with ABCL. NB. One must [patch TRIVIAL-GRAY-STREAMS][1] to use the
new generic for FILE-POSITION for this to work.

[1]: ​http://detroit.slack.net/~evenson/abcl/trivial-gray-streams-abcl-20110320a.patch

GRAY-STREAMS:STREAM-FILE-POSITION now provides a generic function
counterpart. for FILE-POSITION on a Gray stream.

Fix OPEN-STREAM-P as described in the Gray streams proposal by adding
a field to the FUNDAMENTAL-STREAM class whose which records whether
CLOSE has been called on this stream.

Fix STREAM-OUTPUT-STREAM-P and STREAM-INPUT-STREAM_P by providing
default methods on FUNDAMENTAL-INPUT-STREAM and
FUNDAMENTAL-OUTPUT-STREAM.

Renamed all symbols old-XXXX-XXXX to the more informative
ansi-XXXX-XXXX pattern.

Remove export of unused symbols STREAM-OPEN-STREAM-P, STREAM-STREAMP,
STREAM-INPUT-STREAM-P, STREAM-OUTPUT-STREAM-P,
STREAM-STREAM-ELEMENT-TYPE, and STREAM-CLOSE which should have been
removed with r12183.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp

    r12373 r13255  
    5858;;;; Notes
    5959;;;; =====
     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;;;;
    6069;;;; A simple implementation of Gray streams for Corman Lisp 1.42.
    6170;;;; Gray streams are 'clos' based streams as described at:
    6271;;;;
    6372;;;; 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
    6479;;;;
    6580;;;; Some differences exist between this implementation and the
    … …  
    106121  (:export
    107122   "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"
    114123   "FUNDAMENTAL-OUTPUT-STREAM"
    115124   "FUNDAMENTAL-INPUT-STREAM"
    … …  
    139148   "STREAM-READ-SEQUENCE"
    140149   "STREAM-WRITE-SEQUENCE"
     150   "STREAM-FILE-POSITION"
    141151   "FUNDAMENTAL-BINARY-INPUT-STREAM"
    142152   "FUNDAMENTAL-BINARY-OUTPUT-STREAM"))
    … …  
    144154(in-package :gray-streams)
    145155
    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*
    166176  #'(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)
    179189  (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"))
    183196
    184197(defgeneric gray-close (stream &key abort))
    … …  
    190203(defgeneric gray-stream-element-type (stream))
    191204
    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))
    194214  s)
    195215
    196216(defclass fundamental-input-stream (fundamental-stream))
    197217
    198 (defmethod stream-input-character-stream-p (s)  ;; # fb 1.01
    199   (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))
    203223  (declare (ignore s))
    204224  t)
    … …  
    206226(defclass fundamental-output-stream (fundamental-stream))
    207227
    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))
    209232  (declare (ignore s))
    210233  t)
    211234
     235(defmethod gray-output-stream-p ((s fundamental-input-stream))
     236  (typep s 'fundamental-output-stream))
     237
    212238(defclass fundamental-character-stream (fundamental-stream))
    213239
    214 (defmethod stream-stream-element-type ((s fundamental-character-stream))
     240(defmethod gray-stream-element-type ((s fundamental-character-stream))
    215241  (declare (ignore s))
    216242  'character)
    … …  
    383409(defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p)
    384410  (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)
    387413        (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))))
    388414
    … …  
    390416                                 eof-value recursive-p)
    391417  (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)
    394420        (if (null peek-type)
    395421            (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value)
    … …  
    407433(defun gray-unread-char (character &optional input-stream)
    408434  (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)
    411437        (stream-unread-char stream character))))
    412438
    413439(defun gray-listen (&optional input-stream)
    414440  (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)
    417443        (stream-listen stream))))
    418444
    … …  
    420446                                 eof-value recursive-p)
    421447  (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)
    424450        (multiple-value-bind (string eofp)
    425451          (stream-read-line stream)
    … …  
    432458(defun gray-clear-input (&optional input-stream)
    433459  (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)
    436462        (stream-clear-input stream))))
    437463
    … …  
    439465                                         eof-value recursive-p)
    440466  (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)
    443469        (check-for-eof (stream-read-char-no-hang stream)
    444470                       stream eof-errorp eof-value))))
    … …  
    446472(defun gray-write-char (character &optional output-stream)
    447473  (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)
    450476        (stream-write-char stream character))))
    451477
    452478(defun gray-fresh-line (&optional output-stream)
    453479  (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)
    456482        (stream-fresh-line stream))))
    457483
    458484(defun gray-terpri (&optional output-stream)
    459485  (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)
    462488        (stream-terpri stream))))
    463489
    464490(defun gray-write-string (string &optional output-stream &key (start 0) end)
    465491  (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)
    468494        (stream-write-string stream string start end))))
    469495
    470496(defun gray-write-line (string &optional output-stream &key (start 0) end)
    471497  (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)
    474500        (progn
    475501          (stream-write-string stream string start end)
    … …  
    479505(defun gray-force-output (&optional output-stream)
    480506  (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)
    483509        (stream-force-output stream))))
    484510
    485511(defun gray-finish-output (&optional output-stream)
    486512  (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)
    489515        (stream-finish-output stream))))
    490516
    491517(defun gray-clear-output (&optional output-stream)
    492518  (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)
    495521        (stream-clear-output stream))))
    496522
    497523(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)
    500526      (check-for-eof (stream-read-byte binary-input-stream)
    501527                     binary-input-stream eof-errorp eof-value)))
    502528
    503529(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)
    506532      (stream-write-byte binary-output-stream integer)))
    507533
    … …  
    511537(defun gray-stream-column (&optional input-stream)
    512538  (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)
    515541        (stream-line-column stream))))
    516542
    517543(defmethod gray-stream-element-type (stream)
    518   (funcall *old-stream-element-type* stream))
     544  (funcall *ansi-stream-element-type* stream))
    519545
    520546(defmethod gray-close (stream &key abort)
    521   (funcall *old-close* stream :abort abort))
     547  (funcall *ansi-close* stream :abort abort))
    522548
    523549(defmethod gray-input-stream-p (stream)
    524   (funcall *old-input-stream-p* stream))
     550  (funcall *ansi-input-stream-p* stream))
    525551
    526552(defmethod gray-input-character-stream-p (stream)
    527   (funcall *old-input-character-stream-p* stream))
     553  (funcall *ansi-input-character-stream-p* stream))
    528554
    529555(defmethod gray-output-stream-p (stream)
    530   (funcall *old-output-stream-p* stream))
     556  (funcall *ansi-output-stream-p* stream))
    531557
    532558(defmethod gray-open-stream-p (stream)
    533   (funcall *old-open-stream-p* stream))
     559  (funcall *ansi-open-stream-p* stream))
    534560
    535561(defmethod gray-streamp (stream)
    536   (funcall *old-streamp* stream))
     562  (funcall *ansi-streamp* stream))
    537563
    538564(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)
    541567      (stream-write-sequence stream sequence start end)))
    542568
    543569(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)
    546572      (stream-read-sequence stream sequence start end)))
    547573
     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 
    548585#|
    549586(defstruct (two-way-stream-g (:include stream))
    … …  
    551588
    552589(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)
    555592      (make-two-way-stream-g :input-stream in :output-stream out)))
    556593
    557594(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)
    560597      (two-way-stream-g-input-stream stream)))
    561598
    562599(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)
    565602      (two-way-stream-g-output-stream stream)))
    566603
    … …  
    593630(setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence)
    594631(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence)
     632(setf (symbol-function 'common-lisp::file-position) #'gray-file-position)
    595633
    596634#|
Note: See TracChangeset for help on using the changeset viewer.