Update of /project/cells/cvsroot/cells-gtk/cffi/examples In directory clnet:/tmp/cvs-serv9292/cffi/examples

Added Files: examples.lisp gethostname.lisp gettimeofday.lisp run-examples.lisp translator-test.lisp Log Message:

--- /project/cells/cvsroot/cells-gtk/cffi/examples/examples.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/examples.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; examples.lisp --- Simple test examples of CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman jamesjb@jamesjb.com ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;;

(defpackage #:cffi-examples (:use #:cl #:cffi) (:export #:run-examples #:sqrtf #:getenv))

(in-package #:cffi-examples)

;; A simple libc function. (defcfun "sqrtf" :float (n :float))

;; This definition uses the STRING type translator to automatically ;; convert Lisp strings to foreign strings and vice versa. (defcfun "getenv" :string (name :string))

;; Calling a varargs function. (defun sprintf-test () "Test calling a varargs function." (with-foreign-pointer-as-string (buf 255 buf-size) (foreign-funcall "snprintf" :pointer buf :int buf-size :string "%d %f #x%x!" :int 666 :double (coerce pi 'double-float) :unsigned-int #xcafebabe :void)))

;; Defining an emerated type. (defcenum test-enum (:invalid 0) (:positive 1) (:negative -1))

;; Use the absolute value function to test keyword/enum translation. (defcfun ("abs" c-abs) test-enum (n test-enum))

(defun cffi-version () (asdf:component-version (asdf:find-system 'cffi)))

(defun run-examples () (format t "~&;;; CFFI version ~A on ~A ~A:~%" (cffi-version) (lisp-implementation-type) (lisp-implementation-version)) (format t "~&;; shell: ~A~%" (getenv "SHELL")) (format t "~&;; sprintf test: ~A~%" (sprintf-test)) (format t "~&;; (c-abs :positive): ~A~%" (c-abs :positive)) (format t "~&;; (c-abs :negative): ~A~%" (c-abs :negative)) (force-output)) --- /project/cells/cvsroot/cells-gtk/cffi/examples/gethostname.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/gethostname.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; gethostname.lisp --- A simple CFFI example. ;;; ;;; Copyright (C) 2005-2006, James Bielman jamesjb@jamesjb.com ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;;

;;;# CFFI Example: gethostname binding ;;; ;;; This is a very simple CFFI example that illustrates calling a C ;;; function that fills in a user-supplied string buffer.

(defpackage #:cffi-example-gethostname (:use #:common-lisp #:cffi) (:export #:gethostname))

(in-package #:cffi-example-gethostname)

;;; Define the Lisp function %GETHOSTNAME to call the C 'gethostname' ;;; function, which will fill BUF with up to BUFSIZE characters of the ;;; system's hostname. (defcfun ("gethostname" %gethostname) :int (buf :pointer) (bufsize :int))

;;; Define a Lispy interface to 'gethostname'. The utility macro ;;; WITH-FOREIGN-POINTER-AS-STRING is used to allocate a temporary ;;; buffer and return it as a Lisp string. (defun gethostname () (with-foreign-pointer-as-string (buf 255 bufsize) (%gethostname buf bufsize))) --- /project/cells/cvsroot/cells-gtk/cffi/examples/gettimeofday.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/gettimeofday.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2) ;;; ;;; Copyright (C) 2005-2006, James Bielman jamesjb@jamesjb.com ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;;

;;;# CFFI Example: gettimeofday binding ;;; ;;; This example illustrates the use of foreign structures, typedefs, ;;; and using type translators to do checking of input and output ;;; arguments to a foreign function.

(defpackage #:cffi-example-gettimeofday (:use #:common-lisp #:cffi #:cffi-utils) (:export #:gettimeofday))

(in-package #:cffi-example-gettimeofday)

;;; Define the TIMEVAL structure used by 'gettimeofday'. This assumes ;;; that 'time_t' is a 'long' --- it would be nice if CFFI could ;;; provide a proper :TIME-T type to help make this portable. (defcstruct timeval (tv-sec :long) (tv-usec :long))

;;; A NULL-POINTER is a foreign :POINTER that must always be NULL. ;;; Both a NULL pointer and NIL are legal values---any others will ;;; result in a runtime error. (defctype null-pointer :pointer)

;;; This type translator is used to ensure that a NULL-POINTER has a ;;; null value. It also converts NIL to a null pointer. (defmethod translate-to-foreign (value (name (eql 'null-pointer))) (cond ((null value) (null-pointer)) ((null-pointer-p value) value) (t (error "~A is not a null pointer." value))))

;;; The SYSCALL-RESULT type is an integer type used for the return ;;; value of C functions that return -1 and set errno on errors. ;;; Someday when CFFI has a portable interface for dealing with ;;; 'errno', this error reporting can be more useful. (defctype syscall-result :int)

;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error ;;; if the value is negative. (defmethod translate-from-foreign (value (name (eql 'syscall-result))) (if (minusp value) (error "System call failed with return value ~D." value) value))

;;; Define the Lisp function %GETTIMEOFDAY to call the C function ;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill ;;; in. The TZP parameter is deprecated and should be NULL --- we can ;;; enforce this by using our NULL-POINTER type defined above. (defcfun ("gettimeofday" %gettimeofday) syscall-result (tp :pointer) (tzp null-pointer))

;;; Define a Lispy interface to 'gettimeofday' that returns the ;;; seconds and microseconds as multiple values. (defun gettimeofday () (with-foreign-object (tv 'timeval) (%gettimeofday tv nil) (with-foreign-slots ((tv-sec tv-usec) tv timeval) (values tv-sec tv-usec)))) --- /project/cells/cvsroot/cells-gtk/cffi/examples/run-examples.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/run-examples.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; run-examples.lisp --- Simple script to run the examples. ;;; ;;; Copyright (C) 2005-2006, James Bielman jamesjb@jamesjb.com ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;;

(setf *load-verbose* nil *compile-verbose* nil)

#+(and (not asdf) (or sbcl openmcl)) (require "asdf") #+clisp (load "~/Downloads/asdf")

(asdf:operate 'asdf:load-op 'cffi-examples :verbose nil) (cffi-examples:run-examples) (force-output) (quit) --- /project/cells/cvsroot/cells-gtk/cffi/examples/translator-test.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/translator-test.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; translator-test.lisp --- Testing type translators. ;;; ;;; Copyright (C) 2005-2006, James Bielman jamesjb@jamesjb.com ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;;

(defpackage #:cffi-translator-test (:use #:common-lisp #:cffi #:cffi-utils))

(in-package #:cffi-translator-test)

;;;# Verbose Pointer Translator ;;; ;;; This is a silly type translator that doesn't actually do any ;;; translating, but it prints out a debug message when the pointer is ;;; converted to/from its foreign representation.

(defctype verbose-pointer :pointer)

(defmethod translate-to-foreign (value (name (eql 'verbose-pointer))) (format *debug-io* "~&;; to foreign: VERBOSE-POINTER: ~S~%" value) value)

(defmethod translate-from-foreign (value (name (eql 'verbose-pointer))) (format *debug-io* "~&;; from foreign: VERBOSE-POINTER: ~S~%" value) value)

;;;# Verbose String Translator ;;; ;;; A VERBOSE-STRING is a typedef for a VERBOSE-POINTER except the ;;; Lisp string is first converted to a C string. If things are ;;; working properly, both type translators should be called when ;;; converting a Lisp string to/from a C string. ;;; ;;; The translators should be called most-specific-first when ;;; translating to C, and most-specific-last when translating from C.

(defctype verbose-string verbose-pointer)

(defmethod translate-to-foreign ((s string) (name (eql 'verbose-string))) (let ((value (foreign-string-alloc s))) (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~S~%" s value) (values value t)))

(defmethod translate-to-foreign (value (name (eql 'verbose-string))) (if (pointerp value) (progn (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~:*~S~%" value) (values value nil)) (error "Cannot convert ~S to a foreign string: it is not a Lisp ~ string or pointer." value)))

(defmethod translate-from-foreign (ptr (name (eql 'verbose-string))) (let ((value (foreign-string-to-lisp ptr))) (format *debug-io* "~&;; from foreign: VERBOSE-STRING: ~S -> ~S~%" ptr value) value))

(defmethod free-translated-object (ptr (name (eql 'verbose-string)) free-p) (when free-p (foreign-string-free ptr)))

(defun test-verbose-string () (foreign-funcall "getenv" verbose-string "SHELL" verbose-string))

;;;# Testing Chained Parameters

(defctype inner-type :int) (defctype middle-type inner-type) (defctype outer-type middle-type)

(defmethod translate-to-foreign (value (name (eql 'inner-type))) (values value 1))

(defmethod translate-to-foreign (value (name (eql 'middle-type))) (values value 2))

(defmethod translate-to-foreign (value (name (eql 'outer-type))) (values value 3))

(defmethod free-translated-object (value (name (eql 'inner-type)) param) (format t "~&;; free inner-type ~A~%" param))

(defmethod free-translated-object (value (name (eql 'middle-type)) param) (format t "~&;; free middle-type ~A~%" param))

(defmethod free-translated-object (value (name (eql 'outer-type)) param) (format t "~&;; free outer-type ~A~%" param))