chiark / gitweb /
Removed :colors initarg from initialize-instance for the COLOR class
[clg] / glib / glib.lisp
CommitLineData
560af5c5 1;; Common Lisp bindings for GTK+ v1.2.x
2;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.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
415444ae 18;; $Id: glib.lisp,v 1.6 2000-09-04 22:10:26 espen Exp $
560af5c5 19
20
21(in-package "GLIB")
22(use-prefix "g")
23
24
25;;;; Memory management
26
27(define-foreign ("g_malloc0" allocate-memory) () pointer
28 (size unsigned-long))
29
30(define-foreign ("g_realloc" reallocate-memory) () pointer
31 (address pointer)
32 (size unsigned-long))
33
34(define-foreign ("g_free" deallocate-memory) () nil
35 (address pointer))
36
37(defun copy-memory (from length &optional (to (allocate-memory length)))
38 (kernel:system-area-copy from 0 to 0 (* 8 length))
39 to)
40
41
42
0aef1da8 43;;;; Quarks
44
45(deftype quark () 'unsigned)
46
415444ae 47;(define-foreign %quark-get-reserved () quark)
48
49(define-foreign %quark-from-string () quark
50 (string string))
51
52(defvar *string-counter* 0)
53
54(defun %quark-get-reserved ()
55 (%quark-from-string (format nil "CLG-~D" (incf *string-counter*))))
0aef1da8 56
57(defvar *quark-from-object* (make-hash-table))
58(defvar *quark-to-object* (make-hash-table))
59
60(defun quark-from-object (object &key (test #'eq))
61 (let ((hash-code (sxhash object)))
62 (or
63 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
64 (let ((quark (%quark-get-reserved)))
ab566f2c 65 (setf
66 (gethash hash-code *quark-from-object*)
67 (append
68 (gethash hash-code *quark-from-object*)
69 (list (cons object quark))))
0aef1da8 70 (setf (gethash quark *quark-to-object*) object)
71 quark))))
72
73(defun quark-to-object (quark)
74 (gethash quark *quark-to-object*))
75
76(defun remove-quark (quark)
77 (let* ((object (gethash quark *quark-to-object*))
78 (hash-code (sxhash object)))
79 (remhash quark *quark-to-object*)
80 (unless (setf
81 (gethash hash-code *quark-from-object*)
82 (assoc-delete object (gethash hash-code *quark-from-object*)))
83 (remhash hash-code *quark-from-object*))))
84
85
86
560af5c5 87;;;; Linked list
88
89(deftype glist () 'pointer)
90(deftype double-list (type) `(or (null (cons ,type list))))
91
92
93(define-foreign ("g_list_append" %glist-append) () glist
94 (glist glist)
95 (data unsigned))
96
97(defmacro glist-append (glist value type-spec)
98 (ecase (first (mklist (translate-type-spec type-spec)))
99 (unsigned `(%glist-append ,glist ,value))
100; (signed `(%glist-append ,glist (signed-to-unsigned ,value)))
101 (system-area-pointer `(%glist-append ,glist (system:sap-int ,value)))))
102
103
104(defmacro glist-data (glist type-spec)
105 (ecase (first (mklist (translate-type-spec type-spec)))
106 (unsigned `(sap-ref-unsigned ,glist 0))
107 (signed `(sap-ref-signed ,glist 0))
108 (system-area-pointer `(sap-ref-sap ,glist 0))))
109
110
111(defun glist-next (glist)
112 (unless (null-pointer-p glist)
113 (sap-ref-sap glist +size-of-sap+)))
114
115
116(define-foreign ("g_list_free" glist-free) () nil
117 (glist pointer))
118
119
120(deftype-method translate-type-spec double-list (type-spec)
121 (declare (ignore type-spec))
415444ae 122 (translate-type-spec 'pointer))
123
124(deftype-method size-of double-list (type-spec)
125 (declare (ignore type-spec))
126 (size-of 'pointer))
560af5c5 127
128(deftype-method translate-to-alien double-list (type-spec list &optional copy)
129 (declare (ignore copy))
130 (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
131 (to-alien (translate-to-alien element-type-spec 'element t)))
132 `(let ((glist (make-pointer 0)))
133 (dolist (element ,list glist)
4e94e04b 134 (setq glist (glist-append glist ,to-alien ,element-type-spec))))))
560af5c5 135
136(deftype-method
137 translate-from-alien
fb754a8b 138 double-list (type-spec glist &optional (alloc :reference))
560af5c5 139 (let ((element-type-spec (second (type-expand-to 'double-list type-spec))))
140 `(let ((glist ,glist)
141 (list nil))
142 (do ((tmp glist (glist-next tmp)))
143 ((null-pointer-p tmp))
144 (push
145 ,(translate-from-alien
146 element-type-spec `(glist-data tmp ,element-type-spec) alloc)
147 list))
fb754a8b 148 ,(when (eq alloc :reference)
560af5c5 149 '(glist-free glist))
150 (nreverse list))))
151
152(deftype-method cleanup-alien double-list (type-spec glist &optional copied)
153 (declare (ignore copied))
154 (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
155 (alien-type-spec (translate-type-spec element-type-spec)))
156 `(let ((glist ,glist))
157 (unless (null-pointer-p glist)
158 ,(when (eq alien-type-spec 'system-area-pointer)
159 `(do ((tmp glist (glist-next tmp)))
160 ((null-pointer-p tmp))
4e94e04b 161 ,(cleanup-alien
162 element-type-spec `(glist-data tmp ,element-type-spec) t)))
560af5c5 163 (glist-free glist)))))
164
165
166
415444ae 167;;; Vector
168
169(deftype-method translate-type-spec vector (type-spec)
170 (declare (ignore type-spec))
171 (translate-type-spec 'pointer))
172
173(deftype-method size-of vector (type-spec)
174 (declare (ignore type-spec))
175 (size-of 'pointer))
176
177(deftype-method translate-to-alien vector (type-spec vector &optional copy)
178 (declare (ignore copy))
179 (destructuring-bind (element-type &optional (length '*))
180 (cdr (type-expand-to 'vector type-spec))
181 (let ((element-to-alien (translate-to-alien element-type 'element :copy))
182 (element-size (size-of element-type)))
183 `(let ((vector ,vector))
184 (let ((c-vector
185 (allocate-memory
186 ,(if (eq length '*)
187 `(* ,element-size (length vector))
188 (* element-size length)))))
189 (dotimes (i ,(if (eq length '*) '(length vector) length) c-vector)
190 (setf
191 (,(sap-ref-fname element-type) c-vector (* i ,element-size))
192 ,(translate-to-alien element-type '(svref vector i) :copy))))))))
193
194(deftype-method cleanup-alien vector (type-spec sap &optional copied)
195 (declare (ignore type-spec copied))
196 ;; The individual elements also have to be cleaned up to avoid memory leaks,
197 ;; but this is currently not possible because we can't always tell the
198 ;; length of the vector
199 `(deallocate-memory ,sap))