[gtk-cffi-cvs] CVS gtk-cffi/g-object
CVS User rklochkov
rklochkov at common-lisp.net
Sat Jan 21 18:35:00 UTC 2012
Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object
In directory tiger.common-lisp.net:/tmp/cvs-serv13474/g-object
Modified Files:
defslots.lisp g-object.lisp
Log Message:
Refactored defslots/def*funs
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/10/23 08:39:53 1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/01/21 18:35:00 1.7
@@ -7,11 +7,19 @@
(in-package #:g-object-cffi)
-(defun defslot (prefix current-class slot-name slot-type)
- (let ((name-lisp (if (consp slot-name) (car slot-name) slot-name))
- (name-gtk (if (consp slot-name) (cdr slot-name) slot-name)))
- (let ((getter (symbolicate prefix current-class '-get- name-gtk))
- (setter (symbolicate prefix current-class '-set- name-gtk)))
+(defvar *gtk-prefixes* nil
+ "Assoc: lisp package -> C function prefix")
+
+(defun register-prefix (package prefix)
+ (push (cons package prefix) *gtk-prefixes*))
+
+(defun pair (maybe-pair)
+ (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
+
+(defun expand-defslot (prefix current-class slot-name slot-type)
+ (destructuring-bind (name-lisp . name-gtk) (pair slot-name)
+ (let ((getter (symbolicate prefix '- current-class '-get- name-gtk))
+ (setter (symbolicate prefix '- current-class '-set- name-gtk)))
`(progn
(save-setter ,current-class ,name-lisp)
(defcfun ,getter ,slot-type (object pobject))
@@ -24,29 +32,31 @@
(defmethod (setf ,name-lisp) (value (object ,current-class))
(,setter object value) value)))))
-(defmacro defgtkslot (current-class slot-name slot-type)
- (defslot 'gtk- current-class slot-name slot-type))
+(template ((defgtkslot 'gtk)
+ (defgdkslot 'gdk)
+ (defslot (assoc *package* *gtk-prefixes*)))
+ (destructuring-bind (name prefix) param
+ `(defmacro ,name (current-class slot-name slot-type)
+ (expand-defslot ,prefix current-class slot-name slot-type))))
-(defun defslots (def-macro current-class slots)
+(defun expand-defslots (prefix current-class slots)
`(progn
(clear-setters ,current-class)
,@(iter
(for x on slots by #'cddr)
- (collect (list def-macro current-class (first x) (second x))))))
-
-(defmacro defgtkslots (current-class &rest slots)
- (defslots 'defgtkslot current-class slots))
+ (collect
+ (expand-defslot prefix current-class (first x) (second x))))))
-(defmacro defgdkslot (current-class slot-name slot-type)
- (defslot 'gdk- current-class slot-name slot-type))
-
-(defmacro defgdkslots (current-class &rest slots)
- (defslots 'defgdkslot current-class slots))
-
-(defun def-fun (prefix name res-type class params &key get)
- (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))
+(template ((defgtkslots 'gtk)
+ (defgdkslots 'gdk)
+ (defslots (assoc *package* *gtk-prefixes*)))
+ (destructuring-bind (name prefix) param
+ `(defmacro ,name (current-class &rest slots)
+ (expand-defslots ,prefix current-class slots))))
+
+(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)))
`(progn
(defcfun ,fun-name ,res-type (,class pobject) , at params)
@@ -55,9 +65,24 @@
(defmethod ,name-lisp ((,class ,class) , at param-list)
(,fun-name ,class , at param-list))))))
-(defun defsetter (prefix name slot-type class params last)
- (let ((name-lisp (if (consp name) (car name) name))
- (name-gtk (if (consp name) (cdr name) name)))
+
+(template ((defgtkfun 'gtk)
+ (defgdkfun 'gdk)
+ (deffun (assoc *package* *gtk-prefixes*)))
+ (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 (assoc *package* *gtk-prefixes*)))
+ (destructuring-bind (name prefix) param
+ `(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)))
`(progn
@@ -72,52 +97,35 @@
(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))
-
-(defmacro defgdkfun (name res-type class &rest params)
- (def-fun 'gdk- name res-type class params))
-
-(defmacro defgtkgetter (name res-type class &rest params)
- (def-fun 'gtk- name res-type class params :get t))
-
-(defmacro defgdkgetter (name res-type class &rest params)
- (def-fun 'gdk- name res-type class params :get t))
-
-(defmacro defgtksetter (name slot-type class last &rest params)
- (defsetter 'gtk- name slot-type class params last))
-
-(defmacro defgdksetter (name slot-type class last &rest params)
- (defsetter 'gdk- name slot-type class params last))
-
-(flet ((inject-class (fun class)
- (list* (first fun) (second fun) class (nthcdr 2 fun)))
- (inject-class2 (fun class last)
- (list* (first fun) (second fun) class last (nthcdr 2 fun))))
- (defmacro defgtkfuns (class &rest funs)
- (cons 'progn
- (mapcar (lambda (fun)
+(template ((defgtksetter 'gtk)
+ (defgdksetter 'gdk)
+ (defsetter (assoc *package* *gtk-prefixes*)))
+ (destructuring-bind (name prefix) param
+ `(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
+ (mapcar (lambda (fun)
+ (destructuring-bind (name slot-type &rest params)
+ (if (keywordp (car fun)) (cdr fun) fun)
(case (car fun)
- (:set `(defgtksetter ,@(inject-class2 (cdr fun)
- class nil)))
- (:set-last `(defgtksetter ,@(inject-class2 (cdr fun)
- class t)))
- (:get `(defgtkgetter ,@(inject-class (cdr fun) class)))
- (t `(defgtkfun ,@(inject-class fun class)))))
+ (:set (expand-defsetter prefix
+ name slot-type class params nil))
+ (:set-last (expand-defsetter prefix
+ name slot-type class
+ params t))
+ (:get (expand-deffun prefix
+ name slot-type class params :get t))
+ (t (expand-deffun prefix name slot-type class params)))))
funs)))
- (defmacro defgdkfuns (class &rest funs)
- (cons 'progn
- (mapcar (lambda (fun)
- (case (car fun)
- (:set `(defgdksetter ,@(inject-class2 (cdr fun)
- class nil)))
- (:set-last `(defgdksetter ,@(inject-class2 (cdr fun)
- class t)))
- (:get `(defgdkgetter ,@(inject-class (cdr fun) class)))
- (t `(defgdkfun ,@(inject-class fun class)))))
- funs))))
-
+(template ((defgtkfuns 'gtk)
+ (defgdkfuns 'gdk)
+ (deffuns (assoc *package* *gtk-prefixes*)))
+ (destructuring-bind (name prefix) param
+ `(defmacro ,name (class &rest 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.lisp 2011/09/21 12:03:47 1.7
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/01/21 18:35:00 1.8
@@ -10,7 +10,8 @@
(defclass g-object (object)
((signals :accessor gsignals :initform nil)
;; redefining VOLATILE for saving in hash
- (cffi-object::volatile :accessor volatile :initarg :volatile :initform nil)
+ (cffi-object::volatile :initform nil)
+ (cffi-object::free-after :initform nil)
(%properties :accessor %properties :initform nil :allocation :class))
(:documentation "Lisp wrapper for GObject"))
More information about the gtk-cffi-cvs
mailing list