[gtk-cffi-cvs] CVS gtk-cffi/cffi
CVS User rklochkov
rklochkov at common-lisp.net
Wed Jan 25 19:15:08 UTC 2012
Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi
In directory tiger.common-lisp.net:/tmp/cvs-serv31071/cffi
Modified Files:
object.lisp package.lisp struct.lisp
Log Message:
Refactored freeable
Added loadlib to gio
Fixed compilation without loading
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2012/01/21 18:35:00 1.7
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2012/01/25 19:15:07 1.8
@@ -18,8 +18,10 @@
: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)
- (free-after :type boolean :initarg :free-after :initform t)
+ :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."))
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/09/18 18:10:47 1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2012/01/25 19:15:07 1.7
@@ -23,9 +23,9 @@
#:free
;; types
- #:gtk-string
- #:gtk-dyn-string
- #:gtk-new-string
+ #:gtk-string ; deprecated
+ #:gtk-dyn-string ; deprecated
+ #:gtk-new-string ; deprecated
#:pfunction
#:cffi-object
@@ -35,7 +35,9 @@
#:free-struct
#:freeable
- #:free-if-needed
+ #:freeable-base
+ #:free-sent-if-needed
+ #:free-returned-if-needed
#:free-ptr
#:defcstruct-accessors
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/10/23 08:39:53 1.9
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2012/01/25 19:15:07 1.10
@@ -67,6 +67,8 @@
(struct-name (if (consp class) (cdr class) class)))
`(progn
(clear-setters ,class-name)
+ ;(eval-when (:compile-toplevel :load-toplevel :execute)
+ ; (setf (get ',class-name 'struct) ',struct-name))
,@(mapcar
(lambda (x)
`(progn
@@ -83,9 +85,10 @@
(if (slot-boundp ,class-name 'value)
(push val (slot-value ,class-name 'value))
(setf (foreign-slot-value (pointer ,class-name)
- ',struct-name ',x) val)))
+ ',struct-name ',x)
+ val)))
(save-setter ,class-name ,x)))
- (foreign-slot-names struct-name)))))
+ (foreign-slot-names `,struct-name)))))
(defmacro defbitaccessors (class slot &rest fields)
(let ((pos 0))
@@ -143,17 +146,40 @@
(foreign-slot-names class))
res))
-(define-foreign-type freeable ()
- ((free :accessor obj-free :initarg :free :initform nil
- :documentation "Free returned value")))
+(define-foreign-type freeable-base ()
+ ((free :accessor obj-free :initarg :free :initform :no-transfer
+ :type (member :none :all :no-transfer :transfer)
+ :documentation "Free returned or sent value")))
(defgeneric free-ptr (type ptr)
- (:method ((type freeable) ptr)
+ (:method ((type freeable-base) ptr)
(foreign-free ptr)))
-(defgeneric free-if-needed (type ptr)
- (:method ((type freeable) ptr)
- (when (obj-free type) (free-ptr type 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 (obj-free type) '(:all :no-transfer))
+ (free-sent-ptr type ptr)))
+
+(defun free-returned-if-needed (type ptr)
+ (when (member (obj-free type) '(:all :transfer))
+ (free-returned-ptr type ptr)))
+
+(defclass freeable (freeable-base) ())
+
+(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 cffi-struct (cffi-object freeable)
((out :accessor obj-out :initarg :out
@@ -167,10 +193,14 @@
"Return the size in bytes of a foreign typedef."
(foreign-type-size (obj-class type)))
-(defmethod cffi::aggregatep ((type cffi-struct)) t)
+;(defmethod cffi::aggregatep ((type cffi-struct)) t)
+
+;(defmethod cffi::canonicalize ((type cffi-struct))
+; `(:struct ,(obj-class type)))
(define-parse-method struct (class &key free out)
- (make-instance 'cffi-struct :class class :free free :out out))
+ (make-instance 'cffi-struct
+ :class class :free free :out out))
(defun %class (type value)
(or (obj-class type) (class-name (class-of value))))
@@ -179,20 +209,16 @@
(values (clos->new-struct (%class type value) value) value))
(defmethod free-translated-object (value (type cffi-struct) (param struct))
- (let ((class (%class type param)))
- (when (slot-boundp param 'value)
- (when (obj-out type)
- (struct->clos class value param))
- (free-struct class value))))
+ (when (and (slot-boundp param 'value)
+ (obj-out type))
+ (struct->clos (%class type param) value param)))
(defmethod translate-from-foreign (value (type cffi-struct))
(let ((class (obj-class type)))
- (prog1
- (struct->clos class value)
- (free-if-needed type value))))
+ (struct->clos class value)))
;;; for use with pobject designator
-;; pobject == (struct nil :out t)
+;; pobject == (struct nil :out t :free t)
(defmethod free-translated-object (value (type cffi-object) (param struct))
(let ((class (%class type param)))
@@ -202,16 +228,16 @@
-;; This is needed to get correct mem-aref, when used on array of structs
(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (get 'mem-ref 'struct)
- (let ((old (fdefinition '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)))
+ (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"
More information about the gtk-cffi-cvs
mailing list