1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
4 ;; This library is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU Lesser General Public
6 ;; License as published by the Free Software Foundation; either
7 ;; version 2 of the License, or (at your option) any later version.
9 ;; This library is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;; Lesser General Public License for more details.
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this library; if not, write to the Free Software
16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18 ;; $Id: gtkobject.lisp,v 1.9 2001-05-29 16:00:52 espen Exp $
26 ; (defun name-to-string (name)
27 ; (substitute #\_ #\- (string-downcase (string name))))
29 ; (defun string-to-name (name &optional (package "KEYWORD"))
30 ; (intern (substitute #\- #\_ (string-upcase name)) package))
33 ;;; Argument stuff - to be removed soon
35 (deftype arg () 'pointer)
37 (defconstant +arg-type-offset+ 0)
38 (defconstant +arg-name-offset+ 4)
39 (defconstant +arg-value-offset+ 8)
40 (defconstant +arg-size+ 16)
42 (defbinding arg-new () arg
45 (defbinding %arg-free () nil
47 (free-contents boolean))
49 (defun arg-free (arg free-contents &optional alien)
51 (alien (%arg-free arg free-contents))
53 (unless (null-pointer-p arg)
56 (intern-destroy-function (type-from-number (arg-type arg)))
57 arg +arg-value-offset+))
58 (deallocate-memory arg)))))
60 (defbinding %arg-reset () nil
64 (funcall (intern-reader-function 'string) arg +arg-name-offset+))
66 (defun (setf arg-name) (name arg)
67 (funcall (intern-writer-function 'string) name arg +arg-name-offset+)
71 (system:sap-ref-32 arg +arg-type-offset+))
73 (defun (setf arg-type) (type arg)
74 (setf (system:sap-ref-32 arg +arg-type-offset+) type))
76 (defun arg-value (arg &optional (type (type-from-number (arg-type arg))))
77 (funcall (intern-reader-function type) arg +arg-value-offset+))
79 ;; One should never call this function on an arg whose value is already set
80 (defun (setf arg-value)
81 (value arg &optional (type (type-from-number (arg-type arg))))
82 (funcall (intern-writer-function type) value arg +arg-value-offset+)
85 (defun (setf return-arg-value)
86 (value arg &optional (type (type-from-number (arg-type arg))))
87 ; this is probably causing a memory leak
88 (funcall (intern-writer-function type) value (arg-value arg 'pointer) 0)
91 (defun arg-array-ref (arg0 index)
92 (system:sap+ arg0 (* index +arg-size+)))
95 ;;;; Superclass for the gtk class hierarchy
97 (eval-when (:compile-toplevel :load-toplevel :execute)
98 (init-types-in-library "/opt/gnome/lib/libgtk-x11-1.3.so")
100 (defclass %object (gobject)
102 (:metaclass gobject-class)
103 (:alien-name "GtkObject")))
106 (defmethod shared-initialize ((object %object) names &rest initargs
108 (declare (ignore initargs names))
110 (%object-sink object)
111 (dolist (signal signals)
112 (apply #'signal-connect object signal)))
114 (defmethod initialize-proxy ((object %object) &rest initargs &key location)
115 (declare (ignore initargs))
117 (%object-sink location))
119 (defbinding %object-sink () nil
123 ;;;; Main loop, timeouts and idle functions
125 (declaim (inline events-pending-p main-iteration))
127 (defbinding (events-pending-p "gtk_events_pending") () boolean)
129 (defbinding get-current-event () gdk:event)
131 (defbinding main-do-event () nil
134 (defbinding main () nil)
136 (defbinding main-level () int)
138 (defbinding main-quit () nil)
140 (defbinding main-iteration-do (&optional (blocking t)) boolean
143 (defun main-iterate-all (&rest args)
144 (declare (ignore args))
145 (when (events-pending-p)
146 (main-iteration-do nil)
149 (system:add-fd-handler (gdk:event-poll-fd) :input #'main-iterate-all)
150 (setq lisp::*periodic-polling-function* #'main-iterate-all)
151 (setq lisp::*max-event-to-sec* 0)
152 (setq lisp::*max-event-to-usec* 1000)
156 ;;;; Metaclass for child classes
158 (defvar *container-to-child-class-mappings* (make-hash-table))
160 (eval-when (:compile-toplevel :load-toplevel :execute)
161 (defclass child-class (virtual-slot-class))
163 (defclass direct-child-slot-definition (direct-virtual-slot-definition)
164 ((arg-name :reader slot-definition-arg-name)))
166 (defclass effective-child-slot-definition
167 (effective-virtual-slot-definition)))
170 (defmethod shared-initialize ((class child-class) names &rest initargs
172 (declare (ignore initargs))
175 (gethash (find-class (first container)) *container-to-child-class-mappings*)
178 (defmethod initialize-instance ((slotd direct-child-slot-definition)
179 &rest initargs &key arg-name)
180 (declare (ignore initargs))
183 (setf (slot-value slotd 'arg-name) arg-name)
184 (error "Need argument name for slot with allocation :arg")))
186 (defmethod direct-slot-definition-class ((class child-class) initargs)
187 (case (getf initargs :allocation)
188 (:arg (find-class 'direct-child-slot-definition))
189 (t (call-next-method))))
191 (defmethod effective-slot-definition-class ((class child-class) initargs)
192 (case (getf initargs :allocation)
193 (:arg (find-class 'effective-child-slot-definition))
194 (t (call-next-method))))
196 (defmethod compute-virtual-slot-accessor
197 ((class child-class) (slotd effective-child-slot-definition) direct-slotds)
198 (with-slots (type) slotd
199 (let ((arg-name (slot-definition-arg-name (first direct-slotds)))
200 (type-number (find-type-number type))
201 ; (reader (intern-reader-function type))
202 ; (writer (intern-writer-function type))
203 ; (destroy (intern-destroy-function type))
207 (with-slots (parent child) object
209 (let ((arg (arg-new type-number)))
210 (setf (arg-name arg) arg-name)
211 (%container-child-getv parent child arg)
214 (intern-reader-function type)
215 arg +arg-value-offset+)
216 (arg-free arg t t))))))
217 #'(lambda (value object)
218 (with-slots (parent child) object
220 (let ((arg (arg-new type-number)))
221 (setf (arg-name arg) arg-name)
223 (intern-writer-function type)
224 value arg +arg-value-offset+)
225 (%container-child-setv parent child arg)
227 (intern-destroy-function type)
228 arg +arg-value-offset+)
233 (defmethod pcl::add-reader-method ((class child-class) generic-function slot-name)
236 (make-instance 'standard-method
237 :specializers (list (find-class 'widget))
238 :lambda-list '(widget)
239 :function #'(lambda (args next-methods)
240 (declare (ignore next-methods))
241 (child-slot-value (first args) slot-name)))))
243 (defmethod pcl::add-writer-method
244 ((class child-class) generic-function slot-name)
247 (make-instance 'standard-method
248 :specializers (list (find-class t) (find-class 'widget))
249 :lambda-list '(value widget)
250 :function #'(lambda (args next-methods)
251 (declare (ignore next-methods))
252 (destructuring-bind (value widget) args
254 (child-slot-value widget slot-name)
258 (defmethod validate-superclass ((class child-class) (super pcl::standard-class))
259 (subtypep (class-name super) 'container-child))
262 (defclass container-child ()
263 ((parent :initarg :parent :type container)
264 (child :initarg :child :type widget)))
269 (defbinding %container-query-child-args () arg
270 (type-number type-number)
272 (n-args unsigned-int :out))
274 (defun query-container-type-dependencies (type-number)
275 (let ((child-slot-types ()))
276 (multiple-value-bind (args n-args)
277 (%container-query-child-args type-number)
279 (push (arg-type (arg-array-ref args i)) child-slot-types)))
281 (append (query-object-type-dependencies type-number) child-slot-types))))
283 (defun default-container-child-name (container-class)
284 (intern (format nil "~A-CHILD" container-class)))
286 (defun expand-container-type (type-number &optional slots)
287 (let* ((class (type-from-number type-number))
288 (super (supertype type-number))
289 (child-class (default-container-child-name class))
291 (multiple-value-bind (args n-args)
292 (%container-query-child-args type-number)
294 (let* ((arg (arg-array-ref args i))
295 (arg-name (arg-name arg))
296 (slot-name (default-slot-name
297 (subseq arg-name (+ (position #\: arg-name) 2))))
298 (type (type-from-number (arg-type arg) #|t|#)))
303 :accessor ,(default-slot-accessor child-class slot-name type)
304 :initarg ,(intern (string slot-name) "KEYWORD")
308 ,(expand-gobject-type type-number slots)
309 (defclass ,child-class
310 (,(default-container-child-name super))
312 (:metaclass child-class)
313 (:container ,class))))))
315 (register-derivable-type
316 'container "GtkContainer"
317 :query 'query-container-type-dependencies
318 :expand 'expand-container-type)