1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.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: gobject.lisp,v 1.2 2000-08-23 21:40:38 espen Exp $
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (defclass gobject (gtype)
26 (:metaclass gtype-class)
27 (:alien-name "GObject"))
29 (defclass gobject-class (gtype-class)))
32 ;;;; Reference counting for gobject
34 ;; Specializing reference-instance and unreference-instance on gobject
35 ;; is not really necessary but done for efficiency
37 (defmethod reference-instance ((object gobject))
41 (defmethod unreference-instance ((object gobject))
42 (%object-unref object))
44 (deftype-method alien-ref gobject (type-spec)
45 (declare (ignore type-spec))
48 (deftype-method alien-unref gobject (type-spec)
49 (declare (ignore type-spec))
52 (define-foreign %object-ref () pointer
53 (object (or gobject pointer)))
55 (define-foreign %object-unref () nil
56 (object (or gobject pointer)))
59 ;; Parameter stuff not yet implemented
61 ; (define-foreign object-set-param () nil
66 ; (define-foreign object-get-param () nil
69 ; (value gvalue :out))
71 ; (define-foreign object-queue-param-changed () nil
76 ;;;; User data mechanism
78 (declaim (fixnum *user-data-count*))
80 (defvar *user-data* (make-hash-table))
81 (defvar *user-data-count* 0)
83 ;; Until the callback mechanism is moved to glib, the value of
84 ;; *destroy-marshal* is set in gtkobject.lisp
85 (defvar *destroy-marshal* nil)
87 (defun register-user-data (object &optional destroy-function)
88 (check-type destroy-function (or null symbol function))
89 ; (incf *user-data-count*)
90 (setq *user-data-count* (the fixnum (1+ *user-data-count*)))
92 (gethash *user-data-count* *user-data*)
93 (cons object destroy-function))
96 (defun find-user-data (id)
97 (check-type id fixnum)
98 (multiple-value-bind (user-data p) (gethash id *user-data*)
99 (values (car user-data) p)))
101 (defun destroy-user-data (id)
102 (check-type id fixnum)
103 (let ((user-data (gethash id *user-data*)))
104 (when (cdr user-data)
105 (funcall (cdr user-data) (car user-data))))
106 (remhash id *user-data*))
108 (define-foreign %object-set-qdata-full () nil
112 (destroy-marshal pointer))
114 (defun (setf object-data) (data object key &key (test #'eq))
115 (%object-set-qdata-full
116 object (quark-from-object key :test test)
117 (register-user-data data) *destroy-marshal*)
120 (define-foreign %object-get-qdata () unsigned-long
124 (defun object-data (object key &key (test #'eq))
126 (%object-get-qdata object (quark-from-object key :test test))))
130 ;;;; Methods for gobject-class
132 (defmethod shared-initialize ((class gobject-class) names &rest initargs
134 (declare (ignore initargs names))
137 (alien::make-heap-alien-info
138 :type (alien::parse-alien-type '(function (unsigned 32)))
139 :sap-form (system:foreign-symbol-address
142 (default-alien-func-name
144 nil "~A_get_type" (or name (class-name class))))))))))
145 (alien:alien-funcall alien))
149 ; (define-foreign object-class-install-param () nil
152 ; (parameter parameter))
154 ; (define-foreign object-class-find-param-spec () parameter