contrib/sb-simple-streams/classes.lisp

   1 ;;; -*- lisp -*-
   2 ;;;
   3 ;;; **********************************************************************
   4 ;;; This code was written by Paul Foley and has been placed in the public
   5 ;;; domain.
   6 ;;;
   7
   8 ;;; Sbcl port by Rudi Schlatte.
   9
  10 (in-package "SB-SIMPLE-STREAMS")
  11
  12 ;;;
  13 ;;; **********************************************************************
  14 ;;;
  15 ;;; Base class and generic function definitions for simple-streams
  16
  17 ;;; See chapter
  18 ;;; 12.2 Strategy descriptions necessary for encapsulation
  19 ;;; in the Franz documentation for a description of the j-xxx-fn slots.
  20
  21 ;;;; Types for buffer and strategy functions
  22
  23 (deftype simple-stream-buffer ()
  24   '(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
  25
  26 (deftype blocking ()
  27   '(member t nil :bnb))
  28
  29 (deftype j-listen-fn ()
  30   '(function (simple-stream) boolean))
  31
  32 (deftype j-read-char-fn ()
  33   '(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE
  34
  35 (deftype j-read-chars-fn ()
  36   '(function (simple-stream string (or character null) fixnum fixnum blocking)
  37              (values fixnum &optional (member nil t :eof))))
  38
  39 (deftype j-write-char-fn ()
  40   '(function ((or character null) simple-stream) (or character null)))
  41
  42 (deftype j-write-chars-fn ()
  43   '(function (string simple-stream fixnum fixnum) t)) ; return chars-written?
  44
  45 (deftype j-unread-char-fn ()
  46   '(function (simple-stream t) t)) ; "relaxed" arg is boolean?  what return?
  47
  48 ;;;; Base simple-stream classes
  49
  50 (def-stream-class simple-stream (standard-object stream)
  51   (;; instance flags (not a normal slot in Allegro CL)
  52    (%flags :initform 0 :type fixnum)
  53    (plist :initform nil :type list :accessor stream-plist)
  54
  55    ;; Strategy slots.  See section 12.2 of streams.htm for function
  56    ;; signatures and possible side-effects.
  57
  58    ;; A function that determines if one character can be successfully
  59    ;; read from stream.
  60    (j-listen :initform #'sb-kernel:ill-in :type j-listen-fn)
  61    ;; A function that reads one character.
  62    (j-read-char :initform #'sb-kernel:ill-in :type j-read-char-fn)
  63    ;; A function that reads characters into a string.
  64    (j-read-chars :initform #'sb-kernel:ill-in :type j-read-chars-fn)
  65    ;; A function that writes one character.
  66    (j-write-char :initform #'sb-kernel:ill-out :type j-write-char-fn)
  67    ;; A function that writes characters from a string into the stream.
  68    (j-write-chars :initform #'sb-kernel:ill-out :type j-write-chars-fn)
  69    ;; A function that unreads the last character read.
  70    (j-unread-char :initform #'sb-kernel:ill-in :type j-unread-char-fn)
  71
  72    ;; Other slots
  73
  74    ;; TODO: find out what this one does
  75    (oc-state :initform nil)
  76    ;; TODO: find out what this one does
  77    (co-state :initform nil)
  78    (external-format :initform (find-external-format :default))
  79
  80    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
  81    ;; the stream is not open for input.
  82    (input-handle :initform nil :initarg :input-handle
  83                  :type (or null fixnum stream)
  84                  :accessor stream-input-handle)
  85    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
  86    ;; the stream is not open for output.
  87    (output-handle :initform nil :initarg :output-handle
  88                   :type (or null fixnum stream)
  89                   :accessor stream-output-handle)
  90    (control-in :initform nil :type (or null simple-vector))
  91    (control-out :initform nil :type (or null simple-vector))
  92
  93    ;; a stream, allowing for composing external formats (see
  94    ;; streams.htm, section 12.5) TODO: document this better
  95    (melded-stream :type (or null simple-stream))
  96    ;; a stream, allowing for composing external formats (see
  97    ;; streams.htm, section 12.5) TODO: document this better
  98    (melding-base :type (or null simple-stream))
  99
 100    ;; Number of octets the last read-char operation consumed TODO:
 101    ;; document this better; what is the difference to
 102    ;; last-char-read-size ?
 103    (encapsulated-char-read-size :initform 0 :type fixnum)
 104    ;; Number of octets the last read-char operation consumed
 105    (last-char-read-size :initform 0 :type fixnum)
 106    (charpos :initform 0 :type (or null integer)
 107             :accessor stream-line-column)
 108    (record-end :initform nil :type (or null fixnum))
 109
 110   ;; Input/output buffer.
 111    (buffer :initform nil :type (or simple-stream-buffer null))
 112    ;; Current position in buffer.
 113    (buffpos :initform 0 :type fixnum)
 114    ;; Maximum valid position in buffer, or -1 on eof.
 115    (buffer-ptr :initform 0 :type fixnum)
 116    (buf-len :initform 0 :type fixnum)
 117
 118    (pending :initform nil :type list)
 119    (handler :initform nil :type (or null sb-impl::handler))))
 120
 121 (def-stream-class single-channel-simple-stream (simple-stream)
 122   (;; the "dirty" flag -- if this is > 0, write out buffer contents
 123    ;; before changing position; see flush-buffer
 124    (mode :initform 0 :type fixnum)))
 125
 126 (def-stream-class dual-channel-simple-stream (simple-stream)
 127   (;; Output buffer.
 128    (out-buffer :initform nil :type (or simple-stream-buffer null))
 129    ;; Current position in output buffer.
 130    (outpos :initform 0 :type fixnum)
 131    ;; Buffer length (one greater than maximum output buffer index)
 132    (max-out-pos :initform 0 :type fixnum)))
 133
 134 ;;; A stream with a string as buffer.
 135 (def-stream-class string-simple-stream (simple-stream string-stream)
 136   ())
 137
 138
 139 ;;; ======================================================
 140
 141
 142 ;;;
 143 ;;; DEVICE-LEVEL FUNCTIONS
 144 ;;;
 145
 146 (defgeneric device-open (stream options))
 147
 148 (defgeneric device-close (stream abort))
 149
 150 (defgeneric device-buffer-length (stream))
 151
 152 (defgeneric device-file-position (stream))
 153
 154 (defgeneric (setf device-file-position) (value stream))
 155
 156 (defgeneric device-file-length (stream))
 157
 158 (defgeneric device-read (stream buffer start end blocking))
 159
 160 (defgeneric device-clear-input (stream buffer-only))
 161
 162 (defgeneric device-write (stream buffer start end blocking))
 163
 164 (defgeneric device-clear-output (stream))
 165
 166 (defgeneric device-finish-record (stream blocking action))
 167
 168
 169 (defmethod shared-initialize :after ((instance simple-stream) slot-names
 170                                      &rest initargs &key &allow-other-keys)
 171   (declare (ignore slot-names))
 172   (unless (slot-boundp instance 'melded-stream)
 173     (setf (slot-value instance 'melded-stream) instance)
 174     (setf (slot-value instance 'melding-base) instance))
 175   (unless (device-open instance initargs)
 176     (device-close instance t)))
 177
 178
 179 (defmethod print-object ((object simple-stream) stream)
 180   (print-unreadable-object (object stream :type nil :identity nil)
 181     (cond ((not (any-stream-instance-flags object :simple))
 182            (princ "Invalid " stream))
 183           ((not (any-stream-instance-flags object :input :output))
 184            (princ "Closed " stream)))
 185     (format stream "~:(~A~)" (type-of object))))
 186
 187 ;;; This takes care of the things all device-close methods have to do,
 188 ;;; regardless of the type of simple-stream
 189 (defmethod device-close :around ((stream simple-stream) abort)
 190   (with-stream-class (simple-stream stream)
 191     (when (any-stream-instance-flags stream :input :output)
 192       (when (any-stream-instance-flags stream :output)
 193         (ignore-errors (if abort
 194                            (clear-output stream)
 195                            (finish-output stream))))
 196       (call-next-method)
 197       (setf (sm input-handle stream) nil
 198             (sm output-handle stream) nil)
 199       (remove-stream-instance-flags stream :input :output)
 200       (sb-ext:cancel-finalization stream)
 201       ;; This sets all readers and writers to error-raising functions
 202       (setf (stream-external-format stream) :void))))
 203
 204 (defmethod device-close ((stream simple-stream) abort)
 205   (declare (ignore abort))
 206   t)
 207
 208 (defmethod device-buffer-length ((stream simple-stream))
 209   4096)
 210
 211 (defmethod device-file-position ((stream simple-stream))
 212   (with-stream-class (simple-stream stream)
 213     (sm buffpos stream)))
 214
 215 (defmethod (setf device-file-position) (value (stream simple-stream))
 216   (with-stream-class (simple-stream stream)
 217     (setf (sm buffpos stream) value)))
 218
 219 (defmethod device-file-length ((stream simple-stream))
 220   nil)
 221
 222 (defgeneric (setf stream-external-format) (value stream))
 223
 224 (defmethod (setf stream-external-format) :before (value (stream simple-stream))
 225   ;; (unless (eq value (sm external-format stream))
 226   ;;   flush out the existing external-format
 227   )
 228
 229 (defmethod (setf stream-external-format) :after
 230     (ef (stream single-channel-simple-stream))
 231   (compose-encapsulating-streams stream ef)
 232   (install-single-channel-character-strategy (melding-stream stream) ef nil))
 233
 234 (defmethod (setf stream-external-format) :after
 235     (ef (stream dual-channel-simple-stream))
 236   (compose-encapsulating-streams stream ef)
 237   (install-dual-channel-character-strategy (melding-stream stream) ef))
 238
 239
 240 (defmethod device-read ((stream single-channel-simple-stream) buffer
 241                         start end blocking)
 242   (read-octets stream buffer start end blocking))
 243
 244 (defmethod device-read ((stream dual-channel-simple-stream) buffer
 245                         start end blocking)
 246   (read-octets stream buffer start end blocking))
 247
 248 (defmethod device-clear-input ((stream simple-stream) buffer-only)
 249   (declare (ignore buffer-only))
 250   nil)
 251
 252 (defmethod device-write ((stream single-channel-simple-stream) buffer
 253                          start end blocking)
 254   ;; buffer may be :flush to force/finish-output
 255   (when (or (and (null buffer) (not (eql start end)))
 256             (eq buffer :flush))
 257     (with-stream-class (single-channel-simple-stream stream)
 258       (setf buffer (sm buffer stream))
 259       (setf end (sm buffpos stream))))
 260   (write-octets stream buffer start end blocking))
 261
 262 (defmethod device-write ((stream dual-channel-simple-stream) buffer
 263                          start end blocking)
 264   ;; buffer may be :flush to force/finish-output
 265   (when (or (and (null buffer) (not (eql start end)))
 266             (eq buffer :flush))
 267     (with-stream-class (dual-channel-simple-stream stream)
 268       (setf buffer (sm out-buffer stream))
 269       (setf end (sm outpos stream))))
 270   (write-octets stream buffer start end blocking))
 271
 272 (defmethod device-clear-output ((stream simple-stream))
 273   nil)