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 ((or character null) simple-stream) (or character null)))
  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 ;;; Commented out in favor of standard class machinery that does not
  70 ;;; depend on implementation internals.
  71 #+nil
  72 (defmacro def-stream-class (name superclasses slots &rest options)
  73   (let ((accessors ())
  74         (real-slots ()))
  75     (dolist (slot slots)
  76       ;; Frob the slot arguments, memorizing either the location (an
  77       ;; integer) or the accessor of the slot.  Optionally construct
  78       ;; an accessor if none is given.
  79       (cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
  80              ;; We have got a location specifier.  Memorize it and
  81              ;; extract it until pcl itself can work with these.
  82              (push (cons (first slot)
  83                          (cons (getf (rest slot) :type t)
  84                                (getf (rest slot) 'sb-pcl::location)))
  85                    accessors)
  86              (let ((slot (copy-list slot)))
  87                (remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
  88                (push slot real-slots)))
  89             ((or (not (consp slot)) (not (getf (rest slot) :accessor)))
  90              (if *automagic-accessors*
  91                  ;; Add an :accessor argument, and memorize it.  FIXME:
  92                  ;; will this work with sbcl?  reader/writers are
  93                  ;; named differently there (see
  94                  ;; src/pcl/slot-name.lisp)
  95                  (let* ((slot (if (consp slot) slot (list slot)))
  96                         (accessor (or (cdr (gethash (first slot)
  97                                                     *slot-access-functions*))
  98                                       (intern (format nil "~A ~A slot ACCESSOR"
  99                                                       name (first slot))
 100                                               "SB-SLOT-ACCESSOR-NAME"))))
 101                    (push (cons (first slot)
 102                                (cons (getf (rest slot) :type t) accessor))
 103                          accessors)
 104                    (push (append slot `(:accessor ,accessor)) real-slots))
 105                  (push slot real-slots)))
 106             (t
 107              ;; No location given, but we have an accessor.  Memorize it.
 108              (push (cons (first slot)
 109                          (cons (getf (rest slot) :type t)
 110                                (getf (rest slot) :accessor)))
 111                    accessors)
 112              (push slot real-slots))))
 113     `(prog1
 114          (defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
 115        (eval-when (:compile-toplevel :load-toplevel :execute)
 116          ,@(loop for accessor in accessors
 117               do (let ((exists (gethash (car accessor)
 118                                         *slot-access-functions*)))
 119                    (when (and exists
 120                               (integerp (cdr exists))
 121                               (integerp (cddr accessor))
 122                               (/= (cdr exists) (cddr accessor)))
 123                      (warn "~S slot ~S has moved!  ~
 124                             I hope you know what you're doing!"
 125                            name (car accessor))))
 126               collect `(setf (gethash ',(car accessor) *slot-access-functions*)
 127                              ',(cdr accessor)))))))
 128
 129
 130 (defmacro def-stream-class (name superclasses slots &rest options)
 131   (let ((slots (copy-tree slots)))
 132     (dolist (slot slots) (remf (cdr slot) 'sb-pcl::location))
 133     `(defclass ,name ,superclasses ,slots ,@options)))
 134
 135 (def-stream-class simple-stream (standard-object stream)
 136   ((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
 137
 138    ;; Strategy slots.  See section 12.2 of streams.htm for function
 139    ;; signatures and possible side-effects.
 140
 141    ;; A function that determines if one character can be successfully
 142    ;; read from stream.
 143    (j-listen :initform #'sb-kernel:ill-in :type j-listen-fn sb-pcl::location 18)
 144    ;; A function that reads one character.
 145    (j-read-char :initform #'sb-kernel:ill-in :type j-read-char-fn sb-pcl::location 17)
 146    ;; A function that reads characters into a string.
 147    (j-read-chars :initform #'sb-kernel:ill-in :type j-read-chars-fn sb-pcl::location 16)
 148    ;; A function that writes one character.
 149    (j-write-char :initform #'sb-kernel:ill-out :type j-write-char-fn sb-pcl::location 15)
 150    ;; A function that writes characters from a string into the stream.
 151    (j-write-chars :initform #'sb-kernel:ill-out :type j-write-chars-fn sb-pcl::location 14)
 152    ;; A function that unreads the last character read.
 153    (j-unread-char :initform #'sb-kernel:ill-in :type j-unread-char-fn sb-pcl::location 13)
 154
 155    ;; Other slots
 156
 157    ;; Always a stream, allowing for composing external formats (see
 158    ;; streams.htm, section 12.5) TODO: document this better
 159    (melded-stream sb-pcl::location 12)
 160    ;; Always a stream, allowing for composing external formats (see
 161    ;; streams.htm, section 12.5) TODO: document this better
 162    (melding-base sb-pcl::location 11)
 163    ;; Number of octets the last read-char operation consumed TODO:
 164    ;; document this better; what is the difference to
 165    ;; last-char-read-size ?
 166    (encapsulated-char-read-size :initform 0 :type fixnum sb-pcl::location 10)
 167    (mode :initform 0 :type fixnum sb-pcl::location 9)
 168    (control-in :initform nil :type (or null simple-vector)
 169                sb-pcl::location 8)
 170    (control-out :initform nil :type (or null simple-vector)
 171                 sb-pcl::location 7)
 172    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
 173    ;; the stream is not open for input.
 174    (input-handle :initform nil :initarg :input-handle sb-pcl::location 6
 175                  :type (or null fixnum stream)
 176                  :accessor stream-input-handle)
 177    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
 178    ;; the stream is not open for output.
 179    (output-handle :initform nil :initarg :output-handle sb-pcl::location 5
 180                   :type (or null fixnum stream)
 181                   :accessor stream-output-handle)
 182    (external-format :initform :default sb-pcl::location 4)
 183    (record-end :initform nil :type (or null fixnum) sb-pcl::location 3)
 184    ;; The character position of the stream.
 185    (charpos :initform 0 :type (or null integer) sb-pcl::location 2)
 186    ;; Number of octets the last read-char operation consumed
 187    (last-char-read-size :initform 0 :type fixnum sb-pcl::location 1)
 188    ;; instance flags (not a normal slot in Allegro CL)
 189    (%flags :initform 0 :type fixnum sb-pcl::location 0)))
 190
 191 (def-stream-class probe-simple-stream (simple-stream)
 192   ())
 193
 194 ;;; A stream with a single buffer, for example a file stream.
 195 (def-stream-class single-channel-simple-stream (simple-stream)
 196   ;; Input/output buffer.
 197   ((buffer :initform nil :type (or simple-stream-buffer null)
 198            sb-pcl::location 23)
 199    ;; Current position in buffer.
 200    (buffpos :initform 0 :type fixnum sb-pcl::location 22)
 201    ;; Maximum valid position in buffer, or -1 on eof.
 202    (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
 203    (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
 204
 205 (def-stream-class direct-simple-stream (single-channel-simple-stream)
 206   ())
 207
 208 (def-stream-class buffer-input-simple-stream (direct-simple-stream)
 209   ())
 210
 211 (def-stream-class buffer-output-simple-stream (direct-simple-stream)
 212   ((out-buffer :initform nil :type (or simple-stream-buffer null)
 213                sb-pcl::location 26)
 214    ;; Current position in output buffer.
 215    (outpos :initform 0 :type fixnum sb-pcl::location 25)
 216    ;; Buffer length (one greater than maximum output buffer index)
 217    (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
 218
 219 (def-stream-class null-simple-stream (single-channel-simple-stream)
 220   ())
 221
 222 (def-stream-class file-simple-stream (single-channel-simple-stream)
 223   ((pathname :initform nil :initarg :pathname sb-pcl::location 27)
 224    (filename :initform nil :initarg :filename sb-pcl::location 26)
 225    (original :initform nil :initarg :original sb-pcl::location 25)
 226    (delete-original :initform nil :initarg :delete-original
 227                     sb-pcl::location 24)
 228    ))
 229
 230 (def-stream-class mapped-file-simple-stream (file-simple-stream
 231                                              direct-simple-stream)
 232   ())
 233
 234 ;;; A stream with two octet buffers, for example a socket or terminal
 235 ;;; stream.
 236 (def-stream-class dual-channel-simple-stream (simple-stream)
 237   (;; Output buffer.
 238    (out-buffer :initform nil :type (or simple-stream-buffer null)
 239                sb-pcl::location 26)
 240    ;; Current position in output buffer.
 241    (outpos :initform 0 :type fixnum sb-pcl::location 25)
 242    ;; Buffer length (one greater than maximum output buffer index)
 243    (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)
 244    ;; Input buffer (in this case; the 'buffer' slot serves as
 245    ;; bidirectional buffer for single-channel-simple-streams).
 246    (buffer :initform nil :type (or simple-stream-buffer null)
 247            sb-pcl::location 23)
 248    ;; Current position in buffer.
 249    (buffpos :initform 0 :type fixnum sb-pcl::location 22)
 250    ;; Maximum valid position in buffer, or -1 on eof.
 251    (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
 252    (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
 253
 254 (def-stream-class terminal-simple-stream (dual-channel-simple-stream)
 255   ())
 256
 257 (def-stream-class socket-simple-stream (dual-channel-simple-stream)
 258   ((socket :initform nil :type (or sb-bsd-sockets:socket null)
 259            :initarg :socket sb-pcl::location 27)))
 260
 261 (def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
 262   ())
 263
 264 (def-stream-class hiper-socket-simple-stream (dual-channel-simple-stream)
 265   ())
 266
 267 ;;; A stream with a string as buffer.
 268 (def-stream-class string-simple-stream (simple-stream)
 269   ())
 270
 271 (def-stream-class composing-stream (string-simple-stream)
 272   ())
 273
 274 (def-stream-class string-input-simple-stream (string-simple-stream)
 275   (;; The input buffer.
 276    (buffer :initform nil :type (or simple-stream-buffer null)
 277            sb-pcl::location 23)
 278    ;; Current position in buffer.
 279    (buffpos :initform 0 :type fixnum sb-pcl::location 22)
 280    ;; Maximum valid position in buffer, or -1 on eof.
 281    (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
 282    (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
 283
 284 (def-stream-class string-output-simple-stream (string-simple-stream)
 285   (;; The input buffer.
 286    (buffer :initform nil :type (or simple-stream-buffer null)
 287             sb-pcl::location 26)
 288    ;; Current position in input buffer.
 289    (buffpos :initform 0 :type fixnum  sb-pcl::location 25)
 290    ;; Maximum valid position in input buffer, or -1 on eof.
 291    (buffer-ptr :initform 0 :type fixnum  sb-pcl::location 24)
 292    (buf-len :initform 0 :type fixnum sb-pcl::location 23)
 293    ;; The output buffer (slot added so that a class can inherit from
 294    ;; both string-input-simple-stream and string-output-simple-stream
 295    ;; without the strategies clashing)
 296    (out-buffer :initform nil :type (or simple-stream-buffer null)
 297                 sb-pcl::location 22)
 298    ;; Current position in output buffer.
 299    (outpos :initform 0 :type fixnum sb-pcl::location 21)
 300    ;; Buffer length (one greater than maximum output buffer index)
 301    (max-out-pos :initform 0 :type fixnum sb-pcl::location 20)))
 302
 303 (def-stream-class fill-pointer-output-simple-stream
 304     (string-output-simple-stream)
 305   ())
 306
 307 (def-stream-class limited-string-output-simple-stream
 308     (string-output-simple-stream)
 309   ())
 310
 311 (def-stream-class xp-simple-stream (string-output-simple-stream)
 312   ())
 313
 314 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
 315   ())
 316
 317
 318 (defclass default-latin1-base-ef () ())
 319 (defclass stream-recording-mixin () ())
 320 (defclass stream-recording-repaint-mixin () ())
 321
 322
 323 (eval-when (:compile-toplevel :load-toplevel :execute)
 324   (setf *automagic-accessors* nil))
 325
 326 ;;;
 327 ;;; DEVICE-LEVEL FUNCTIONS
 328 ;;;
 329
 330 (defgeneric device-open (stream options))
 331
 332 (defgeneric device-close (stream abort))
 333
 334 (defgeneric device-buffer-length (stream))
 335
 336 (defgeneric device-file-position (stream))
 337
 338 (defgeneric (setf device-file-position) (value stream))
 339
 340 (defgeneric device-file-length (stream))
 341
 342 (defgeneric device-read (stream buffer start end blocking))
 343
 344 (defgeneric device-clear-input (stream buffer-only))
 345
 346 (defgeneric device-write (stream buffer start end blocking))
 347
 348 (defgeneric device-clear-output (stream))
 349
 350 (defgeneric device-finish-record (stream blocking action))