io-multiplex/time.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :io.multiplex)
  23
  24 (deftype timeout ()
  25   'double-float)
  26
  27
  28 ;;; Break a real timeout into seconds and microseconds.
  29 (defun decode-timeout (timeout)
  30   (typecase timeout
  31     (integer (values timeout 0))
  32     (null    nil)
  33     (real
  34      (multiple-value-bind (q r) (truncate (coerce timeout 'double-float))
  35        (declare (type unsigned-byte q)
  36                 (type double-float r))
  37        (values q (the (values unsigned-byte t) (truncate (* r 1d6))))))
  38     (t
  39      (error "Timeout is not a real number or NIL: ~S" timeout))))
  40
  41
  42 (defun gettime ()
  43   (multiple-value-bind (sec nsec)
  44       (et:clock-get-time et:clock-monotonic)
  45     (+ sec (/ nsec 1d9))))
  46
  47
  48 (defun normalize-timeout (timeout)
  49   (when timeout
  50     (assert (not (minusp timeout)))
  51     (etypecase timeout
  52       ((or integer real) (coerce timeout 'double-float)))))
  53
  54
  55 (defun abs-timeout (timeout)
  56   (when timeout
  57     (+ (gettime) (normalize-timeout timeout))))
  58
  59
  60 (defun calc-min-timeout (t1 t2)
  61   (if t1
  62       (if t2
  63           (min t1 t2)
  64           t1)
  65       t2))