Update of /project/cells/cvsroot/cells-gtk/cffi/uffi-compat
In directory clnet:/tmp/cvs-serv9292/cffi/uffi-compat
Added Files:
uffi-compat.lisp
Log Message:
--- /project/cells/cvsroot/cells-gtk/cffi/uffi-compat/uffi-compat.lisp 2008/01/28 23:59:41 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/uffi-compat/uffi-compat.lisp 2008/01/28 23:59:41 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; uffi-compat.lisp --- UFFI compatibility layer for CFFI.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb(a)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.
;;;
;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg.
(defpackage #:cffi-uffi-compat
(:nicknames #:uffi) ;; is this a good idea?
(:use #:cl)
(:export
;; immediate types
#:def-constant
#:def-foreign-type
#:def-type
#:null-char-p
;; aggregate types
#:def-enum
#:def-struct
#:get-slot-value
#:get-slot-pointer
#:def-array-pointer
#:deref-array
#:def-union
;; objects
#:allocate-foreign-object
#:free-foreign-object
#:with-foreign-object
#:with-foreign-objects
#:size-of-foreign-type
#:pointer-address
#:deref-pointer
#:ensure-char-character
#:ensure-char-integer
#:ensure-char-storable
#:null-pointer-p
#:make-null-pointer
#:make-pointer
#:+null-cstring-pointer+
#:char-array-to-pointer
#:with-cast-pointer
#:def-foreign-var
#:convert-from-foreign-usb8
;; string functions
#:convert-from-cstring
#:convert-to-cstring
#:free-cstring
#:with-cstring
#:with-cstrings
#:convert-from-foreign-string
#:convert-to-foreign-string
#:allocate-foreign-string
#:with-foreign-string
#:with-foreign-strings
#:foreign-string-length ; not implemented
;; function call
#:def-function
;; libraries
#:find-foreign-library
#:load-foreign-library
#:default-foreign-library-type
#:foreign-library-types
;; os
#:getenv
#:run-shell-command
))
(in-package #:cffi-uffi-compat)
#+clisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (equal (machine-type) "POWER MACINTOSH")
(pushnew :ppc *features*)))
(defun convert-uffi-type (uffi-type)
"Convert a UFFI primitive type to a CFFI type."
;; Many CFFI types are the same as UFFI. This list handles the
;; exceptions only.
(case uffi-type
(:cstring :pointer)
(:pointer-void :pointer)
(:pointer-self :pointer)
(:char '(uffi-char :char))
(:unsigned-char '(uffi-char :unsigned-char))
(:byte :char)
(:unsigned-byte :unsigned-char)
(t
(if (listp uffi-type)
(case (car uffi-type)
;; this is imho gross but it is what uffi does
(quote (convert-uffi-type (second uffi-type)))
(* :pointer)
(:array `(uffi-array ,(convert-uffi-type (second uffi-type))
,(third uffi-type)))
(:union (second uffi-type))
(:struct (convert-uffi-type (second uffi-type)))
(:struct-pointer :pointer))
uffi-type))))
(defclass uffi-array-type (cffi::foreign-typedef)
;; ELEMENT-TYPE should be /unparsed/, suitable for passing to mem-aref.
((element-type :initform (error "An element-type is required.")
:accessor element-type :initarg :element-type)
(nelems :initform (error "nelems is required.")
:accessor nelems :initarg :nelems))
(:documentation "UFFI's :array type."))
(defmethod initialize-instance :after ((self uffi-array-type) &key)
(setf (cffi::actual-type self) (cffi::parse-type :pointer)))
(defmethod cffi:foreign-type-size ((type uffi-array-type))
(* (cffi:foreign-type-size (element-type type)) (nelems type)))
(defmethod cffi::aggregatep ((type uffi-array-type))
t)
(cffi::define-type-spec-parser uffi-array (element-type count)
(make-instance 'uffi-array-type :element-type element-type
:nelems (or count 1)))
;; UFFI's :(unsigned-)char
(cffi:define-foreign-type uffi-char (base-type)
base-type)
(defmethod cffi:translate-to-foreign ((value character) (name (eql 'uffi-char)))
(char-code value))
(defmethod cffi:translate-from-foreign (obj (name (eql 'uffi-char)))
(code-char obj))
(defmethod cffi::unparse ((name (eql 'uffi-char)) type)
`(uffi-char ,(cffi::name (cffi::actual-type type))))
(defmacro def-type (name type)
"Define a Common Lisp type NAME for UFFI type TYPE."
(declare (ignore type))
`(deftype ,name () t))
(defmacro def-foreign-type (name type)
"Define a new foreign type."
`(cffi:defctype ,name ,(convert-uffi-type type)))
(defmacro def-constant (name value &key export)
"Define a constant and conditionally export it."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant ,name ,value)
,@(when export `((export ',name)))
',name))
(defmacro null-char-p (val)
"Return true if character is null."
`(zerop (char-code ,val)))
(defmacro def-enum (enum-name args &key (separator-string "#"))
"Creates a constants for a C type enum list, symbols are
created in the created in the current package. The symbol is the
concatenation of the enum-name name, separator-string, and
field-name"
(let ((counter 0)
(cmds nil)
(constants nil))
(declare (fixnum counter))
(dolist (arg args)
(let ((name (if (listp arg) (car arg) arg))
(value (if (listp arg)
(prog1
(setq counter (cadr arg))
(incf counter))
(prog1
counter
(incf counter)))))
(setq name (intern (concatenate 'string
(symbol-name enum-name)
separator-string
(symbol-name name))))
(push `(def-constant ,name ,value) constants)))
(setf cmds (append '(progn) `((cffi:defctype ,enum-name :int))
(nreverse constants)))
cmds))
(defmacro def-struct (name &body fields)
"Define a C structure."
`(cffi:defcstruct ,name
,@(loop for (name uffi-type) in fields
for cffi-type = (convert-uffi-type uffi-type)
collect (list name cffi-type))))
;; TODO: figure out why the compiler macro is kicking in before
;; the setf expander.
(defun %foreign-slot-value (obj type field)
(cffi:foreign-slot-value obj type field))
(defun (setf %foreign-slot-value) (value obj type field)
(setf (cffi:foreign-slot-value obj type field) value))
(defmacro get-slot-value (obj type field)
"Access a slot value from a structure."
`(%foreign-slot-value ,obj ,type ,field))
;; UFFI uses a different function when accessing a slot whose
;; type is a pointer. We don't need that in CFFI so we use
;; foreign-slot-value too.
(defmacro get-slot-pointer (obj type field)
"Access a pointer slot value from a structure."
`(cffi:foreign-slot-value ,obj ,type ,field))
(defmacro def-array-pointer (name type)
"Define a foreign array type."
`(cffi:defctype ,name (uffi-array ,(convert-uffi-type type) 1)))
(defmacro deref-array (array type position)
"Dereference an array."
`(cffi:mem-aref ,array
,(if (constantp type)
`',(element-type (cffi::parse-type
(convert-uffi-type (eval type))))
`(element-type (cffi::parse-type
(convert-uffi-type ,type))))
,position))
;; UFFI's documentation on DEF-UNION is a bit scarce, I'm not sure
;; if DEFCUNION and DEF-UNION are strictly compatible.
(defmacro def-union (name &body fields)
"Define a foreign union type."
`(cffi:defcunion ,name
,@(loop for (name uffi-type) in fields
for cffi-type = (convert-uffi-type uffi-type)
collect (list name cffi-type))))
(defmacro allocate-foreign-object (type &optional (size 1))
"Allocate one or more instance of a foreign type."
`(cffi:foreign-alloc ,(if (constantp type)
`',(convert-uffi-type (eval type))
`(convert-uffi-type ,type))
:count ,size))
(defmacro free-foreign-object (ptr)
"Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT."
`(cffi:foreign-free ,ptr))
(defmacro with-foreign-object ((var type) &body body)
"Wrap the allocation of a foreign object around BODY."
`(cffi:with-foreign-object (,var (convert-uffi-type ,type))
,@body))
;; Taken from UFFI's src/objects.lisp
(defmacro with-foreign-objects (bindings &rest body)
(if bindings
`(with-foreign-object ,(car bindings)
(with-foreign-objects ,(cdr bindings)
,@body))
`(progn ,@body)))
(defmacro size-of-foreign-type (type)
"Return the size in bytes of a foreign type."
`(cffi:foreign-type-size (convert-uffi-type ,type)))
(defmacro pointer-address (ptr)
"Return the address of a pointer."
`(cffi:pointer-address ,ptr))
;; Hmm, we need to translate chars, so translations are necessary here.
(defun %deref-pointer (ptr type)
(cffi::translate-type-from-foreign (cffi:mem-ref ptr type) (cffi::parse-type type)))
(defun (setf %deref-pointer) (value ptr type)
(setf (cffi:mem-ref ptr type)
(cffi::translate-type-to-foreign value (cffi::parse-type type))))
(defmacro deref-pointer (ptr type)
"Dereference a pointer."
`(%deref-pointer ,ptr (convert-uffi-type ,type)))
(defmacro ensure-char-character (obj &environment env)
"Convert OBJ to a character if it is an integer."
(if (constantp obj env)
(if (characterp obj) obj (code-char obj))
(let ((obj-var (gensym)))
`(let ((,obj-var ,obj))
(if (characterp ,obj-var)
,obj-var
(code-char ,obj-var))))))
(defmacro ensure-char-integer (obj &environment env)
"Convert OBJ to an integer if it is a character."
(if (constantp obj env)
(let ((the-obj (eval obj)))
(if (characterp the-obj) (char-code the-obj) the-obj))
(let ((obj-var (gensym)))
`(let ((,obj-var ,obj))
(if (characterp ,obj-var)
(char-code ,obj-var)
,obj-var)))))
(defmacro ensure-char-storable (obj)
"Ensure OBJ is storable as a character."
`(ensure-char-integer ,obj))
(defmacro make-null-pointer (type)
"Create a NULL pointer."
(declare (ignore type))
`(cffi:null-pointer))
(defmacro make-pointer (address type)
"Create a pointer to ADDRESS."
(declare (ignore type))
`(cffi:make-pointer ,address))
(defmacro null-pointer-p (ptr)
"Return true if PTR is a null pointer."
`(cffi:null-pointer-p ,ptr))
(defparameter +null-cstring-pointer+ (cffi:null-pointer)
"A constant NULL string pointer.")
(defmacro char-array-to-pointer (obj)
obj)
(defmacro with-cast-pointer ((var ptr type) &body body)
"Cast a pointer, does nothing in CFFI."
(declare (ignore type))
`(let ((,var ,ptr))
,@body))
(defmacro def-foreign-var (name type module)
"Define a symbol macro to access a foreign variable."
(declare (ignore module))
(flet ((lisp-name (name)
(intern (cffi-sys:canonicalize-symbol-name-case
(substitute #\- #\_ name)))))
`(cffi:defcvar ,(if (listp name)
name
(list name (lisp-name name)))
,(convert-uffi-type type))))
(defmacro convert-from-cstring (s)
"Convert a cstring to a Lisp string."
(let ((ret (gensym)))
`(let ((,ret (cffi:foreign-string-to-lisp ,s)))
(if (equal ,ret "")
nil
,ret))))
(defmacro convert-to-cstring (obj)
"Convert a Lisp string to a cstring."
(let ((str (gensym)))
`(let ((,str ,obj))
(if (null ,str)
(cffi:null-pointer)
(cffi:foreign-string-alloc ,str)))))
(defmacro free-cstring (ptr)
"Free a cstring."
`(cffi:foreign-string-free ,ptr))
(defmacro with-cstring ((foreign-string lisp-string) &body body)
"Binds a newly creating string."
(let ((str (gensym)))
`(let ((,str ,lisp-string))
(if (null ,str)
(let ((,foreign-string (cffi:null-pointer)))
,@body)
(cffi:with-foreign-string (,foreign-string ,str)
,@body)))))
;; Taken from UFFI's src/strings.lisp
(defmacro with-cstrings (bindings &rest body)
(if bindings
`(with-cstring ,(car bindings)
(with-cstrings ,(cdr bindings)
,@body))
[224 lines skipped]
