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 ;;; Device Classes and Types
  10 ;;;-----------------------------------------------------------------------------
  11
  12 (defclass device ()
  13   ((handle :initarg :handle :accessor handle-of)
  14    (readable :initarg :readable :accessor device-readablep)
  15    (writeable :initarg :writeable :accessor device-writeablep)
  16    (seekable :initarg :seekable :accessor device-seekablep)))
  17
  18 (defclass direct-device (device) ())
  19
  20 (defclass memory-buffer-device (direct-device) ())
  21 \f
  22
  23 ;;;-----------------------------------------------------------------------------
  24 ;;; Relinquish I/O resources
  25 ;;;-----------------------------------------------------------------------------
  26
  27 (defgeneric relinquish (device &key abort &allow-other-keys))
  28 \f
  29
  30 ;;;-----------------------------------------------------------------------------
  31 ;;; Generic functions
  32 ;;;-----------------------------------------------------------------------------
  33
  34 (defgeneric device-read (device vector &key start end timeout))
  35
  36 (defgeneric device-write (device vector &key start end timeout))
  37
  38 (defgeneric device-position (device))
  39
  40 (defgeneric (setf device-position) (position device &optional from))
  41
  42 (defgeneric device-length (device))
  43
  44 (defgeneric device-poll-input (device &key timeout))
  45
  46 (defgeneric device-poll-output (device &key timeout))
  47
  48 ;;; Internal functions
  49
  50 (defgeneric device-open (device &rest initargs))
  51
  52 (defgeneric device-read/non-blocking (device vector start end))
  53
  54 (defgeneric device-read/timeout (device vector start end timeout))
  55
  56 (defgeneric device-write/non-blocking (device vector start end))
  57
  58 (defgeneric device-write/timeout (device vector start end timeout))
  59 \f
  60
  61 ;;;-----------------------------------------------------------------------------
  62 ;;; Helper macros
  63 ;;;-----------------------------------------------------------------------------
  64
  65 (defmacro with-device ((name) &body body)
  66   `(let ((*device* ,name))
  67      (declare (special *device*))
  68      ,@body))
  69 \f
  70
  71 ;;;-----------------------------------------------------------------------------
  72 ;;; Default no-op methods
  73 ;;;-----------------------------------------------------------------------------
  74
  75 (defmethod device-position ((device device))
  76   (values nil))
  77
  78 (defmethod (setf device-position) (position (device device) &optional from)
  79   (declare (ignore position from))
  80   (values nil))
  81
  82 (defmethod device-length ((device device))
  83   (values nil))
  84 \f
  85
  86 ;;;-----------------------------------------------------------------------------
  87 ;;; Default DEVICE-READ
  88 ;;;-----------------------------------------------------------------------------
  89
  90 (defmethod device-read :around ((device device) vector &key (start 0) end timeout)
  91   (check-bounds vector start end)
  92   (if (= start end)
  93       0
  94       (call-next-method device vector :start start :end end :timeout timeout)))
  95
  96 (defmethod device-read ((device device) vector &key start end timeout)
  97   (if (and timeout (zerop timeout))
  98       (device-read/non-blocking device vector start end)
  99       (device-read/timeout device vector start end timeout)))
 100 \f
 101
 102 ;;;-----------------------------------------------------------------------------
 103 ;;; Default DEVICE-WRITE
 104 ;;;-----------------------------------------------------------------------------
 105
 106 (defmethod device-write :around ((device device) vector &key start end timeout)
 107   (check-bounds vector start end)
 108   (if (= start end)
 109       0
 110       (call-next-method device vector :start start :end end :timeout timeout)))
 111
 112 (defmethod device-write ((device device) vector &key start end timeout)
 113   (if (and timeout (zerop timeout))
 114       (device-write/non-blocking device vector start end)
 115       (device-write/timeout device vector start end timeout)))