94f15c3c |
1 | ;; Common Lisp bindings for GTK+ v2.0 |
2 | ;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no> |
3 | ;; |
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. |
8 | ;; |
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. |
13 | ;; |
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 |
17 | |
7479d92c |
18 | ;; $Id: gboxed.lisp,v 1.2 2001-04-30 11:25:25 espen Exp $ |
94f15c3c |
19 | |
20 | (in-package "GLIB") |
21 | |
22 | |
23 | (eval-when (:compile-toplevel :load-toplevel :execute) |
7479d92c |
24 | (defclass boxed (proxy) |
94f15c3c |
25 | () |
26 | (:metaclass proxy-class))) |
27 | |
28 | (defmethod initialize-proxy ((boxed boxed) &rest initargs |
29 | &key location weak-ref) |
30 | (declare (ignore initargs)) |
31 | (setf |
32 | (slot-value boxed 'location) |
33 | (if weak-ref |
34 | (%boxed-copy (find-type-number (class-of boxed)) location) |
35 | location)) |
36 | (call-next-method)) |
37 | |
38 | (defmethod instance-finalizer ((boxed boxed)) |
39 | (let ((location (proxy-location boxed)) |
40 | (type-number (find-type-number (class-of boxed)))) |
41 | (declare (type system-area-pointer location)) |
42 | #'(lambda () |
43 | (%boxed-free type-number location) |
44 | (remove-cached-instance location)))) |
45 | |
46 | |
47 | (deftype-method translate-to-alien boxed (type-spec boxed &optional weak-ref) |
48 | (if weak-ref |
49 | `(proxy-location ,boxed) |
50 | `(let ((boxed ,boxed)) |
51 | (%boxed-copy |
52 | (find-type-number type-spec) |
53 | (proxy-location boxed))))) |
54 | |
55 | (deftype-method unreference-alien boxed (type-spec c-struct) |
56 | `(%boxed-free ,(find-type-number type-spec) ,c-struct)) |
57 | |
58 | |
59 | (defbinding %boxed-copy () pointer |
60 | (type type-number) |
61 | (location pointer)) |
62 | |
63 | (defbinding %boxed-free () nil |
64 | (type type-number) |
65 | (location pointer)) |
66 | |
67 | |
68 | ;;;; Metaclass for boxed classes |
69 | |
70 | (eval-when (:compile-toplevel :load-toplevel :execute) |
71 | (defclass boxed-class (proxy-class))) |
72 | |
73 | |
74 | (defmethod shared-initialize ((class boxed-class) names |
75 | &rest initargs |
76 | &key name alien-name type-init) |
77 | (declare (ignore initargs names)) |
78 | (call-next-method) |
79 | |
80 | (let* ((class-name (or name (class-name class))) |
81 | (type-number |
82 | (cond |
83 | ((and alien-name type-init) |
84 | (error |
85 | "Specify either :type-init or :alien-name for class ~A" |
86 | class-name)) |
87 | (alien-name (type-number-from-alien-name (first alien-name))) |
7479d92c |
88 | (type-init (funcall (mkbinding (first type-init) 'type-number))) |
94f15c3c |
89 | (t |
90 | (or |
91 | (type-number-from-alien-name |
92 | (default-alien-type-name class-name) nil) |
93 | (funcall |
7479d92c |
94 | (mkbinding |
94f15c3c |
95 | (default-alien-fname (format nil "~A_get_type" class-name)) |
7479d92c |
96 | 'type-number))))))) |
94f15c3c |
97 | (setf (find-type-number class) type-number))) |
98 | |
99 | |
100 | (defmethod validate-superclass |
101 | ((class boxed-class) (super pcl::standard-class)) |
102 | (subtypep (class-name super) 'boxed)) |
103 | |
104 | |
105 | ;;;; Initializing type numbers |
106 | |
107 | (setf (alien-type-name 'boxed) "GBoxed") |