[gtk-cffi-cvs] CVS gtk-cffi/g-object
CVS User rklochkov
rklochkov at common-lisp.net
Mon Feb 20 16:51:37 UTC 2012
Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object
In directory tiger.common-lisp.net:/tmp/cvs-serv21507/g-object
Modified Files:
defslots.lisp g-object-cffi.asd g-object.lisp g-value.lisp
pobject.lisp
Log Message:
Finished GtkWindow
Made global clean-up. Now it compiles all from scratch with asdf:compile-op
Add version-dependent functions (for ex. "since gtk 3.2")
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/02/12 17:29:41 1.9
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/02/20 16:51:37 1.10
@@ -35,12 +35,11 @@
(defmethod (setf ,name-lisp) (value (object ,current-class))
(,setter object value) value)))))
-(template ((defgtkslot 'gtk)
- (defgdkslot 'gdk)
- (defslot (get-prefix)))
- (destructuring-bind (name prefix) param
- `(defmacro ,name (current-class slot-name slot-type)
- (expand-defslot ,prefix current-class slot-name slot-type))))
+(template (name prefix) ((defgtkslot 'gtk)
+ (defgdkslot 'gdk)
+ (defslot (get-prefix)))
+ `(defmacro ,name (current-class slot-name slot-type)
+ (expand-defslot ,prefix current-class slot-name slot-type)))
(defun expand-defslots (prefix current-class slots)
`(progn
@@ -50,62 +49,65 @@
(collect
(expand-defslot prefix current-class (first x) (second x))))))
-(template ((defgtkslots 'gtk)
- (defgdkslots 'gdk)
- (defslots (get-prefix)))
- (destructuring-bind (name prefix) param
- `(defmacro ,name (current-class &body slots)
- (expand-defslots ,prefix current-class slots))))
+(template (name prefix) ((defgtkslots 'gtk)
+ (defgdkslots 'gdk)
+ (defslots (get-prefix)))
+ `(defmacro ,name (current-class &body slots)
+ (expand-defslots ,prefix current-class slots)))
+
+(defun param-list (l)
+ (nconc (mapcar #'ensure-car l)
+ (if (find '&key l) '(&allow-other-keys) nil)))
(defun expand-deffun (prefix name res-type class params &key get)
(destructuring-bind (name-lisp . name-gtk) (pair name)
- (let ((fun-name (symbolicate prefix '- class (if get '-get- '-) name-gtk))
- (param-list (mapcar #'car params)))
+ (let* ((fun-name (symbolicate prefix '- class (if get '-get- '-) name-gtk))
+ (param-list (param-list params))
+ (cparams (remove '&key params)))
`(progn
- (defcfun ,fun-name ,res-type (,class pobject) , at params)
+ (defcfun ,fun-name ,res-type (,class pobject) , at cparams)
(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))))))
+ (,fun-name ,class ,@(mapcar #'car cparams)))))))
-(template ((defgtkfun 'gtk)
- (defgdkfun 'gdk)
- (deffun (get-prefix)))
- (destructuring-bind (name prefix) param
- `(defmacro ,name (name res-type class &rest params)
- (expand-deffun ,prefix name res-type class params))))
-
-(template ((defgtkgetter 'gtk)
- (defgdkgetter 'gdk)
- (defgetter (get-prefix)))
- (destructuring-bind (name prefix) param
- `(defmacro ,name (name res-type class &rest params)
- (expand-deffun ,prefix name res-type class params :get t))))
+(template (name prefix) ((defgtkfun 'gtk)
+ (defgdkfun 'gdk)
+ (deffun (get-prefix)))
+ `(defmacro ,name (name res-type class &rest params)
+ (expand-deffun ,prefix name res-type class params)))
+
+(template (name prefix) ((defgtkgetter 'gtk)
+ (defgdkgetter 'gdk)
+ (defgetter (get-prefix)))
+ `(defmacro ,name (name res-type class &rest params)
+ (expand-deffun ,prefix name res-type class params :get t)))
+
(defun expand-defsetter (prefix name slot-type class params last)
(destructuring-bind (name-lisp . name-gtk) (pair name)
(let ((setter (symbolicate prefix '- class '-set- name-gtk))
- (param-list (mapcar #'car params)))
+ (param-list (param-list params))
+ (cparams (remove '&key params)))
`(progn
,(unless params `(save-setter ,class ,name-lisp))
,(if last
`(defcfun ,setter :void (widget pobject)
- , at params (value ,slot-type))
+ , at cparams (value ,slot-type))
`(defcfun ,setter :void (widget pobject)
- (value ,slot-type) , at params))
+ (value ,slot-type) , at cparams))
(unless (fboundp '(setf ,name-lisp))
(defgeneric (setf ,name-lisp) (value ,class , at param-list)))
(defmethod (setf ,name-lisp) (value (object ,class) , at param-list)
- (,setter object value , at param-list) value)))))
+ (,setter object value ,@(mapcar #'car cparams)) value)))))
-(template ((defgtksetter 'gtk)
- (defgdksetter 'gdk)
- (defsetter (get-prefix)))
- (destructuring-bind (name prefix) param
- `(defmacro ,name (name slot-type class last &rest params)
- (expand-defsetter ,prefix name slot-type class params last))))
+(template (name prefix) ((defgtksetter 'gtk)
+ (defgdksetter 'gdk)
+ (defsetter (get-prefix)))
+ `(defmacro ,name (name slot-type class last &rest params)
+ (expand-defsetter ,prefix name slot-type class params last)))
(defun expand-deffuns (prefix class funs)
(cons 'progn
@@ -123,12 +125,11 @@
(t (expand-deffun prefix name slot-type class params)))))
funs)))
-(template ((defgtkfuns 'gtk)
- (defgdkfuns 'gdk)
- (deffuns (get-prefix)))
- (destructuring-bind (name prefix) param
- `(defmacro ,name (class &body funs)
- (expand-deffuns ,prefix class funs))))
+(template (name prefix) ((defgtkfuns 'gtk)
+ (defgdkfuns 'gdk)
+ (deffuns (get-prefix)))
+ `(defmacro ,name (class &body funs)
+ (expand-deffuns ,prefix class funs)))
(defmacro with-object ((name &optional for-free) init &rest body)
`(let ((,name ,init))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2012/02/12 17:29:41 1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2012/02/20 16:51:37 1.5
@@ -14,7 +14,7 @@
:author "Roman Klochkov <kalimehtar at mail.ru>"
:version "0.3"
:license "BSD"
- :depends-on (cffi-object g-lib-cffi gtk-cffi-utils)
+ :depends-on (g-lib-cffi gtk-cffi-utils)
:components
((:file package)
(:file loadlib :depends-on (package))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/01/21 18:35:00 1.8
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/02/20 16:51:37 1.9
@@ -10,8 +10,8 @@
(defclass g-object (object)
((signals :accessor gsignals :initform nil)
;; redefining VOLATILE for saving in hash
- (cffi-object::volatile :initform nil)
- (cffi-object::free-after :initform nil)
+ (cffi-objects::volatile :initform nil)
+ (cffi-objects::free-after :initform nil)
(%properties :accessor %properties :initform nil :allocation :class))
(:documentation "Lisp wrapper for GObject"))
@@ -140,7 +140,7 @@
(hint :pointer)
(data :pointer))
(declare (ignore hint data))
- (let ((lisp-func (object closure))
+ (let ((lisp-func (find-object closure))
(lisp-params
(iter
(for i from 0 below n-values)
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/02/12 17:29:41 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/02/20 16:51:37 1.4
@@ -159,8 +159,8 @@
(fundamental-type (g-type-fundamental g-type)))
(case fundamental-type
(#.(keyword->g-type :boxed)
- (object (g-value-get-boxed value)
- :class (g-type->lisp g-type)))
+ (find-object (g-value-get-boxed value)
+ (g-type->lisp g-type)))
(#.(keyword->g-type :enum)
(convert-from-foreign
(g-value-get-enum value) (g-type->lisp g-type)))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2012/01/25 19:15:08 1.5
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2012/02/20 16:51:37 1.6
@@ -19,9 +19,9 @@
make up lisp object"
(declare (type foreign-pointer ptr))
(unless (null-pointer-p ptr)
- (let ((class (or (cffi-object::obj-class cffi-pobject)
+ (let ((class (or (object-class cffi-pobject)
(g-type->lisp (g-type-from-instance ptr)))))
- (object ptr :class class))))
+ (find-object ptr class))))
;; register as object type for g-list
(defmethod g-lib-cffi::object-type ((type-name (eql 'pobject))) t)
@@ -30,7 +30,7 @@
(defclass storage (object)
((data :accessor data :initarg :data)
- (cffi-object::volatile :initform nil :accessor volatile))
+ (volatile :initform nil :accessor volatile))
(:documentation "A storage for any data for callbacks.
On make-instance it allocates one byte on heap and associates itself
with the address of that byte."))
@@ -44,7 +44,7 @@
(defcallback free-storage :void ((data :pointer) (closure :pointer))
(declare (ignore closure))
(unless (null-pointer-p data)
- (setf (pointer (object data)) (null-pointer))
+ (setf (pointer (find-object data)) (null-pointer))
(remhash (pointer-address data) *objects*)
(foreign-free data)))
@@ -63,7 +63,7 @@
(defmethod translate-from-foreign (ptr (type cffi-pdata))
"Returns saved data."
- (let ((obj (object ptr)))
+ (let ((obj (find-object ptr)))
(if obj
(typecase obj
(storage (prog1 (data obj) (free-returned-if-needed type obj)))
@@ -86,20 +86,6 @@
(when param
(free-sent-if-needed type param)))
-;; (defmethod translate-to-foreign :around ((any-data storage) (name cffi-pdata))
-;; (call-next-method any-data name))
-
-;; (define-foreign-type g-list-object (g-list)
-;; ()
-;; (:actual-type :pointer)
-;; (:simple-parser g-list-object)
-;; (:documentation "GList with pointers to GObjects"))
-
-;; (defmethod translate-from-foreign :around (ptr (name g-list-object))
-;; (declare (ignorable ptr name))
-;; (mapcar (lambda (x) (convert-from-foreign x 'pobject))
-;; (call-next-method)))
-
(defctype g-list-object (g-list :elt pobject))
More information about the gtk-cffi-cvs
mailing list