contrib/sb-simple-streams/classes.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;; This code is in the public domain.
   4
   5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
   6 ;;; who placed the code in the public domain.  Sbcl port by Rudi
   7 ;;; Schlatte.
   8
   9 (in-package "SB-SIMPLE-STREAMS")
  10
  11 ;;; (pushnew :sb-simple-stream *features*)
  12
  13 ;;;
  14 ;;; TYPES FOR BUFFER AND STRATEGY FUNCTIONS
  15 ;;;
  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 (deftype simple-stream-buffer ()
  22   '(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
  23
  24 (deftype blocking ()
  25   `(member t nil :bnb))
  26
  27 (deftype j-listen-fn ()
  28   '(function (simple-stream) boolean))
  29
  30 (deftype j-read-char-fn ()
  31   '(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE
  32
  33 (deftype j-read-chars-fn ()
  34   '(function (simple-stream string (or character null) fixnum fixnum blocking)
  35              (values fixnum &optional (member nil t :eof))))
  36
  37 (deftype j-write-char-fn ()
  38   '(function (character simple-stream) character))
  39
  40 (deftype j-write-chars-fn ()
  41   '(function (string simple-stream fixnum fixnum) t)) ;; return chars-written?
  42
  43 (deftype j-unread-char-fn ()
  44   '(function (simple-stream t) t)) ;; "relaxed" arg is boolean?  what return?
  45
  46 ;;;
  47 ;;; STREAM CLASSES
  48 ;;;
  49
  50 ;;; KLUDGE (sat 2003-01-15): def-stream-class and the
  51 ;;; with-stream-class / sm accessors implement a form of "sealing" of
  52 ;;; classes -- i.e., implementing very fast slot access at the price
  53 ;;; of not being able to change the class definition at runtime.
  54 ;;; Instead of a method call, a slot access for a simple-stream
  55 ;;; subclass is a funcall or (when the def-stream-class form has a
  56 ;;; location argument for the slot) a sb-pcl::clos-slots-ref.  Given a
  57 ;;; sufficiently advanced PCL with (non-standard) sealing
  58 ;;; declarations, this machinery would be superfluous.  For the time
  59 ;;; being, replacing 4 method calls with vector accesses for the fast
  60 ;;; path of read-char seems worthwhile to me.  Besides, it's the
  61 ;;; documented interface to simple-stream internals, and so it's worth
  62 ;;; keeping.
  63
  64 (eval-when (:compile-toplevel :load-toplevel :execute)
  65   (declaim (type hash-table *slot-access-functions*))
  66   (defvar *slot-access-functions* (make-hash-table))
  67   (defvar *automagic-accessors* nil))
  68
  69 (defmacro def-stream-class (name superclasses slots &rest options)
  70   (let ((accessors ())
  71         (real-slots ()))
  72     (dolist (slot slots)
  73       ;; Frob the slot arguments, memorizing either the location (an
  74       ;; integer) or the accessor of the slot.  Optionally construct
  75       ;; an accessor if none is given.
  76       (cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
  77              ;; We have got a location specifier.  Memorize it and
  78              ;; extract it until pcl itself can work with these.
  79              (push (cons (first slot)
  80                          (cons (getf (rest slot) :type t)
  81                                (getf (rest slot) 'sb-pcl::location)))
  82                    accessors)
  83              (let ((slot (copy-list slot)))
  84                (remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
  85                (push slot real-slots)))
  86             ((or (not (consp slot)) (not (getf (rest slot) :accessor)))
  87              (if *automagic-accessors*
  88                  ;; Add an :accessor argument, and memorize it.  FIXME:
  89                  ;; will this work with sbcl?  reader/writers are
  90                  ;; named differently there (see
  91                  ;; src/pcl/slot-name.lisp)
  92                  (let* ((slot (if (consp slot) slot (list slot)))
  93                         (accessor (or (cdr (gethash (first slot)
  94                                                     *slot-access-functions*))
  95                                       (intern (format nil "~A ~A slot ACCESSOR"
  96                                                       name (first slot))
  97                                               "SB-SLOT-ACCESSOR-NAME"))))
  98                    (push (cons (first slot)
  99                                (cons (getf (rest slot) :type t) accessor))
 100                          accessors)
 101                    (push (append slot `(:accessor ,accessor)) real-slots))
 102                  (push slot real-slots)))
 103             (t
 104              ;; No location given, but we have an accessor.  Memorize it.
 105              (push (cons (first slot)
 106                          (cons (getf (rest slot) :type t)
 107                                (getf (rest slot) :accessor)))
 108                    accessors)
 109              (push slot real-slots))))
 110     `(prog1
 111          (defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
 112        (eval-when (:compile-toplevel :load-toplevel :execute)
 113          ,@(loop for accessor in accessors
 114               do (let ((exists (gethash (car accessor)
 115                                         *slot-access-functions*)))
 116                    (when (and exists
 117                               (integerp (cdr exists))
 118                               (integerp (cddr accessor))
 119                               (/= (cdr exists) (cddr accessor)))
 120                      (warn "~S slot ~S has moved!  ~
 121                             I hope you know what you're doing!"
 122                            name (car accessor))))
 123               collect `(setf (gethash ',(car accessor) *slot-access-functions*)
 124                              ',(cdr accessor)))))))
 125
 126 (def-stream-class simple-stream (standard-object stream)
 127   ((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
 128
 129    ;; Strategy slots.  See section 12.2 of streams.htm for function
 130    ;; signatures and possible side-effects.
 131
 132    ;; A function that determines if one character can be successfully
 133    ;; read from stream.
 134    (j-listen :type j-listen-fn sb-pcl::location 18)
 135    ;; A function that reads one character.
 136    (j-read-char :type j-read-char-fn sb-pcl::location 17)
 137    ;; A function that reads characters into a string.
 138    (j-read-chars :type j-read-chars-fn sb-pcl::location 16)
 139    ;; A function that writes one character.
 140    (j-write-char :type j-write-char-fn sb-pcl::location 15)
 141    ;; A function that writes characters from a string into the stream.
 142    (j-write-chars :type j-write-chars-fn sb-pcl::location 14)
 143    ;; A function that unreads the last character read.
 144    (j-unread-char :type j-unread-char-fn sb-pcl::location 13)
 145
 146    ;; Other slots
 147
 148    ;; Always a stream, allowing for composing external formats (see
 149    ;; streams.htm, section 12.5) TODO: document this better
 150    (melded-stream sb-pcl::location 12)
 151    ;; Always a stream, allowing for composing external formats (see
 152    ;; streams.htm, section 12.5) TODO: document this better
 153    (melding-base sb-pcl::location 11)
 154    ;; Number of octets the last read-char operation consumed TODO:
 155    ;; document this better; what is the difference to
 156    ;; last-char-read-size ?
 157    (encapsulated-char-read-size :initform 0 :type fixnum sb-pcl::location 10)
 158    (mode :initform 0 :type fixnum sb-pcl::location 9)
 159    (control-in :initform nil :type (or null simple-vector)
 160                sb-pcl::location 8)
 161    (control-out :initform nil :type (or null simple-vector)
 162                 sb-pcl::location 7)
 163    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
 164    ;; the stream is not open for input.
 165    (input-handle :initform nil :initarg :input-handle sb-pcl::location 6
 166                  :type (or null fixnum stream)
 167                  :accessor stream-input-handle)
 168    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
 169    ;; the stream is not open for output.
 170    (output-handle :initform nil :initarg :output-handle sb-pcl::location 5
 171                   :type (or null fixnum stream)
 172                   :accessor stream-output-handle)
 173    (external-format :initform :default sb-pcl::location 4)
 174    (record-end :initform nil :type (or null fixnum) sb-pcl::location 3)
 175    ;; The character position of the stream.
 176    (charpos :initform 0 :type (or null integer) sb-pcl::location 2)
 177    ;; Number of octets the last read-char operation consumed
 178    (last-char-read-size :initform 0 :type fixnum sb-pcl::location 1)
 179    ;; instance flags (not a normal slot in Allegro CL)
 180    (%flags :initform 0 :type fixnum sb-pcl::location 0)))
 181
 182 (def-stream-class probe-simple-stream (simple-stream)
 183   ())
 184
 185 ;;; A stream with a single buffer, for example a file stream.
 186 (def-stream-class single-channel-simple-stream (simple-stream)
 187   ;; Input/output buffer.
 188   ((buffer :initform nil :type (or simple-stream-buffer null)
 189            sb-pcl::location 23)
 190    ;; Current position in buffer.
 191    (buffpos :initform 0 :type fixnum sb-pcl::location 22)
 192    ;; Maximum valid position in buffer, or -1 on eof.
 193    (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
 194    (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
 195
 196 (def-stream-class direct-simple-stream (single-channel-simple-stream)
 197   ())
 198
 199 (def-stream-class buffer-input-simple-stream (direct-simple-stream)
 200   ())
 201
 202 (def-stream-class buffer-output-simple-stream (direct-simple-stream)
 203   ((out-buffer :initform nil :type (or simple-stream-buffer null)
 204                sb-pcl::location 26)
 205    ;; Current position in output buffer.
 206    (outpos :initform 0 :type fixnum sb-pcl::location 25)
 207    ;; Buffer length (one greater than maximum output buffer index)
 208    (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
 209
 210 (def-stream-class null-simple-stream (single-channel-simple-stream)
 211   ())
 212
 213 (def-stream-class file-simple-stream (single-channel-simple-stream)
 214   ((pathname :initform nil :initarg :pathname)
 215    (filename :initform nil :initarg :filename)
 216    (original :initform nil :initarg :original)
 217    (delete-original :initform nil :initarg :delete-original)
 218    ))
 219
 220 (def-stream-class mapped-file-simple-stream (file-simple-stream
 221                                              direct-simple-stream)
 222   ())
 223
 224 ;;; A stream with two octet buffers, for example a socket or terminal
 225 ;;; stream.
 226 (def-stream-class dual-channel-simple-stream (simple-stream)
 227   ;; Output buffer.
 228   ((out-buffer :initform nil :type (or simple-stream-buffer null)
 229                sb-pcl::location 26)
 230    ;; Current position in output buffer.
 231    (outpos :initform 0 :type fixnum sb-pcl::location 25)
 232    ;; Buffer length (one greater than maximum output buffer index)
 233    (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)
 234    ;; Input buffer (in this case; the 'buffer' slot serves as
 235    ;; bidirectional buffer for single-channel-simple-streams).
 236    (buffer :initform nil :type (or simple-stream-buffer null)
 237            sb-pcl::location 23)
 238    ;; Current position in buffer.
 239    (buffpos :initform 0 :type fixnum sb-pcl::location 22)
 240    ;; Maximum valid position in buffer, or -1 on eof.
 241    (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
 242    (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
 243
 244 (def-stream-class terminal-simple-stream (dual-channel-simple-stream)
 245   ())
 246
 247 (def-stream-class socket-simple-stream (dual-channel-simple-stream)
 248   ((socket :initform nil :type (or sb-bsd-sockets:socket null)
 249            :initarg :socket sb-pcl::location 27)))
 250
 251 (def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
 252   ())
 253
 254 (def-stream-class hiper-socket-simple-stream (dual-channel-simple-stream)
 255   ())
 256
 257 ;;; A stream with a string as buffer.
 258 (def-stream-class string-simple-stream (simple-stream)
 259   ;; The input/output buffer.
 260   ((buffer :initform nil :type (or simple-stream-buffer null)
 261            sb-pcl::location 23)
 262    ;; Current position in buffer.
 263    (buffpos :initform 0 :type fixnum sb-pcl::location 22)
 264    ;; Maximum valid position in buffer, or -1 on eof.
 265    (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
 266    (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
 267
 268 (def-stream-class composing-stream (string-simple-stream)
 269   ())
 270
 271 (def-stream-class string-input-simple-stream (string-simple-stream)
 272   ())
 273
 274 (def-stream-class string-output-simple-stream (string-simple-stream)
 275   ;; The output buffer (slot added so that a class can inherit from
 276   ;; both string-input-simple-stream and string-output-simple-stream
 277   ;; without the strategies clashing)
 278   ((out-buffer :initform nil :type (or simple-stream-buffer null)
 279                sb-pcl::location 26)
 280    ;; Current position in output buffer.
 281    (outpos :initform 0 :type fixnum sb-pcl::location 25)
 282    ;; Buffer length (one greater than maximum output buffer index)
 283    (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
 284
 285 (def-stream-class fill-pointer-output-simple-stream
 286     (string-output-simple-stream)
 287   ())
 288
 289 (def-stream-class limited-string-output-simple-stream
 290     (string-output-simple-stream)
 291   ())
 292
 293 (def-stream-class xp-simple-stream (string-output-simple-stream)
 294   ())
 295
 296 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
 297   ())
 298
 299
 300 (defclass default-latin1-base-ef () ())
 301 (defclass stream-recording-mixin () ())
 302 (defclass stream-recording-repaint-mixin () ())
 303
 304
 305 (eval-when (:compile-toplevel :load-toplevel :execute)
 306   (setf *automagic-accessors* nil))
 307
 308 ;;;
 309 ;;; DEVICE-LEVEL FUNCTIONS
 310 ;;;
 311
 312 (defgeneric device-open (stream options))
 313
 314 (defgeneric device-close (stream abort))
 315
 316 (defgeneric device-buffer-length (stream))
 317
 318 (defgeneric device-file-position (stream))
 319
 320 (defgeneric (setf device-file-position) (value stream))
 321
 322 (defgeneric device-file-length (stream))
 323
 324 (defgeneric device-read (stream buffer start end blocking))
 325
 326 (defgeneric device-clear-input (stream buffer-only))
 327
 328 (defgeneric device-write (stream buffer start end blocking))
 329
 330 (defgeneric device-clear-output (stream))
 331
 332 (defgeneric device-extend (stream need action))
 333
 334 (defgeneric device-finish-record (stream blocking action))