/[gtk-cffi]/gtk-cffi/g-object/defslots.lisp
ViewVC logotype

Contents of /gtk-cffi/g-object/defslots.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Mon Dec 24 16:32:05 2012 UTC (15 months, 3 weeks ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.15: +15 -12 lines
Reloading after CVS was broken
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; defslots.lisp --- def*slot(s) macros for group binding setters and getters
4 ;;;
5 ;;; Copyright (C) 2011, Roman Klochkov <kalimehtar@mail.ru>
6 ;;;
7
8 (in-package #:g-object-cffi)
9
10 (defvar *gtk-prefixes* nil
11 "Assoc: lisp package -> C function prefix")
12
13 (defun register-prefix (package prefix)
14 (push (cons package prefix) *gtk-prefixes*))
15
16 (defun get-prefix ()
17 (cdr (assoc *package* *gtk-prefixes*)))
18
19 ;(defun pair (maybe-pair)
20 ; (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
21
22 (defun expand-defslot (prefix current-class slot-name slot-type)
23 (destructuring-bind (name-lisp . name-gtk) (pair slot-name)
24 (let ((getter (symbolicate prefix '- current-class '-get- name-gtk))
25 (setter (symbolicate prefix '- current-class '-set- name-gtk)))
26 `(progn
27 (save-setter ,current-class ,name-lisp)
28 (export ',name-lisp)
29 (defcfun ,getter ,slot-type (object pobject))
30 (defcfun ,setter :void (widget pobject) (value ,slot-type))
31 (unless (fboundp ',name-lisp)
32 (defgeneric ,name-lisp (,current-class)))
33 (unless (fboundp '(setf ,name-lisp))
34 (defgeneric (setf ,name-lisp) (value ,current-class)))
35 (defmethod ,name-lisp ((object ,current-class)) (,getter object))
36 (defmethod (setf ,name-lisp) (value (object ,current-class))
37 (,setter object value) value)))))
38
39 (template (name prefix) ((defgtkslot 'gtk)
40 (defgdkslot 'gdk)
41 (defslot (get-prefix)))
42 `(defmacro ,name (current-class slot-name slot-type)
43 (expand-defslot ,prefix current-class slot-name slot-type)))
44
45 (defun expand-defslots (prefix current-class slots)
46 `(progn
47 (clear-setters ,current-class)
48 ,@(iter
49 (for x on slots by #'cddr)
50 (collect
51 (expand-defslot prefix current-class (first x) (second x))))))
52
53 (template (name prefix) ((defgtkslots 'gtk)
54 (defgdkslots 'gdk)
55 (defslots (get-prefix)))
56 `(defmacro ,name (current-class &body slots)
57 (expand-defslots ,prefix current-class slots)))
58
59 (defun param-list (l)
60 (nconc (mapcar #'ensure-car l)
61 (if (find '&key l) '(&allow-other-keys) nil)))
62
63 (defun expand-deffun (prefix name res-type class params &key get)
64 (destructuring-bind (name-lisp . name-gtk) (pair name)
65 (let* ((fun-name (symbolicate prefix '- class (if get '-get- '-) name-gtk))
66 (param-list (param-list params))
67 (cparams (remove '&key params)))
68 `(progn
69 (export ',name-lisp)
70 (defcfun ,fun-name ,res-type (,class pobject) ,@cparams)
71 (unless (fboundp ',name-lisp)
72 (defgeneric ,name-lisp (,class ,@param-list)))
73 (defmethod ,name-lisp ((,class ,class) ,@param-list)
74 (,fun-name ,class ,@(mapcar #'car cparams)))))))
75
76
77 (template (name prefix) ((defgtkfun 'gtk)
78 (defgdkfun 'gdk)
79 (deffun (get-prefix)))
80 `(defmacro ,name (name res-type class &rest params)
81 (expand-deffun ,prefix name res-type class params)))
82
83 (template (name prefix) ((defgtkgetter 'gtk)
84 (defgdkgetter 'gdk)
85 (defgetter (get-prefix)))
86 `(defmacro ,name (name res-type class &rest params)
87 (expand-deffun ,prefix name res-type class params :get t)))
88
89
90
91 (defun expand-defsetter (prefix name slot-type class params last)
92 (destructuring-bind (name-lisp . name-gtk) (pair name)
93 (let ((setter (symbolicate prefix '- class '-set- name-gtk))
94 (param-list (param-list params))
95 (cparams (remove '&key params)))
96 `(progn
97 (export ',name-lisp)
98 ,(unless params `(save-setter ,class ,name-lisp))
99 ,(if last
100 `(defcfun ,setter :void (widget pobject)
101 ,@cparams (value ,slot-type))
102 `(defcfun ,setter :void (widget pobject)
103 (value ,slot-type) ,@cparams))
104 (unless (fboundp '(setf ,name-lisp))
105 (defgeneric (setf ,name-lisp) (value ,class ,@param-list)))
106 (defmethod (setf ,name-lisp) (value (object ,class) ,@param-list)
107 (,setter object value ,@(mapcar #'car cparams)) value)))))
108
109 (template (name prefix) ((defgtksetter 'gtk)
110 (defgdksetter 'gdk)
111 (defsetter (get-prefix)))
112 `(defmacro ,name (name slot-type class last &rest params)
113 (expand-defsetter ,prefix name slot-type class params last)))
114
115 (defun expand-deffuns (prefix class funs)
116 (cons 'progn
117 (mapcar (lambda (fun)
118 (destructuring-bind (name slot-type &rest params)
119 (if (keywordp (car fun)) (cdr fun) fun)
120 (case (car fun)
121 (:set (expand-defsetter prefix
122 name slot-type class params nil))
123 (:set-last (expand-defsetter prefix
124 name slot-type class
125 params t))
126 (:get (expand-deffun prefix
127 name slot-type class params :get t))
128 (t (expand-deffun prefix name slot-type class params)))))
129 funs)))
130
131 (template (name prefix) ((defgtkfuns 'gtk)
132 (defgdkfuns 'gdk)
133 (deffuns (get-prefix)))
134 `(defmacro ,name (class &body funs)
135 (expand-deffuns ,prefix class funs)))
136
137 (defmacro with-object ((name &optional for-free) init &rest body)
138 `(let ((,name ,init))
139 (unwind-protect
140 (progn
141 ,@body)
142 (free ,(or for-free name)))))
143
144 (defvar *callback* nil
145 "Lisp callback for use in gtk methods, that need callback function")
146
147 (defgeneric foreach (class func &optional data)
148 (:documentation "For each element in CLASS execute FUNC"))
149 (defmacro make-foreach (class &rest params)
150 "Class is a symbol: class or list: (class gtk-name)"
151 (destructuring-bind (class gtk-name)
152 (if (listp class) class
153 (list class (symbolicate 'gtk- class '-foreach)))
154 (let ((cb-name (gensym)))
155 `(progn
156 (defcfun ,gtk-name :void
157 (,class pobject) (func pfunction) (data (pdata :free-to-foreign t)))
158 (defcallback ,cb-name :void ,params ;((tag pobject) (data pdata))
159 (funcall *callback* ,@(mapcar #'car params)))
160 (defmethod foreach ((,class ,class) func &optional data)
161 (if (functionp func)
162 (let ((*callback* func))
163 (,gtk-name ,class (callback ,cb-name) data))
164 (,gtk-name ,class func data)))))))
165
166 (defmacro set-callback (object setter cb-standard func data destroy-notify
167 &rest add-params)
168 `(let ((func ,func) (data ,data))
169 (if (functionp func)
170 (,setter ,object ,@add-params
171 (callback ,cb-standard)
172 func
173 (callback free-storage))
174 (,setter ,object ,@add-params func data
175 (or ,destroy-notify
176 (if (or (null data)
177 (pointerp data) (typep data 'g-object))
178 (null-pointer) (callback free-storage)))))))

  ViewVC Help
Powered by ViewVC 1.1.5