losp/muerte/simple-streams.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2003-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      simple-streams.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Fri Aug 29 13:39:43 2003
  12 ;;;;
  13 ;;;; $Id: simple-streams.lisp,v 1.8 2005/06/10 18:35:44 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (require :muerte/los-closette)
  19 (provide :muerte/simple-streams)
  20
  21 (in-package muerte)
  22
  23 (defvar *default-external-format* :ascii)
  24
  25
  26 (defconstant +flag-bits+ '(:simple      ; instance is valid
  27                            :input :output ; direction
  28                            :dual :string ; type of stream
  29                            :eof         ; latched EOF
  30                            :dirty       ; output buffer needs write
  31                            :interactive)) ; interactive stream
  32
  33
  34 (eval-when (:compile-toplevel :load-toplevel :execute)
  35   (defun %flags (flags)
  36     (loop for flag in flags
  37           as pos = (position flag +flag-bits+)
  38         when (eq flag :gray) do
  39           (error "Gray streams not supported.")
  40         if pos
  41           sum (ash 1 pos) into bits
  42         else
  43           collect flag into unused
  44       finally (when unused
  45                 (warn "Invalid stream instance flag~P: ~{~S~^, ~}"
  46                       (length unused) unused))
  47               (return bits))))
  48
  49 (defmacro simple-stream-dispatch (stream single-clause dual-clause string-clause)
  50   (assert (eq 'single-channel-simple-stream (car single-clause)))
  51   (assert (eq 'dual-channel-simple-stream (car dual-clause)))
  52   (assert (eq 'string-simple-stream (car string-clause)))
  53   (let ((s (gensym "stream-")))
  54     `(let ((,s ,stream))
  55        (with-stream-class (simple-stream ,s)
  56          (let ((%flags (sm %flags ,s)))
  57            (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
  58                   ,@(cdr single-clause))
  59                  ((zerop (logand %flags ,(%flags '(:string))))
  60                   ,@(cdr dual-clause))
  61                  (t ,@(cdr string-clause))))))))
  62
  63 (defmacro with-stream-class ((class-name &optional stream) &body body)
  64   (if stream
  65       (let ((stream-var (gensym "stream-"))
  66             (slots-var (gensym "stream-slots-")))
  67         `(let* ((,stream-var ,stream)
  68                 (,slots-var (std-instance-slots ,stream-var)))
  69            (declare (type ,class-name ,stream-var)
  70                     (type simple-vector ,slots-var)
  71                     (ignorable ,slots-var))
  72            (macrolet ((sm (slot-name stream)
  73                         (declare (ignore stream))
  74                         `(slot-value ,',stream-var ',slot-name)
  75                         #+ignore `(svref%unsafe ,',slots-var
  76                                                 ,(slot-location ,(movitz-find-class class-name)
  77                                                                 slot-name)))
  78                       (add-stream-instance-flags (stream &rest flags)
  79                         (declare (ignore stream))
  80                         `(setf (sm %flags ,',stream-var)
  81                            (logior (sm %flags ,',stream-var)
  82                                    ,(%flags flags))))
  83                       (remove-stream-instance-flags (stream &rest flags)
  84                         (declare (ignore stream))
  85                         `(setf (sm %flags ,',stream-var)
  86                            (logandc2 (sm %flags ,',stream-var)
  87                                      ,(%flags flags))))
  88                       (any-stream-instance-flags (stream &rest flags)
  89                         (declare (ignore stream))
  90                         `(not (zerop (logand (sm %flags ,',stream-var)
  91                                              ,(%flags flags))))))
  92              ,@body)))
  93     `(macrolet ((sm (slot-name stream)
  94                   `(svref%unsafe (std-instance-slots stream)
  95                                  ,(slot-location ,(movitz-find-class class-name)
  96                                                  slot-name))))
  97        ,@body)))
  98
  99 (defmacro sm (slot-name stream)
 100   "Access the named slot in Stream."
 101   ;; (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
 102   `(slot-value ,stream ',slot-name))
 103
 104 (defmacro funcall-stm-handler (slot-name stream &rest args)
 105   "Call the strategy function named by Slot-Name on Stream."
 106   (let ((s (gensym)))
 107     `(let ((,s ,stream))
 108        (funcall (sm ,slot-name ,s) ,s ,@args))))
 109
 110 (defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
 111   "Call the strategy function named by Slot-Name on Stream."
 112   (let ((s (gensym)))
 113     `(let ((,s ,stream))
 114        (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
 115
 116 (defmacro add-stream-instance-flags (stream &rest flags)
 117   "Set the given Flags in Stream."
 118   (let ((s (gensym "STREAM")))
 119     `(let ((,s ,stream))
 120        (with-stream-class (simple-stream ,s)
 121          (add-stream-instance-flags ,s ,@flags)))))
 122
 123 (defmacro remove-stream-instance-flags (stream &rest flags)
 124   "Clear the given Flags in Stream."
 125   (let ((s (gensym "STREAM")))
 126     `(let ((,s ,stream))
 127        (with-stream-class (simple-stream ,s)
 128          (remove-stream-instance-flags ,s ,@flags)))))
 129
 130 (defmacro any-stream-instance-flags (stream &rest flags)
 131   "Determine whether any one of the Flags is set in Stream."
 132   (let ((s (gensym "STREAM")))
 133     `(let ((,s ,stream))
 134        (with-stream-class (simple-stream ,s)
 135          (any-stream-instance-flags ,s ,@flags)))))
 136
 137
 138 (defun ill-in-any (stream &rest ignore)
 139   (declare (ignore ignore))
 140   (error 'simple-type-error
 141          :datum stream
 142          :expected-type '(satisfies input-stream-p)
 143          :format-control "~S is not an input stream."
 144          :format-arguments (list stream)))
 145
 146 (defun ill-out-any (stream &rest ignore)
 147   (declare (ignore ignore))
 148   (error 'simple-type-error
 149          :datum stream
 150          :expected-type '(satisfies output-stream-p)
 151          :format-control "~S is not an output stream."
 152          :format-arguments (list stream)))
 153
 154 (defclass simple-stream (stream)
 155   ((%flags
 156     :initform 0
 157     :type fixnum)
 158    (plist
 159     :initform nil
 160     :type list
 161     :accessor stream-plist)
 162
 163    (j-listen
 164     :initform 'ill-in-any
 165     :type j-listen-fn)
 166    (j-read-char
 167     :initform 'ill-in-any
 168     :type j-read-char-fn)
 169    (j-read-chars
 170     :initform 'ill-in-any
 171     :type j-read-chars-fn)
 172    (j-unread-char
 173     :initform 'ill-in-any
 174     :type j-unread-char-fn)
 175    (j-write-char
 176     :initform 'ill-out-any
 177     :type j-write-char-fn)              ;@@
 178    (j-write-chars
 179     :initform 'ill-out-any
 180     :type j-write-chars-fn)             ;@@
 181
 182    (oc-state
 183     :initform nil)
 184    (co-state
 185     :initform nil)
 186    (external-format
 187     :initform *default-external-format*)
 188
 189    (input-handle
 190     :initform nil
 191     :initarg :input-handle
 192     :type (or null fixnum stream)
 193
 194     :accessor stream-input-handle)
 195    (output-handle
 196     :initform nil
 197     :initarg :output-handle
 198     :type (or null fixnum stream)
 199     :accessor stream-output-handle)
 200    (control-in
 201     :initform nil
 202     :type (or null simple-vector))
 203    (control-out
 204     :initform nil
 205     :type (or null simple-vector))
 206
 207    (melded-stream
 208     :type (or null simple-stream))
 209    (melding-base
 210     :type (or null simple-stream))
 211
 212    (encapsulated-char-read-size
 213     :initform 0
 214     :type fixnum)
 215    (last-char-read-size
 216     :initform 0
 217     :type fixnum)
 218    (charpos
 219     :initform 0
 220     :type (or null integer)
 221     :accessor stream-line-column)
 222    (record-end
 223     :initform nil
 224     :type (or null fixnum))
 225
 226    (buffer
 227     :initform nil
 228     :type (or simple-stream-buffer null))
 229    (buffpos
 230     :initform 0
 231     :type fixnum)
 232    (buffer-ptr
 233     :initform 0
 234     :type fixnum)
 235    (buf-len
 236     :initform 0
 237     :type fixnum)
 238
 239    (pending
 240     :initform nil
 241     :type list)
 242    (handler
 243     :initform nil
 244     :type (or null handler))))
 245
 246 (defclass single-channel-simple-stream (simple-stream)
 247   ((mode
 248     :initform 0
 249     :type fixnum)))
 250
 251 (defclass dual-channel-simple-stream (simple-stream)
 252   ((out-buffer
 253     :initform nil
 254     :type (or simple-stream-buffer null))
 255    (outpos
 256     :initform 0
 257     :type fixnum)
 258    (max-out-pos
 259     :initform 0
 260     :type fixnum)))
 261
 262 (defclass string-simple-stream (simple-stream) ())
 263
 264
 265 ;;;;
 266
 267 ;;;; Generic function definitions
 268
 269 (defgeneric device-open (stream options)
 270   (:documentation "Write me"))
 271
 272 (defgeneric device-close (stream abort)
 273   (:documentation "Write me"))
 274
 275 (defgeneric device-buffer-length (stream)
 276   (:documentation "Write me"))
 277
 278 (defgeneric device-file-position (stream)
 279   (:documentation "Write me"))
 280
 281 (defgeneric (setf device-file-position) (value stream)
 282   ;; (:argument-precedence-order stream value)
 283   (:documentation "Write me"))
 284
 285 (defgeneric device-file-length (stream)
 286   (:documentation "Write me"))
 287
 288 (defgeneric device-read (stream buffer start end blocking)
 289   (:documentation "Write me"))
 290
 291 (defgeneric device-clear-input (stream buffer-only)
 292   (:documentation "Write me"))
 293
 294 (defgeneric device-write (stream buffer start end blocking)
 295   (:documentation "Write me"))
 296
 297 (defgeneric device-clear-output (stream)
 298   (:documentation "Write me"))
 299
 300 (defgeneric device-finish-record (stream blocking action)
 301   (:documentation "Write me"))
 302
 303 (defmethod shared-initialize :after ((instance simple-stream) slot-names
 304                                      &rest initargs &key &allow-other-keys)
 305   (declare (ignore slot-names)
 306            (dynamic-extent initargs))
 307   (unless (slot-boundp instance 'melded-stream)
 308     (setf (slot-value instance 'melded-stream) instance)
 309     (setf (slot-value instance 'melding-base) instance))
 310   (unless (device-open instance initargs)
 311     (device-close instance t)))
 312
 313 (defmethod print-object ((object simple-stream) stream)
 314   (print-unreadable-object (object stream :type nil :identity nil)
 315     (cond ((not (any-stream-instance-flags object :simple))
 316            (princ "Invalid " stream))
 317           ((not (any-stream-instance-flags object :input :output))
 318            (princ "Closed " stream)))
 319     (format stream "~:(~A~)" (type-of object))))
 320
 321 #+ignore
 322 (defmethod device-close :around ((stream simple-stream) abort)
 323   (with-stream-class (simple-stream stream)
 324     (when (any-stream-instance-flags stream :input :output)
 325       (when (any-stream-instance-flags stream :output)
 326         (ignore-errors (if abort
 327                            (clear-output stream)
 328                          (%finish-output stream))))
 329       (call-next-method)
 330       (setf (sm input-handle stream) nil
 331             (sm output-handle stream) nil)
 332       (remove-stream-instance-flags stream :input :output)
 333       ;; (ext:cancel-finalization stream)
 334       (setf (stream-external-format stream) :void))))
 335
 336 (defmethod device-close ((stream simple-stream) abort)
 337   (declare (ignore abort))
 338   t)
 339
 340 (defmethod device-buffer-length ((stream simple-stream))
 341   4096)
 342
 343 (defmethod device-file-position ((stream simple-stream))
 344   (with-stream-class (simple-stream stream)
 345     (sm buffpos stream)))
 346
 347 (defmethod (setf device-file-position) (value (stream simple-stream))
 348   (with-stream-class (simple-stream stream)
 349     (setf (sm buffpos stream) value)))
 350
 351 (defmethod device-file-length ((stream simple-stream))
 352   nil)
 353
 354 (defmethod (setf stream-external-format) (ef (stream simple-stream))
 355   (with-stream-class (simple-stream stream)
 356     (setf (sm external-format stream) (find-external-format ef)))
 357   ef)
 358
 359 (defmethod (setf stream-external-format) :after (ef (stream single-channel-simple-stream))
 360   (with-stream-class (single-channel-simple-stream stream)
 361     (compose-encapsulating-streams stream ef)
 362     (install-single-channel-character-strategy (melding-stream stream)
 363                                                ef nil)))
 364
 365 (defmethod (setf stream-external-format) :after (ef (stream dual-channel-simple-stream))
 366   (with-stream-class (dual-channel-simple-stream stream)
 367     (compose-encapsulating-streams stream ef)
 368     (install-dual-channel-character-strategy (melding-stream stream) ef)))
 369
 370 ;;;(defmethod device-read ((stream single-channel-simple-stream) buffer start end blocking)
 371 ;;;  (read-octets stream buffer start end blocking))
 372 ;;;
 373 ;;;(defmethod device-read ((stream dual-channel-simple-stream) buffer start end blocking)
 374 ;;;  (read-octets stream buffer start end blocking))
 375
 376 (defmethod device-clear-input ((stream simple-stream) buffer-only)
 377   (declare (ignore buffer-only))
 378   nil)
 379
 380 (defmethod device-write ((stream single-channel-simple-stream) buffer
 381                          start end blocking)
 382   ;; buffer may be :flush to force/finish-output
 383   (when (or (and (null buffer) (not (eql start end)))
 384             (eq buffer :flush))
 385     (with-stream-class (single-channel-simple-stream stream)
 386       (setf buffer (sm buffer stream))
 387       (setf end (sm buffpos stream))))
 388   (write-octets stream buffer start end blocking))
 389
 390 (defmethod device-write ((stream dual-channel-simple-stream) buffer
 391                          start end blocking)
 392   ;; buffer may be :flush to force/finish-output
 393   (when (or (and (null buffer) (not (eql start end)))
 394             (eq buffer :flush))
 395     (with-stream-class (dual-channel-simple-stream stream)
 396       (setf buffer (sm out-buffer stream))
 397       (setf end (sm outpos stream))))
 398   (write-octets stream buffer start end blocking))
 399
 400 (defmethod device-clear-output ((stream simple-stream))
 401   nil)
 402
 403 ;;;; CL layer interface
 404
 405 (defun %check (stream kind)
 406   (declare (type simple-stream stream)
 407            (optimize (speed 3) (space 1) (debug 0) (safety 0)))
 408   (with-stream-class (simple-stream stream)
 409     (cond ((not (any-stream-instance-flags stream :simple))
 410            (error "~S is uninitialized." stream))
 411           ((and (eq kind :open)
 412                 (not (any-stream-instance-flags stream :input :output)))
 413            (closed-flame stream))
 414           ((and (or (eq kind :input) (eq kind :io))
 415                 (not (any-stream-instance-flags stream :input)))
 416            (ill-in-any stream))
 417           ((and (or (eq kind :output) (eq kind :io))
 418                 (not (any-stream-instance-flags stream :output)))
 419            (ill-out-any stream)))))
 420
 421 (defun %write-char (character stream)
 422   (etypecase stream
 423     (function
 424      (funcall stream 'stream-write-char character))
 425     (simple-stream
 426      (with-stream-class (simple-stream stream)
 427        (%check stream :output)
 428        (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
 429     (string
 430      (vector-push-extend character stream))))
 431
 432 (defun %read-line (stream eof-error-p eof-value recursive-p)
 433   (declare (ignore recursive-p))
 434   (etypecase stream
 435     (function
 436      (funcall stream 'read-line eof-error-p eof-value))
 437     (simple-stream
 438      (with-stream-class (simple-stream stream)
 439        (%check stream :input)
 440        (when (any-stream-instance-flags stream :eof)
 441          (return-from %read-line
 442            (eof-or-lose stream eof-error-p eof-value)))
 443        ;; for interactive streams, finish output first to force prompt
 444        (when (and (any-stream-instance-flags stream :output)
 445                   (any-stream-instance-flags stream :interactive))
 446          (%finish-output stream))
 447        (let* ((encap (sm melded-stream stream)) ; encapsulating stream
 448               (cbuf (make-string 80))   ; current buffer
 449               (bufs (list cbuf))        ; list of buffers
 450               (tail bufs)               ; last cons of bufs list
 451               (index 0)                 ; current index in current buffer
 452               (total 0))                ; total characters
 453          (loop
 454            (multiple-value-bind (chars done)
 455                (funcall-stm-handler j-read-chars encap cbuf
 456                                     #\Newline index (length cbuf) t)
 457              (incf index chars)
 458              (incf total chars)
 459              (when (and (eq done :eof) (zerop total))
 460                (if eof-error-p
 461                    (error 'end-of-file :stream stream)
 462                  (return (values eof-value t))))
 463              (when done
 464                ;; If there's only one buffer in use, return it directly
 465                (when (null (cdr bufs))
 466                  (return (values (shrink-vector cbuf total)
 467                                  (eq done :eof))))
 468                ;; If total fits in final buffer, use it
 469                (when (<= total (length cbuf))
 470                  (replace cbuf cbuf :start1 (- total index) :end2 index)
 471                  (let ((idx 0))
 472                    (declare (type index idx))
 473                    (do ((list bufs (cdr list)))
 474                        ((eq list tail))
 475                      (let ((buf (car list)))
 476                        (declare (type simple-base-string buf))
 477                        (replace cbuf buf :start1 idx)
 478                        (incf idx (length buf)))))
 479                  (return (values (shrink-vector cbuf total)
 480                                  (eq done :eof))))
 481                ;; Allocate new string of appropriate length
 482                (let ((string (make-string total))
 483                      (index 0))
 484                  (declare (type index index))
 485                  (dolist (buf bufs)
 486                    (declare (type simple-base-string buf))
 487                    (replace string buf :start1 index)
 488                    (incf index (length buf)))
 489                  (return  (values string (eq done :eof)))))
 490              (when (>= index (length cbuf))
 491                (setf cbuf (make-string (the index (* 2 index))))
 492                (setf index 0)
 493                (setf (cdr tail) (cons cbuf nil))
 494                (setf tail (cdr tail))))))))))
 495
 496 (defun %read-char (stream eof-error-p eof-value recursive-p blocking-p)
 497   (declare (ignore recursive-p))
 498   (etypecase stream
 499     (function
 500      (funcall stream 'stream-read-char))
 501     (simple-stream
 502      (with-stream-class (simple-stream stream)
 503        (%check stream :input)
 504        (when (any-stream-instance-flags stream :eof)
 505          (return-from %read-char
 506            (eof-or-lose stream eof-error-p eof-value)))
 507        ;; for interactive streams, finish output first to force prompt
 508        (when (and (any-stream-instance-flags stream :output)
 509                   (any-stream-instance-flags stream :interactive))
 510          (%finish-output stream))
 511        (funcall-stm-handler j-read-char (sm melded-stream stream)
 512                             eof-error-p eof-value blocking-p)))))
 513
 514 (defun %read-key (stream eof-error-p eof-value recursive-p blocking-p)
 515   (etypecase stream
 516     (function
 517      (funcall stream 'stream-read-key))
 518     (simple-stream                      ; XXX
 519      (%read-char stream eof-error-p eof-value recursive-p blocking-p))))
 520
 521 (defun %unread-char (stream character)
 522   (declare (type simple-stream stream) (ignore character))
 523   (with-stream-class (simple-stream stream)
 524     (%check stream :input)
 525     (if (zerop (sm last-char-read-size stream))
 526         (error "Nothing to unread.")
 527         (progn
 528           (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)
 529           (remove-stream-instance-flags stream :eof)
 530           (setf (sm last-char-read-size stream) 0)))))
 531
 532 (defun %peek-char (stream peek-type eof-error-p eof-value recursive-p)
 533   (declare (type simple-stream stream)
 534            (ignore recursive-p))
 535   (with-stream-class (simple-stream stream)
 536     (%check stream :input)
 537     (when (any-stream-instance-flags stream :eof)
 538       (return-from %peek-char
 539         (eof-or-lose stream eof-error-p eof-value)))
 540     (let* ((encap (sm melded-stream stream))
 541            (char (funcall-stm-handler j-read-char encap
 542                                      eof-error-p stream t)))
 543       (cond ((eq char stream) eof-value)
 544             ((characterp peek-type)
 545              (do ((char char (funcall-stm-handler j-read-char encap
 546                                                   eof-error-p
 547                                                   stream t)))
 548                  ((or (eq char stream) (char= char peek-type))
 549                   (unless (eq char stream)
 550                     (funcall-stm-handler j-unread-char encap t))
 551                   (if (eq char stream) eof-value char))))
 552             ((eq peek-type t)
 553              (do ((char char (funcall-stm-handler j-read-char encap
 554                                                   eof-error-p
 555                                                   stream t)))
 556                  ((or (eq char stream)
 557                       (not (char-whitespace-p char)))
 558                   (unless (eq char stream)
 559                     (funcall-stm-handler j-unread-char encap t))
 560                   (if (eq char stream) eof-value char))))
 561             (t
 562              (funcall-stm-handler j-unread-char encap t)
 563              char)))))
 564
 565
 566 (defun %finish-output (stream)
 567   (declare (type simple-stream stream))
 568   (with-stream-class (simple-stream stream)
 569     (%check stream :output)
 570     (when (sm handler stream)
 571       (do ()
 572           ((null (sm pending stream)))
 573         #+ignore (sys:serve-all-events)))
 574     (device-write stream :flush 0 nil t)
 575     (simple-stream-dispatch stream
 576       (single-channel-simple-stream
 577        (setf (sm buffpos stream) 0))
 578       (dual-channel-simple-stream
 579        (with-stream-class (dual-channel-simple-stream stream)
 580          (setf (sm outpos stream) 0)))
 581       (string-simple-stream
 582        nil)))
 583   nil)
 584
 585 (defun %force-output (stream)
 586   (declare (type simple-stream stream))
 587   (with-stream-class (simple-stream stream)
 588     (%check stream :output)
 589     (device-write stream :flush 0 nil nil)
 590     (simple-stream-dispatch stream
 591       (single-channel-simple-stream
 592        (setf (sm buffpos stream) 0))
 593       (dual-channel-simple-stream
 594        (with-stream-class (dual-channel-simple-stream stream)
 595          (setf (sm outpos stream) 0)))
 596       (string-simple-stream)))
 597   nil)
 598
 599 (defun %clear-output (stream)
 600   (declare (type simple-stream stream))
 601   (with-stream-class (simple-stream stream)
 602     (%check stream :output)
 603     (when (sm handler stream)
 604       (setf (sm handler stream) nil
 605             (sm pending stream) nil))
 606     (simple-stream-dispatch stream
 607       (single-channel-simple-stream
 608        (with-stream-class (single-channel-simple-stream stream)
 609          (case (sm mode stream)
 610            (1 (setf (sm buffpos stream) 0))
 611            (3 (setf (sm mode stream) 0)))))
 612       (dual-channel-simple-stream
 613        (with-stream-class (dual-channel-simple-stream stream)
 614          (setf (sm outpos stream) 0)))
 615       (string-simple-stream))
 616     (device-clear-output stream)))
 617
 618
 619
 620
 621 ;;;; Null stream
 622
 623 (defun null-read-char (stream eof-error-p eof-value blocking)
 624   (declare (ignore blocking))
 625   (eof-or-lose stream eof-error-p eof-value))
 626
 627 (defun null-read-chars (stream string search start end blocking)
 628   (declare (ignore stream string search start end blocking))
 629   (values 0 :eof))
 630
 631 (defun null-unread-char (stream relaxed)
 632   (declare (ignore stream relaxed)))
 633
 634 (defun null-write-char (character stream)
 635   (declare (ignore stream))
 636   character)
 637
 638 (defun null-write-chars (string stream start end)
 639   (declare (ignore string stream))
 640   (- end start))
 641
 642 (defun null-listen (stream)
 643   (declare (ignore stream))
 644   nil)
 645
 646 (defclass null-simple-stream (single-channel-simple-stream) ())
 647
 648 (defmethod device-open ((stream null-simple-stream) options)
 649   (with-stream-class (null-simple-stream stream)
 650     (add-stream-instance-flags stream :simple :input :output)
 651     (setf (sm j-read-char stream) 'null-read-char
 652           (sm j-read-chars stream) 'null-read-chars
 653           (sm j-unread-char stream) 'null-unread-char
 654           (sm j-write-char stream) 'null-write-char
 655           (sm j-write-chars stream) 'null-write-chars
 656           (sm j-listen stream) 'null-listen))
 657   stream)
 658
 659 (defmethod device-buffer-length ((stream null-simple-stream))
 660   256)
 661
 662 (defmethod device-write ((stream null-simple-stream) buffer start end blocking)
 663   (declare (ignore buffer blocking))
 664   (- end start))
 665
 666 (defmethod device-read ((stream null-simple-stream) buffer start end blocking)
 667   (declare (ignore buffer start end blocking))
 668   -1)
 669
 670 ;;;;; String stream
 671
 672 (defclass string-input-simple-stream (string-simple-stream) ())
 673
 674 (defclass string-output-simple-stream (string-simple-stream)
 675   ((out-buffer
 676     :initform nil
 677     :type (or simple-stream-buffer null))
 678    (outpos
 679     :initform 0
 680     :type fixnum)
 681    (max-out-pos
 682     :initform 0
 683     :type fixnum)))
 684
 685 (defclass composing-stream (string-simple-stream) ())
 686
 687 (defun install-string-input-character-strategy (stream)
 688   #| implement me |#
 689   (with-stream-class (simple-stream stream)
 690     (setf (sm j-read-char stream) #'string-read-char-e-crlf))
 691   stream)
 692
 693 (defun install-string-output-character-strategy (stream)
 694   (declare (ignore stream))
 695   #| implement me |#)
 696
 697 (defun string-read-char-e-crlf (stream eof-error-p eof-value blocking)
 698   (with-stream-class (composing-stream stream)
 699     (let* ((encap (sm melded-stream stream))
 700            (ctrl (sm control-in stream))
 701            (char (funcall-stm-handler j-read-char encap nil stream blocking)))
 702       ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
 703       ;; character was available...
 704       (when (eql char #\Return)
 705         (let ((next (funcall-stm-handler j-read-char encap nil stream blocking)))
 706           ;; if NEXT is STREAM, we hit EOF, so we should just return the
 707           ;; #\Return (and mark the stream :EOF?  At least unread if we
 708           ;; got a soft EOF, from a terminal, etc.
 709           ;; if NEXT is NIL, blocking is NIL and there's a CR but no
 710           ;; LF available on the stream: have to unread the CR and
 711           ;; return NIL, letting the CR be reread later.
 712           ;;
 713           ;; If we did get a linefeed, adjust the last-char-read-size
 714           ;; so that an unread of the resulting newline will unread both
 715           ;; the linefeed _and_ the carriage return.
 716           (if (eql next #\Linefeed)
 717               (setq char #\Newline)
 718               (funcall-stm-handler j-unread-char encap nil))))
 719       (when (characterp char)
 720         (let ((code (char-code char)))
 721           (when (and (< code 32) ctrl (svref ctrl code))
 722             (setq char (funcall (the (or symbol function) (svref ctrl code))
 723                                 stream char)))))
 724       (if (eq char stream)
 725           (eof-or-lose stream eof-error-p eof-value)
 726         char))))
 727
 728 (defmethod device-open :before ((stream string-input-simple-stream) options)
 729   ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
 730   (with-stream-class (string-input-simple-stream stream)
 731     (let ((string (getf options :string)))
 732       (when (and string (null (sm buffer stream)))
 733         (let ((start (getf options :start))
 734               (end (or (getf options :end) (length string))))
 735           (setf (sm buffer stream) string
 736                 (sm buffpos stream) start
 737                 (sm buffer-ptr stream) end))))
 738     (install-string-input-character-strategy stream)
 739     (add-stream-instance-flags stream :string :input :simple)))
 740
 741 #+ignore
 742 (defmethod device-open :before ((stream string-output-simple-stream) options)
 743   ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
 744   (with-stream-class (string-output-simple-stream stream)
 745     (unless (sm out-buffer stream)
 746       (let ((string (getf options :string)))
 747         (if string
 748             (setf (sm out-buffer stream) string
 749                   (sm max-out-pos stream) (length string))
 750             (let ((buflen (max (device-buffer-length stream) 16)))
 751               (setf (sm out-buffer stream) (make-string buflen)
 752                     (sm max-out-pos stream) buflen)))))
 753     (unless (sm control-out stream)
 754       (setf (sm control-out stream) *std-control-out-table*))
 755     (install-string-output-character-strategy stream)
 756     (add-stream-instance-flags stream :string :output :simple)))
 757
 758 (defmethod device-open ((stream string-simple-stream) options)
 759   (declare (ignore options))
 760   (with-stream-class (string-simple-stream stream)
 761     (if (and (any-stream-instance-flags stream :simple)
 762              (any-stream-instance-flags stream :input :output))
 763         t
 764         nil)))
 765
 766 (defmethod device-file-position ((stream string-simple-stream))
 767   (with-stream-class (simple-stream stream)
 768     (sm buffpos stream)))
 769
 770 (defmethod (setf device-file-position) (value (stream string-simple-stream))
 771   (with-stream-class (simple-stream stream)
 772     (cond ((or (> value (sm buffer-ptr stream))
 773                (< value (- -1 (sm buffer-ptr stream))))
 774            nil)
 775           ((>= value 0)
 776            (setf (sm buffpos stream) value)
 777            t)
 778           (t
 779            (setf (sm buffpos stream) (+ (sm buffer-ptr stream) value 1))
 780            t))))
 781
 782 (defmethod device-file-length ((stream string-simple-stream))
 783   (with-stream-class (simple-stream stream)
 784     (sm buffer-ptr stream)))
 785