1 ;; Common Lisp bindings for GTK+ v1.2.x
2 ;; Copyright (C) 1999 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: glib.lisp,v 1.3 2000/08/22 23:13:39 espen Exp $
25 ;;;; Memory management
27 (define-foreign ("g_malloc0" allocate-memory) () pointer
30 (define-foreign ("g_realloc" reallocate-memory) () pointer
34 (define-foreign ("g_free" deallocate-memory) () nil
37 (defun copy-memory (from length &optional (to (allocate-memory length)))
38 (kernel:system-area-copy from 0 to 0 (* 8 length))
45 (deftype quark () 'unsigned)
47 (define-foreign %quark-get-reserved () quark)
49 (defvar *quark-from-object* (make-hash-table))
50 (defvar *quark-to-object* (make-hash-table))
52 (defun quark-from-object (object &key (test #'eq))
53 (let ((hash-code (sxhash object)))
55 (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
56 (let ((quark (%quark-get-reserved)))
57 (push (cons object quark) (gethash hash-code *quark-from-object*))
58 (setf (gethash quark *quark-to-object*) object)
61 (defun quark-to-object (quark)
62 (gethash quark *quark-to-object*))
64 (defun remove-quark (quark)
65 (let* ((object (gethash quark *quark-to-object*))
66 (hash-code (sxhash object)))
67 (remhash quark *quark-to-object*)
69 (gethash hash-code *quark-from-object*)
70 (assoc-delete object (gethash hash-code *quark-from-object*)))
71 (remhash hash-code *quark-from-object*))))
77 (deftype glist () 'pointer)
78 (deftype double-list (type) `(or (null (cons ,type list))))
81 (define-foreign ("g_list_append" %glist-append) () glist
85 (defmacro glist-append (glist value type-spec)
86 (ecase (first (mklist (translate-type-spec type-spec)))
87 (unsigned `(%glist-append ,glist ,value))
88 ; (signed `(%glist-append ,glist (signed-to-unsigned ,value)))
89 (system-area-pointer `(%glist-append ,glist (system:sap-int ,value)))))
92 (defmacro glist-data (glist type-spec)
93 (ecase (first (mklist (translate-type-spec type-spec)))
94 (unsigned `(sap-ref-unsigned ,glist 0))
95 (signed `(sap-ref-signed ,glist 0))
96 (system-area-pointer `(sap-ref-sap ,glist 0))))
99 (defun glist-next (glist)
100 (unless (null-pointer-p glist)
101 (sap-ref-sap glist +size-of-sap+)))
104 (define-foreign ("g_list_free" glist-free) () nil
108 (deftype-method translate-type-spec double-list (type-spec)
109 (declare (ignore type-spec))
110 'system-area-pointer)
112 (deftype-method translate-to-alien double-list (type-spec list &optional copy)
113 (declare (ignore copy))
114 (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
115 (to-alien (translate-to-alien element-type-spec 'element t)))
116 `(let ((glist (make-pointer 0)))
117 (dolist (element ,list glist)
118 (setq glist (glist-append glist ,to-alien ,element-type-spec))))))
122 double-list (type-spec glist &optional (alloc :dynamic))
123 (let ((element-type-spec (second (type-expand-to 'double-list type-spec))))
124 `(let ((glist ,glist)
126 (do ((tmp glist (glist-next tmp)))
127 ((null-pointer-p tmp))
129 ,(translate-from-alien
130 element-type-spec `(glist-data tmp ,element-type-spec) alloc)
132 ,(when (eq alloc :dynamic)
136 (deftype-method cleanup-alien double-list (type-spec glist &optional copied)
137 (declare (ignore copied))
138 (let* ((element-type-spec (second (type-expand-to 'double-list type-spec)))
139 (alien-type-spec (translate-type-spec element-type-spec)))
140 `(let ((glist ,glist))
141 (unless (null-pointer-p glist)
142 ,(when (eq alien-type-spec 'system-area-pointer)
143 `(do ((tmp glist (glist-next tmp)))
144 ((null-pointer-p tmp))
146 element-type-spec `(glist-data tmp ,element-type-spec) t)))
147 (glist-free glist)))))
153 (define-foreign ("g_array_new" %array-new) () garray
154 (zero-terminated boolean)
156 (element-size unsigned-int))
158 (defun array-new (&key zero-terminated clear (element-size 4) initial-contents)
159 (let ((array (%array-new zero-terminated clear element-size)))
160 (when initial-contents
161 (dolist (element initial-contents)
162 (array-append array element)))
165 (define-foreign ("g_array_free" %array-free) () none
167 (free-segment boolean))
169 (defun array-free (array &optional free-data (free-segment t))
171 (dotimes (i (array-get-size array))
172 (free (array-get-pointer array i))))
173 (%array-free array free-segment))
175 (defmacro with-array (binding &body body)
176 (let ((array (gensym)))
177 (destructuring-bind (var &rest args
178 &key (free-contents nil) (free-segment t)
181 (remf args :free-contents)
182 (remf args :free-segment)
183 `(let* ((,array (array-new ,@args))
184 (,var (array-get-data ,array)))
187 (array-free ,array ,free-contents ,free-segment))))))
190 (define-foreign ("g_array_insert_int" array-insert-int) () garray
195 (defun array-insert-value (array index value)
197 (null (array-insert-int array index 0))
198 (integer (array-insert-int array index value))
199 (string (array-insert-int array index (sap-int (gforeign::pointer-to-sap (%strdup value)))))
200 (pointer (array-insert-int array index (sap-int (gforeign::pointer-to-sap value))))))
202 (defun array-prepend (array value)
203 (array-insert-value array 0 value))
205 (defun array-append (array value)
206 (array-insert-value array (array-get-size array) value))
209 (define-foreign ("g_array_get_int" array-get-int) () int
211 (index unsigned-int))
213 (defun array-get-pointer (array index)
214 (gforeign::sap-to-pointer (int-sap (array-get-int array index))))
217 (define-foreign ("g_array_get_data" array-get-data) () pointer
220 (define-foreign ("g_array_set_size" array-set-size) () garray
225 (define-foreign ("g_array_get_size" array-get-size) () int