io.streams/zeta/device.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Device common functions.
   4 ;;;
   5
   6 (in-package :io.zeta-streams)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Classes and Types
  10 ;;;-------------------------------------------------------------------------
  11
  12 (defclass device ()
  13   ((handle :initarg :handle
  14            :accessor device-handle)
  15    (readable :initarg :readable
  16              :accessor device-readablep)
  17    (writeable :initarg :writeable
  18               :accessor device-writeablep)
  19    (seekable :initarg :seekable
  20              :accessor device-seekablep)))
  21
  22 (defclass direct-device (device) ())
  23
  24 (defclass memory-buffer-device (direct-device) ())
  25 \f
  26
  27 ;;;-------------------------------------------------------------------------
  28 ;;; Relinquish I/O resources
  29 ;;;-------------------------------------------------------------------------
  30
  31 (defgeneric relinquish (device &rest args &key abort))
  32 \f
  33
  34 ;;;-------------------------------------------------------------------------
  35 ;;; Generic functions
  36 ;;;-------------------------------------------------------------------------
  37
  38 (defgeneric device-read (device vector &key start end timeout))
  39
  40 (defgeneric device-write (device vector &key start end timeout))
  41
  42 (defgeneric device-position (device))
  43
  44 (defgeneric (setf device-position) (position device &optional from))
  45
  46 (defgeneric device-length (device))
  47
  48 (defgeneric (setf device-length) (length device))
  49
  50 (defgeneric device-poll (device direction &optional timeout))
  51
  52 ;;; Internal functions
  53
  54 (defgeneric device-open (device &rest initargs))
  55
  56 (defgeneric device-read/non-blocking (device vector start end))
  57
  58 (defgeneric device-read/timeout (device vector start end timeout))
  59
  60 (defgeneric device-write/non-blocking (device vector start end))
  61
  62 (defgeneric device-write/timeout (device vector start end timeout))
  63 \f
  64
  65 ;;;-------------------------------------------------------------------------
  66 ;;; Helper macros
  67 ;;;-------------------------------------------------------------------------
  68
  69 (defmacro with-device ((name) &body body)
  70   `(let ((*device* ,name))
  71      (declare (special *device*))
  72      ,@body))
  73 \f
  74
  75 ;;;-------------------------------------------------------------------------
  76 ;;; Default no-op methods
  77 ;;;-------------------------------------------------------------------------
  78
  79 (defmethod relinquish (device &key abort)
  80   (declare (ignore device abort)))
  81
  82 (defmethod device-position ((device device))
  83   ;; FIXME: signal proper condition
  84   (error "Device not seekable: ~S" device))
  85
  86 (defmethod (setf device-position) (position (device device) &optional from)
  87   (declare (ignore position from))
  88   ;; FIXME: signal proper condition
  89   (error "Device not seekable: ~S" device))
  90
  91 (defmethod device-length ((device device))
  92   ;; FIXME: signal proper condition
  93   (error "Device not seekable: ~S" device))
  94
  95 (defmethod (setf device-length) (length (device device))
  96   (declare (ignore length))
  97   ;; FIXME: signal proper condition
  98   (error "Device not seekable: ~S" device))
  99 \f
 100
 101 ;;;-------------------------------------------------------------------------
 102 ;;; Default DEVICE-READ
 103 ;;;-------------------------------------------------------------------------
 104
 105 (defmethod device-read :around ((device device) vector &key
 106                                 (start 0) end timeout)
 107   (check-bounds vector start end)
 108   (when (= start end) (return* 0))
 109   (call-next-method device vector :start start :end end :timeout timeout))
 110
 111 (defmethod device-read ((device device) vector &key start end timeout)
 112   (if (and timeout (zerop timeout))
 113       (device-read/non-blocking device vector start end)
 114       (device-read/timeout device vector start end timeout)))
 115 \f
 116
 117 ;;;-------------------------------------------------------------------------
 118 ;;; Default DEVICE-WRITE
 119 ;;;-------------------------------------------------------------------------
 120
 121 (defmethod device-write :around ((device device) vector &key
 122                                  (start 0) end timeout)
 123   (check-bounds vector start end)
 124   (when (= start end) (return* 0))
 125   (call-next-method device vector :start start :end end :timeout timeout))
 126
 127 (defmethod device-write ((device device) vector &key start end timeout)
 128   (if (and timeout (zerop timeout))
 129       (device-write/non-blocking device vector start end)
 130       (device-write/timeout device vector start end timeout)))