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