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 :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 &rest args &key abort))
  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
  91                                 (start 0) end timeout)
  92   (check-bounds vector start end)
  93   (if (= start end)
  94       0
  95       (call-next-method device vector :start start
  96                         :end end :timeout timeout)))
  97
  98 (defmethod device-read ((device device) vector &key start end timeout)
  99   (if (and timeout (zerop timeout))
 100       (device-read/non-blocking device vector start end)
 101       (device-read/timeout device vector start end timeout)))
 102 \f
 103
 104 ;;;-------------------------------------------------------------------------
 105 ;;; Default DEVICE-WRITE
 106 ;;;-------------------------------------------------------------------------
 107
 108 (defmethod device-write :around ((device device) vector &key
 109                                  (start 0) end timeout)
 110   (check-bounds vector start end)
 111   (if (= start end)
 112       0
 113       (call-next-method device vector :start start
 114                         :end end :timeout timeout)))
 115
 116 (defmethod device-write ((device device) vector &key start end timeout)
 117   (if (and timeout (zerop timeout))
 118       (device-write/non-blocking device vector start end)
 119       (device-write/timeout device vector start end timeout)))