GopherProxy

	tgettimeofday.lisp - clic - Clic is an command line interactive client for goph…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tgettimeofday.lisp (3778B)
	---
	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 <[email protected]>
	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)
	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))))