[gtk-cffi-cvs] CVS gtk-cffi/g-object
CVS User rklochkov
rklochkov at common-lisp.net
Sun Aug 28 10:31:30 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object
In directory tiger.common-lisp.net:/tmp/cvs-serv22502/g-object
Modified Files:
defslots.lisp g-object.lisp package.lisp
Log Message:
Refactored GBoxed structs. Now they can be garbage collected
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/26 17:16:13 1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/28 10:31:30 1.2
@@ -13,8 +13,7 @@
(let ((getter (symbolicate prefix current-class '-get- name-gtk))
(setter (symbolicate prefix current-class '-set- name-gtk)))
`(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (push ',name-lisp (get ',current-class 'slots)))
+ (save-setter ,current-class ,name-lisp)
(defcfun ,getter ,slot-type (object pobject))
(defcfun ,setter :void (widget pobject) (value ,slot-type))
(unless (fboundp ',name-lisp)
@@ -30,8 +29,7 @@
(defun defslots (def-macro current-class slots)
`(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',current-class 'slots) nil))
+ (clear-setters ,current-class)
,@(iter
(for x on slots by #'cddr)
(collect (list def-macro current-class (first x) (second x))))))
@@ -46,20 +44,21 @@
(defslots 'defgdkslot current-class slots))
(defun def-fun (prefix name res-type class params &key get)
- (let ((fun-name (symbolicate prefix class (if get '-get- '-) name))
- (param-list (mapcar #'car params)))
- `(progn
- (defcfun ,fun-name ,res-type (,class pobject) , at params)
- (unless (fboundp ',name)
- (defgeneric ,name (,class , at param-list)))
- (defmethod ,name ((,class ,class) , at param-list)
- (,fun-name ,class , at param-list)))))
+ (let ((name-lisp (if (consp name) (car name) name))
+ (name-gtk (if (consp name) (cdr name) name)))
+ (let ((fun-name (symbolicate prefix class (if get '-get- '-) name-gtk))
+ (param-list (mapcar #'car params)))
+ `(progn
+ (defcfun ,fun-name ,res-type (,class pobject) , at params)
+ (unless (fboundp ',name-lisp)
+ (defgeneric ,name-lisp (,class , at param-list)))
+ (defmethod ,name-lisp ((,class ,class) , at param-list)
+ (,fun-name ,class , at param-list))))))
(defun defsetter (prefix name slot-type class)
(let ((setter (symbolicate prefix class '-set- name)))
`(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (push ',name (get ',class 'slots)))
+ (save-setter ,class ,name)
(defcfun ,setter :void (widget pobject) (value ,slot-type))
(unless (fboundp '(setf ,name))
(defgeneric (setf ,name) (value ,class)))
@@ -91,26 +90,5 @@
, at body)
(free ,(or for-free name)))))
-(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 DEFSLOTS* 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)))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/26 17:16:13 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/28 10:31:30 1.4
@@ -31,59 +31,113 @@
(defmethod (setf pointer) :after (value (g-object g-object))
(declare (type foreign-pointer value))
(unless (null-pointer-p value)
- (format t "Creating ~a ~a~%" g-object value)
+ (debug-out "Creating ~a ~a~%" g-object value)
(g-object-weak-ref value (callback destroy-object) (null-pointer))))
-(defcfun "g_object_set_property" :void
- (object pobject) (name :string) (value pobject))
+;; (defcfun "g_object_set_property" :void
+;; (object pobject) (name :string) (value pobject))
-(defcfun "g_object_get_property" :void
- (object pobject) (name :string) (value pobject))
+;; (defcfun "g_object_get_property" :void
+;; (object pobject) (name :string) (value pobject))
-(defgeneric (setf property) (values g-object &rest keys))
-(defmethod (setf property) (values (g-object g-object) &rest keys)
- "Usage: (setf (property object :property) value)
+(defmacro generate-property-accessors (name object set get type
+ class find prop-slot)
+ `(progn
+ (defgeneric ,type (,object key))
+ (defmethod ,type ((,object ,object) (key symbol))
+ (,type ,object (string-downcase key)))
+ (defmethod ,type ((,object ,object) (key string))
+ "Should return GType of property KEY."
+ (or (cdr (assoc key (,prop-slot ,object)))
+ (let* ((gclass (make-instance ',class :object ,object))
+ (prop (,find gclass key)))
+ (when prop
+ (let ((g-type (g-type prop)))
+ (setf (,prop-slot ,object)
+ (acons key g-type (,prop-slot ,object)))
+ g-type)))
+ (error "Incorrect property name ~a" key)))
+
+ ,@(when set
+ `((defcfun ,set :void
+ (object pobject) (name :string) (value pobject))
+ (defgeneric (setf ,name) (values ,object &rest keys))
+ (defmethod (setf ,name) (values (,object ,object) &rest keys)
+ "Usage:
+ (setf (property object :property) value)
(setf (property object :prop1 :prop2) (list value1 value2))"
- (mapc (lambda (key value)
- (declare (type (or symbol string) key))
- ;(debug-out "key: ~a, value: ~a, type: ~a~%" key value
- ; (property-type g-object key))
- (let ((skey (string-downcase key)))
- (with-g-value (:value value :g-type (property-type g-object skey))
- (g-object-set-property g-object skey *g-value*))))
- keys (if (listp values) values (list values))))
-
-(defgeneric property (g-object &rest keys))
-
-(defmethod property ((g-object g-object) &rest keys)
- "Usage (property object :prop1) -> value1
+ (mapc (lambda (key value)
+ (declare (type (or symbol string) key))
+ (let ((skey (string-downcase key)))
+ (with-g-value (:value value :g-type (,type ,object skey))
+ (,set ,object skey *g-value*))))
+ keys (if (listp values) values (list values))))))
+
+ (defcfun ,get :void
+ (object pobject) (name :string) (value pobject))
+ (defgeneric ,name (,object &rest keys))
+ (defmethod ,name ((,object ,object) &rest keys)
+ "Usage
+ (property object :prop1) -> value1
(property object :prop1 :prop2 ...) -> (value1 value2 ...)"
- (funcall (lambda (x) (if (cdr x) x (car x)))
- (mapcar (lambda (key)
- (let* ((skey (string-downcase key))
- (g-type (property-type g-object skey)))
- (with-g-value
- (:g-type g-type)
- (g-object-get-property g-object skey *g-value*))))
- keys)))
-
-(defgeneric property-type (g-object key))
-
-(defmethod property-type ((g-object g-object) (key symbol))
- (property-type g-object (string-downcase key)))
-
-(defmethod property-type ((g-object g-object) (key string))
- "Should return GType of property KEY."
- (or (cdr (assoc key (%properties g-object)))
- (let* ((gclass (make-instance 'g-object-class :object g-object))
- (prop (find-property gclass key)))
- (when prop
- (let ((g-type (g-type prop)))
- (setf (%properties g-object)
- (acons key g-type (%properties g-object)))
- g-type)))
- (error "Incorrect property name ~a" key)))
+ (funcall (lambda (x) (if (cdr x) x (car x)))
+ (mapcar (lambda (key)
+ (let* ((skey (string-downcase key))
+ (g-type (,type ,object skey)))
+ (with-g-value
+ (:g-type g-type)
+ (,get ,object skey *g-value*))))
+ keys)))))
+
+(generate-property-accessors property g-object
+ g-object-set-property g-object-get-property
+ property-type
+ g-object-class find-property %properties)
+
+
+;; (defgeneric (setf property) (values g-object &rest keys))
+
+;; (defmethod (setf property) (values (g-object g-object) &rest keys)
+;; "Usage: (setf (property object :property) value)
+;; (setf (property object :prop1 :prop2) (list value1 value2))"
+;; (mapc (lambda (key value)
+;; (declare (type (or symbol string) key))
+;; (let ((skey (string-downcase key)))
+;; (with-g-value (:value value :g-type (property-type g-object skey))
+;; (g-object-set-property g-object skey *g-value*))))
+;; keys (if (listp values) values (list values))))
+
+;; (defgeneric property (g-object &rest keys))
+
+;; (defmethod property ((g-object g-object) &rest keys)
+;; "Usage (property object :prop1) -> value1
+;; (property object :prop1 :prop2 ...) -> (value1 value2 ...)"
+;; (funcall (lambda (x) (if (cdr x) x (car x)))
+;; (mapcar (lambda (key)
+;; (let* ((skey (string-downcase key))
+;; (g-type (property-type g-object skey)))
+;; (with-g-value
+;; (:g-type g-type)
+;; (g-object-get-property g-object skey *g-value*))))
+;; keys)))
+
+;; (defgeneric property-type (g-object key))
+
+;; (defmethod property-type ((g-object g-object) (key symbol))
+;; (property-type g-object (string-downcase key)))
+
+;; (defmethod property-type ((g-object g-object) (key string))
+;; "Should return GType of property KEY."
+;; (or (cdr (assoc key (%properties g-object)))
+;; (let* ((gclass (make-instance 'g-object-class :object g-object))
+;; (prop (find-property gclass key)))
+;; (when prop
+;; (let ((g-type (g-type prop)))
+;; (setf (%properties g-object)
+;; (acons key g-type (%properties g-object)))
+;; g-type)))
+;; (error "Incorrect property name ~a" key)))
(defbitfield connect-flags
(:none 0)
@@ -105,11 +159,9 @@
(defcallback free-closure :void ((data :pointer) (closure :pointer))
(declare (ignore data))
- (when closure
+ (when (not (null-pointer-p closure))
(remhash (pointer-address closure) *objects*)))
-
-
(defcfun "g_closure_add_finalize_notifier" :void
(closure :pointer) (data :pointer) (func pfunction))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/26 17:16:13 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/28 10:31:30 1.4
@@ -61,9 +61,6 @@
#:register-type
#:register-package
- #:setf-init
- #:init-slots
-
#:ref
#:unref
@@ -74,6 +71,7 @@
#:g-param-spec
#:g-object-newv
#:new
+ #:make-closure
#:defgtkslot
#:defgtkslots
More information about the gtk-cffi-cvs
mailing list