1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 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: gboxed.lisp,v 1.12 2004-11-07 21:41:35 espen Exp $
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (init-types-in-library #.(concatenate 'string
25 (pkg-config:pkg-variable "glib-2.0" "libdir")
26 "/libgobject-2.0.so")))
28 (defclass boxed (struct)
30 (:metaclass struct-class))
33 ;;;; Metaclass for boxed classes
35 (eval-when (:compile-toplevel :load-toplevel :execute)
36 (defclass boxed-class (struct-class)
39 (defmethod validate-superclass ((class boxed-class) (super standard-class))
40 (subtypep (class-name super) 'boxed)))
43 (defmethod shared-initialize ((class boxed-class) names
44 &rest initargs &key name alien-name)
45 (declare (ignore initargs names))
48 (let* ((class-name (or name (class-name class)))
51 (or (first alien-name) (default-alien-type-name class-name)))))
52 (register-type class-name type-number)))
55 (defbinding %boxed-copy (type location) pointer
56 ((find-type-number type) type-number)
59 (defbinding %boxed-free (type location) nil
60 ((find-type-number type) type-number)
63 (defmethod reference-foreign ((class boxed-class) location)
64 (%boxed-copy (class-name class) location))
66 (defmethod unreference-foreign ((class boxed-class) location)
67 (%boxed-free (class-name class) location))
72 (defun expand-boxed-type (type-number &optional slots)
73 `(defclass ,(type-from-number type-number) (boxed)
75 (:metaclass boxed-class)
76 (:alien-name ,(find-type-name type-number))))
78 (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
80 ;;;; Special boxed types
82 ;; (defclass gstring (boxed)
84 ;; (:metaclass boxed-class)
85 ;; (:alien-name "GString"))
87 ;; (deftype-method translate-from-alien
88 ;; gstring (type-spec location &optional weak-ref)
89 ;; `(let ((location ,location))
90 ;; (unless (null-pointer-p location)
92 ;; (c-call::%naturalize-c-string location)
94 ;; (unreference-alien type-spec location))))))
96 ;; (deftype-method translate-to-alien
97 ;; gstring (type-spec string &optional weak-ref)
98 ;; (declare (ignore weak-ref))
99 ;; `(let ((string ,string))
100 ;; ;; Always copy strings to prevent seg fault due to GC
102 ;; ',(proxy-class-copy (find-class type-spec))
104 ;; (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
106 ;; (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
108 ;; (unreference-alien type-spec c-string)))