io-multiplex/time.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006,2007 by Stelian Ionescu                            ;
   5 ;                                                                         ;
   6 ;   This program is free software; you can redistribute it and/or modify  ;
   7 ;   it under the terms of the GNU General Public License as published by  ;
   8 ;   the Free Software Foundation; either version 2 of the License, or     ;
   9 ;   (at your option) any later version.                                   ;
  10 ;                                                                         ;
  11 ;   This program is distributed in the hope that it will be useful,       ;
  12 ;   but WITHOUT ANY WARRANTY; without even the implied warranty of        ;
  13 ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         ;
  14 ;   GNU General Public License for more details.                          ;
  15 ;                                                                         ;
  16 ;   You should have received a copy of the GNU General Public License     ;
  17 ;   along with this program; if not, write to the                         ;
  18 ;   Free Software Foundation, Inc.,                                       ;
  19 ;   51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA              ;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  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))