syscalls/conditions.lisp

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