[gtk-cffi-cvs] CVS gtk-cffi/g-object
CVS User rklochkov
rklochkov at common-lisp.net
Sat Sep 10 16:26:10 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object
In directory tiger.common-lisp.net:/tmp/cvs-serv27495/g-object
Modified Files:
defslots.lisp g-object-class.lisp g-object.lisp g-type.lisp
package.lisp
Log Message:
Some refactoring. Now we can use (show #(1 2 3)) or (show '(1 2 3)) to lookup
through the sequence in GTK list view
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/28 10:31:30 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/09/10 16:26:10 1.3
@@ -55,15 +55,18 @@
(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
- (save-setter ,class ,name)
- (defcfun ,setter :void (widget pobject) (value ,slot-type))
- (unless (fboundp '(setf ,name))
- (defgeneric (setf ,name) (value ,class)))
- (defmethod (setf ,name) (value (object ,class))
- (,setter object value) value))))
+(defun defsetter (prefix name slot-type class params)
+ (let ((name-lisp (if (consp name) (car name) name))
+ (name-gtk (if (consp name) (cdr name) name)))
+ (let ((setter (symbolicate prefix class '-set- name-gtk))
+ (param-list (mapcar #'car params)))
+ `(progn
+ ,(unless params `(save-setter ,class ,name-lisp))
+ (defcfun ,setter :void (widget pobject) (value ,slot-type) , at params)
+ (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)))))
(defmacro defgtkfun (name res-type class &rest params)
(def-fun 'gtk- name res-type class params))
@@ -77,11 +80,33 @@
(defmacro defgdkgetter (name res-type class &rest params)
(def-fun 'gdk- name res-type class params :get t))
-(defmacro defgtksetter (name slot-type class)
- (defsetter 'gtk- name slot-type class))
+(defmacro defgtksetter (name slot-type class &rest params)
+ (defsetter 'gtk- name slot-type class params))
-(defmacro defgdksetter (name slot-type class)
- (defsetter 'gdk- name slot-type class))
+(defmacro defgdksetter (name slot-type class &rest params)
+ (defsetter 'gdk- name slot-type class params))
+
+(defun inject-class (fun class)
+ (list* (first fun) (second fun) class (nthcdr 2 fun)))
+
+(defmacro defgtkfuns (class &rest funs)
+ (cons 'progn
+ (mapcar (lambda (fun)
+ (case (car fun)
+ (:set `(defgtksetter ,@(inject-class (cdr fun) class)))
+ (:get `(defgtkgetter ,@(inject-class (cdr fun) class)))
+ (t `(defgtkfun ,@(inject-class fun class)))))
+ funs)))
+
+(defmacro defgdkfuns (class &rest funs)
+ (cons 'progn
+ (mapcar (lambda (fun)
+ (case (car fun)
+ (:set `(defgdksetter ,@(inject-class (cdr fun) class)))
+ (:get `(defgdkgetter ,@(inject-class (cdr fun) class)))
+ (t `(defgdkfun ,@(inject-class fun 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-class.lisp 2011/08/26 17:16:13 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2011/09/10 16:26:10 1.4
@@ -33,8 +33,7 @@
())
(defmethod list-properties ((g-object-class g-object-class))
- (with-array
- (g-object-class-list-properties g-object-class *array-length*)))
+ (g-object-class-list-properties g-object-class *array-length*))
(defcfun "g_object_class_find_property" :pointer
(obj-class pobject) (key :string))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/28 10:31:30 1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/09/10 16:26:10 1.5
@@ -96,49 +96,6 @@
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)
:after
@@ -209,7 +166,9 @@
(defmethod connect ((g-object g-object) c-handler
&key signal data after swapped)
- (let* ((str-signal (string-downcase signal))
+ (let* ((str-signal (string-downcase signal))
+ (c-handler (if (and (symbolp c-handler) (fboundp c-handler))
+ (symbol-function c-handler) c-handler))
(handler-id
(typecase c-handler
(function (g-signal-connect-closure
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/08/26 17:16:13 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/09/10 16:26:10 1.4
@@ -114,5 +114,4 @@
(defcfun g-type-children (garray g-type) (type g-type) (n-children :pointer))
(defun children (type)
- (with-array
- (g-type-children type *array-length*)))
+ (g-type-children type *array-length*))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/28 10:31:30 1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/09/10 16:26:10 1.5
@@ -73,6 +73,7 @@
#:new
#:make-closure
+ ; utility functions
#:defgtkslot
#:defgtkslots
#:defgdkslot
@@ -82,4 +83,6 @@
#:defgtksetter
#:defgdksetter
#:defgtkfun
- #:defgdkfun))
+ #:defgdkfun
+ #:defgtkfuns
+ #:defgdkfuns))
More information about the gtk-cffi-cvs
mailing list