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