src/syscalls/conditions.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Syscall error conditions.
   4 ;;;
   5
   6 (in-package :iolib.syscalls)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; System Errors
  10 ;;;-------------------------------------------------------------------------
  11
  12 (define-condition iolib-condition ()
  13   ())
  14
  15 (define-condition iolib-error (error iolib-condition)
  16   ())
  17
  18 (define-condition syscall-error (iolib-error)
  19   ((syscall :initarg :syscall :reader syscall-of
  20             :documentation "The name of the C syscall.")
  21    (code :initarg :code :reader code-of
  22          :documentation "Numeric error code, or NIL.")
  23    (identifier :initarg :identifier :reader identifier-of
  24                :documentation "Keyword identifier, or NIL.")
  25    (message :initarg :message :reader message-of
  26             :documentation "Error description.")
  27    (handle :initform nil :initarg :handle :reader handle-of
  28            :documentation "The OS handle involved in the error situation.")
  29    (handle2 :initform nil :initarg :handle2 :reader handle2-of
  30             :documentation "An optional second OS handler."))
  31   (:default-initargs :code nil :identifier :unknown :message nil)
  32   (:documentation "Base class for syscall errors."))
  33
  34 (defun syscall-error-p (thing)
  35   (typep thing 'syscall-error))
  36
  37 (defun syscall-error (control-string &rest args)
  38   (error 'syscall-error :message (format nil "~?" control-string args)))
  39 \f
  40
  41 ;;;-------------------------------------------------------------------------
  42 ;;; I/O Poll Errors
  43 ;;;-------------------------------------------------------------------------
  44
  45 (define-condition poll-error (syscall-error)
  46   ((event-type :initarg :event-type :reader event-type-of))
  47   (:report (lambda (c s)
  48              (format s "Poll error(event ~S, handle ~A)"
  49                      (event-type-of c) (handle-of c))
  50              (when (message-of c)
  51                (format s ": ~A" (message-of c)))))
  52   (:documentation
  53    "Signaled when an error occurs while polling for I/O readiness
  54 of a file descriptor."))
  55
  56 (define-condition poll-timeout (poll-error)
  57   ()
  58   (:report (lambda (c s)
  59              (format s "Poll timeout(event ~S, handle ~A)"
  60                      (event-type-of c) (handle-of c))
  61              (when (message-of c)
  62                (format s ": ~A" (message-of c)))))
  63   (:documentation
  64    "Signaled when a timeout occurs while polling for I/O readiness
  65 of a file descriptor."))
  66 \f
  67
  68 ;;;-------------------------------------------------------------------------
  69 ;;; Repeat upon conditions
  70 ;;;-------------------------------------------------------------------------
  71
  72 (defmacro repeat-upon-condition ((&rest conditions) &body body)
  73   (with-gensyms (block-name)
  74     `(loop :named ,block-name :do
  75        (ignore-some-conditions ,conditions
  76          (return-from ,block-name (progn ,@body))))))
  77
  78 (defmacro repeat-upon-eintr (&body body)
  79   `(repeat-upon-condition (eintr) ,@body))
  80
  81 (defmacro repeat-decreasing-timeout
  82     ((timeout-var timeout &optional (block-name nil blockp)) &body body)
  83   (unless (find timeout-var (flatten body))
  84     (warn "You probably want to use ~S inside the body ~A" timeout-var body))
  85   (unless blockp (setf block-name (gensym "BLOCK")))
  86   (with-gensyms (deadline temp-timeout)
  87     `(let* ((,timeout-var ,timeout)
  88             (,deadline (when ,timeout-var
  89                          (+ ,timeout-var (get-monotonic-time)))))
  90        (loop :named ,block-name :do
  91          ,@body
  92            (when ,deadline
  93              (let ((,temp-timeout (- ,deadline (get-monotonic-time))))
  94                (setf ,timeout-var
  95                      (if (plusp ,temp-timeout)
  96                          ,temp-timeout
  97                          0))))))))
  98
  99 (defmacro repeat-upon-condition-decreasing-timeout
 100     (((&rest conditions) timeout-var timeout &optional (block-name nil blockp)) &body body)
 101   (unless blockp (setf block-name (gensym "BLOCK")))
 102   `(repeat-decreasing-timeout (,timeout-var ,timeout ,block-name)
 103      (ignore-some-conditions ,conditions
 104        (return-from ,block-name (progn ,@body)))))