external/cffi.darcs/_darcs/pristine/examples/gettimeofday.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2)
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 ;;;# CFFI Example: gettimeofday binding
  29 ;;;
  30 ;;; This example illustrates the use of foreign structures, typedefs,
  31 ;;; and using type translators to do checking of input and output
  32 ;;; arguments to a foreign function.
  33
  34 (defpackage #:cffi-example-gettimeofday
  35   (:use #:common-lisp #:cffi #:cffi-utils)
  36   (:export #:gettimeofday))
  37
  38 (in-package #:cffi-example-gettimeofday)
  39
  40 ;;; Define the TIMEVAL structure used by 'gettimeofday'.  This assumes
  41 ;;; that 'time_t' is a 'long' --- it would be nice if CFFI could
  42 ;;; provide a proper :TIME-T type to help make this portable.
  43 (defcstruct timeval
  44   (tv-sec :long)
  45   (tv-usec :long))
  46
  47 ;;; A NULL-POINTER is a foreign :POINTER that must always be NULL.
  48 ;;; Both a NULL pointer and NIL are legal values---any others will
  49 ;;; result in a runtime error.
  50 (define-foreign-type null-pointer-type ()
  51   ()
  52   (:actual-type :pointer)
  53   (:simple-parser null-pointer))
  54
  55 ;;; This type translator is used to ensure that a NULL-POINTER has a
  56 ;;; null value.  It also converts NIL to a null pointer.
  57 (defmethod translate-to-foreign (value (type null-pointer-type))
  58   (cond
  59     ((null value) (null-pointer))
  60     ((null-pointer-p value) value)
  61     (t (error "~A is not a null pointer." value))))
  62
  63 ;;; The SYSCALL-RESULT type is an integer type used for the return
  64 ;;; value of C functions that return -1 and set errno on errors.
  65 ;;; Someday when CFFI has a portable interface for dealing with
  66 ;;; 'errno', this error reporting can be more useful.
  67 (define-foreign-type syscall-result-type ()
  68   ()
  69   (:actual-type :int)
  70   (:simple-parser syscall-result))
  71
  72 ;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error
  73 ;;; if the value is negative.
  74 (defmethod translate-from-foreign (value (type syscall-result-type))
  75   (if (minusp value)
  76       (error "System call failed with return value ~D." value)
  77       value))
  78
  79 ;;; Define the Lisp function %GETTIMEOFDAY to call the C function
  80 ;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill
  81 ;;; in.  The TZP parameter is deprecated and should be NULL --- we can
  82 ;;; enforce this by using our NULL-POINTER type defined above.
  83 (defcfun ("gettimeofday" %gettimeofday) syscall-result
  84   (tp :pointer)
  85   (tzp null-pointer))
  86
  87 ;;; Define a Lispy interface to 'gettimeofday' that returns the
  88 ;;; seconds and microseconds as multiple values.
  89 (defun gettimeofday ()
  90   (with-foreign-object (tv 'timeval)
  91     (%gettimeofday tv nil)
  92     (with-foreign-slots ((tv-sec tv-usec) tv timeval)
  93       (values tv-sec tv-usec))))