[gtk-cffi-cvs] CVS gtk-cffi/cffi
CVS User rklochkov
rklochkov at common-lisp.net
Sun Aug 28 10:31:30 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi
In directory tiger.common-lisp.net:/tmp/cvs-serv22502/cffi
Modified Files:
object.lisp package.lisp string.lisp struct.lisp
Log Message:
Refactored GBoxed structs. Now they can be garbage collected
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/26 17:16:13 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/28 10:31:30 1.4
@@ -45,7 +45,6 @@
(defmethod shared-initialize :after ((object object) slot-names
&rest initargs
&key pointer &allow-other-keys)
-; (call-next-method) ;; should be here to initialize VOLATILE slot
(setf (pointer object)
(or pointer (apply #'gconstructor (cons object initargs)))))
@@ -101,20 +100,19 @@
(defmethod translate-to-foreign ((value object) (type cffi-object))
(pointer value))
-(defmethod translate-to-foreign ((value object)
+;; Hack: redefine translater 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)
+(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))
- (object ptr :class (obj-class cffi-object)))
-
-
+ (object ptr :class (obj-class cffi-object)))
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/08/26 17:16:13 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/08/28 10:31:30 1.3
@@ -10,7 +10,7 @@
(in-package #:cl-user)
(defpackage #:cffi-object
- (:use #:iterate #:common-lisp #:cffi #:gtk-cffi-utils)
+ (:use #:iterate #:common-lisp #:cffi #:gtk-cffi-utils #:alexandria)
(:export
#:gconstructor
@@ -29,5 +29,19 @@
#:pfunction
#:cffi-object
+ #:struct
+ #:cffi-struct
+ #:new-struct
+ #:free-struct
+
#:defcstruct-accessors
- #:defcstruct*))
+ #:defcstruct*
+
+ #:with-foreign-out
+ #:with-foreign-outs
+ #:with-foreign-outs-list
+
+ #:setf-init
+ #:init-slots
+ #:save-setter
+ #:clear-setters))
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/string.lisp 2011/08/26 17:16:13 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/string.lisp 2011/08/28 10:31:30 1.3
@@ -13,9 +13,6 @@
(:actual-type :pointer)
(:simple-parser gtk-string))
-(defmethod translate-to-foreign (value (type gtk-string))
- (string->ptr value))
-
(defun string->ptr (value)
"string -> foreign pointer char*"
(typecase value
@@ -23,6 +20,9 @@
(foreign-pointer value)
(t (foreign-string-alloc (string value) :encoding :utf-8))))
+(defmethod translate-to-foreign (value (type gtk-string))
+ (string->ptr value))
+
(defmethod translate-from-foreign (ptr (name gtk-string))
(foreign-string-to-lisp ptr :encoding :utf-8))
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/08/26 17:39:35 1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/08/28 10:31:30 1.2
@@ -1,32 +1,166 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
-;;; array.lisp --- CFFI wrapper for arrays
+;;; 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-object)
-(defmacro defcstruct-accessors (class &rest slots)
- "CLASS maybe symbol = class-name = struct name,
-or maybe cons (class-name . struct-name)"
+(defclass struct (object)
+ ((value :documentation "Assoc list (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"))
+
+(defmethod gconstructor ((struct struct) &key &allow-other-keys)
+ nil)
+
+(defmacro save-setter (class name)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (push ',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)))
+
+(defmacro init-slots (class add-keys &body body)
+ "For SETF-INIT auto-constructor"
+ (let ((slots (mapcar (lambda (x) (list x nil (symbolicate x '-p)))
+ (get class 'slots))))
+ `(defmethod shared-initialize :after ((,class ,class) slot-names
+ &key , at slots , at add-keys
+ &allow-other-keys)
+ (setf-init ,class , at slots)
+ , at body)))
+
+
+(defmacro defcstruct-accessors (class)
+ "CLASS may be symbol = class-name = struct name,
+or may be cons (class-name . struct-name)"
(let ((class-name (if (consp class) (car class) class))
(struct-name (if (consp class) (cdr class) class)))
`(progn
- ,@(iter
- (for x in slots)
- (collect
+ (clear-setters ,class-name)
+ ,@(mapcar
+ (lambda (x)
`(progn
(defmethod ,x ((,class-name ,class-name))
- (foreign-slot-value (pointer ,class-name) ',struct-name ',x))
+ (if (slot-boundp ,class-name 'value)
+ (cdr (assoc ',x (slot-value ,class-name 'value)))
+ (foreign-slot-value (pointer ,class-name)
+ ',struct-name ',x)))
(defmethod (setf ,x) (val (,class-name ,class-name))
- (setf (foreign-slot-value (pointer ,class-name)
- ',struct-name ',x) val))))))))
+ (if (slot-boundp ,class-name 'value)
+ (push val (slot-value ,class-name 'value))
+ (setf (foreign-slot-value (pointer ,class-name)
+ ',struct-name ',x) val)))
+ (save-setter ,class-name ,x)))
+ (foreign-slot-names struct-name)))))
(defmacro defcstruct* (class &body body)
- `(progn
+ `(progn
(defcstruct ,class , at body)
- (defcstruct-accessors ,class
- ,@(iter
- (for x in body)
- (when (consp x) (collect (car x)))))))
\ No newline at end of file
+ (defcstruct-accessors ,class)))
+
+(defgeneric new-struct (class)
+ (:method (class)
+ (foreign-alloc class)))
+
+(defgeneric free-struct (class value)
+ (:method (class value)
+ (declare (ignore class))
+ (foreign-free value)))
+
+(defun clos->new-struct (class object)
+ (let ((res (new-struct class)))
+ (mapc (lambda (slot) (setf (foreign-slot-value res class slot)
+ (cdr (assoc slot (slot-value object 'value)))))
+ (foreign-slot-names class))
+ res))
+
+(defun struct->clos (class struct &optional object)
+ (let ((res (or object (make-instance class :pointer nil))))
+ (setf (slot-value res 'value) nil)
+ (mapc (lambda (slot)
+ (push (foreign-slot-value struct class slot)
+ (slot-value res 'value)))
+ (foreign-slot-names class))
+ res))
+
+(define-foreign-type cffi-struct (cffi-object)
+ ((free :accessor obj-free :initarg :free
+ :documentation "Free returned value")
+ (out :accessor obj-out :initarg :out
+ :documentation "This is out param (for fill in gtk side)"))
+ (:actual-type :pointer))
+
+(define-parse-method struct (class &key free out)
+ (make-instance 'cffi-struct :class class :free free :out out))
+
+(defmethod translate-to-foreign ((value struct) (type cffi-struct))
+ (values (clos->new-struct (obj-class type) value) value))
+
+(defmethod free-translated-object (value (type cffi-struct) param)
+ (let ((class (obj-class type)))
+ (when (obj-out type)
+ (struct->clos class value param))
+ (free-struct class value)))
+
+(defmethod translate-from-foreign (value (type cffi-struct))
+ (let ((class (obj-class type)))
+ (prog1
+ (struct->clos class value)
+ (when (obj-free type) (free-struct class value)))))
+
+(defun from-foreign (var type count)
+ (if count
+ (let ((res (make-array count)))
+ (if (subtypep type 'struct)
+ (dotimes (i count)
+ (setf (aref res i)
+ (struct->clos type (mem-aref var type i))))
+ (dotimes (i count)
+ (setf (aref res i)
+ (mem-aref var type i))))
+ res)
+ (if (subtypep type 'struct)
+ (struct->clos type var)
+ (mem-ref var type))))
+
+(defmacro with-foreign-out ((var type &optional count) &body body)
+ "The same as WITH-FOREIGN-OBJECT, but returns value of object"
+ `(with-foreign-object (,var ,type ,@(when count count))
+ , at body
+ (from-foreign ,var ,type ,count)))
+
+(defmacro with-foreign-outs (bindings &body body)
+ "The same as WITH-FOREIGN-OBJECTS, but returns (values ...) of binded vars"
+ `(with-foreign-objects ,bindings
+ , at body
+ (values ,@(mapcar (lambda (x)
+ (destructuring-bind (var type &optional count) x
+ `(from-foreign ,var ,type ,count)))
+ bindings))))
+
+(defmacro with-foreign-outs-list (bindings &body body)
+ "The same as WITH-FOREIGN-OBJECTS, but returns list of binded vars"
+ `(with-foreign-objects ,bindings
+ , at body
+ (list ,@(mapcar (lambda (x)
+ (destructuring-bind (var type &optional count) x
+ `(from-foreign ,var ,type ,count)))
+ bindings))))
\ No newline at end of file
More information about the gtk-cffi-cvs
mailing list