[cffi-objects-cvs] r1 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Thu Feb 9 15:53:55 UTC 2012
Author: rklochkov
Date: Thu Feb 9 07:53:55 2012
New Revision: 1
Log:
Initial release
Added:
cffi-objects.asd
freeable.lisp
object.lisp
package.lisp
pfunction.lisp
redefines.lisp
setters.lisp
struct.lisp
test.lisp
Added: cffi-objects.asd
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ cffi-objects.asd Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,25 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-object.asd --- ASDF system definition for cffi-objects
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(defpackage #:cffi-object-system
+ (:use #:cl #:asdf))
+(in-package #:cffi-object-system)
+
+(defsystem cffi-objects
+ :description "CFFI in-place replacement with object wrappers, structs and arrays"
+ :author "Roman Klochkov <monk at slavsoft.surgut.ru>"
+ :version "0.9"
+ :license "BSD"
+ :depends-on (cffi trivial-garbage)
+ :components
+ ((:file package)
+ (:file redefines :depends-on (package))
+ (:file freeable :depends-on (package))
+ (:file object :depends-on (freeable))
+ (:file pfunction :depends-on (package))
+ (:file setters :depends-on (package))
+ (:file struct :depends-on (object setters))))
Added: freeable.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ freeable.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,63 @@
+;;;; -*- Mode: lisp -*-
+;;;
+;;; freeable.lisp --- Interface for objects, that may be freed after use
+;;;
+;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(in-package #:cffi-objects)
+
+(define-foreign-type freeable-base ()
+ ((free :accessor object-free :initarg :free :initform :no-transfer
+ :type (member :none :all :no-transfer :transfer)
+ :documentation "Free returned or sent value.
+:NONE -- no free at all
+:ALL -- free always (after sending to FFI, or after recieved translation)
+:TRANSFER -- client frees, so free after recieve
+:NO-TRANSFER -- host frees, so free after sending to FFI.
+You should call FREE-RETURNED-IF-NEEDED and FREE-SENT-IF-NEEDED in
+appropriate places of your CFFI translators")))
+
+(defgeneric free-ptr (type ptr)
+ (:documentation "Called to free ptr, unless overriden free-sent-ptr or free-returned-ptr.")
+ (:method (type ptr)
+ (foreign-free ptr)))
+
+(defgeneric free-sent-ptr (type ptr)
+ (:method ((type freeable-base) ptr)
+ (free-ptr type ptr)))
+
+(defgeneric free-returned-ptr (type ptr)
+ (:method ((type freeable-base) ptr)
+ (free-ptr type ptr)))
+
+(defun free-sent-if-needed (type ptr)
+ (when (member (object-free type) '(:all :no-transfer))
+ (free-sent-ptr type ptr)))
+
+(defun free-returned-if-needed (type ptr)
+ (when (member (object-free type) '(:all :transfer))
+ (free-returned-ptr type ptr)))
+
+(defclass freeable (freeable-base) ()
+ (:documentation "Mixing to auto-set translators"))
+
+(defmethod free-translated-object :after (ptr (type freeable) param)
+ (declare (ignore param))
+ (free-sent-if-needed type ptr))
+
+(defmethod translate-from-foreign :after (ptr (type freeable))
+ (free-returned-if-needed type ptr))
+
+(define-foreign-type freeable-out (freeable)
+ ((out :accessor object-out :initarg :out :initform t
+ :documentation "This is out param (for fill in foreign side)"))
+ (:documentation "For returning data in out params.
+To use translate-to-foreign MUST return (values ptr place)"))
+
+(defgeneric copy-from-foreign (type ptr place)
+ (:documentation "Transfers data from pointer PTR to PLACE"))
+
+(defmethod free-translated-object :before (ptr (type freeable-out) place)
+ (when (object-out type)
+ (copy-from-foreign type ptr place)))
Added: object.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ object.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,128 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; object.lisp --- CFFI type OBJECT
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+
+(in-package :cffi-objects)
+
+(defvar *objects* (make-hash-table)
+ "Hash table: foreign-pointer address as integer -> lisp object")
+
+(defvar *objects-ids* (make-hash-table)
+ "Hash table: atom -> lisp object")
+
+(defclass object ()
+ ((pointer :accessor pointer :initarg :pointer
+ :initform (null-pointer) :type foreign-pointer)
+ ;; by default object shouldn't be stored unless it is GtkObject
+ (volatile :type boolean :accessor volatile
+ :initarg :volatile :initform t
+ :documentation "Will not be saved in hash")
+ (free-after :type boolean :initarg :free-after :initform t
+ :documentation "Should be freed by finalizer")
+ (id :type symbol :accessor id :initarg :id :initform nil))
+ (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
+shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
+
+(defmethod (setf pointer) :after (value (object object))
+ (declare (type foreign-pointer value))
+ (tg:cancel-finalization object)
+ (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
+ (let ((class (class-of object)))
+ (tg:finalize object (lambda ()
+ (free-ptr class value)))))
+ ; specialize EQL CLASS to override
+ (unless (or (volatile object) (null-pointer-p value))
+ (setf (gethash (pointer-address value) *objects*) object)
+ (when (id object)
+ (let ((cur-obj (gethash (id object) *objects-ids*)))
+ (unless (or (null cur-obj) (eq cur-obj object))
+ (warn "ID ~a for object ~a already set for ~a~%"
+ (id object) object (gethash (id object) *objects-ids*)))
+ (setf (gethash (id object) *objects-ids*) object)))))
+
+(defgeneric gconstructor (object &rest initargs)
+ (:documentation "Called during initialization of OBJECT instance.
+Should return a pointer to foreign OBJECT instance,
+for example, by g_object_new."))
+
+(defmethod gconstructor (something-bad &rest rest)
+ (warn "No constructor for ~a ~a~%" something-bad rest))
+
+(defmethod shared-initialize :after ((object object) slot-names
+ &rest initargs
+ &key pointer &allow-other-keys)
+ (unless pointer
+ (setf (pointer object) (apply #'gconstructor object initargs))))
+
+(defmethod pointer (something-bad)
+ (declare (ignore something-bad))
+ "Empty method to return null-pointer for non-objects"
+ (null-pointer))
+
+(defgeneric free (object)
+ (:documentation "Removes object pointer from lisp hashes."))
+
+(defmethod free ((object object))
+ (unless (null-pointer-p (pointer object))
+ (remhash (pointer-address (pointer object)) *objects*)
+ (remhash (id object) *objects-ids*)
+ (setf (pointer object) (null-pointer)
+ (id object) nil)))
+
+(defun find-object (pointer &optional class)
+ "Returns lisp object for an Object pointer.
+If not found or found with wrong class, create new one with given CLASS"
+ (declare (type symbol class) (type foreign-pointer pointer))
+ (unless (null-pointer-p pointer)
+ (let ((try-find (gethash (pointer-address pointer) *objects*)))
+ (if class
+ (progn
+ (unless (or (null try-find)
+ (eq (class-of try-find) (find-class class)))
+ (progn
+ (free try-find)
+ (setf try-find nil)))
+ (or try-find (make-instance class :pointer pointer)))
+ try-find))))
+
+(defun object-by-id (id-key)
+ (gethash id-key *objects-ids*))
+
+;; Type OBJECT
+;; converts class object to pointer and vice versa
+
+(define-foreign-type cffi-object ()
+ ((class :initarg :class :accessor object-class))
+ (:actual-type :pointer))
+
+(define-parse-method object (&optional class)
+ (make-instance 'cffi-object :class class))
+
+(defmethod translate-to-foreign ((value null) (type cffi-object))
+ (null-pointer))
+
+(defmethod translate-to-foreign ((value object) (type cffi-object))
+ (pointer value))
+
+;; Hack: redefine translator for :pointer to be able to use
+;; objects or nulls instead of pointer
+(defmethod translate-to-foreign ((value object)
+ (type cffi::foreign-pointer-type))
+ (pointer value))
+
+(defmethod translate-to-foreign ((value null)
+ (type cffi::foreign-pointer-type))
+ (null-pointer))
+
+(defmethod translate-to-foreign (value (type cffi-object))
+ (check-type value foreign-pointer)
+ value)
+
+(defmethod translate-from-foreign (ptr (cffi-object cffi-object))
+ (find-object ptr (object-class cffi-object)))
+
+
+
Added: package.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ package.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,69 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; package.lisp --- Package definition for cffi-object
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+;;; This library is a CFFI add-on, that support
+;;; GLib/GObject/GDK/GTK and similar objects
+
+(in-package #:cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (let ((p (find-package "CFFI-OBJECTS")))
+ (when p
+ (do-external-symbols (v p)
+ (unexport (list v) p)))))
+
+(defpackage #:cffi-objects
+ (:use #:common-lisp #:cffi)
+ (:export
+ #:gconstructor
+
+ #:object
+ #:object-by-id
+ #:*objects*
+ #:*objects-ids*
+ ;; slots
+ #:pointer
+ ;; methods
+ #:free
+
+ ;; types
+ #:pstring
+ #:pfunction
+ #:cffi-object
+
+ #:struct
+; #:cffi-struct
+ #:new-struct
+ #:free-struct
+
+ #:freeable
+ #:freeable-base
+ #:free-sent-if-needed
+ #:free-returned-if-needed
+ #:free-ptr
+ #:freeable-out
+ #:copy-from-foreign
+
+ #:defcstruct-accessors
+ #:defcstruct*
+ #:defbitaccessors
+
+ #:with-foreign-out
+ #:with-foreign-outs
+ #:with-foreign-outs-list
+
+ #:pair
+ #:setf-init
+ #:init-slots
+ #:save-setter
+ #:remove-setter
+ #:clear-setters))
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (let ((cffi (find-package "CFFI"))
+ (cffi-objects (find-package "CFFI-OBJECTS")))
+ (do-external-symbols (v cffi)
+ (export (list v) cffi-objects))))
\ No newline at end of file
Added: pfunction.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ pfunction.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,25 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; object.lisp --- CFFI type PFUNCTION
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(in-package :cffi-objects)
+
+(define-foreign-type pfunction ()
+ ()
+ (:actual-type :pointer)
+ (:simple-parser pfunction)
+ (:documentation "Takes a foreign pointer, keyword or a string.
+Keyword or a string = name of C function, substituting #\- to #\_"))
+
+(defmethod translate-to-foreign (value (type pfunction))
+ (labels ((to-ptr (str)
+ (declare (type string str))
+ (foreign-symbol-pointer (substitute #\_ #\- str))))
+ (etypecase value
+ (string (to-ptr value))
+ (keyword (to-ptr (string-downcase value)))
+ (foreign-pointer value)
+ (null (null-pointer)))))
Added: redefines.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ redefines.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,30 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; redefines.lisp --- fix :double, alternate string
+;;;
+;;; Copyright (C) 2012, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+
+(in-package #:cffi-objects)
+
+(defmethod expand-to-foreign-dyn :around
+ (value var body (type cffi::foreign-built-in-type))
+ (if (eq (cffi::type-keyword type) :double)
+ `(let ((,var (coerce ,value 'double-float))) , at body)
+ `(let ((,var ,value)) , at body)))
+
+;; make type string with :free for uniformity
+(define-foreign-type cffi-string (freeable)
+ ()
+ (:actual-type :pointer)
+ (:simple-parser pstring))
+
+(defmethod translate-to-foreign ((value string) (type cffi-string))
+ (values (foreign-string-alloc value) value))
+
+(defmethod free-ptr ((type cffi-string) ptr)
+ (foreign-string-free ptr))
+
+(defmethod translate-from-foreign (ptr (type cffi-string))
+ (foreign-string-to-lisp ptr))
+
Added: setters.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ setters.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,49 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; object.lisp --- Auto setters for foreign slots
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+
+(in-package #:cffi-objects)
+
+(defmacro save-setter (class name)
+ "Use this to register setters for SETF-INIT and INIT-SLOTS macro"
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew ',name (get ',class 'slots))))
+
+(defmacro remove-setter (class name)
+ "Use this to unregister setters for SETF-INIT and INIT-SLOTS macro"
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',class 'slots)
+ (delete ',name (get ',class 'slots)))))
+
+(defmacro clear-setters (class)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',class 'slots) nil)))
+
+(defmacro setf-init (object &rest fields)
+ "Should be used in constructors"
+ `(progn
+ ,@(mapcar (lambda (field-all)
+ (let ((field (if (consp field-all)
+ (first field-all) field-all))
+ (field-p (if (consp field-all)
+ (third field-all) field-all)))
+ `(when ,field-p
+ (setf (,field ,object) ,field))))
+ fields)))
+
+(defun name-p (name)
+ (intern (format nil "~a-P" name) (symbol-package name)))
+
+(defmacro init-slots (class &optional add-keys &body body)
+ "For SETF-INIT auto-constructor"
+ (let ((slots (mapcar (lambda (x) (list x nil (name-p x)))
+ (get class 'slots))))
+ `(defmethod shared-initialize :after ((,class ,class) slot-names
+ &key , at slots , at add-keys
+ &allow-other-keys)
+ (declare (ignore slot-names))
+ (setf-init ,class , at slots)
+ , at body)))
Added: struct.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ struct.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,210 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; struct.lisp --- CFFI wrapper for structs. We need to save on lisp
+;;; side only values of struct field, not pointer on
+;;; the struct to be able to garbage collect it
+;;;
+;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(in-package :cffi-objects)
+
+(defclass struct (object)
+ ((value :documentation "plist ({field-name field-value}*)"))
+ (:documentation "If value bound, use it, else use pointer.
+Struct may be used in OBJECT cffi-type or STRUCT cffi-type"))
+
+(defgeneric new-struct (class)
+ (:method (class)
+ (foreign-alloc class)))
+
+(defgeneric free-struct (class value)
+ (:method (class value)
+ (declare (ignore class))
+ (foreign-free value)))
+
+(defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys)
+ (if new-struct
+ (new-struct (class-name (class-of struct)))
+ (progn
+ (setf (slot-value struct 'value) nil)
+ (null-pointer))))
+
+(defun pair (maybe-pair)
+ (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
+
+(defmacro defcstruct-accessors (class)
+ "CLASS may be symbol = class-name = struct name,
+or may be cons (class-name . struct-name)"
+ (destructuring-bind (class-name . struct-name) (pair class)
+ `(progn
+ (clear-setters ,class-name)
+ ,@(mapcar
+ (lambda (x)
+ `(progn
+ (unless (fboundp ',x)
+ (defgeneric ,x (,class-name)))
+ (defmethod ,x ((,class-name ,class-name))
+ (if (slot-boundp ,class-name 'value)
+ (getf (slot-value ,class-name 'value) ',x)
+ (foreign-slot-value (pointer ,class-name)
+ ',struct-name ',x)))
+ (unless (fboundp '(setf ,x))
+ (defgeneric (setf ,x) (val ,class-name)))
+ (defmethod (setf ,x) (val (,class-name ,class-name))
+ (if (slot-boundp ,class-name 'value)
+ (setf (getf (slot-value ,class-name 'value) ',x) val)
+ (setf (foreign-slot-value (pointer ,class-name)
+ ',struct-name ',x)
+ val)))
+ (save-setter ,class-name ,x)))
+ (foreign-slot-names struct-name)))))
+
+(defmacro defbitaccessors (class slot &rest fields)
+ (let ((pos 0))
+ (flet ((build-field (field)
+ (destructuring-bind (name type size) field
+ (prog1
+ `(progn
+ (unless (fboundp ',name)
+ (defgeneric ,name (,class)))
+ (defmethod ,name ((,class ,class))
+ (convert-from-foreign
+ (ldb (byte ,size ,pos) (slot-value ,class ',slot))
+ ,type))
+ (unless (fboundp '(setf ,name))
+ (defgeneric (setf ,name) (value ,class)))
+ (defmethod (setf ,name) (value (,class ,class))
+ (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))
+ (convert-to-foreign value ,type))))
+ (incf pos size)))))
+ (cons 'progn (mapcar #'build-field fields)))))
+
+
+(defmacro defcstruct* (class &body body)
+ `(progn
+ (defclass ,class (struct) ())
+ (defcstruct ,class , at body)
+ (defcstruct-accessors ,class)
+ (init-slots ,class)))
+
+
+(defun clos->new-struct (class object)
+ (if (slot-boundp object 'value)
+ (let ((res (new-struct class))
+ (default (gensym)))
+ (mapc (lambda (slot)
+ (let ((val (getf (slot-value object 'value) slot default)))
+ (unless (eq val default)
+ (setf (foreign-slot-value res class slot) val))))
+ (foreign-slot-names class))
+ res)
+ (slot-value object 'pointer)))
+
+(defun struct->clos (class struct &optional object)
+ (let ((res (or object (make-instance class))))
+ (setf (slot-value res 'value) nil)
+ (mapc (lambda (slot)
+ (setf (getf (slot-value res 'value) slot)
+ (foreign-slot-value struct class slot)))
+ (foreign-slot-names class))
+ res))
+
+
+
+(define-foreign-type cffi-struct (cffi-object freeable-out)
+ ()
+ (:actual-type :pointer))
+
+(defmethod free-ptr ((type cffi-struct) ptr)
+ (free-struct (object-class type) ptr))
+
+(defmethod foreign-type-size ((type cffi-struct))
+ "Return the size in bytes of a foreign typedef."
+ (foreign-type-size (object-class type)))
+
+(define-parse-method struct (class &key (free :no-transfer) out)
+ (make-instance 'cffi-struct
+ :class class :free free :out out))
+
+(defun %class (type value)
+ (or (object-class type) (class-name (class-of value))))
+
+(defmethod copy-from-foreign ((type cffi-object) ptr place)
+ (when (or (slot-boundp place 'value)
+ (member (object-free type) '(:all :transfer)))
+ (struct->clos (%class type place) ptr place)))
+
+(defmethod translate-to-foreign ((value struct) (type cffi-object))
+ (values (clos->new-struct (%class type value) value) value))
+
+(defmethod translate-from-foreign (value (type cffi-struct))
+ (struct->clos (object-class type) value))
+
+;;; Allowed use with object designator
+;; object == (struct nil :out t :free t)
+
+
+;; to allow using array of structs
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (get 'mem-ref 'struct)
+ (let ((old (fdefinition 'mem-ref)))
+ (fmakunbound 'mem-ref)
+ (defun mem-ref (ptr type &optional (offset 0))
+ (let ((ptype (cffi::parse-type type)))
+ (if (subtypep (type-of ptype) 'cffi-struct)
+ (translate-from-foreign (inc-pointer ptr offset) ptype)
+ (funcall old ptr type offset)))))
+ (setf (get 'mem-ref 'struct) t)))
+
+
+(defun from-foreign (var type count)
+ "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
+ (if count
+ (let ((res (make-array count)))
+ (dotimes (i count)
+ (setf (aref res i)
+ (mem-aref var type i)))
+ res)
+ (mem-ref var type)))
+
+
+(defmacro with-foreign-out ((var type &optional count) return-result &body body)
+ "The same as WITH-FOREIGN-OBJECT, but returns value of object"
+ (let ((value `(from-foreign ,var ,type ,count)))
+ `(with-foreign-object (,var ,type ,@(when count (list count)))
+ ,(if (eq return-result :ignore)
+ `(progn , at body ,value)
+ `(let ((res , at body))
+ ,(ecase return-result
+ (:if-success `(when res ,value))
+ (:return `(values res ,value))))))))
+
+(flet
+ ((make-with-foreign-outs (res-fun bindings return-result body)
+ (let ((values-form (mapcar (lambda (x)
+ (destructuring-bind
+ (var type &optional count) x
+ `(from-foreign ,var ,type ,count)))
+ bindings)))
+ `(with-foreign-objects ,bindings
+ ,(if (eq return-result :ignore)
+ `(progn , at body (,res-fun , at values-form))
+ `(let ((res , at body))
+ ,(ecase return-result
+ (:if-success
+ `(when res (,res-fun , at values-form)))
+ (:return
+ `(,res-fun res , at values-form)))))))))
+
+ (defmacro with-foreign-outs (bindings return-result &body body)
+ "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
+of result and binded vars, RETURN-RESULT may be
+:RETURN - return result and values
+:IF-SUCCESS - return values if result t
+:IGNORE - discard result"
+ (make-with-foreign-outs 'values bindings return-result body))
+
+ (defmacro with-foreign-outs-list (bindings return-result &body body)
+ "The same as WITH-FOREIGN-OBJECTS, but returns list"
+ (make-with-foreign-outs 'list bindings return-result body)))
Added: test.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ test.lisp Thu Feb 9 07:53:55 2012 (r1)
@@ -0,0 +1,30 @@
+(defpackage cffi-objects.test
+ (:use cl cffi-objects))
+(in-package cffi-objects.test)
+
+(defcallback test-double :double ((x :double))
+ (+ x 2))
+
+(defun call-test-double ()
+ (= 4 (foreign-funcall-pointer (callback test-double) () :double 2 :double)))
+
+(defcstruct* tstruct
+ (a :int)
+ (b :int))
+
+(defcallback test-struct :int ((x :pointer))
+ (setf (mem-aref x :int 0) 10)
+ (mem-aref x :int 1))
+
+(defun call-test-struct ()
+ (let ((s (make-instance 'tstruct)))
+ (setf (a s) 1 (b s) 2)
+ (prog1
+ (foreign-funcall-pointer
+ (callback test-struct) () (struct tstruct :out t) s :int)
+ (assert (= (a s) 10)))))
+
+(assert (call-test-double))
+
+(assert (= (call-test-struct) 2))
+
More information about the cffi-objects-cvs
mailing list