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