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 start end &optional timeout))
  35
  36 (defgeneric device-write (device vector start end &optional 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 &optional timeout))
  45
  46 (defgeneric device-poll-output (device &optional 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 start end &optional timeout)
  91   (declare (ignore timeout))
  92   (if (= start end) 0 (call-next-method)))
  93
  94 (defmethod device-read ((device device) vector start end &optional timeout)
  95   (if (and timeout (zerop timeout))
  96       (device-read/non-blocking device vector start end)
  97       (device-read/timeout device vector start end timeout)))
  98 \f
  99
 100 ;;;-----------------------------------------------------------------------------
 101 ;;; Default DEVICE-WRITE
 102 ;;;-----------------------------------------------------------------------------
 103
 104 (defmethod device-write :around ((device device) vector start end &optional timeout)
 105   (declare (ignore timeout))
 106   (if (= start end) 0 (call-next-method)))
 107
 108 (defmethod device-write ((device device) vector start end &optional timeout)
 109   (if (and timeout (zerop timeout))
 110       (device-write/non-blocking device vector start end)
 111       (device-write/timeout device vector start end timeout)))